diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,9 @@ +## 3.2.3 + +* Using http2 v1.5.x which much improves the performance of HTTP/2. +* To get rid of the bottleneck of ByteString's (==), a new logic to + compare header names is introduced. + ## 3.2.2 * Throwing errno for pread [#499](https://github.com/yesodweb/wai/issues/499). diff --git a/Network/Wai/Handler/Warp/HTTP2/HPACK.hs b/Network/Wai/Handler/Warp/HTTP2/HPACK.hs --- a/Network/Wai/Handler/Warp/HTTP2/HPACK.hs +++ b/Network/Wai/Handler/Warp/HTTP2/HPACK.hs @@ -1,16 +1,13 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NamedFieldPuns, RecordWildCards #-} module Network.Wai.Handler.Warp.HTTP2.HPACK where import Control.Arrow (first) import qualified Control.Exception as E -import qualified Data.ByteString as B -import Data.ByteString.Builder (Builder) import qualified Data.ByteString.Char8 as B8 import Data.CaseInsensitive (foldedCase) -import Data.IORef (readIORef, writeIORef) -import Network.HPACK +import Network.HPACK hiding (Buffer) import qualified Network.HTTP.Types as H import Network.HTTP2 import Network.Wai.Handler.Warp.HTTP2.Types @@ -22,39 +19,34 @@ -- $setup -- >>> :set -XOverloadedStrings +strategy :: EncodeStrategy +strategy = EncodeStrategy { compressionAlgo = Linear, useHuffman = False } + -- Set-Cookie: contains only one cookie value. -- So, we don't need to split it. -hpackEncodeHeader :: Context -> InternalInfo -> S.Settings +hpackEncodeHeader :: Context -> Buffer -> BufSize + -> InternalInfo -> S.Settings -> H.Status -> H.ResponseHeaders - -> IO Builder -hpackEncodeHeader ctx ii settings s h = do - hdr1 <- addServerAndDate h - let hdr2 = (":status", status) : map (first foldedCase) hdr1 - hpackEncodeRawHeaders ctx hdr2 + -> IO (HeaderList, Int) +hpackEncodeHeader Context{..} buf siz ii settings s hdr0 = do + hdr1 <- addServerAndDate hdr0 + let hs = (":status", status) : map (first foldedCase) hdr1 + encodeHeaderBuffer buf siz strategy True encodeDynamicTable hs where status = B8.pack $ show $ H.statusCode s dc = dateCacher ii - rspidxhdr = indexResponseHeader h + rspidxhdr = indexResponseHeader hdr0 defServer = S.settingsServerName settings addServerAndDate = addDate dc rspidxhdr . addServer defServer rspidxhdr -hpackEncodeCIHeaders :: Context -> [H.Header] -> IO Builder -hpackEncodeCIHeaders ctx = hpackEncodeRawHeaders ctx . map (first foldedCase) - -hpackEncodeRawHeaders :: Context -> [(B.ByteString, B.ByteString)] -> IO Builder -hpackEncodeRawHeaders Context{encodeDynamicTable} hdr = do - ehdrtbl <- readIORef encodeDynamicTable - (ehdrtbl', builder) <- encodeHeaderBuilder defaultEncodeStrategy ehdrtbl hdr - writeIORef encodeDynamicTable ehdrtbl' - return builder +hpackEncodeHeaderLoop :: Context -> Buffer -> BufSize -> HeaderList + -> IO (HeaderList, Int) +hpackEncodeHeaderLoop Context{..} buf siz hs = + encodeHeaderBuffer buf siz strategy False encodeDynamicTable hs ---------------------------------------------------------------- hpackDecodeHeader :: HeaderBlockFragment -> Context -> IO HeaderList -hpackDecodeHeader hdrblk Context{decodeDynamicTable} = do - hdrtbl <- readIORef decodeDynamicTable - (hdrtbl', hdr) <- decodeHeader hdrtbl hdrblk `E.onException` cleanup - writeIORef decodeDynamicTable hdrtbl' - return hdr - where - cleanup = E.throwIO $ ConnectionError CompressionError "cannot decompress the header" +hpackDecodeHeader hdrblk Context{..} = + decodeHeader decodeDynamicTable hdrblk `E.catch` \(E.SomeException _) -> + E.throwIO $ ConnectionError CompressionError "cannot decompress the header" diff --git a/Network/Wai/Handler/Warp/HTTP2/Sender.hs b/Network/Wai/Handler/Warp/HTTP2/Sender.hs --- a/Network/Wai/Handler/Warp/HTTP2/Sender.hs +++ b/Network/Wai/Handler/Warp/HTTP2/Sender.hs @@ -105,9 +105,7 @@ connSendAll frame case lookup SettingsHeaderTableSize alist of Nothing -> return () - Just siz -> do - dyntbl <- readIORef encodeDynamicTable - setLimitForEncoding siz dyntbl + Just siz -> setLimitForEncoding siz encodeDynamicTable return True output (ONext strm curr mtbq) off0 lim = do @@ -195,43 +193,32 @@ headerContinue sid rspn endOfStream off = do let !s = rspnStatus rspn !h = rspnHeaders rspn - builder <- hpackEncodeHeader ctx ii settings s h let !offkv = off + frameHeaderLength let !bufkv = connWriteBuffer `plusPtr` offkv !limkv = connBufferSize - offkv - (kvlen, signal) <- B.runBuilder builder bufkv limkv - let flag0 = case signal of - B.Done -> setEndHeader defaultFlags - _ -> defaultFlags + (hs,kvlen) <- hpackEncodeHeader ctx bufkv limkv ii settings s h + let flag0 = case hs of + [] -> setEndHeader defaultFlags + _ -> defaultFlags flag = if endOfStream then setEndStream flag0 else flag0 let buf = connWriteBuffer `plusPtr` off fillFrameHeader FrameHeaders kvlen sid flag buf - continue sid kvlen signal + continue sid kvlen hs bufHeaderPayload = connWriteBuffer `plusPtr` frameHeaderLength headerPayloadLim = connBufferSize - frameHeaderLength - continue _ kvlen B.Done = return kvlen - continue sid kvlen (B.More _ writer) = do + continue _ kvlen [] = return kvlen + continue sid kvlen hs = do flushN $ kvlen + frameHeaderLength -- Now off is 0 - (kvlen', signal') <- writer bufHeaderPayload headerPayloadLim - let flag = case signal' of - B.Done -> setEndHeader defaultFlags - _ -> defaultFlags + (hs', kvlen') <- hpackEncodeHeaderLoop ctx bufHeaderPayload headerPayloadLim hs + when (hs == hs') $ E.throwIO $ ConnectionError CompressionError "cannot compress the header" + let flag = case hs' of + [] -> setEndHeader defaultFlags + _ -> defaultFlags fillFrameHeader FrameContinuation kvlen' sid flag connWriteBuffer - continue sid kvlen' signal' - continue sid kvlen (B.Chunk bs writer) = do - flushN $ kvlen + frameHeaderLength - -- Now off is 0 - let (bs1,bs2) = BS.splitAt headerPayloadLim bs - kvlen' = BS.length bs1 - void $ copy bufHeaderPayload bs1 - fillFrameHeader FrameContinuation kvlen' sid defaultFlags connWriteBuffer - if bs2 == "" then - continue sid kvlen' (B.More 0 writer) - else - continue sid kvlen' (B.Chunk bs2 writer) + continue sid kvlen' hs' -- Re-enqueue the stream in the output queue. maybeEnqueueNext :: Stream -> Maybe (TBQueue Sequence) -> Maybe DynaNext -> IO () diff --git a/Network/Wai/Handler/Warp/HTTP2/Types.hs b/Network/Wai/Handler/Warp/HTTP2/Types.hs --- a/Network/Wai/Handler/Warp/HTTP2/Types.hs +++ b/Network/Wai/Handler/Warp/HTTP2/Types.hs @@ -24,7 +24,7 @@ import Network.HTTP2 import Network.HTTP2.Priority -import Network.HPACK +import Network.HPACK hiding (Buffer) ---------------------------------------------------------------- @@ -109,8 +109,8 @@ , inputQ :: !(TQueue Input) , outputQ :: !(PriorityTree Output) , controlQ :: !(TQueue Control) - , encodeDynamicTable :: !(IORef DynamicTable) - , decodeDynamicTable :: !(IORef DynamicTable) + , encodeDynamicTable :: !DynamicTable + , decodeDynamicTable :: !DynamicTable , connectionWindow :: !(TVar WindowSize) } @@ -127,8 +127,8 @@ <*> newTQueueIO <*> newPriorityTree <*> newTQueueIO - <*> (newDynamicTableForEncoding defaultDynamicTableSize >>= newIORef) - <*> (newDynamicTableForDecoding defaultDynamicTableSize >>= newIORef) + <*> newDynamicTableForEncoding defaultDynamicTableSize + <*> newDynamicTableForDecoding defaultDynamicTableSize 4096 <*> newTVarIO defaultInitialWindowSize clearContext :: Context -> IO () diff --git a/Network/Wai/Handler/Warp/Header.hs b/Network/Wai/Handler/Warp/Header.hs --- a/Network/Wai/Handler/Warp/Header.hs +++ b/Network/Wai/Handler/Warp/Header.hs @@ -4,6 +4,8 @@ import Data.Array import Data.Array.ST +import qualified Data.ByteString as BS +import Data.CaseInsensitive (foldedCase) import Network.HTTP.Types import Network.Wai.Handler.Warp.Types @@ -38,18 +40,22 @@ requestMaxIndex = fromEnum (maxBound :: RequestHeaderIndex) requestKeyIndex :: HeaderName -> Int -requestKeyIndex "content-length" = fromEnum ReqContentLength -requestKeyIndex "transfer-encoding" = fromEnum ReqTransferEncoding -requestKeyIndex "expect" = fromEnum ReqExpect -requestKeyIndex "connection" = fromEnum ReqConnection -requestKeyIndex "range" = fromEnum ReqRange -requestKeyIndex "host" = fromEnum ReqHost -requestKeyIndex "if-modified-since" = fromEnum ReqIfModifiedSince -requestKeyIndex "if-unmodified-since" = fromEnum ReqIfUnmodifiedSince -requestKeyIndex "if-range" = fromEnum ReqIfRange -requestKeyIndex "referer" = fromEnum ReqReferer -requestKeyIndex "user-agent" = fromEnum ReqUserAgent -requestKeyIndex _ = -1 +requestKeyIndex hn = case BS.length bs of + 4 -> if bs == "host" then fromEnum ReqHost else -1 + 5 -> if bs == "range" then fromEnum ReqRange else -1 + 6 -> if bs == "expect" then fromEnum ReqExpect else -1 + 7 -> if bs == "referer" then fromEnum ReqReferer else -1 + 8 -> if bs == "if-range" then fromEnum ReqIfRange else -1 + 10 -> if bs == "user-agent" then fromEnum ReqUserAgent else + if bs == "connection" then fromEnum ReqConnection else -1 + 14 -> if bs == "content-length" then fromEnum ReqContentLength else -1 + 17 -> if bs == "transfer-encoding" then fromEnum ReqTransferEncoding else + if bs == "if-modified-since" then fromEnum ReqIfModifiedSince + else -1 + 19 -> if bs == "if-unmodified-since" then fromEnum ReqIfUnmodifiedSince else -1 + _ -> -1 + where + bs = foldedCase hn defaultIndexRequestHeader :: IndexedHeader defaultIndexRequestHeader = array (0,requestMaxIndex) [(i,Nothing)|i<-[0..requestMaxIndex]] @@ -69,10 +75,13 @@ responseMaxIndex = fromEnum (maxBound :: ResponseHeaderIndex) responseKeyIndex :: HeaderName -> Int -responseKeyIndex "content-length" = fromEnum ResContentLength -responseKeyIndex "server" = fromEnum ResServer -responseKeyIndex "date" = fromEnum ResDate -responseKeyIndex _ = -1 +responseKeyIndex hn = case BS.length bs of + 4 -> if bs == "date" then fromEnum ResDate else -1 + 6 -> if bs == "server" then fromEnum ResServer else -1 + 14 -> if bs == "content-length" then fromEnum ResContentLength else -1 + _ -> -1 + where + bs = foldedCase hn ---------------------------------------------------------------- diff --git a/warp.cabal b/warp.cabal --- a/warp.cabal +++ b/warp.cabal @@ -1,5 +1,5 @@ Name: warp -Version: 3.2.2 +Version: 3.2.3 Synopsis: A fast, light-weight web server for WAI applications. License: MIT License-file: LICENSE @@ -43,7 +43,7 @@ , ghc-prim , http-types >= 0.8.5 , iproute >= 1.3.1 - , http2 >= 1.4 && < 1.5 + , http2 >= 1.5 && < 1.6 , simple-sendfile >= 0.2.7 && < 0.3 , unix-compat >= 0.2 , wai >= 3.2 && < 3.3 @@ -163,7 +163,7 @@ , directory , process , containers - , http2 >= 1.4 && < 1.5 + , http2 >= 1.5 && < 1.6 , word8 , hashable , http-date