http2 5.1.4 → 5.2.0
raw patch · 60 files changed
+479/−1720 lines, 60 filesdep +http-semanticsdep ~case-insensitivedep ~unliftionew-component:exe:h2c-clientnew-component:exe:h2c-server
Dependencies added: http-semantics
Dependency ranges changed: case-insensitive, unliftio
Files
- ChangeLog.md +14/−0
- Imports.hs +6/−0
- Network/HPACK.hs +11/−14
- Network/HPACK/HeaderBlock.hs +3/−3
- Network/HPACK/HeaderBlock/Decode.hs +18/−34
- Network/HPACK/HeaderBlock/Encode.hs +20/−17
- Network/HPACK/Huffman/Decode.hs +1/−1
- Network/HPACK/Huffman/Encode.hs +1/−1
- Network/HPACK/Internal.hs +5/−0
- Network/HPACK/Table/Dynamic.hs +3/−3
- Network/HPACK/Table/Entry.hs +14/−14
- Network/HPACK/Table/RevIndex.hs +20/−21
- Network/HPACK/Table/Static.hs +1/−0
- Network/HPACK/Token.hs +2/−482
- Network/HPACK/Types.hs +2/−27
- Network/HTTP2/Client.hs +4/−134
- Network/HTTP2/Client/Internal.hs +3/−1
- Network/HTTP2/Client/Run.hs +4/−3
- Network/HTTP2/Client/Types.hs +0/−25
- Network/HTTP2/Frame.hs +1/−1
- Network/HTTP2/Frame/Decode.hs +1/−1
- Network/HTTP2/Frame/Types.hs +4/−4
- Network/HTTP2/H2.hs +0/−6
- Network/HTTP2/H2/Config.hs +1/−2
- Network/HTTP2/H2/Context.hs +12/−12
- Network/HTTP2/H2/File.hs +0/−38
- Network/HTTP2/H2/HPACK.hs +17/−17
- Network/HTTP2/H2/Manager.hs +1/−1
- Network/HTTP2/H2/ReadN.hs +0/−40
- Network/HTTP2/H2/Receiver.hs +7/−8
- Network/HTTP2/H2/Sender.hs +6/−184
- Network/HTTP2/H2/Settings.hs +2/−2
- Network/HTTP2/H2/Status.hs +0/−44
- Network/HTTP2/H2/Stream.hs +1/−1
- Network/HTTP2/H2/StreamTable.hs +1/−2
- Network/HTTP2/H2/Types.hs +6/−135
- Network/HTTP2/Internal.hs +0/−33
- Network/HTTP2/Server.hs +3/−166
- Network/HTTP2/Server/Internal.hs +3/−1
- Network/HTTP2/Server/Run.hs +3/−2
- Network/HTTP2/Server/Types.hs +0/−43
- Network/HTTP2/Server/Worker.hs +9/−8
- bench-hpack/Main.hs +1/−1
- http2.cabal +30/−29
- test-hpack/HPACKDecode.hs +4/−4
- test-hpack/HPACKEncode.hs +1/−1
- test-hpack/JSON.hs +8/−7
- test-hpack/hpack-stat.hs +2/−1
- test/HPACK/DecodeSpec.hs +5/−5
- test/HPACK/EncodeSpec.hs +3/−3
- test/HPACK/HeaderBlock.hs +8/−8
- test/HTTP2/ClientSpec.hs +2/−1
- test/HTTP2/ServerSpec.hs +5/−5
- test2/ServerSpec.hs +1/−1
- util/Client.hs +29/−0
- util/Server.hs +55/−0
- util/client.hs +0/−48
- util/h2c-client.hs +65/−0
- util/h2c-server.hs +50/−0
- util/server.hs +0/−75
ChangeLog.md view
@@ -1,3 +1,17 @@+## 5.2.0++* Using http-semantics+ [#114](https://github.com/kazu-yamamoto/http2/pull/114)+* `Header` of `http-types` should be used as high-level header.+* `TokenHeader` of `http-semantics` should be used as low-level header.+* Breaking change: `encodeHeader` takes `Header` of `http-types`.+* Breaking change: `decodeHeader` returns `Header` of `http-types`.+* Breaking change: `HeaderName` as `ByteString` is removed.++## 5.1.4++* Using network-control v0.1.+ ## 5.1.3 * Defining SendRequest type synonym.
Imports.hs view
@@ -14,6 +14,9 @@ module Data.String, module Data.Word, module Numeric,+ module Network.HTTP.Semantics,+ module Network.HTTP.Types,+ module Data.CaseInsensitive, GCBuffer, withForeignPtr, mallocPlainForeignPtrBytes,@@ -24,6 +27,7 @@ import Data.Bits hiding (Bits) import Data.ByteString.Internal (ByteString (..)) import Data.ByteString.Short (ShortByteString)+import Data.CaseInsensitive (foldedCase, mk, original) import Data.Either import Data.Foldable import Data.Int@@ -35,6 +39,8 @@ import Data.Word import Foreign.ForeignPtr import GHC.ForeignPtr (mallocPlainForeignPtrBytes)+import Network.HTTP.Semantics+import Network.HTTP.Types import Numeric type GCBuffer = ForeignPtr Word8
Network/HPACK.hs view
@@ -5,6 +5,10 @@ -- * Encoding and decoding encodeHeader, decodeHeader,+ Header,+ original,+ foldedCase,+ mk, -- * Encoding and decoding with token encodeTokenHeader,@@ -28,37 +32,30 @@ DecodeError (..), BufferOverrun (..), - -- * Headers- HeaderList,- Header,- HeaderName,- HeaderValue,- TokenHeaderList,+ -- * Token header+ FieldValue, TokenHeader,+ TokenHeaderList,+ toTokenHeaderTable, -- * Value table ValueTable,- HeaderTable,+ TokenHeaderTable,+ getFieldValue, getHeaderValue,- toHeaderTable, -- * Basic types Size, Index, Buffer, BufferSize,-- -- * Re-exports- original,- foldedCase,- mk, ) where #if __GLASGOW_HASKELL__ < 709 import Control.Applicative ((<$>)) #endif-import Data.CaseInsensitive +import Imports import Network.HPACK.HeaderBlock import Network.HPACK.Table import Network.HPACK.Types
Network/HPACK/HeaderBlock.hs view
@@ -2,9 +2,9 @@ decodeHeader, decodeTokenHeader, ValueTable,- HeaderTable,- toHeaderTable,- getHeaderValue,+ TokenHeaderTable,+ toTokenHeaderTable,+ getFieldValue, encodeHeader, encodeTokenHeader, ) where
Network/HPACK/HeaderBlock/Decode.hs view
@@ -5,47 +5,35 @@ decodeHeader, decodeTokenHeader, ValueTable,- HeaderTable,- toHeaderTable,- getHeaderValue,+ TokenHeaderTable,+ toTokenHeaderTable,+ getFieldValue, decodeString, decodeS, decodeSophisticated, decodeSimple, -- testing ) where -import Control.Exception (catch, throwIO)-import Data.Array (Array)-import Data.Array.Base (unsafeAt, unsafeRead, unsafeWrite)+import Data.Array.Base (unsafeRead, unsafeWrite) import qualified Data.Array.IO as IOA import qualified Data.Array.Unsafe as Unsafe import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as B8-import Data.CaseInsensitive (CI (..)) import Data.Char (isUpper) import Network.ByteOrder+import Network.HTTP.Semantics+import UnliftIO.Exception (catch, throwIO) import Imports hiding (empty) import Network.HPACK.Builder import Network.HPACK.HeaderBlock.Integer import Network.HPACK.Huffman import Network.HPACK.Table-import Network.HPACK.Token import Network.HPACK.Types --- | An array to get 'HeaderValue' quickly.--- 'getHeaderValue' should be used.--- Internally, the key is 'tokenIx'.-type ValueTable = Array Int (Maybe HeaderValue)---- | Accessing 'HeaderValue' with 'Token'.-{-# INLINE getHeaderValue #-}-getHeaderValue :: Token -> ValueTable -> Maybe HeaderValue-getHeaderValue t tbl = tbl `unsafeAt` tokenIx t- ---------------------------------------------------------------- --- | Converting the HPACK format to 'HeaderList'.+-- | Converting the HPACK format to '[Header]'. -- -- * Headers are decoded as is. -- * 'DecodeError' would be thrown if the HPACK format is broken.@@ -54,7 +42,7 @@ :: DynamicTable -> ByteString -- ^ An HPACK format- -> IO HeaderList+ -> IO [Header] decodeHeader dyntbl inp = decodeHPACK dyntbl inp (decodeSimple (toTokenHeader dyntbl)) -- | Converting the HPACK format to 'TokenHeaderList'@@ -75,7 +63,7 @@ :: DynamicTable -> ByteString -- ^ An HPACK format- -> IO HeaderTable+ -> IO TokenHeaderTable decodeTokenHeader dyntbl inp = decodeHPACK dyntbl inp (decodeSophisticated (toTokenHeader dyntbl)) `catch` \BufferOverrun -> throwIO HeaderBlockTruncated @@ -96,7 +84,7 @@ ff rbuf (-1) dec rbuf --- | Converting to 'HeaderList'.+-- | Converting to '[Header]'. -- -- * Headers are decoded as is. -- * 'DecodeError' would be thrown if the HPACK format is broken.@@ -104,7 +92,7 @@ decodeSimple :: (Word8 -> ReadBuffer -> IO TokenHeader) -> ReadBuffer- -> IO HeaderList+ -> IO [Header] decodeSimple decTokenHeader rbuf = go empty where go builder = do@@ -117,7 +105,7 @@ go builder' else do let tvs = run builder- kvs = map (\(t, v) -> let k = tokenFoldedKey t in (k, v)) tvs+ kvs = map (\(t, v) -> let k = tokenKey t in (k, v)) tvs return kvs headerLimit :: Int@@ -141,7 +129,7 @@ decodeSophisticated :: (Word8 -> ReadBuffer -> IO TokenHeader) -> ReadBuffer- -> IO HeaderTable+ -> IO TokenHeaderTable decodeSophisticated decTokenHeader rbuf = do -- using maxTokenIx to reduce condition arr <- IOA.newArray (minTokenIx, maxTokenIx) Nothing@@ -149,7 +137,7 @@ tbl <- Unsafe.unsafeFreeze arr return (tvs, tbl) where- pseudoNormal :: IOA.IOArray Int (Maybe HeaderValue) -> IO TokenHeaderList+ pseudoNormal :: IOA.IOArray Int (Maybe FieldValue) -> IO TokenHeaderList pseudoNormal arr = pseudo where pseudo = do@@ -334,23 +322,19 @@ ---------------------------------------------------------------- --- | A pair of token list and value table.-type HeaderTable = (TokenHeaderList, ValueTable)- -- | Converting a header list of the http-types style to -- 'TokenHeaderList' and 'ValueTable'.-toHeaderTable :: [(CI HeaderName, HeaderValue)] -> IO HeaderTable-toHeaderTable kvs = do+toTokenHeaderTable :: [Header] -> IO TokenHeaderTable+toTokenHeaderTable kvs = do arr <- IOA.newArray (minTokenIx, maxTokenIx) Nothing tvs <- conv arr tbl <- Unsafe.unsafeFreeze arr return (tvs, tbl) where- conv :: IOA.IOArray Int (Maybe HeaderValue) -> IO TokenHeaderList+ conv :: IOA.IOArray Int (Maybe FieldValue) -> IO TokenHeaderList conv arr = go kvs empty where- go- :: [(CI HeaderName, HeaderValue)] -> Builder TokenHeader -> IO TokenHeaderList+ go :: [Header] -> Builder TokenHeader -> IO TokenHeaderList go [] builder = return $ run builder go ((k, v) : xs) builder = do let t = toToken (foldedCase k)
Network/HPACK/HeaderBlock/Encode.hs view
@@ -8,8 +8,6 @@ encodeS, ) where -import Control.Exception (bracket, throwIO)-import qualified Control.Exception as E import qualified Data.ByteString as BS import Data.ByteString.Internal (create) import Data.IORef@@ -17,12 +15,14 @@ import Foreign.Marshal.Utils (copyBytes) import Foreign.Ptr (minusPtr) import Network.ByteOrder+import Network.HTTP.Semantics+import UnliftIO.Exception (bracket, throwIO)+import qualified UnliftIO.Exception as E import Imports import Network.HPACK.HeaderBlock.Integer import Network.HPACK.Huffman import Network.HPACK.Table-import Network.HPACK.Token import Network.HPACK.Types ----------------------------------------------------------------@@ -41,7 +41,7 @@ ---------------------------------------------------------------- --- | Converting 'HeaderList' to the HPACK format.+-- | Converting '[Header]' to the HPACK format. -- This function has overhead of allocating/freeing a temporary buffer. -- 'BufferOverrun' will be thrown if the temporary buffer is too small. encodeHeader@@ -49,14 +49,17 @@ -> Size -- ^ The size of a temporary buffer. -> DynamicTable- -> HeaderList+ -> [Header] -> IO ByteString -- ^ An HPACK format encodeHeader stgy siz dyntbl hs = encodeHeader' stgy siz dyntbl hs' where- hs' = map (\(k, v) -> let t = toToken k in (t, v)) hs+ mk' (k, v) = (t, v)+ where+ t = toToken $ foldedCase k+ hs' = map mk' hs --- | Converting 'HeaderList' to the HPACK format.+-- | Converting 'TokenHeaderList' to the HPACK format. -- 'BufferOverrun' will be thrown if the temporary buffer is too small. encodeHeader' :: EncodeStrategy@@ -135,26 +138,26 @@ ---------------------------------------------------------------- naiveStep- :: (HeaderName -> HeaderValue -> IO ()) -> Token -> HeaderValue -> IO ()+ :: (FieldName -> FieldValue -> IO ()) -> Token -> FieldValue -> IO () naiveStep fe t v = fe (tokenFoldedKey t) v ---------------------------------------------------------------- -staticStep :: FA -> FD -> FE -> Token -> HeaderValue -> IO ()+staticStep :: FA -> FD -> FE -> Token -> FieldValue -> IO () staticStep fa fd fe t v = lookupRevIndex' t v fa fd fe ---------------------------------------------------------------- -linearStep :: RevIndex -> FA -> FB -> FC -> FD -> Token -> HeaderValue -> IO ()+linearStep :: RevIndex -> FA -> FB -> FC -> FD -> Token -> FieldValue -> IO () linearStep rev fa fb fc fd t v = lookupRevIndex t v fa fb fc fd rev ---------------------------------------------------------------- type FA = HIndex -> IO ()-type FB = HeaderValue -> Entry -> HIndex -> IO ()-type FC = HeaderName -> HeaderValue -> Entry -> IO ()-type FD = HeaderValue -> HIndex -> IO ()-type FE = HeaderName -> HeaderValue -> IO ()+type FB = FieldValue -> Entry -> HIndex -> IO ()+type FC = FieldName -> FieldValue -> Entry -> IO ()+type FD = FieldValue -> HIndex -> IO ()+type FE = FieldName -> FieldValue -> IO () -- 6.1. Indexed Header Field Representation -- Indexed Header Field@@ -194,7 +197,7 @@ newName wbuf huff set0000 k v literalHeaderFieldWithoutIndexingNewName'- :: DynamicTable -> WriteBuffer -> Bool -> HeaderName -> HeaderValue -> IO ()+ :: DynamicTable -> WriteBuffer -> Bool -> FieldName -> FieldValue -> IO () literalHeaderFieldWithoutIndexingNewName' _ wbuf huff k v = newName wbuf huff set0000 k v @@ -211,14 +214,14 @@ -- Using Huffman encoding {-# INLINE indexedName #-} indexedName- :: WriteBuffer -> Bool -> Int -> Setter -> HeaderValue -> Index -> IO ()+ :: WriteBuffer -> Bool -> Int -> Setter -> FieldValue -> Index -> IO () indexedName wbuf huff n set v idx = do encodeI wbuf set n idx encStr wbuf huff v -- Using Huffman encoding {-# INLINE newName #-}-newName :: WriteBuffer -> Bool -> Setter -> HeaderName -> HeaderValue -> IO ()+newName :: WriteBuffer -> Bool -> Setter -> FieldName -> FieldValue -> IO () newName wbuf huff set k v = do write8 wbuf $ set 0 encStr wbuf huff k
Network/HPACK/Huffman/Decode.hs view
@@ -9,11 +9,11 @@ GCBuffer, ) where -import Control.Exception (throwIO) import Data.Array (Array, listArray) import Data.Array.Base (unsafeAt) import qualified Data.ByteString as BS import Network.ByteOrder+import UnliftIO.Exception (throwIO) import Imports import Network.HPACK.Huffman.Bit
Network/HPACK/Huffman/Encode.hs view
@@ -6,7 +6,6 @@ encodeHuffman, ) where -import Control.Exception (throwIO) import Data.Array.Base (unsafeAt) import Data.Array.IArray (listArray) import Data.Array.Unboxed (UArray)@@ -14,6 +13,7 @@ import Foreign.Ptr (minusPtr, plusPtr) import Foreign.Storable (poke) import Network.ByteOrder hiding (copy)+import UnliftIO.Exception (throwIO) import Imports import Network.HPACK.Huffman.Params (idxEos)
Network/HPACK/Internal.hs view
@@ -7,6 +7,9 @@ module Network.HPACK.HeaderBlock.Decode, module Network.HPACK.Huffman, module Network.HPACK.Table.Entry,++ -- * Types+ module Network.HPACK.Types, ) where import Network.HPACK.HeaderBlock.Decode (@@ -14,8 +17,10 @@ decodeSimple, decodeSophisticated, decodeString,+ toTokenHeaderTable, ) import Network.HPACK.HeaderBlock.Encode (encodeS, encodeString) import Network.HPACK.HeaderBlock.Integer import Network.HPACK.Huffman import Network.HPACK.Table.Entry+import Network.HPACK.Types (CompressionAlgo (..), EncodeStrategy (..))
Network/HPACK/Table/Dynamic.hs view
@@ -24,11 +24,11 @@ getRevIndex, ) where -import Control.Exception (throwIO) import Data.Array.Base (unsafeRead, unsafeWrite) import Data.Array.IO (IOArray, newArray) import qualified Data.ByteString.Char8 as BS import Data.IORef+import UnliftIO.Exception (throwIO) import Imports import Network.HPACK.Huffman@@ -156,9 +156,9 @@ putStr "] (s = " putStr $ show $ entrySize e putStr ") "- BS.putStr $ entryHeaderName e+ BS.putStr $ original $ entryHeaderName e putStr ": "- BS.putStrLn $ entryHeaderValue e+ BS.putStrLn $ entryFieldValue e ----------------------------------------------------------------
Network/HPACK/Table/Entry.hs view
@@ -4,9 +4,7 @@ -- * Type Size, Entry (..),- Header, -- re-exporting- HeaderName, -- re-exporting- HeaderValue, -- re-exporting+ FieldValue, -- re-exporting Index, -- re-exporting -- * Header and Entry@@ -18,7 +16,7 @@ entryTokenHeader, entryToken, entryHeaderName,- entryHeaderValue,+ entryFieldValue, -- * For initialization dummyEntry,@@ -26,16 +24,18 @@ ) where import qualified Data.ByteString as BS-import Network.HPACK.Token import Network.HPACK.Types+import Network.HTTP.Semantics +import Imports+ ---------------------------------------------------------------- -- | Size in bytes. type Size = Int -- | Type for table entry. Size includes the 32 bytes magic number.-data Entry = Entry Size Token HeaderValue deriving (Show)+data Entry = Entry Size Token FieldValue deriving (Show) ---------------------------------------------------------------- @@ -44,11 +44,11 @@ headerSize :: Header -> Size headerSize (k, v) =- BS.length k+ BS.length (foldedCase k) + BS.length v + headerSizeMagicNumber -headerSize' :: Token -> HeaderValue -> Size+headerSize' :: Token -> FieldValue -> Size headerSize' t v = BS.length (tokenFoldedKey t) + BS.length v@@ -60,10 +60,10 @@ toEntry :: Header -> Entry toEntry kv@(k, v) = Entry siz t v where- t = toToken k+ t = toToken $ foldedCase k siz = headerSize kv -toEntryToken :: Token -> HeaderValue -> Entry+toEntryToken :: Token -> FieldValue -> Entry toEntryToken t v = Entry siz t v where siz = headerSize' t v@@ -84,11 +84,11 @@ -- | Getting 'HeaderName'. entryHeaderName :: Entry -> HeaderName-entryHeaderName (Entry _ t _) = tokenFoldedKey t+entryHeaderName (Entry _ t _) = tokenKey t -- xxx --- | Getting 'HeaderValue'.-entryHeaderValue :: Entry -> HeaderValue-entryHeaderValue (Entry _ _ v) = v+-- | Getting 'FieldValue'.+entryFieldValue :: Entry -> FieldValue+entryFieldValue (Entry _ _ v) = v ----------------------------------------------------------------
Network/HPACK/Table/RevIndex.hs view
@@ -15,16 +15,15 @@ import Data.Array (Array) import qualified Data.Array as A import Data.Array.Base (unsafeAt)-import Data.CaseInsensitive (foldedCase) import Data.Function (on) import Data.IORef import Data.Map.Strict (Map) import qualified Data.Map.Strict as M+import Network.HTTP.Semantics import Imports import Network.HPACK.Table.Entry import Network.HPACK.Table.Static-import Network.HPACK.Token import Network.HPACK.Types ----------------------------------------------------------------@@ -33,7 +32,7 @@ type DynamicRevIndex = Array Int (IORef ValueMap) -data KeyValue = KeyValue HeaderName HeaderValue deriving (Eq, Ord)+data KeyValue = KeyValue FieldName FieldValue deriving (Eq, Ord) -- We always create an index for a pair of an unknown header and its value -- in Linear{H}.@@ -55,14 +54,14 @@ data StaticEntry = StaticEntry HIndex (Maybe ValueMap) deriving (Show) -type ValueMap = Map HeaderValue HIndex+type ValueMap = Map FieldValue HIndex ---------------------------------------------------------------- staticRevIndex :: StaticRevIndex staticRevIndex = A.array (minTokenIx, maxStaticTokenIx) $ map toEnt zs where- toEnt (k, xs) = (tokenIx (toToken k), m)+ toEnt (k, xs) = (tokenIx $ toToken $ foldedCase k, m) where m = case xs of [] -> error "staticRevIndex"@@ -77,7 +76,7 @@ {-# INLINE lookupStaticRevIndex #-} lookupStaticRevIndex- :: Int -> HeaderValue -> (HIndex -> IO ()) -> (HIndex -> IO ()) -> IO ()+ :: Int -> FieldValue -> (HIndex -> IO ()) -> (HIndex -> IO ()) -> IO () lookupStaticRevIndex ix v fa' fbd' = case staticRevIndex `unsafeAt` ix of StaticEntry i Nothing -> fbd' i StaticEntry i (Just m) -> case M.lookup v m of@@ -87,9 +86,9 @@ ---------------------------------------------------------------- newDynamicRevIndex :: IO DynamicRevIndex-newDynamicRevIndex = A.listArray (minTokenIx, maxStaticTokenIx) <$> mapM mk lst+newDynamicRevIndex = A.listArray (minTokenIx, maxStaticTokenIx) <$> mapM mk' lst where- mk _ = newIORef M.empty+ mk' _ = newIORef M.empty lst = [minTokenIx .. maxStaticTokenIx] renewDynamicRevIndex :: DynamicRevIndex -> IO ()@@ -100,7 +99,7 @@ {-# INLINE lookupDynamicStaticRevIndex #-} lookupDynamicStaticRevIndex :: Int- -> HeaderValue+ -> FieldValue -> DynamicRevIndex -> (HIndex -> IO ()) -> (HIndex -> IO ())@@ -114,13 +113,13 @@ {-# INLINE insertDynamicRevIndex #-} insertDynamicRevIndex- :: Token -> HeaderValue -> HIndex -> DynamicRevIndex -> IO ()+ :: Token -> FieldValue -> HIndex -> DynamicRevIndex -> IO () insertDynamicRevIndex t v i drev = modifyIORef ref $ M.insert v i where ref = drev `unsafeAt` tokenIx t {-# INLINE deleteDynamicRevIndex #-}-deleteDynamicRevIndex :: Token -> HeaderValue -> DynamicRevIndex -> IO ()+deleteDynamicRevIndex :: Token -> FieldValue -> DynamicRevIndex -> IO () deleteDynamicRevIndex t v drev = modifyIORef ref $ M.delete v where ref = drev `unsafeAt` tokenIx t@@ -135,19 +134,19 @@ {-# INLINE lookupOtherRevIndex #-} lookupOtherRevIndex- :: Header -> OtherRevIdex -> (HIndex -> IO ()) -> IO () -> IO ()+ :: (FieldName, FieldValue) -> OtherRevIdex -> (HIndex -> IO ()) -> IO () -> IO () lookupOtherRevIndex (k, v) ref fa' fc' = do oth <- readIORef ref maybe fc' fa' $ M.lookup (KeyValue k v) oth {-# INLINE insertOtherRevIndex #-}-insertOtherRevIndex :: Token -> HeaderValue -> HIndex -> OtherRevIdex -> IO ()+insertOtherRevIndex :: Token -> FieldValue -> HIndex -> OtherRevIdex -> IO () insertOtherRevIndex t v i ref = modifyIORef' ref $ M.insert (KeyValue k v) i where k = tokenFoldedKey t {-# INLINE deleteOtherRevIndex #-}-deleteOtherRevIndex :: Token -> HeaderValue -> OtherRevIdex -> IO ()+deleteOtherRevIndex :: Token -> FieldValue -> OtherRevIdex -> IO () deleteOtherRevIndex t v ref = modifyIORef' ref $ M.delete (KeyValue k v) where k = tokenFoldedKey t@@ -165,11 +164,11 @@ {-# INLINE lookupRevIndex #-} lookupRevIndex :: Token- -> HeaderValue+ -> FieldValue -> (HIndex -> IO ())- -> (HeaderValue -> Entry -> HIndex -> IO ())- -> (HeaderName -> HeaderValue -> Entry -> IO ())- -> (HeaderValue -> HIndex -> IO ())+ -> (FieldValue -> Entry -> HIndex -> IO ())+ -> (FieldName -> FieldValue -> Entry -> IO ())+ -> (FieldValue -> HIndex -> IO ()) -> RevIndex -> IO () lookupRevIndex t@Token{..} v fa fb fc fd (RevIndex dyn oth)@@ -189,10 +188,10 @@ {-# INLINE lookupRevIndex' #-} lookupRevIndex' :: Token- -> HeaderValue+ -> FieldValue -> (HIndex -> IO ())- -> (HeaderValue -> HIndex -> IO ())- -> (HeaderName -> HeaderValue -> IO ())+ -> (FieldValue -> HIndex -> IO ())+ -> (FieldName -> FieldValue -> IO ()) -> IO () lookupRevIndex' Token{..} v fa fd fe | isStaticTokenIx tokenIx = lookupStaticRevIndex tokenIx v fa' fd'
Network/HPACK/Table/Static.hs view
@@ -9,6 +9,7 @@ import Data.Array (Array, listArray) import Data.Array.Base (unsafeAt) import Network.HPACK.Table.Entry+import Network.HTTP.Types (Header) ----------------------------------------------------------------
Network/HPACK/Token.hs view
@@ -1,485 +1,5 @@-{-# LANGUAGE OverloadedStrings #-}- module Network.HPACK.Token (- -- * Data type- Token (..),- tokenCIKey,- tokenFoldedKey,- toToken,-- -- * Ix- minTokenIx,- maxStaticTokenIx,- maxTokenIx,- cookieTokenIx,-- -- * Utilities- isMaxTokenIx,- isCookieTokenIx,- isStaticTokenIx,- isStaticToken,-- -- * Defined tokens- tokenAuthority,- tokenMethod,- tokenPath,- tokenScheme,- tokenStatus,- tokenAcceptCharset,- tokenAcceptEncoding,- tokenAcceptLanguage,- tokenAcceptRanges,- tokenAccept,- tokenAccessControlAllowOrigin,- tokenAge,- tokenAllow,- tokenAuthorization,- tokenCacheControl,- tokenContentDisposition,- tokenContentEncoding,- tokenContentLanguage,- tokenContentLength,- tokenContentLocation,- tokenContentRange,- tokenContentType,- tokenCookie,- tokenDate,- tokenEtag,- tokenExpect,- tokenExpires,- tokenFrom,- tokenHost,- tokenIfMatch,- tokenIfModifiedSince,- tokenIfNoneMatch,- tokenIfRange,- tokenIfUnmodifiedSince,- tokenLastModified,- tokenLink,- tokenLocation,- tokenMaxForwards,- tokenProxyAuthenticate,- tokenProxyAuthorization,- tokenRange,- tokenReferer,- tokenRefresh,- tokenRetryAfter,- tokenServer,- tokenSetCookie,- tokenStrictTransportSecurity,- tokenTransferEncoding,- tokenUserAgent,- tokenVary,- tokenVia,- tokenWwwAuthenticate,- tokenConnection,- tokenTE,- tokenMax,- tokenAccessControlAllowCredentials,- tokenAccessControlAllowHeaders,- tokenAccessControlAllowMethods,- tokenAccessControlExposeHeaders,- tokenAccessControlRequestHeaders,- tokenAccessControlRequestMethod,- tokenAltSvc,- tokenContentSecurityPolicy,- tokenEarlyData,- tokenExpectCt,- tokenForwarded,- tokenOrigin,- tokenPurpose,- tokenTimingAllowOrigin,- tokenUpgradeInsecureRequests,- tokenXContentTypeOptions,- tokenXForwardedFor,- tokenXFrameOptions,- tokenXXssProtection,+ module Network.HTTP.Semantics.Token, ) where -import qualified Data.ByteString as B-import Data.ByteString.Internal (ByteString (..), memcmp)-import Data.CaseInsensitive (CI (..), mk, original)-import Foreign.ForeignPtr (withForeignPtr)-import Foreign.Ptr (plusPtr)-import System.IO.Unsafe (unsafeDupablePerformIO)---- $setup--- >>> :set -XOverloadedStrings---- | Internal representation for header keys.-data Token = Token- { tokenIx :: Int- -- ^ Index for value table- , shouldBeIndexed :: Bool- -- ^ should be indexed in HPACK- , isPseudo :: Bool- -- ^ is this a pseudo header key?- , tokenKey :: CI ByteString- -- ^ Case insensitive header key- }- deriving (Eq, Show)---- | Extracting a case insensitive header key from a token.-{-# INLINE tokenCIKey #-}-tokenCIKey :: Token -> ByteString-tokenCIKey (Token _ _ _ ci) = original ci---- | Extracting a folded header key from a token.-{-# INLINE tokenFoldedKey #-}-tokenFoldedKey :: Token -> ByteString-tokenFoldedKey (Token _ _ _ ci) = foldedCase ci--{- FOURMOLU_DISABLE -}-tokenAuthority :: Token-tokenMethod :: Token-tokenPath :: Token-tokenScheme :: Token-tokenStatus :: Token-tokenAcceptCharset :: Token-tokenAcceptEncoding :: Token-tokenAcceptLanguage :: Token-tokenAcceptRanges :: Token-tokenAccept :: Token-tokenAccessControlAllowOrigin :: Token-tokenAge :: Token-tokenAllow :: Token-tokenAuthorization :: Token-tokenCacheControl :: Token-tokenContentDisposition :: Token-tokenContentEncoding :: Token-tokenContentLanguage :: Token-tokenContentLength :: Token-tokenContentLocation :: Token-tokenContentRange :: Token-tokenContentType :: Token-tokenCookie :: Token-tokenDate :: Token-tokenEtag :: Token-tokenExpect :: Token-tokenExpires :: Token-tokenFrom :: Token-tokenHost :: Token-tokenIfMatch :: Token-tokenIfModifiedSince :: Token-tokenIfNoneMatch :: Token-tokenIfRange :: Token-tokenIfUnmodifiedSince :: Token-tokenLastModified :: Token-tokenLink :: Token-tokenLocation :: Token-tokenMaxForwards :: Token-tokenProxyAuthenticate :: Token-tokenProxyAuthorization :: Token-tokenRange :: Token-tokenReferer :: Token-tokenRefresh :: Token-tokenRetryAfter :: Token-tokenServer :: Token-tokenSetCookie :: Token-tokenStrictTransportSecurity :: Token-tokenTransferEncoding :: Token-tokenUserAgent :: Token-tokenVary :: Token-tokenVia :: Token-tokenWwwAuthenticate :: Token-tokenConnection :: Token -- Warp-tokenTE :: Token -- Warp-tokenAccessControlAllowCredentials :: Token -- QPACK-tokenAccessControlAllowHeaders :: Token -- QPACK-tokenAccessControlAllowMethods :: Token -- QPACK-tokenAccessControlExposeHeaders :: Token -- QPACK-tokenAccessControlRequestHeaders :: Token -- QPACK-tokenAccessControlRequestMethod :: Token -- QPACK-tokenAltSvc :: Token -- QPACK-tokenContentSecurityPolicy :: Token -- QPACK-tokenEarlyData :: Token -- QPACK-tokenExpectCt :: Token -- QPACK-tokenForwarded :: Token -- QPACK-tokenOrigin :: Token -- QPACK-tokenPurpose :: Token -- QPACK-tokenTimingAllowOrigin :: Token -- QPACK-tokenUpgradeInsecureRequests :: Token -- QPACK-tokenXContentTypeOptions :: Token -- QPACK-tokenXForwardedFor :: Token -- QPACK-tokenXFrameOptions :: Token -- QPACK-tokenXXssProtection :: Token -- QPACK--tokenMax :: Token -- Other tokens--tokenAuthority = Token 0 True True ":authority"-tokenMethod = Token 1 True True ":method"-tokenPath = Token 2 False True ":path"-tokenScheme = Token 3 True True ":scheme"-tokenStatus = Token 4 True True ":status"-tokenAcceptCharset = Token 5 True False "Accept-Charset"-tokenAcceptEncoding = Token 6 True False "Accept-Encoding"-tokenAcceptLanguage = Token 7 True False "Accept-Language"-tokenAcceptRanges = Token 8 True False "Accept-Ranges"-tokenAccept = Token 9 True False "Accept"-tokenAccessControlAllowOrigin = Token 10 True False "Access-Control-Allow-Origin"-tokenAge = Token 11 True False "Age"-tokenAllow = Token 12 True False "Allow"-tokenAuthorization = Token 13 True False "Authorization"-tokenCacheControl = Token 14 True False "Cache-Control"-tokenContentDisposition = Token 15 True False "Content-Disposition"-tokenContentEncoding = Token 16 True False "Content-Encoding"-tokenContentLanguage = Token 17 True False "Content-Language"-tokenContentLength = Token 18 False False "Content-Length"-tokenContentLocation = Token 19 False False "Content-Location"-tokenContentRange = Token 20 True False "Content-Range"-tokenContentType = Token 21 True False "Content-Type"-tokenCookie = Token 22 True False "Cookie"-tokenDate = Token 23 True False "Date"-tokenEtag = Token 24 False False "Etag"-tokenExpect = Token 25 True False "Expect"-tokenExpires = Token 26 True False "Expires"-tokenFrom = Token 27 True False "From"-tokenHost = Token 28 True False "Host"-tokenIfMatch = Token 29 True False "If-Match"-tokenIfModifiedSince = Token 30 True False "If-Modified-Since"-tokenIfNoneMatch = Token 31 True False "If-None-Match"-tokenIfRange = Token 32 True False "If-Range"-tokenIfUnmodifiedSince = Token 33 True False "If-Unmodified-Since"-tokenLastModified = Token 34 True False "Last-Modified"-tokenLink = Token 35 True False "Link"-tokenLocation = Token 36 True False "Location"-tokenMaxForwards = Token 37 True False "Max-Forwards"-tokenProxyAuthenticate = Token 38 True False "Proxy-Authenticate"-tokenProxyAuthorization = Token 39 True False "Proxy-Authorization"-tokenRange = Token 40 True False "Range"-tokenReferer = Token 41 True False "Referer"-tokenRefresh = Token 42 True False "Refresh"-tokenRetryAfter = Token 43 True False "Retry-After"-tokenServer = Token 44 True False "Server"-tokenSetCookie = Token 45 False False "Set-Cookie"-tokenStrictTransportSecurity = Token 46 True False "Strict-Transport-Security"-tokenTransferEncoding = Token 47 True False "Transfer-Encoding"-tokenUserAgent = Token 48 True False "User-Agent"-tokenVary = Token 49 True False "Vary"-tokenVia = Token 50 True False "Via"-tokenWwwAuthenticate = Token 51 True False "Www-Authenticate"---- | A place holder to hold header keys not defined in the static table.--- | For Warp-tokenConnection = Token 52 False False "Connection"-tokenTE = Token 53 False False "TE"--- | For QPACK-tokenAccessControlAllowCredentials = Token 54 True False "Access-Control-Allow-Credentials"-tokenAccessControlAllowHeaders = Token 55 True False "Access-Control-Allow-Headers"-tokenAccessControlAllowMethods = Token 56 True False "Access-Control-Allow-Methods"-tokenAccessControlExposeHeaders = Token 57 True False "Access-Control-Expose-Headers"-tokenAccessControlRequestHeaders = Token 58 True False "Access-Control-Request-Headers"-tokenAccessControlRequestMethod = Token 59 True False "Access-Control-Request-Method"-tokenAltSvc = Token 60 True False "Alt-Svc"-tokenContentSecurityPolicy = Token 61 True False "Content-Security-Policy"-tokenEarlyData = Token 62 True False "Early-Data"-tokenExpectCt = Token 63 True False "Expect-Ct"-tokenForwarded = Token 64 True False "Forwarded"-tokenOrigin = Token 65 True False "Origin"-tokenPurpose = Token 66 True False "Purpose"-tokenTimingAllowOrigin = Token 67 True False "Timing-Allow-Origin"-tokenUpgradeInsecureRequests = Token 68 True False "Upgrade-Insecure-Requests"-tokenXContentTypeOptions = Token 69 True False "X-Content-Type-Options"-tokenXForwardedFor = Token 70 True False "X-Forwarded-For"-tokenXFrameOptions = Token 71 True False "X-Frame-Options"-tokenXXssProtection = Token 72 True False "X-Xss-Protection"--tokenMax = Token 73 True False "for other tokens"-{- FOURMOLU_ENABLE -}---- | Minimum token index.-minTokenIx :: Int-minTokenIx = 0---- | Maximun token index defined in the static table.-maxStaticTokenIx :: Int-maxStaticTokenIx = 51---- | Maximum token index.-maxTokenIx :: Int-maxTokenIx = 73---- | Token index for 'tokenCookie'.-cookieTokenIx :: Int-cookieTokenIx = 22---- | Is this token ix for Cookie?-{-# INLINE isCookieTokenIx #-}-isCookieTokenIx :: Int -> Bool-isCookieTokenIx n = n == cookieTokenIx---- | Is this token ix to be held in the place holder?-{-# INLINE isMaxTokenIx #-}-isMaxTokenIx :: Int -> Bool-isMaxTokenIx n = n == maxTokenIx---- | Is this token ix for a header not defined in the static table?-{-# INLINE isStaticTokenIx #-}-isStaticTokenIx :: Int -> Bool-isStaticTokenIx n = n <= maxStaticTokenIx---- | Is this token for a header not defined in the static table?-{-# INLINE isStaticToken #-}-isStaticToken :: Token -> Bool-isStaticToken n = tokenIx n <= maxStaticTokenIx---- | Making a token from a header key.------ >>> toToken ":authority" == tokenAuthority--- True--- >>> toToken "foo"--- Token {tokenIx = 73, shouldBeIndexed = True, isPseudo = False, tokenKey = "foo"}--- >>> toToken ":bar"--- Token {tokenIx = 73, shouldBeIndexed = True, isPseudo = True, tokenKey = ":bar"}-toToken :: ByteString -> Token-toToken "" = Token maxTokenIx True False ""-toToken bs = case len of- 2 -> if bs === "te" then tokenTE else mkTokenMax bs- 3 -> case lst of- 97 | bs === "via" -> tokenVia- 101 | bs === "age" -> tokenAge- _ -> mkTokenMax bs- 4 -> case lst of- 101 | bs === "date" -> tokenDate- 103 | bs === "etag" -> tokenEtag- 107 | bs === "link" -> tokenLink- 109 | bs === "from" -> tokenFrom- 116 | bs === "host" -> tokenHost- 121 | bs === "vary" -> tokenVary- _ -> mkTokenMax bs- 5 -> case lst of- 101 | bs === "range" -> tokenRange- 104 | bs === ":path" -> tokenPath- 119 | bs === "allow" -> tokenAllow- _ -> mkTokenMax bs- 6 -> case lst of- 101 | bs === "cookie" -> tokenCookie- 110 | bs === "origin" -> tokenOrigin- 114 | bs === "server" -> tokenServer- 116- | bs === "expect" -> tokenExpect- | bs === "accept" -> tokenAccept- _ -> mkTokenMax bs- 7 -> case lst of- 99 | bs === "alt-svc" -> tokenAltSvc- 100 | bs === ":method" -> tokenMethod- 101- | bs === ":scheme" -> tokenScheme- | bs === "purpose" -> tokenPurpose- 104 | bs === "refresh" -> tokenRefresh- 114 | bs === "referer" -> tokenReferer- 115- | bs === "expires" -> tokenExpires- | bs === ":status" -> tokenStatus- _ -> mkTokenMax bs- 8 -> case lst of- 101 | bs === "if-range" -> tokenIfRange- 104 | bs === "if-match" -> tokenIfMatch- 110 | bs === "location" -> tokenLocation- _ -> mkTokenMax bs- 9 -> case lst of- 100 | bs === "forwarded" -> tokenForwarded- 116 | bs === "expect-ct" -> tokenExpectCt- _ -> mkTokenMax bs- 10 -> case lst of- 97 | bs === "early-data" -> tokenEarlyData- 101 | bs === "set-cookie" -> tokenSetCookie- 110 | bs === "connection" -> tokenConnection- 116 | bs === "user-agent" -> tokenUserAgent- 121 | bs === ":authority" -> tokenAuthority- _ -> mkTokenMax bs- 11 -> case lst of- 114 | bs === "retry-after" -> tokenRetryAfter- _ -> mkTokenMax bs- 12 -> case lst of- 101 | bs === "content-type" -> tokenContentType- 115 | bs === "max-forwards" -> tokenMaxForwards- _ -> mkTokenMax bs- 13 -> case lst of- 100 | bs === "last-modified" -> tokenLastModified- 101 | bs === "content-range" -> tokenContentRange- 104 | bs === "if-none-match" -> tokenIfNoneMatch- 108 | bs === "cache-control" -> tokenCacheControl- 110 | bs === "authorization" -> tokenAuthorization- 115 | bs === "accept-ranges" -> tokenAcceptRanges- _ -> mkTokenMax bs- 14 -> case lst of- 104 | bs === "content-length" -> tokenContentLength- 116 | bs === "accept-charset" -> tokenAcceptCharset- _ -> mkTokenMax bs- 15 -> case lst of- 101 | bs === "accept-language" -> tokenAcceptLanguage- 103 | bs === "accept-encoding" -> tokenAcceptEncoding- 114 | bs === "x-forwarded-for" -> tokenXForwardedFor- 115 | bs === "x-frame-options" -> tokenXFrameOptions- _ -> mkTokenMax bs- 16 -> case lst of- 101- | bs === "content-language" -> tokenContentLanguage- | bs === "www-authenticate" -> tokenWwwAuthenticate- 103 | bs === "content-encoding" -> tokenContentEncoding- 110- | bs === "content-location" -> tokenContentLocation- | bs === "x-xss-protection" -> tokenXXssProtection- _ -> mkTokenMax bs- 17 -> case lst of- 101 | bs === "if-modified-since" -> tokenIfModifiedSince- 103 | bs === "transfer-encoding" -> tokenTransferEncoding- _ -> mkTokenMax bs- 18 -> case lst of- 101 | bs === "proxy-authenticate" -> tokenProxyAuthenticate- _ -> mkTokenMax bs- 19 -> case lst of- 101 | bs === "if-unmodified-since" -> tokenIfUnmodifiedSince- 110- | bs === "proxy-authorization" -> tokenProxyAuthorization- | bs === "content-disposition" -> tokenContentDisposition- | bs === "timing-allow-origin" -> tokenTimingAllowOrigin- _ -> mkTokenMax bs- 22 -> case lst of- 115 | bs === "x-content-type-options" -> tokenXContentTypeOptions- _ -> mkTokenMax bs- 23 -> case lst of- 121 | bs === "content-security-policy" -> tokenContentSecurityPolicy- _ -> mkTokenMax bs- 25 -> case lst of- 115 | bs === "upgrade-insecure-requests" -> tokenUpgradeInsecureRequests- 121 | bs === "strict-transport-security" -> tokenStrictTransportSecurity- _ -> mkTokenMax bs- 27 -> case lst of- 110 | bs === "access-control-allow-origin" -> tokenAccessControlAllowOrigin- _ -> mkTokenMax bs- 28 -> case lst of- 115- | bs === "access-control-allow-headers" -> tokenAccessControlAllowHeaders- | bs === "access-control-allow-methods" -> tokenAccessControlAllowMethods- _ -> mkTokenMax bs- 29 -> case lst of- 100 | bs === "access-control-request-method" -> tokenAccessControlRequestMethod- 115 | bs === "access-control-expose-headers" -> tokenAccessControlExposeHeaders- _ -> mkTokenMax bs- 30 -> case lst of- 115 | bs === "access-control-request-headers" -> tokenAccessControlRequestHeaders- _ -> mkTokenMax bs- 32 -> case lst of- 115- | bs === "access-control-allow-credentials" ->- tokenAccessControlAllowCredentials- _ -> mkTokenMax bs- _ -> mkTokenMax bs- where- len = B.length bs- lst = B.last bs- PS fp1 off1 siz === PS fp2 off2 _ = unsafeDupablePerformIO $- withForeignPtr fp1 $ \p1 ->- withForeignPtr fp2 $ \p2 -> do- i <- memcmp (p1 `plusPtr` off1) (p2 `plusPtr` off2) siz- return $ i == 0--mkTokenMax :: ByteString -> Token-mkTokenMax bs = Token maxTokenIx True p (mk bs)- where- p- | B.length bs == 0 = False- | B.head bs == 58 = True- | otherwise = False+import Network.HTTP.Semantics.Token
Network/HPACK/Types.hs view
@@ -2,10 +2,7 @@ module Network.HPACK.Types ( -- * Header- HeaderName,- HeaderValue,- Header,- HeaderList,+ FieldValue, TokenHeader, TokenHeaderList, @@ -25,32 +22,10 @@ BufferOverrun (..), ) where -import Control.Exception as E-import Data.Typeable import Network.ByteOrder (Buffer, BufferOverrun (..), BufferSize)+import UnliftIO.Exception as E import Imports-import Network.HPACK.Token (Token)---------------------------------------------------------------------- | Header name.-type HeaderName = ByteString---- | Header value.-type HeaderValue = ByteString---- | Header.-type Header = (HeaderName, HeaderValue)---- | Header list.-type HeaderList = [Header]---- | TokenBased header.-type TokenHeader = (Token, HeaderValue)---- | TokenBased header list.-type TokenHeaderList = [TokenHeader] ----------------------------------------------------------------
Network/HTTP2/Client.hs view
@@ -10,11 +10,11 @@ -- > -- > module Main where -- >--- > import Control.Concurrent.Async--- > import qualified Control.Exception as E -- > import qualified Data.ByteString.Char8 as C8 -- > import Network.HTTP.Types -- > import Network.Run.TCP (runTCPClient) -- network-run+-- > import UnliftIO.Async -- unliftio+-- > import qualified UnliftIO.Exception as E -- unliftio -- > -- > import Network.HTTP2.Client -- >@@ -47,8 +47,6 @@ run, -- * Client configuration- Scheme,- Authority, ClientConfig, defaultClientConfig, scheme,@@ -72,47 +70,7 @@ Config (..), allocSimpleConfig, freeSimpleConfig,-- -- * HTTP\/2 client- Client,- SendRequest,-- -- * Request- Request,-- -- * Creating request- requestNoBody,- requestFile,- requestStreaming,- requestStreamingUnmask,- requestBuilder,-- -- ** Trailers maker- TrailersMaker,- NextTrailersMaker (..),- defaultTrailersMaker,- setRequestTrailersMaker,-- -- * Response- Response,-- -- ** Accessing response- responseStatus,- responseHeaders,- responseBodySize,- getResponseBodyChunk,- getResponseTrailers,-- -- * Aux- Aux,- auxPossibleClientStreams,-- -- * Types- Method,- Path,- FileSpec (..),- FileOffset,- ByteCount,+ module Network.HTTP.Semantics.Client, -- * Error HTTP2Error (..),@@ -134,98 +92,10 @@ InadequateSecurity, HTTP11Required ),-- -- * RecvN- defaultReadN,-- -- * Position read for files- PositionReadMaker,- PositionRead,- Sentinel (..),- defaultPositionReadMaker, ) where -import Data.ByteString (ByteString)-import Data.ByteString.Builder (Builder)-import Data.IORef (readIORef)-import Network.HTTP.Types+import Network.HTTP.Semantics.Client -import Network.HPACK import Network.HTTP2.Client.Run-import Network.HTTP2.Client.Types import Network.HTTP2.Frame import Network.HTTP2.H2 hiding (authority, scheme)---------------------------------------------------------------------- | Creating request without body.-requestNoBody :: Method -> Path -> RequestHeaders -> Request-requestNoBody m p hdr = Request $ OutObj hdr' OutBodyNone defaultTrailersMaker- where- hdr' = addHeaders m p hdr---- | Creating request with file.-requestFile :: Method -> Path -> RequestHeaders -> FileSpec -> Request-requestFile m p hdr fileSpec = Request $ OutObj hdr' (OutBodyFile fileSpec) defaultTrailersMaker- where- hdr' = addHeaders m p hdr---- | Creating request with builder.-requestBuilder :: Method -> Path -> RequestHeaders -> Builder -> Request-requestBuilder m p hdr builder = Request $ OutObj hdr' (OutBodyBuilder builder) defaultTrailersMaker- where- hdr' = addHeaders m p hdr---- | Creating request with streaming.-requestStreaming- :: Method- -> Path- -> RequestHeaders- -> ((Builder -> IO ()) -> IO () -> IO ())- -> Request-requestStreaming m p hdr strmbdy = Request $ OutObj hdr' (OutBodyStreaming strmbdy) defaultTrailersMaker- where- hdr' = addHeaders m p hdr---- | Like 'requestStreaming', but run the action with exceptions masked-requestStreamingUnmask- :: Method- -> Path- -> RequestHeaders- -> ((forall x. IO x -> IO x) -> (Builder -> IO ()) -> IO () -> IO ())- -> Request-requestStreamingUnmask m p hdr strmbdy = Request $ OutObj hdr' (OutBodyStreamingUnmask strmbdy) defaultTrailersMaker- where- hdr' = addHeaders m p hdr--addHeaders :: Method -> Path -> RequestHeaders -> RequestHeaders-addHeaders m p hdr = (":method", m) : (":path", p) : hdr---- | Setting 'TrailersMaker' to 'Response'.-setRequestTrailersMaker :: Request -> TrailersMaker -> Request-setRequestTrailersMaker (Request req) tm = Request req{outObjTrailers = tm}---------------------------------------------------------------------- | Getting the status of a response.-responseStatus :: Response -> Maybe Status-responseStatus (Response rsp) = getStatus $ inpObjHeaders rsp---- | Getting the headers from a response.-responseHeaders :: Response -> HeaderTable-responseHeaders (Response rsp) = inpObjHeaders rsp---- | Getting the body size from a response.-responseBodySize :: Response -> Maybe Int-responseBodySize (Response rsp) = inpObjBodySize rsp---- | Reading a chunk of the response body.--- An empty 'ByteString' returned when finished.-getResponseBodyChunk :: Response -> IO ByteString-getResponseBodyChunk (Response rsp) = inpObjBody rsp---- | Reading response trailers.--- This function must be called after 'getResponseBodyChunk'--- returns an empty.-getResponseTrailers :: Response -> IO (Maybe HeaderTable)-getResponseTrailers (Response rsp) = readIORef (inpObjTrailers rsp)
Network/HTTP2/Client/Internal.hs view
@@ -11,6 +11,8 @@ runIO, ) where +import Network.HTTP.Semantics.Client+import Network.HTTP.Semantics.Client.Internal+ import Network.HTTP2.Client.Run-import Network.HTTP2.Client.Types import Network.HTTP2.H2
Network/HTTP2/Client/Run.hs view
@@ -6,19 +6,20 @@ module Network.HTTP2.Client.Run where import Control.Concurrent.STM (check)-import Control.Exception import Data.ByteString.Builder (Builder) import qualified Data.ByteString.UTF8 as UTF8 import Data.IORef import Network.Control (RxFlow (..), defaultMaxData)+import Network.HTTP.Semantics.Client+import Network.HTTP.Semantics.Client.Internal+import Network.HTTP.Semantics.IO import Network.Socket (SockAddr) import UnliftIO.Async import UnliftIO.Concurrent+import UnliftIO.Exception import UnliftIO.STM import Imports-import Network.HTTP.Types (Header)-import Network.HTTP2.Client.Types import Network.HTTP2.Frame import Network.HTTP2.H2
− Network/HTTP2/Client/Types.hs
@@ -1,25 +0,0 @@-{-# LANGUAGE RankNTypes #-}--module Network.HTTP2.Client.Types where--import Network.HTTP2.H2---------------------------------------------------------------------- | Send a request and receive its response.-type SendRequest = forall r. Request -> (Response -> IO r) -> IO r---- | Client type.-type Client a = SendRequest -> Aux -> IO a---- | Request from client.-newtype Request = Request OutObj deriving (Show)---- | Response from server.-newtype Response = Response InpObj deriving (Show)---- | Additional information.-data Aux = Aux- { auxPossibleClientStreams :: IO Int- -- ^ How many streams can be created without blocking.- }
Network/HTTP2/Frame.hs view
@@ -73,7 +73,7 @@ SettingsList, SettingsKey ( SettingsKey,- SettingsHeaderTableSize,+ SettingsTokenHeaderTableSize, SettingsEnablePush, SettingsMaxConcurrentStreams, SettingsInitialWindowSize,
Network/HTTP2/Frame/Decode.hs view
@@ -24,12 +24,12 @@ decodeContinuationFrame, ) where -import Control.Exception (Exception) import Data.Array (Array, listArray, (!)) import qualified Data.ByteString as BS import Foreign.Ptr (Ptr, plusPtr) import qualified Network.ByteOrder as N import System.IO.Unsafe (unsafeDupablePerformIO)+import UnliftIO.Exception (Exception) import Imports import Network.HTTP2.Frame.Types
Network/HTTP2/Frame/Types.hs view
@@ -114,8 +114,8 @@ maxSettingsKey = SettingsKey 6 {- FOURMOLU_DISABLE -}-pattern SettingsHeaderTableSize :: SettingsKey-pattern SettingsHeaderTableSize = SettingsKey 1+pattern SettingsTokenHeaderTableSize :: SettingsKey+pattern SettingsTokenHeaderTableSize = SettingsKey 1 pattern SettingsEnablePush :: SettingsKey pattern SettingsEnablePush = SettingsKey 2@@ -135,7 +135,7 @@ {- FOURMOLU_DISABLE -} instance Show SettingsKey where- show SettingsHeaderTableSize = "SettingsHeaderTableSize"+ show SettingsTokenHeaderTableSize = "SettingsTokenHeaderTableSize" show SettingsEnablePush = "SettingsEnablePush" show SettingsMaxConcurrentStreams = "SettingsMaxConcurrentStreams" show SettingsInitialWindowSize = "SettingsInitialWindowSize"@@ -150,7 +150,7 @@ Ident idnt <- lexP readSK idnt where- readSK "SettingsHeaderTableSize" = return SettingsHeaderTableSize+ readSK "SettingsTokenHeaderTableSize" = return SettingsTokenHeaderTableSize readSK "SettingsEnablePush" = return SettingsEnablePush readSK "SettingsMaxConcurrentStreams" = return SettingsMaxConcurrentStreams readSK "SettingsInitialWindowSize" = return SettingsInitialWindowSize
Network/HTTP2/H2.hs view
@@ -2,15 +2,12 @@ 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,@@ -20,15 +17,12 @@ 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
Network/HTTP2/H2/Config.hs view
@@ -2,13 +2,12 @@ import Data.IORef import Foreign.Marshal.Alloc (free, mallocBytes)+import Network.HTTP.Semantics.Client import Network.Socket import Network.Socket.ByteString (sendAll) import qualified System.TimeManager as T import Network.HPACK-import Network.HTTP2.H2.File-import Network.HTTP2.H2.ReadN import Network.HTTP2.H2.Types -- | Making simple configuration whose IO is not efficient.
Network/HTTP2/H2/Context.hs view
@@ -4,11 +4,10 @@ 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 UnliftIO.Exception import qualified UnliftIO.Exception as E import UnliftIO.STM @@ -178,16 +177,17 @@ setStreamState _ Stream{streamState} newState = do oldState <- readIORef streamState case (oldState, newState) of- (Open _ (Body q _ _ _), Open _ (Body q' _ _ _)) | q == q' ->- -- The stream stays open with the same body; nothing to do- return ()- (Open _ (Body q _ _ _), _) ->- -- The stream is either closed, or is open with a /new/ body- -- We need to close the old queue so that any reads from it won't block- atomically $ writeTQueue q $ Left $ toException ConnectionIsClosed- _otherwise ->- -- The stream wasn't open to start with; nothing to do- return ()+ (Open _ (Body q _ _ _), Open _ (Body q' _ _ _))+ | q == q' ->+ -- The stream stays open with the same body; nothing to do+ return ()+ (Open _ (Body q _ _ _), _) ->+ -- The stream is either closed, or is open with a /new/ body+ -- We need to close the old queue so that any reads from it won't block+ atomically $ writeTQueue q $ Left $ toException ConnectionIsClosed+ _otherwise ->+ -- The stream wasn't open to start with; nothing to do+ return () writeIORef streamState newState opened :: Context -> Stream -> IO ()
− Network/HTTP2/H2/File.hs
@@ -1,38 +0,0 @@-module Network.HTTP2.H2.File where--import System.IO--import Imports-import Network.HPACK---- | Offset for file.-type FileOffset = Int64---- | How many bytes to read-type ByteCount = Int64---- | Position read for files.-type PositionRead = FileOffset -> ByteCount -> Buffer -> IO ByteCount---- | Manipulating a file resource.-data Sentinel- = -- | Closing a file resource. Its refresher is automatiaclly generated by- -- the internal timer.- Closer (IO ())- | -- | Refreshing a file resource while reading.- -- Closing the file must be done by its own timer or something.- Refresher (IO ())---- | Making a position read and its closer.-type PositionReadMaker = FilePath -> IO (PositionRead, Sentinel)---- | Position read based on 'Handle'.-defaultPositionReadMaker :: PositionReadMaker-defaultPositionReadMaker file = do- hdl <- openBinaryFile file ReadMode- return (pread hdl, Closer $ hClose hdl)- where- pread :: Handle -> PositionRead- pread hdl off bytes buf = do- hSeek hdl AbsoluteSeek $ fromIntegral off- fromIntegral <$> hGetBufSome hdl buf (fromIntegral bytes)
Network/HTTP2/H2/HPACK.hs view
@@ -10,13 +10,13 @@ fixHeaders, ) where -import qualified Control.Exception as E import Network.ByteOrder-import qualified Network.HTTP.Types as H+import Network.HTTP.Semantics+import Network.HTTP.Types+import qualified UnliftIO.Exception as E import Imports import Network.HPACK-import Network.HPACK.Token import Network.HTTP2.Frame import Network.HTTP2.H2.Context import Network.HTTP2.H2.Types@@ -26,17 +26,17 @@ ---------------------------------------------------------------- -fixHeaders :: H.ResponseHeaders -> H.ResponseHeaders+fixHeaders :: ResponseHeaders -> ResponseHeaders fixHeaders hdr = deleteUnnecessaryHeaders hdr -deleteUnnecessaryHeaders :: H.ResponseHeaders -> H.ResponseHeaders+deleteUnnecessaryHeaders :: ResponseHeaders -> ResponseHeaders deleteUnnecessaryHeaders hdr = filter del hdr where del (k, _) = k `notElem` headersToBeRemoved -headersToBeRemoved :: [H.HeaderName]+headersToBeRemoved :: [HeaderName] headersToBeRemoved =- [ H.hConnection+ [ hConnection , "Transfer-Encoding" -- Keep-Alive -- Proxy-Connection@@ -71,7 +71,7 @@ ---------------------------------------------------------------- hpackDecodeHeader- :: HeaderBlockFragment -> StreamId -> Context -> IO HeaderTable+ :: HeaderBlockFragment -> StreamId -> Context -> IO TokenHeaderTable hpackDecodeHeader hdrblk sid ctx = do tbl@(_, vt) <- hpackDecodeTrailer hdrblk sid ctx if isClient ctx || checkRequestHeader vt@@ -79,7 +79,7 @@ else E.throwIO $ StreamErrorIsSent ProtocolError sid "illegal header" hpackDecodeTrailer- :: HeaderBlockFragment -> StreamId -> Context -> IO HeaderTable+ :: HeaderBlockFragment -> StreamId -> Context -> IO TokenHeaderTable hpackDecodeTrailer hdrblk sid Context{..} = decodeTokenHeader decodeDynamicTable hdrblk `E.catch` handl where handl IllegalHeaderName =@@ -101,14 +101,14 @@ | just mTE (/= "trailers") = False | otherwise = checkAuth mAuthority mHost where- mStatus = getHeaderValue tokenStatus reqvt- mScheme = getHeaderValue tokenScheme reqvt- mPath = getHeaderValue tokenPath reqvt- mMethod = getHeaderValue tokenMethod reqvt- mConnection = getHeaderValue tokenConnection reqvt- mTE = getHeaderValue tokenTE reqvt- mAuthority = getHeaderValue tokenAuthority reqvt- mHost = getHeaderValue tokenHost reqvt+ mStatus = getFieldValue tokenStatus reqvt+ mScheme = getFieldValue tokenScheme reqvt+ mPath = getFieldValue tokenPath reqvt+ mMethod = getFieldValue tokenMethod reqvt+ mConnection = getFieldValue tokenConnection reqvt+ mTE = getFieldValue tokenTE reqvt+ mAuthority = getFieldValue tokenAuthority reqvt+ mHost = getFieldValue tokenHost reqvt checkAuth :: Maybe ByteString -> Maybe ByteString -> Bool checkAuth Nothing Nothing = False
Network/HTTP2/H2/Manager.hs view
@@ -21,13 +21,13 @@ 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 UnliftIO.Exception import qualified UnliftIO.Exception as E import UnliftIO.STM
− Network/HTTP2/H2/ReadN.hs
@@ -1,40 +0,0 @@-module Network.HTTP2.H2.ReadN where--import qualified Data.ByteString as B-import Data.IORef-import Network.Socket-import qualified Network.Socket.ByteString as N---- | Naive implementation for readN.-defaultReadN :: Socket -> IORef (Maybe B.ByteString) -> Int -> IO B.ByteString-defaultReadN _ _ 0 = return B.empty-defaultReadN s ref n = do- mbs <- readIORef ref- writeIORef ref Nothing- case mbs of- Nothing -> do- bs <- N.recv s n- if B.null bs- then return B.empty- else- if B.length bs == n- then return bs- else loop bs- Just bs- | B.length bs == n -> return bs- | B.length bs > n -> do- let (bs0, bs1) = B.splitAt n bs- writeIORef ref (Just bs1)- return bs0- | otherwise -> loop bs- where- loop bs = do- let n' = n - B.length bs- bs1 <- N.recv s n'- if B.null bs1- then return B.empty- else do- let bs2 = bs `B.append` bs1- if B.length bs2 == n- then return bs2- else loop bs2
Network/HTTP2/H2/Receiver.hs view
@@ -13,13 +13,12 @@ import qualified Data.ByteString.UTF8 as UTF8 import Data.IORef import Network.Control+import Network.HTTP.Semantics 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.Frame import Network.HTTP2.H2.Context import Network.HTTP2.H2.EncodeFrame@@ -173,7 +172,7 @@ processState :: StreamState -> Context -> Stream -> StreamId -> IO Bool -- Transition (process1) processState (Open _ (NoBody tbl@(_, reqvt))) ctx@Context{..} strm@Stream{streamInput} streamId = do- let mcl = fst <$> (getHeaderValue tokenContentLength reqvt >>= C8.readInt)+ let mcl = fst <$> (getFieldValue tokenContentLength reqvt >>= C8.readInt) when (just mcl (/= (0 :: Int))) $ E.throwIO $ StreamErrorIsSent@@ -192,7 +191,7 @@ -- Transition (process2) processState (Open hcl (HasBody tbl@(_, reqvt))) ctx@Context{..} strm@Stream{streamInput} _streamId = do- let mcl = fst <$> (getHeaderValue tokenContentLength reqvt >>= C8.readInt)+ let mcl = fst <$> (getFieldValue tokenContentLength reqvt >>= C8.readInt) bodyLength <- newIORef 0 tlr <- newIORef Nothing q <- newTQueueIO@@ -366,12 +365,12 @@ (_, vt) <- hpackDecodeHeader frag streamId ctx let ClientInfo{..} = toClientInfo $ roleInfo ctx when- ( getHeaderValue tokenAuthority vt == Just (UTF8.fromString authority)- && getHeaderValue tokenScheme vt == Just scheme+ ( getFieldValue tokenAuthority vt == Just (UTF8.fromString authority)+ && getFieldValue tokenScheme vt == Just scheme ) $ do- let mmethod = getHeaderValue tokenMethod vt- mpath = getHeaderValue tokenPath vt+ let mmethod = getFieldValue tokenMethod vt+ mpath = getFieldValue tokenPath vt case (mmethod, mpath) of (Just method, Just path) -> -- FLOW CONTROL: SETTINGS_MAX_CONCURRENT_STREAMS: recv: rejecting if over my limit
Network/HTTP2/H2/Sender.hs view
@@ -5,29 +5,23 @@ module Network.HTTP2.H2.Sender ( frameSender,- fillBuilderBodyGetNext,- fillFileBodyGetNext,- fillStreamBodyGetNext,- runTrailersMaker, ) where import Control.Concurrent.MVar (putMVar)-import qualified Data.ByteString as BS-import Data.ByteString.Builder (Builder)-import qualified Data.ByteString.Builder.Extra as B import Data.IORef (modifyIORef', readIORef, writeIORef) import Data.IntMap.Strict (IntMap) import Foreign.Ptr (minusPtr, plusPtr) import Network.ByteOrder+import Network.HTTP.Semantics.Client+import Network.HTTP.Semantics.IO import qualified UnliftIO.Exception as E import UnliftIO.STM import Imports-import Network.HPACK (TokenHeaderList, setLimitForEncoding, toHeaderTable)+import Network.HPACK (setLimitForEncoding, toTokenHeaderTable) import Network.HTTP2.Frame import Network.HTTP2.H2.Context import Network.HTTP2.H2.EncodeFrame-import Network.HTTP2.H2.File import Network.HTTP2.H2.HPACK import Network.HTTP2.H2.Manager hiding (start) import Network.HTTP2.H2.Queue@@ -39,13 +33,6 @@ ---------------------------------------------------------------- -data Leftover- = LZero- | LOne B.BufferWriter- | LTwo ByteString B.BufferWriter------------------------------------------------------------------- {-# INLINE waitStreaming #-} waitStreaming :: TBQueue a -> IO () waitStreaming tbq = atomically $ do@@ -158,7 +145,7 @@ | otherwise = confBufferSize writeIORef outputBufferLimit buflim -- Peer SETTINGS_HEADER_TABLE_SIZE- case lookup SettingsHeaderTableSize peerAlist of+ case lookup SettingsTokenHeaderTableSize peerAlist of Nothing -> return () Just siz -> setLimitForEncoding siz encodeDynamicTable @@ -187,7 +174,7 @@ endOfStream = case body of OutBodyNone -> True _ -> False- (ths, _) <- toHeaderTable $ fixHeaders hdr+ (ths, _) <- toTokenHeaderTable $ fixHeaders hdr off' <- headerContinue sid ths endOfStream off0 -- halfClosedLocal calls closed which removes -- the stream from stream table.@@ -352,7 +339,7 @@ where handleTrailers Nothing off0 = return off0 handleTrailers (Just trailers) off0 = do- (ths, _) <- toHeaderTable trailers+ (ths, _) <- toTokenHeaderTable trailers headerContinue streamNumber ths True {- endOfStream -} off0 fillDataHeaderEnqueueNext _@@ -419,168 +406,3 @@ , flags = flag , streamId = sid }---- | Running trailers-maker.------ > bufferIO buf siz $ \bs -> tlrmkr (Just bs)-runTrailersMaker :: TrailersMaker -> Buffer -> Int -> IO NextTrailersMaker-runTrailersMaker tlrmkr buf siz = bufferIO buf siz $ \bs -> tlrmkr (Just bs)--------------------------------------------------------------------fillBuilderBodyGetNext :: Builder -> DynaNext-fillBuilderBodyGetNext bb buf siz lim = do- let room = min siz lim- (len, signal) <- B.runBuilder bb buf room- return $ nextForBuilder len signal--fillFileBodyGetNext- :: PositionRead -> FileOffset -> ByteCount -> IO () -> DynaNext-fillFileBodyGetNext pread start bytecount refresh buf siz lim = do- let room = min siz lim- len <- pread start (mini room bytecount) buf- let len' = fromIntegral len- return $ nextForFile len' pread (start + len) (bytecount - len) refresh--fillStreamBodyGetNext :: IO (Maybe StreamingChunk) -> DynaNext-fillStreamBodyGetNext takeQ buf siz lim = do- let room = min siz lim- (cont, len, reqflush, leftover) <- runStreamBuilder buf room takeQ- return $ nextForStream cont len reqflush leftover takeQ--------------------------------------------------------------------fillBufBuilder :: Leftover -> DynaNext-fillBufBuilder leftover buf0 siz0 lim = do- let room = min siz0 lim- case leftover of- LZero -> error "fillBufBuilder: LZero"- LOne writer -> do- (len, signal) <- writer buf0 room- getNext len signal- LTwo bs writer- | BS.length bs <= room -> do- buf1 <- copy buf0 bs- let len1 = BS.length bs- (len2, signal) <- writer buf1 (room - len1)- getNext (len1 + len2) signal- | otherwise -> do- let (bs1, bs2) = BS.splitAt room bs- void $ copy buf0 bs1- getNext room (B.Chunk bs2 writer)- where- getNext l s = return $ nextForBuilder l s--nextForBuilder :: BytesFilled -> B.Next -> Next-nextForBuilder len B.Done =- Next len True Nothing -- let's flush-nextForBuilder len (B.More _ writer) =- Next len False $ Just (fillBufBuilder (LOne writer))-nextForBuilder len (B.Chunk bs writer) =- Next len False $ Just (fillBufBuilder (LTwo bs writer))--------------------------------------------------------------------runStreamBuilder- :: Buffer- -> BufferSize- -> IO (Maybe StreamingChunk)- -> IO- ( Bool -- continue- , BytesFilled- , Bool -- require flusing- , Leftover- )-runStreamBuilder buf0 room0 takeQ = loop buf0 room0 0- where- loop buf room total = do- mbuilder <- takeQ- case mbuilder of- Nothing -> return (True, total, False, LZero)- Just (StreamingBuilder builder) -> do- (len, signal) <- B.runBuilder builder buf room- let total' = total + len- case signal of- B.Done -> loop (buf `plusPtr` len) (room - len) total'- B.More _ writer -> return (True, total', False, LOne writer)- B.Chunk bs writer -> return (True, total', False, LTwo bs writer)- Just StreamingFlush -> return (True, total, True, LZero)- Just (StreamingFinished dec) -> do- dec- return (False, total, True, LZero)--fillBufStream :: Leftover -> IO (Maybe StreamingChunk) -> DynaNext-fillBufStream leftover0 takeQ buf0 siz0 lim0 = do- let room0 = min siz0 lim0- case leftover0 of- LZero -> do- (cont, len, reqflush, leftover) <- runStreamBuilder buf0 room0 takeQ- getNext cont len reqflush leftover- LOne writer -> write writer buf0 room0 0- LTwo bs writer- | BS.length bs <= room0 -> do- buf1 <- copy buf0 bs- let len = BS.length bs- write writer buf1 (room0 - len) len- | otherwise -> do- let (bs1, bs2) = BS.splitAt room0 bs- void $ copy buf0 bs1- getNext True room0 False $ LTwo bs2 writer- where- getNext :: Bool -> BytesFilled -> Bool -> Leftover -> IO Next- getNext cont len reqflush l = return $ nextForStream cont len reqflush l takeQ-- write- :: (Buffer -> BufferSize -> IO (Int, B.Next))- -> Buffer- -> BufferSize- -> Int- -> IO Next- write writer1 buf room sofar = do- (len, signal) <- writer1 buf room- case signal of- B.Done -> do- (cont, extra, reqflush, leftover) <-- runStreamBuilder (buf `plusPtr` len) (room - len) takeQ- let total = sofar + len + extra- getNext cont total reqflush leftover- B.More _ writer -> do- let total = sofar + len- getNext True total False $ LOne writer- B.Chunk bs writer -> do- let total = sofar + len- getNext True total False $ LTwo bs writer--nextForStream- :: Bool- -> BytesFilled- -> Bool- -> Leftover- -> IO (Maybe StreamingChunk)- -> Next-nextForStream False len reqflush _ _ = Next len reqflush Nothing-nextForStream True len reqflush leftOrZero takeQ =- Next len reqflush $ Just (fillBufStream leftOrZero takeQ)--------------------------------------------------------------------fillBufFile :: PositionRead -> FileOffset -> ByteCount -> IO () -> DynaNext-fillBufFile pread start bytes refresh buf siz lim = do- let room = min siz lim- len <- pread start (mini room bytes) buf- refresh- let len' = fromIntegral len- return $ nextForFile len' pread (start + len) (bytes - len) refresh--nextForFile- :: BytesFilled -> PositionRead -> FileOffset -> ByteCount -> IO () -> Next-nextForFile 0 _ _ _ _ = Next 0 True Nothing -- let's flush-nextForFile len _ _ 0 _ = Next len False Nothing-nextForFile len pread start bytes refresh =- Next len False $ Just $ fillBufFile pread start bytes refresh--{-# INLINE mini #-}-mini :: Int -> Int64 -> Int64-mini i n- | fromIntegral i < n = fromIntegral i- | otherwise = n
Network/HTTP2/H2/Settings.hs view
@@ -67,7 +67,7 @@ fromSettingsList :: Settings -> SettingsList -> Settings fromSettingsList settings kvs = foldl' update settings kvs where- update def (SettingsHeaderTableSize,x) = def { headerTableSize = x }+ update def (SettingsTokenHeaderTableSize,x) = def { headerTableSize = x } -- fixme: x should be 0 or 1 update def (SettingsEnablePush,x) = def { enablePush = x > 0 } update def (SettingsMaxConcurrentStreams,x) = def { maxConcurrentStreams = Just x }@@ -101,7 +101,7 @@ s s0 headerTableSize- SettingsHeaderTableSize+ SettingsTokenHeaderTableSize id , diff s
− Network/HTTP2/H2/Status.hs
@@ -1,44 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Network.HTTP2.H2.Status (- getStatus,- setStatus,-) where--import qualified Data.ByteString.Char8 as C8-import Data.ByteString.Internal (unsafeCreate)-import Foreign.Ptr (plusPtr)-import Foreign.Storable (poke)-import qualified Network.HTTP.Types as H--import Imports-import Network.HPACK-import Network.HPACK.Token--------------------------------------------------------------------getStatus :: HeaderTable -> Maybe H.Status-getStatus (_, vt) = getHeaderValue tokenStatus vt >>= toStatus--setStatus :: H.Status -> H.ResponseHeaders -> H.ResponseHeaders-setStatus st hdr = (":status", fromStatus st) : hdr--------------------------------------------------------------------fromStatus :: H.Status -> ByteString-fromStatus status = unsafeCreate 3 $ \p -> do- poke p (toW8 r2)- poke (p `plusPtr` 1) (toW8 r1)- poke (p `plusPtr` 2) (toW8 r0)- where- toW8 :: Int -> Word8- toW8 n = 48 + fromIntegral n- s = H.statusCode status- (q0, r0) = s `divMod` 10- (q1, r1) = q0 `divMod` 10- r2 = q1 `mod` 10--toStatus :: ByteString -> Maybe H.Status-toStatus bs = case C8.readInt bs of- Nothing -> Nothing- Just (code, _) -> Just $ toEnum code
Network/HTTP2/H2/Stream.hs view
@@ -3,12 +3,12 @@ module Network.HTTP2.H2.Stream where -import Control.Exception import Control.Monad import Data.IORef import Data.Maybe (fromMaybe) import Network.Control import UnliftIO.Concurrent+import UnliftIO.Exception import UnliftIO.STM import Network.HTTP2.Frame
Network/HTTP2/H2/StreamTable.hs view
@@ -33,12 +33,11 @@ import Control.Concurrent import Control.Concurrent.STM-import Control.Exception import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as IntMap import Network.Control (LRUCache) import qualified Network.Control as LRUCache-import Network.HTTP.Types (Method)+import UnliftIO.Exception import Imports import Network.HTTP2.H2.Types (Stream (..))
Network/HTTP2/H2/Types.hs view
@@ -4,135 +4,25 @@ module Network.HTTP2.H2.Types where -import qualified Control.Exception as E-import Data.ByteString.Builder (Builder) import Data.IORef import Data.Typeable import Network.Control-import qualified Network.HTTP.Types as H+import Network.HTTP.Semantics.Client+import Network.HTTP.Semantics.IO import Network.Socket hiding (Stream) import System.IO.Unsafe import qualified System.TimeManager as T import UnliftIO.Concurrent import UnliftIO.Exception (SomeException)+import qualified UnliftIO.Exception as E import UnliftIO.STM import Imports import Network.HPACK import Network.HTTP2.Frame-import Network.HTTP2.H2.File ---------------------------------------------------------------- --- | "http" or "https".-type Scheme = ByteString---- | Authority.-type Authority = String---- | Path.-type Path = ByteString--------------------------------------------------------------------type InpBody = IO ByteString--data OutBody- = OutBodyNone- | -- | Streaming body takes a write action and a flush action.- OutBodyStreaming ((Builder -> IO ()) -> IO () -> IO ())- | -- | Like 'OutBodyStreaming', but with a callback to unmask expections- --- -- This is used in the client: we spawn the new thread for the request body- -- with exceptions masked, and provide the body of 'OutBodyStreamingUnmask'- -- with a callback to unmask them again (typically after installing an exception- -- handler).- --- -- We do /NOT/ support this in the server, as here the scope of the thread- -- that is spawned for the server is the entire handler, not just the response- -- streaming body.- --- -- TODO: The analogous change for the server-side would be to provide a similar- -- @unmask@ callback as the first argument in the 'Server' type alias.- OutBodyStreamingUnmask- ((forall x. IO x -> IO x) -> (Builder -> IO ()) -> IO () -> IO ())- | OutBodyBuilder Builder- | OutBodyFile FileSpec---- | Input object-data InpObj = InpObj- { inpObjHeaders :: HeaderTable- -- ^ Accessor for headers.- , inpObjBodySize :: Maybe Int- -- ^ Accessor for body length specified in content-length:.- , inpObjBody :: InpBody- -- ^ Accessor for body.- , inpObjTrailers :: IORef (Maybe HeaderTable)- -- ^ Accessor for trailers.- }--instance Show InpObj where- show (InpObj (thl, _) _ _body _tref) = show thl---- | Output object-data OutObj = OutObj- { outObjHeaders :: [H.Header]- -- ^ Accessor for header.- , outObjBody :: OutBody- -- ^ Accessor for outObj body.- , outObjTrailers :: TrailersMaker- -- ^ Accessor for trailers maker.- }--instance Show OutObj where- show (OutObj hdr _ _) = show hdr---- | Trailers maker. A chunks of the response body is passed--- with 'Just'. The maker should update internal state--- with the 'ByteString' and return the next trailers maker.--- When response body reaches its end,--- 'Nothing' is passed and the maker should generate--- trailers. An example:------ > {-# LANGUAGE BangPatterns #-}--- > import Data.ByteString (ByteString)--- > import qualified Data.ByteString.Char8 as C8--- > import Crypto.Hash (Context, SHA1) -- cryptonite--- > import qualified Crypto.Hash as CH--- >--- > -- Strictness is important for Context.--- > trailersMaker :: Context SHA1 -> Maybe ByteString -> IO NextTrailersMaker--- > trailersMaker ctx Nothing = return $ Trailers [("X-SHA1", sha1)]--- > where--- > !sha1 = C8.pack $ show $ CH.hashFinalize ctx--- > trailersMaker ctx (Just bs) = return $ NextTrailersMaker $ trailersMaker ctx'--- > where--- > !ctx' = CH.hashUpdate ctx bs------ Usage example:------ > let h2rsp = responseFile ...--- > maker = trailersMaker (CH.hashInit :: Context SHA1)--- > h2rsp' = setResponseTrailersMaker h2rsp maker-type TrailersMaker = Maybe ByteString -> IO NextTrailersMaker---- | TrailersMake to create no trailers.-defaultTrailersMaker :: TrailersMaker-defaultTrailersMaker Nothing = return $ Trailers []-defaultTrailersMaker _ = return $ NextTrailersMaker defaultTrailersMaker---- | Either the next trailers maker or final trailers.-data NextTrailersMaker- = NextTrailersMaker TrailersMaker- | Trailers [H.Header]---------------------------------------------------------------------- | File specification.-data FileSpec = FileSpec FilePath FileOffset ByteCount deriving (Eq, Show)------------------------------------------------------------------- {- == Stream state@@ -216,14 +106,14 @@ Int -- Total size Int -- The number of continuation frames Bool -- End of stream- | NoBody HeaderTable- | HasBody HeaderTable+ | NoBody TokenHeaderTable+ | HasBody TokenHeaderTable | Body (TQueue (Either SomeException ByteString)) (Maybe Int) -- received Content-Length -- compared the body length for error checking (IORef Int) -- actual body length- (IORef (Maybe HeaderTable)) -- trailers+ (IORef (Maybe TokenHeaderTable)) -- trailers data ClosedCode = Finished@@ -295,29 +185,10 @@ ---------------------------------------------------------------- -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 ----------------------------------------------------------------
Network/HTTP2/Internal.hs view
@@ -1,39 +1,6 @@ module Network.HTTP2.Internal (- -- * File- module Network.HTTP2.H2.File,-- -- * Types- Scheme,- Authority,- Path,-- -- * Request and response- InpObj (..),- InpBody,- OutObj (..),- OutBody (..),- FileSpec (..),-- -- * Sender- Next (..),- BytesFilled,- DynaNext,- StreamingChunk (..),- fillBuilderBodyGetNext,- fillFileBodyGetNext,- fillStreamBodyGetNext,-- -- * Trailer- TrailersMaker,- defaultTrailersMaker,- NextTrailersMaker (..),- runTrailersMaker,- -- * Thread Manager module Network.HTTP2.H2.Manager, ) where -import Network.HTTP2.H2.File import Network.HTTP2.H2.Manager-import Network.HTTP2.H2.Sender-import Network.HTTP2.H2.Types
Network/HTTP2/Server.hs view
@@ -7,7 +7,7 @@ -- > {-# LANGUAGE OverloadedStrings #-} -- > module Main (main) where -- >--- > import qualified Control.Exception as E+-- > import qualified UnliftIO.Exception as E -- > import Data.ByteString.Builder (byteString) -- > import Network.HTTP.Types (ok200) -- > import Network.Run.TCP (runTCPServer) -- network-run@@ -50,177 +50,14 @@ Config (..), allocSimpleConfig, freeSimpleConfig,-- -- * HTTP\/2 server- Server,-- -- * Request- Request,-- -- ** Accessing request- requestMethod,- requestPath,- requestAuthority,- requestScheme,- requestHeaders,- requestBodySize,- getRequestBodyChunk,- getRequestTrailers,-- -- * Aux- Aux,- auxTimeHandle,- auxMySockAddr,- auxPeerSockAddr,-- -- * Response- Response,-- -- ** Creating response- responseNoBody,- responseFile,- responseStreaming,- responseBuilder,-- -- ** Accessing response- responseBodySize,-- -- ** Trailers maker- TrailersMaker,- NextTrailersMaker (..),- defaultTrailersMaker,- setResponseTrailersMaker,-- -- * Push promise- PushPromise,- pushPromise,- promiseRequestPath,- promiseResponse,-- -- * Types- Path,- Authority,- Scheme,- FileSpec (..),- FileOffset,- ByteCount,-- -- * RecvN- defaultReadN,-- -- * Position read for files- PositionReadMaker,- PositionRead,- Sentinel (..),- defaultPositionReadMaker,+ module Network.HTTP.Semantics.Server, ) where -import Data.ByteString.Builder (Builder)-import Data.IORef (readIORef)-import qualified Network.HTTP.Types as H-import qualified Data.ByteString.UTF8 as UTF8+import Network.HTTP.Semantics.Server -import Imports-import Network.HPACK-import Network.HPACK.Token-import Network.HTTP2.Frame.Types import Network.HTTP2.H2 import Network.HTTP2.Server.Run ( ServerConfig (..), defaultServerConfig, run, )-import Network.HTTP2.Server.Types---------------------------------------------------------------------- | Getting the method from a request.-requestMethod :: Request -> Maybe H.Method-requestMethod (Request req) = getHeaderValue tokenMethod vt- where- (_, vt) = inpObjHeaders req---- | Getting the path from a request.-requestPath :: Request -> Maybe Path-requestPath (Request req) = getHeaderValue tokenPath vt- where- (_, vt) = inpObjHeaders req---- | Getting the authority from a request.-requestAuthority :: Request -> Maybe Authority-requestAuthority (Request req) = UTF8.toString <$> getHeaderValue tokenAuthority vt- where- (_, vt) = inpObjHeaders req---- | Getting the scheme from a request.-requestScheme :: Request -> Maybe Scheme-requestScheme (Request req) = getHeaderValue tokenScheme vt- where- (_, vt) = inpObjHeaders req---- | Getting the headers from a request.-requestHeaders :: Request -> HeaderTable-requestHeaders (Request req) = inpObjHeaders req---- | Getting the body size from a request.-requestBodySize :: Request -> Maybe Int-requestBodySize (Request req) = inpObjBodySize req---- | Reading a chunk of the request body.--- An empty 'ByteString' returned when finished.-getRequestBodyChunk :: Request -> IO ByteString-getRequestBodyChunk (Request req) = inpObjBody req---- | Reading request trailers.--- This function must be called after 'getRequestBodyChunk'--- returns an empty.-getRequestTrailers :: Request -> IO (Maybe HeaderTable)-getRequestTrailers (Request req) = readIORef (inpObjTrailers req)---------------------------------------------------------------------- | Creating response without body.-responseNoBody :: H.Status -> H.ResponseHeaders -> Response-responseNoBody st hdr = Response $ OutObj hdr' OutBodyNone defaultTrailersMaker- where- hdr' = setStatus st hdr---- | Creating response with file.-responseFile :: H.Status -> H.ResponseHeaders -> FileSpec -> Response-responseFile st hdr fileSpec = Response $ OutObj hdr' (OutBodyFile fileSpec) defaultTrailersMaker- where- hdr' = setStatus st hdr---- | Creating response with builder.-responseBuilder :: H.Status -> H.ResponseHeaders -> Builder -> Response-responseBuilder st hdr builder = Response $ OutObj hdr' (OutBodyBuilder builder) defaultTrailersMaker- where- hdr' = setStatus st hdr---- | Creating response with streaming.-responseStreaming- :: H.Status- -> H.ResponseHeaders- -> ((Builder -> IO ()) -> IO () -> IO ())- -> Response-responseStreaming st hdr strmbdy = Response $ OutObj hdr' (OutBodyStreaming strmbdy) defaultTrailersMaker- where- hdr' = setStatus st hdr---------------------------------------------------------------------- | Getter for response body size. This value is available for file body.-responseBodySize :: Response -> Maybe Int-responseBodySize (Response (OutObj _ (OutBodyFile (FileSpec _ _ len)) _)) = Just (fromIntegral len)-responseBodySize _ = Nothing---- | Setting 'TrailersMaker' to 'Response'.-setResponseTrailersMaker :: Response -> TrailersMaker -> Response-setResponseTrailersMaker (Response rsp) tm = Response rsp{outObjTrailers = tm}---------------------------------------------------------------------- | Creating push promise.--- The third argument is traditional, not used.-pushPromise :: ByteString -> Response -> Weight -> PushPromise-pushPromise path rsp _ = PushPromise path rsp
Network/HTTP2/Server/Internal.hs view
@@ -9,6 +9,8 @@ runIO, ) where +import Network.HTTP.Semantics.Server+import Network.HTTP.Semantics.Server.Internal+ import Network.HTTP2.H2 import Network.HTTP2.Server.Run-import Network.HTTP2.Server.Types
Network/HTTP2/Server/Run.hs view
@@ -5,15 +5,16 @@ module Network.HTTP2.Server.Run where import Control.Concurrent.STM-import Control.Exception import Imports import Network.Control (defaultMaxData)+import Network.HTTP.Semantics.Server+import Network.HTTP.Semantics.Server.Internal import Network.Socket (SockAddr) import UnliftIO.Async (concurrently_)+import UnliftIO.Exception import Network.HTTP2.Frame import Network.HTTP2.H2-import Network.HTTP2.Server.Types import Network.HTTP2.Server.Worker -- | Server configuration
− Network/HTTP2/Server/Types.hs
@@ -1,43 +0,0 @@-module Network.HTTP2.Server.Types where--import Network.Socket (SockAddr)-import qualified System.TimeManager as T--import Imports-import Network.HTTP2.H2---------------------------------------------------------------------- | Server type. Server takes a HTTP request, should--- generate a HTTP response and push promises, then--- should give them to the sending function.--- The sending function would throw exceptions so that--- they can be logged.-type Server = Request -> Aux -> (Response -> [PushPromise] -> IO ()) -> IO ()---- | Request from client.-newtype Request = Request InpObj deriving (Show)---- | Response from server.-newtype Response = Response OutObj deriving (Show)---- | HTTP/2 push promise or sever push.--- Pseudo REQUEST headers in push promise is automatically generated.--- Then, a server push is sent according to 'promiseResponse'.-data PushPromise = PushPromise- { promiseRequestPath :: ByteString- -- ^ Accessor for a URL path in a push promise (a virtual request from a server).- -- E.g. \"\/style\/default.css\".- , promiseResponse :: Response- -- ^ Accessor for response actually pushed from a server.- }---- | Additional information.-data Aux = Aux- { auxTimeHandle :: T.Handle- -- ^ Time handle for the worker processing this request and response.- , auxMySockAddr :: SockAddr- -- ^ Local socket address copied from 'Config'.- , auxPeerSockAddr :: SockAddr- -- ^ Remove socket address copied from 'Config'.- }
Network/HTTP2/Server/Worker.hs view
@@ -10,7 +10,11 @@ ) where import Data.IORef-import qualified Network.HTTP.Types as H+import Network.HTTP.Semantics+import Network.HTTP.Semantics.IO+import Network.HTTP.Semantics.Server+import Network.HTTP.Semantics.Server.Internal+import Network.HTTP.Types import Network.Socket (SockAddr) import qualified System.TimeManager as T import UnliftIO.Exception (SomeException (..))@@ -18,11 +22,8 @@ import UnliftIO.STM import Imports hiding (insert)-import Network.HPACK-import Network.HPACK.Token import Network.HTTP2.Frame import Network.HTTP2.H2-import Network.HTTP2.Server.Types ---------------------------------------------------------------- @@ -87,16 +88,16 @@ push _ [] n = return (n :: Int) push tvar (pp : pps) n = do (pid, newstrm) <- makePushStream pstrm pp- let scheme = fromJust $ getHeaderValue tokenScheme reqvt+ let scheme = fromJust $ getFieldValue tokenScheme reqvt -- fixme: this value can be Nothing auth = fromJust- ( getHeaderValue tokenAuthority reqvt- <|> getHeaderValue tokenHost reqvt+ ( getFieldValue tokenAuthority reqvt+ <|> getFieldValue tokenHost reqvt ) path = promiseRequestPath pp promiseRequest =- [ (tokenMethod, H.methodGet)+ [ (tokenMethod, methodGet) , (tokenScheme, scheme) , (tokenAuthority, auth) , (tokenPath, path)
bench-hpack/Main.hs view
@@ -2,10 +2,10 @@ module Main where -import Control.Exception import Data.ByteString (ByteString) import Gauge.Main import Network.HPACK+import UnliftIO.Exception ----------------------------------------------------------------
http2.cabal view
@@ -1,6 +1,6 @@ cabal-version: >=1.10 name: http2-version: 5.1.4+version: 5.2.0 license: BSD3 license-file: LICENSE maintainer: Kazu Yamamoto <kazu@iij.ad.jp>@@ -67,7 +67,6 @@ other-modules: Imports Network.HPACK.Builder- Network.HTTP2.Client.Types Network.HTTP2.Client.Run Network.HPACK.HeaderBlock Network.HPACK.HeaderBlock.Decode@@ -90,15 +89,12 @@ Network.HTTP2.H2.Config Network.HTTP2.H2.Context Network.HTTP2.H2.EncodeFrame- Network.HTTP2.H2.File Network.HTTP2.H2.HPACK Network.HTTP2.H2.Manager Network.HTTP2.H2.Queue- Network.HTTP2.H2.ReadN Network.HTTP2.H2.Receiver Network.HTTP2.H2.Sender Network.HTTP2.H2.Settings- Network.HTTP2.H2.Status Network.HTTP2.H2.Stream Network.HTTP2.H2.StreamTable Network.HTTP2.H2.Types@@ -107,7 +103,6 @@ Network.HTTP2.Frame.Encode Network.HTTP2.Frame.Types Network.HTTP2.Server.Run- Network.HTTP2.Server.Types Network.HTTP2.Server.Worker default-language: Haskell2010@@ -115,25 +110,27 @@ ghc-options: -Wall build-depends: base >=4.9 && <5,- array >= 0.5 && < 0.6,- async >= 2.2 && < 2.3,- bytestring >= 0.10,- containers >= 0.6 && < 0.7,- stm >= 2.5 && < 2.6,- case-insensitive >= 1.2 && < 1.3,- http-types >= 0.12 && < 0.13,- network >= 3.1,- network-byte-order >= 0.1.7 && < 0.2,- network-control >= 0.1 && < 0.2,- unix-time >= 0.4.11 && < 0.5,- time-manager >= 0.0.1 && < 0.1,- unliftio >= 0.2 && < 0.3,- utf8-string >= 1.0 && < 1.1+ array >=0.5 && <0.6,+ async >=2.2 && <2.3,+ bytestring >=0.10,+ case-insensitive >=1.2 && <1.3,+ containers >=0.6 && <0.7,+ http-semantics,+ http-types >=0.12 && <0.13,+ network >=3.1,+ network-byte-order >=0.1.7 && <0.2,+ network-control >=0.1 && <0.2,+ stm >=2.5 && <2.6,+ time-manager >=0.0.1 && <0.1,+ unix-time >=0.4.11 && <0.5,+ unliftio >=0.2 && <0.3,+ utf8-string >=1.0 && <1.1 -executable client- main-is: client.hs+executable h2c-client+ main-is: h2c-client.hs hs-source-dirs: util default-language: Haskell2010+ other-modules: Client default-extensions: Strict StrictData ghc-options: -Wall -threaded -rtsopts build-depends:@@ -142,16 +139,18 @@ bytestring, http-types, http2,- network-run+ network-run,+ unliftio if flag(devel) else buildable: False -executable server- main-is: server.hs+executable h2c-server+ main-is: h2c-server.hs hs-source-dirs: util+ other-modules: Server default-language: Haskell2010 default-extensions: Strict StrictData ghc-options: -Wall -threaded@@ -161,7 +160,8 @@ crypton, http2, http-types,- network-run+ network-run,+ unliftio if flag(devel) @@ -185,7 +185,6 @@ array, base16-bytestring >=1.0, bytestring,- case-insensitive, containers, http2, network-byte-order,@@ -215,11 +214,11 @@ array, base16-bytestring >=1.0, bytestring,- case-insensitive, containers, http2, network-byte-order, text,+ unliftio, unordered-containers, vector, word8@@ -242,7 +241,6 @@ aeson-pretty, array, bytestring,- case-insensitive, containers, directory, filepath,@@ -308,11 +306,13 @@ bytestring, crypton, hspec >=1.3,+ http-semantics, http-types, http2, network, network-run >=0.1.0, random,+ unliftio, typed-process test-suite spec2@@ -361,6 +361,7 @@ hspec >=1.3, http2, text,+ unliftio, unordered-containers, vector
test-hpack/HPACKDecode.hs view
@@ -12,13 +12,13 @@ #if __GLASGOW_HASKELL__ < 709 import Control.Applicative ((<$>)) #endif-import Control.Exception import Control.Monad (when) import qualified Data.ByteString.Base16 as B16 import qualified Data.ByteString.Char8 as B8 import Data.List (sort) import Network.HPACK import Network.HPACK.Table+import UnliftIO.Exception import JSON @@ -87,12 +87,12 @@ inp = B16.decodeLenient wirehex hs = headers c --- | Printing 'HeaderList'.-printHeaderList :: HeaderList -> IO ()+-- | Printing '[Header]'.+printHeaderList :: [Header] -> IO () printHeaderList hs = mapM_ printHeader hs where printHeader (k, v) = do- B8.putStr k+ B8.putStr $ original k putStr ": " B8.putStr v putStr "\n"
test-hpack/HPACKEncode.hs view
@@ -20,7 +20,7 @@ data Conf = Conf { debug :: Bool- , enc :: DynamicTable -> HeaderList -> IO ByteString+ , enc :: DynamicTable -> [Header] -> IO ByteString } run :: Bool -> EncodeStrategy -> Test -> IO [ByteString]
test-hpack/JSON.hs view
@@ -6,7 +6,7 @@ module JSON ( Test (..), Case (..),- HeaderList,+ Header, ) where #if __GLASGOW_HASKELL__ < 709@@ -44,7 +44,7 @@ data Case = Case { size :: Maybe Int , wire :: ByteString- , headers :: HeaderList+ , headers :: [Header] , seqno :: Maybe Int } deriving (Show)@@ -87,24 +87,25 @@ , "seqno" .= no ] -instance {-# OVERLAPPING #-} FromJSON HeaderList where+instance {-# OVERLAPPING #-} FromJSON [Header] where parseJSON (Array a) = mapM parseJSON $ V.toList a parseJSON _ = mzero -instance {-# OVERLAPPING #-} ToJSON HeaderList where+instance {-# OVERLAPPING #-} ToJSON [Header] where toJSON hs = toJSON $ map toJSON hs instance {-# OVERLAPPING #-} FromJSON Header where- parseJSON (Array a) = pure (toKey (a ! 0), toValue (a ! 1)) -- old+ parseJSON (Array a) = pure (mk $ toKey (a ! 0), toValue (a ! 1)) -- old where toKey = toValue- parseJSON (Object o) = pure (textToByteString (Key.toText k), toValue v) -- new+ parseJSON (Object o) = pure (mk $ textToByteString $ Key.toText k, toValue v) -- new where (k, v) = head $ H.toList o parseJSON _ = mzero instance {-# OVERLAPPING #-} ToJSON Header where- toJSON (k, v) = object [Key.fromText (byteStringToText k) .= byteStringToText v]+ toJSON (k, v) =+ object [Key.fromText (byteStringToText $ foldedCase k) .= byteStringToText v] textToByteString :: Text -> ByteString textToByteString = B8.pack . T.unpack
test-hpack/hpack-stat.hs view
@@ -12,6 +12,7 @@ import qualified Data.ByteString.Lazy.Char8 as BL import Data.List import Data.Maybe (fromJust)+import Network.HPACK import System.Directory import System.FilePath @@ -81,7 +82,7 @@ let len = sum $ map toT $ cases tc return len where- toT (Case _ _ hs _) = sum $ map (\(x, y) -> BS.length x + BS.length y) hs+ toT (Case _ _ hs _) = sum $ map (\(x, y) -> BS.length (foldedCase x) + BS.length y) hs getHeaderLen :: FilePath -> IO Int getHeaderLen file = do
test/HPACK/DecodeSpec.hs view
@@ -11,7 +11,7 @@ spec :: Spec spec = do describe "fromHeaderBlock" $ do- it "decodes HeaderList in request" $ do+ it "decodes [Header] in request" $ do withDynamicTableForDecoding 4096 4096 $ \dyntabl -> do h1 <- decodeHeader dyntabl d41b h1 `shouldBe` d41h@@ -19,7 +19,7 @@ h2 `shouldBe` d42h h3 <- decodeHeader dyntabl d43b h3 `shouldBe` d43h- it "decodes HeaderList in response" $ do+ it "decodes [Header] in response" $ do withDynamicTableForDecoding 256 4096 $ \dyntabl -> do h1 <- decodeHeader dyntabl d61b h1 `shouldBe` d61h@@ -27,11 +27,11 @@ h2 `shouldBe` d62h h3 <- decodeHeader dyntabl d63b h3 `shouldBe` d63h- it "decodes HeaderList in response (deny max table size update to 0)" $+ it "decodes [Header] in response (deny max table size update to 0)" $ withDynamicTableForDecoding 256 4096 $ \dyntabl -> do h1 <- decodeHeader dyntabl d81b h1 `shouldBe` d81h- it "decodes HeaderList even if an entry is larger than DynamicTable" $+ it "decodes [Header] even if an entry is larger than DynamicTable" $ withDynamicTableForEncoding 64 $ \etbl -> withDynamicTableForDecoding 64 4096 $ \dtbl -> do hs <- encodeHeader defaultEncodeStrategy 4096 etbl hl1@@ -40,7 +40,7 @@ isDynamicTableEmpty etbl `shouldReturn` True isDynamicTableEmpty dtbl `shouldReturn` True -hl1 :: HeaderList+hl1 :: [Header] hl1 = [ ("custom-key", "custom-value") ,
test/HPACK/EncodeSpec.hs view
@@ -5,12 +5,12 @@ #if __GLASGOW_HASKELL__ < 709 import Control.Applicative ((<$>)) #endif-import qualified Control.Exception as E import Data.Bits import qualified Data.ByteString as BS import Data.Maybe (fromMaybe) import Network.HPACK import Test.Hspec+import qualified UnliftIO.Exception as E spec :: Spec spec = do@@ -41,7 +41,7 @@ withDynamicTableForDecoding sz 4096 $ \dtbl -> go etbl dtbl hdrs lens0 `shouldReturn` True where- go :: DynamicTable -> DynamicTable -> [HeaderList] -> [Int] -> IO Bool+ go :: DynamicTable -> DynamicTable -> [[Header]] -> [Int] -> IO Bool go _ _ [] _ = return True go etbl dtbl (h : hs) lens = do bs <-@@ -74,7 +74,7 @@ hdrs <- read <$> readFile "bench-hpack/headers.hs" withDynamicTableForEncoding 0 $ \etbl -> withDynamicTableForDecoding 0 4096 $ \dtbl ->- mapM_ (go etbl dtbl) (hdrs :: [HeaderList])+ mapM_ (go etbl dtbl) (hdrs :: [[Header]]) where go etbl _dtbl h = do print h
test/HPACK/HeaderBlock.hs view
@@ -4,14 +4,14 @@ import Data.ByteString (ByteString) import Data.ByteString.Base16-import Network.HPACK+import Network.HTTP.Types fromHexString :: ByteString -> ByteString fromHexString = decodeLenient ---------------------------------------------------------------- -d41h :: HeaderList+d41h :: [Header] d41h = [ (":method", "GET") , (":scheme", "http")@@ -22,7 +22,7 @@ d41b :: ByteString d41b = fromHexString "828684418cf1e3c2e5f23a6ba0ab90f4ff" -d42h :: HeaderList+d42h :: [Header] d42h = [ (":method", "GET") , (":scheme", "http")@@ -34,7 +34,7 @@ d42b :: ByteString d42b = fromHexString "828684be5886a8eb10649cbf" -d43h :: HeaderList+d43h :: [Header] d43h = [ (":method", "GET") , (":scheme", "https")@@ -48,7 +48,7 @@ ---------------------------------------------------------------- -d61h :: HeaderList+d61h :: [Header] d61h = [ (":status", "302") , ("cache-control", "private")@@ -61,7 +61,7 @@ fromHexString "488264025885aec3771a4b6196d07abe941054d444a8200595040b8166e082a62d1bff6e919d29ad171863c78f0b97c8e9ae82ae43d3" -d62h :: HeaderList+d62h :: [Header] d62h = [ (":status", "307") , ("cache-control", "private")@@ -72,7 +72,7 @@ d62b :: ByteString d62b = fromHexString "4883640effc1c0bf" -d63h :: HeaderList+d63h :: [Header] d63h = [ (":status", "200") , ("cache-control", "private")@@ -89,7 +89,7 @@ ---------------------------------------------------------------- -d81h :: HeaderList+d81h :: [Header] d81h = [ (":status", "403") , ("server", "nginx/1.14.0")
test/HTTP2/ClientSpec.hs view
@@ -6,18 +6,19 @@ module HTTP2.ClientSpec where import Control.Concurrent-import qualified Control.Exception as E import Control.Monad import Data.ByteString.Builder (byteString) import Data.Foldable (for_) import Data.Maybe import Data.Traversable (for)+import Network.HTTP.Semantics import Network.HTTP.Types import Network.Run.TCP import System.IO.Unsafe (unsafePerformIO) import System.Random import System.Timeout (timeout) import Test.Hspec+import qualified UnliftIO.Exception as E import Network.HTTP2.Client import qualified Network.HTTP2.Server as S
test/HTTP2/ServerSpec.hs view
@@ -6,8 +6,6 @@ module HTTP2.ServerSpec where import Control.Concurrent-import Control.Concurrent.Async-import qualified Control.Exception as E import Control.Monad import Crypto.Hash (Context, SHA1) -- cryptonite import qualified Crypto.Hash as CH@@ -16,6 +14,7 @@ import Data.ByteString.Builder (Builder, byteString) import qualified Data.ByteString.Char8 as C8 import Data.IORef+import Network.HTTP.Semantics import Network.HTTP.Types import Network.Run.TCP import Network.Socket@@ -24,10 +23,11 @@ import System.IO.Unsafe import System.Random import Test.Hspec+import UnliftIO.Async+import qualified UnliftIO.Exception as E import Network.HPACK import Network.HPACK.Internal-import Network.HPACK.Token import qualified Network.HTTP2.Client as C import qualified Network.HTTP2.Client.Internal as C import Network.HTTP2.Frame@@ -151,7 +151,7 @@ where h2rsp = responseStreaming ok200 header streamingBody header = [("Content-Type", "text/plain")]- mhx = getHeaderValue (toToken "X-Tag") (snd (requestHeaders req))+ mhx = getFieldValue (toToken "X-Tag") (snd (requestHeaders req)) streamingBody write _flush = do loop mt <- getRequestTrailers req@@ -308,7 +308,7 @@ | otherwise = pure () go (100 :: Int) -firstTrailerValue :: HeaderTable -> HeaderValue+firstTrailerValue :: TokenHeaderTable -> FieldValue firstTrailerValue = snd . Prelude.head . fst runAttack :: (C.ClientIO -> IO ()) -> IO ()
test2/ServerSpec.hs view
@@ -4,13 +4,13 @@ module ServerSpec (spec) where import Control.Concurrent-import qualified Control.Exception as E import Data.ByteString.Builder (byteString) import Network.HTTP.Types import Network.Run.TCP import System.Exit import System.Process.Typed import Test.Hspec+import qualified UnliftIO.Exception as E import Network.HTTP2.Server
+ util/Client.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}++module Client where++import qualified Data.ByteString.Char8 as C8+import Network.HTTP.Types+import UnliftIO.Async+import qualified UnliftIO.Exception as E++import Network.HTTP2.Client++client :: Int -> [Path] -> Client ()+client n0 paths sendRequest _aux = do+ ex <- E.try $ foldr1 concurrently_ $ map (client' n0 sendRequest) paths+ case ex of+ Right () -> return ()+ Left e -> print (e :: HTTP2Error)++client' :: Int -> SendRequest -> Path -> IO ()+client' n0 sendRequest path = loop n0+ where+ req = requestNoBody methodGet path []+ loop 0 = return ()+ loop n = do+ sendRequest req $ \rsp -> do+ print $ responseStatus rsp+ getResponseBodyChunk rsp >>= C8.putStrLn+ loop (n - 1)
+ util/Server.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE OverloadedStrings #-}++module Server where++import Control.Monad+import Crypto.Hash (Context, SHA1) -- cryptonite+import qualified Crypto.Hash as CH+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import Data.ByteString.Builder (byteString)+import qualified Data.ByteString.Char8 as C8+import Network.HTTP.Types+import Network.HTTP2.Server++server :: Server+server req _aux sendResponse = case requestMethod req of+ Just "GET"+ | requestPath req == Just "/" -> sendResponse responseHello []+ Just "POST" -> sendResponse (responseEcho req) []+ _ -> sendResponse response404 []++responseHello :: Response+responseHello = responseBuilder ok200 header body+ where+ header = [("Content-Type", "text/plain")]+ body = byteString "Hello, world!\n"++response404 :: Response+response404 = responseBuilder notFound404 header body+ where+ header = [("Content-Type", "text/plain")]+ body = byteString "Not found\n"++responseEcho :: Request -> Response+responseEcho req = setResponseTrailersMaker h2rsp maker+ where+ h2rsp = responseStreaming ok200 header streamingBody+ header = [("Content-Type", "text/plain")]+ streamingBody write _flush = loop+ where+ loop = do+ bs <- getRequestBodyChunk req+ unless (B.null bs) $ do+ void $ write $ byteString bs+ loop+ maker = trailersMaker (CH.hashInit :: Context SHA1)++-- Strictness is important for Context.+trailersMaker :: Context SHA1 -> Maybe ByteString -> IO NextTrailersMaker+trailersMaker ctx Nothing = return $ Trailers [("X-SHA1", sha1)]+ where+ sha1 = C8.pack $ show $ CH.hashFinalize ctx+trailersMaker ctx (Just bs) = return $ NextTrailersMaker $ trailersMaker ctx'+ where+ ctx' = CH.hashUpdate ctx bs
− util/client.hs
@@ -1,48 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}--module Main where--import Control.Concurrent.Async-import qualified Control.Exception as E-import qualified Data.ByteString.Char8 as C8-import Network.HTTP.Types-import Network.Run.TCP (runTCPClient) -- network-run-import System.Environment-import System.Exit--import Network.HTTP2.Client--serverName :: String-serverName = "127.0.0.1"--main :: IO ()-main = do- args <- getArgs- (host, port) <- case args of- [h, p] -> return (h, p)- _ -> do- putStrLn "client <addr> <port>"- exitFailure- runTCPClient serverName port $ runHTTP2Client host- where- cliconf host = defaultClientConfig{authority = C8.pack host}- runHTTP2Client host s =- E.bracket- (allocSimpleConfig s 4096)- freeSimpleConfig- (\conf -> run (cliconf host) conf client)- client :: Client ()- client sendRequest _aux = do- let req0 = requestNoBody methodGet "/" []- client0 = sendRequest req0 $ \rsp -> do- print rsp- getResponseBodyChunk rsp >>= C8.putStrLn- req1 = requestNoBody methodGet "/foo" []- client1 = sendRequest req1 $ \rsp -> do- print rsp- getResponseBodyChunk rsp >>= C8.putStrLn- ex <- E.try $ concurrently_ client0 client1- case ex of- Left e -> print (e :: HTTP2Error)- Right () -> putStrLn "OK"
+ util/h2c-client.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Main where++import qualified Data.ByteString.Char8 as C8+import Network.HTTP2.Client+import Network.Run.TCP (runTCPClient)+import System.Console.GetOpt+import System.Environment+import System.Exit+import qualified UnliftIO.Exception as E++import Client++data Options = Options+ { optNumOfReqs :: Int+ }+ deriving (Show)++defaultOptions :: Options+defaultOptions =+ Options+ { optNumOfReqs = 1+ }++usage :: String+usage = "Usage: h2c-client [OPTION] addr port [path]"++options :: [OptDescr (Options -> Options)]+options =+ [ Option+ ['n']+ ["number-of-requests"]+ (ReqArg (\n o -> o{optNumOfReqs = read n}) "<n>")+ "specify the number of requests"+ ]++showUsageAndExit :: String -> IO a+showUsageAndExit msg = do+ putStrLn msg+ putStrLn $ usageInfo usage options+ exitFailure++clientOpts :: [String] -> IO (Options, [String])+clientOpts argv =+ case getOpt Permute options argv of+ (o, n, []) -> return (foldl (flip id) defaultOptions o, n)+ (_, _, errs) -> showUsageAndExit $ concat errs++main :: IO ()+main = do+ args <- getArgs+ (Options{..}, ips) <- clientOpts args+ (host, port, paths) <- case ips of+ [] -> showUsageAndExit usage+ _ : [] -> showUsageAndExit usage+ h : p : [] -> return (h, p, ["/"])+ h : p : ps -> return (h, p, C8.pack <$> ps)+ let cliconf = defaultClientConfig{authority = host}+ runTCPClient host port $ \s ->+ E.bracket+ (allocSimpleConfig s 4096)+ freeSimpleConfig+ (\conf -> run cliconf conf $ client optNumOfReqs paths)
+ util/h2c-server.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Main (main) where++import Network.HTTP2.Server+import Network.Run.TCP+import System.Console.GetOpt+import System.Environment+import System.Exit+import qualified UnliftIO.Exception as E++import Server++options :: [OptDescr (Options -> Options)]+options = []++showUsageAndExit :: String -> IO a+showUsageAndExit msg = do+ putStrLn msg+ putStrLn $ usageInfo usage options+ exitFailure++serverOpts :: [String] -> IO (Options, [String])+serverOpts argv =+ case getOpt Permute options argv of+ (o, n, []) -> return (foldl (flip id) defaultOptions o, n)+ (_, _, errs) -> showUsageAndExit $ concat errs++data Options = Options deriving (Show)++defaultOptions :: Options+defaultOptions = Options++usage :: String+usage = "Usage: h2c-server [OPTION] <addr> <port>"++main :: IO ()+main = do+ args <- getArgs+ (Options, ips) <- serverOpts args+ (host, port) <- case ips of+ [h, p] -> return (h, p)+ _ -> showUsageAndExit usage+ runTCPServer (Just host) port $ \s ->+ E.bracket+ (allocSimpleConfig s 4096)+ freeSimpleConfig+ (\conf -> run defaultServerConfig conf server)
− util/server.hs
@@ -1,75 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE OverloadedStrings #-}--module Main (main) where--import qualified Control.Exception as E-import Control.Monad-import Crypto.Hash (Context, SHA1) -- cryptonite-import qualified Crypto.Hash as CH-import Data.ByteString (ByteString)-import qualified Data.ByteString as B-import Data.ByteString.Builder (byteString)-import qualified Data.ByteString.Char8 as C8-import Network.HPACK-import Network.HPACK.Token-import Network.HTTP.Types-import Network.Run.TCP -- network-run-import System.Environment-import System.Exit--import Network.HTTP2.Server--main :: IO ()-main = do- args <- getArgs- (host, port) <- case args of- [h, p] -> return (h, p)- _ -> do- putStrLn "server <addr> <port>"- exitFailure- runTCPServer (Just host) port runHTTP2Server- where- runHTTP2Server s =- E.bracket- (allocSimpleConfig s 4096)- freeSimpleConfig- (\conf -> run defaultServerConfig conf server)- server req _aux sendResponse = case getHeaderValue tokenMethod vt of- Just "GET" -> sendResponse responseHello []- Just "POST" -> sendResponse (responseEcho req) []- _ -> sendResponse response404 []- where- (_, vt) = requestHeaders req--responseHello :: Response-responseHello = responseBuilder ok200 header body- where- header = [("Content-Type", "text/plain")]- body = byteString "Hello, world!\n"--response404 :: Response-response404 = responseNoBody notFound404 []--responseEcho :: Request -> Response-responseEcho req = setResponseTrailersMaker h2rsp maker- where- h2rsp = responseStreaming ok200 header streamingBody- header = [("Content-Type", "text/plain")]- streamingBody write _flush = loop- where- loop = do- bs <- getRequestBodyChunk req- unless (B.null bs) $ do- void $ write $ byteString bs- loop- maker = trailersMaker (CH.hashInit :: Context SHA1)---- Strictness is important for Context.-trailersMaker :: Context SHA1 -> Maybe ByteString -> IO NextTrailersMaker-trailersMaker ctx Nothing = return $ Trailers [("X-SHA1", sha1)]- where- !sha1 = C8.pack $ show $ CH.hashFinalize ctx-trailersMaker ctx (Just bs) = return $ NextTrailersMaker $ trailersMaker ctx'- where- !ctx' = CH.hashUpdate ctx bs