diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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. diff --git a/Imports.hs b/Imports.hs --- a/Imports.hs +++ b/Imports.hs @@ -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 diff --git a/Network/HPACK.hs b/Network/HPACK.hs --- a/Network/HPACK.hs +++ b/Network/HPACK.hs @@ -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 diff --git a/Network/HPACK/HeaderBlock.hs b/Network/HPACK/HeaderBlock.hs --- a/Network/HPACK/HeaderBlock.hs +++ b/Network/HPACK/HeaderBlock.hs @@ -2,9 +2,9 @@ decodeHeader, decodeTokenHeader, ValueTable, - HeaderTable, - toHeaderTable, - getHeaderValue, + TokenHeaderTable, + toTokenHeaderTable, + getFieldValue, encodeHeader, encodeTokenHeader, ) where diff --git a/Network/HPACK/HeaderBlock/Decode.hs b/Network/HPACK/HeaderBlock/Decode.hs --- a/Network/HPACK/HeaderBlock/Decode.hs +++ b/Network/HPACK/HeaderBlock/Decode.hs @@ -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) diff --git a/Network/HPACK/HeaderBlock/Encode.hs b/Network/HPACK/HeaderBlock/Encode.hs --- a/Network/HPACK/HeaderBlock/Encode.hs +++ b/Network/HPACK/HeaderBlock/Encode.hs @@ -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 diff --git a/Network/HPACK/Huffman/Decode.hs b/Network/HPACK/Huffman/Decode.hs --- a/Network/HPACK/Huffman/Decode.hs +++ b/Network/HPACK/Huffman/Decode.hs @@ -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 diff --git a/Network/HPACK/Huffman/Encode.hs b/Network/HPACK/Huffman/Encode.hs --- a/Network/HPACK/Huffman/Encode.hs +++ b/Network/HPACK/Huffman/Encode.hs @@ -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) diff --git a/Network/HPACK/Internal.hs b/Network/HPACK/Internal.hs --- a/Network/HPACK/Internal.hs +++ b/Network/HPACK/Internal.hs @@ -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 (..)) diff --git a/Network/HPACK/Table/Dynamic.hs b/Network/HPACK/Table/Dynamic.hs --- a/Network/HPACK/Table/Dynamic.hs +++ b/Network/HPACK/Table/Dynamic.hs @@ -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 ---------------------------------------------------------------- diff --git a/Network/HPACK/Table/Entry.hs b/Network/HPACK/Table/Entry.hs --- a/Network/HPACK/Table/Entry.hs +++ b/Network/HPACK/Table/Entry.hs @@ -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 ---------------------------------------------------------------- diff --git a/Network/HPACK/Table/RevIndex.hs b/Network/HPACK/Table/RevIndex.hs --- a/Network/HPACK/Table/RevIndex.hs +++ b/Network/HPACK/Table/RevIndex.hs @@ -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' diff --git a/Network/HPACK/Table/Static.hs b/Network/HPACK/Table/Static.hs --- a/Network/HPACK/Table/Static.hs +++ b/Network/HPACK/Table/Static.hs @@ -9,6 +9,7 @@ import Data.Array (Array, listArray) import Data.Array.Base (unsafeAt) import Network.HPACK.Table.Entry +import Network.HTTP.Types (Header) ---------------------------------------------------------------- diff --git a/Network/HPACK/Token.hs b/Network/HPACK/Token.hs --- a/Network/HPACK/Token.hs +++ b/Network/HPACK/Token.hs @@ -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 diff --git a/Network/HPACK/Types.hs b/Network/HPACK/Types.hs --- a/Network/HPACK/Types.hs +++ b/Network/HPACK/Types.hs @@ -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] ---------------------------------------------------------------- diff --git a/Network/HTTP2/Client.hs b/Network/HTTP2/Client.hs --- a/Network/HTTP2/Client.hs +++ b/Network/HTTP2/Client.hs @@ -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) diff --git a/Network/HTTP2/Client/Internal.hs b/Network/HTTP2/Client/Internal.hs --- a/Network/HTTP2/Client/Internal.hs +++ b/Network/HTTP2/Client/Internal.hs @@ -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 diff --git a/Network/HTTP2/Client/Run.hs b/Network/HTTP2/Client/Run.hs --- a/Network/HTTP2/Client/Run.hs +++ b/Network/HTTP2/Client/Run.hs @@ -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 diff --git a/Network/HTTP2/Client/Types.hs b/Network/HTTP2/Client/Types.hs deleted file mode 100644 --- a/Network/HTTP2/Client/Types.hs +++ /dev/null @@ -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. - } diff --git a/Network/HTTP2/Frame.hs b/Network/HTTP2/Frame.hs --- a/Network/HTTP2/Frame.hs +++ b/Network/HTTP2/Frame.hs @@ -73,7 +73,7 @@ SettingsList, SettingsKey ( SettingsKey, - SettingsHeaderTableSize, + SettingsTokenHeaderTableSize, SettingsEnablePush, SettingsMaxConcurrentStreams, SettingsInitialWindowSize, diff --git a/Network/HTTP2/Frame/Decode.hs b/Network/HTTP2/Frame/Decode.hs --- a/Network/HTTP2/Frame/Decode.hs +++ b/Network/HTTP2/Frame/Decode.hs @@ -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 diff --git a/Network/HTTP2/Frame/Types.hs b/Network/HTTP2/Frame/Types.hs --- a/Network/HTTP2/Frame/Types.hs +++ b/Network/HTTP2/Frame/Types.hs @@ -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 diff --git a/Network/HTTP2/H2.hs b/Network/HTTP2/H2.hs --- a/Network/HTTP2/H2.hs +++ b/Network/HTTP2/H2.hs @@ -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 diff --git a/Network/HTTP2/H2/Config.hs b/Network/HTTP2/H2/Config.hs --- a/Network/HTTP2/H2/Config.hs +++ b/Network/HTTP2/H2/Config.hs @@ -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. diff --git a/Network/HTTP2/H2/Context.hs b/Network/HTTP2/H2/Context.hs --- a/Network/HTTP2/H2/Context.hs +++ b/Network/HTTP2/H2/Context.hs @@ -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 () diff --git a/Network/HTTP2/H2/File.hs b/Network/HTTP2/H2/File.hs deleted file mode 100644 --- a/Network/HTTP2/H2/File.hs +++ /dev/null @@ -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) diff --git a/Network/HTTP2/H2/HPACK.hs b/Network/HTTP2/H2/HPACK.hs --- a/Network/HTTP2/H2/HPACK.hs +++ b/Network/HTTP2/H2/HPACK.hs @@ -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 diff --git a/Network/HTTP2/H2/Manager.hs b/Network/HTTP2/H2/Manager.hs --- a/Network/HTTP2/H2/Manager.hs +++ b/Network/HTTP2/H2/Manager.hs @@ -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 diff --git a/Network/HTTP2/H2/ReadN.hs b/Network/HTTP2/H2/ReadN.hs deleted file mode 100644 --- a/Network/HTTP2/H2/ReadN.hs +++ /dev/null @@ -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 diff --git a/Network/HTTP2/H2/Receiver.hs b/Network/HTTP2/H2/Receiver.hs --- a/Network/HTTP2/H2/Receiver.hs +++ b/Network/HTTP2/H2/Receiver.hs @@ -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 diff --git a/Network/HTTP2/H2/Sender.hs b/Network/HTTP2/H2/Sender.hs --- a/Network/HTTP2/H2/Sender.hs +++ b/Network/HTTP2/H2/Sender.hs @@ -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 diff --git a/Network/HTTP2/H2/Settings.hs b/Network/HTTP2/H2/Settings.hs --- a/Network/HTTP2/H2/Settings.hs +++ b/Network/HTTP2/H2/Settings.hs @@ -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 diff --git a/Network/HTTP2/H2/Status.hs b/Network/HTTP2/H2/Status.hs deleted file mode 100644 --- a/Network/HTTP2/H2/Status.hs +++ /dev/null @@ -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 diff --git a/Network/HTTP2/H2/Stream.hs b/Network/HTTP2/H2/Stream.hs --- a/Network/HTTP2/H2/Stream.hs +++ b/Network/HTTP2/H2/Stream.hs @@ -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 diff --git a/Network/HTTP2/H2/StreamTable.hs b/Network/HTTP2/H2/StreamTable.hs --- a/Network/HTTP2/H2/StreamTable.hs +++ b/Network/HTTP2/H2/StreamTable.hs @@ -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 (..)) diff --git a/Network/HTTP2/H2/Types.hs b/Network/HTTP2/H2/Types.hs --- a/Network/HTTP2/H2/Types.hs +++ b/Network/HTTP2/H2/Types.hs @@ -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 ---------------------------------------------------------------- diff --git a/Network/HTTP2/Internal.hs b/Network/HTTP2/Internal.hs --- a/Network/HTTP2/Internal.hs +++ b/Network/HTTP2/Internal.hs @@ -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 diff --git a/Network/HTTP2/Server.hs b/Network/HTTP2/Server.hs --- a/Network/HTTP2/Server.hs +++ b/Network/HTTP2/Server.hs @@ -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 diff --git a/Network/HTTP2/Server/Internal.hs b/Network/HTTP2/Server/Internal.hs --- a/Network/HTTP2/Server/Internal.hs +++ b/Network/HTTP2/Server/Internal.hs @@ -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 diff --git a/Network/HTTP2/Server/Run.hs b/Network/HTTP2/Server/Run.hs --- a/Network/HTTP2/Server/Run.hs +++ b/Network/HTTP2/Server/Run.hs @@ -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 diff --git a/Network/HTTP2/Server/Types.hs b/Network/HTTP2/Server/Types.hs deleted file mode 100644 --- a/Network/HTTP2/Server/Types.hs +++ /dev/null @@ -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'. - } diff --git a/Network/HTTP2/Server/Worker.hs b/Network/HTTP2/Server/Worker.hs --- a/Network/HTTP2/Server/Worker.hs +++ b/Network/HTTP2/Server/Worker.hs @@ -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) diff --git a/bench-hpack/Main.hs b/bench-hpack/Main.hs --- a/bench-hpack/Main.hs +++ b/bench-hpack/Main.hs @@ -2,10 +2,10 @@ module Main where -import Control.Exception import Data.ByteString (ByteString) import Gauge.Main import Network.HPACK +import UnliftIO.Exception ---------------------------------------------------------------- diff --git a/http2.cabal b/http2.cabal --- a/http2.cabal +++ b/http2.cabal @@ -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 @@ -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 diff --git a/test-hpack/HPACKDecode.hs b/test-hpack/HPACKDecode.hs --- a/test-hpack/HPACKDecode.hs +++ b/test-hpack/HPACKDecode.hs @@ -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" diff --git a/test-hpack/HPACKEncode.hs b/test-hpack/HPACKEncode.hs --- a/test-hpack/HPACKEncode.hs +++ b/test-hpack/HPACKEncode.hs @@ -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] diff --git a/test-hpack/JSON.hs b/test-hpack/JSON.hs --- a/test-hpack/JSON.hs +++ b/test-hpack/JSON.hs @@ -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 diff --git a/test-hpack/hpack-stat.hs b/test-hpack/hpack-stat.hs --- a/test-hpack/hpack-stat.hs +++ b/test-hpack/hpack-stat.hs @@ -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 diff --git a/test/HPACK/DecodeSpec.hs b/test/HPACK/DecodeSpec.hs --- a/test/HPACK/DecodeSpec.hs +++ b/test/HPACK/DecodeSpec.hs @@ -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") , diff --git a/test/HPACK/EncodeSpec.hs b/test/HPACK/EncodeSpec.hs --- a/test/HPACK/EncodeSpec.hs +++ b/test/HPACK/EncodeSpec.hs @@ -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 diff --git a/test/HPACK/HeaderBlock.hs b/test/HPACK/HeaderBlock.hs --- a/test/HPACK/HeaderBlock.hs +++ b/test/HPACK/HeaderBlock.hs @@ -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") diff --git a/test/HTTP2/ClientSpec.hs b/test/HTTP2/ClientSpec.hs --- a/test/HTTP2/ClientSpec.hs +++ b/test/HTTP2/ClientSpec.hs @@ -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 diff --git a/test/HTTP2/ServerSpec.hs b/test/HTTP2/ServerSpec.hs --- a/test/HTTP2/ServerSpec.hs +++ b/test/HTTP2/ServerSpec.hs @@ -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 () diff --git a/test2/ServerSpec.hs b/test2/ServerSpec.hs --- a/test2/ServerSpec.hs +++ b/test2/ServerSpec.hs @@ -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 diff --git a/util/Client.hs b/util/Client.hs new file mode 100644 --- /dev/null +++ b/util/Client.hs @@ -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) diff --git a/util/Server.hs b/util/Server.hs new file mode 100644 --- /dev/null +++ b/util/Server.hs @@ -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 diff --git a/util/client.hs b/util/client.hs deleted file mode 100644 --- a/util/client.hs +++ /dev/null @@ -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 " - 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" diff --git a/util/h2c-client.hs b/util/h2c-client.hs new file mode 100644 --- /dev/null +++ b/util/h2c-client.hs @@ -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}) "") + "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) diff --git a/util/h2c-server.hs b/util/h2c-server.hs new file mode 100644 --- /dev/null +++ b/util/h2c-server.hs @@ -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] " + +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) diff --git a/util/server.hs b/util/server.hs deleted file mode 100644 --- a/util/server.hs +++ /dev/null @@ -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 " - 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