diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,6 +1,15 @@ +## 3.2.6 + +* Using token based APIs of http2 1.6. + +## 3.2.5 + +* Ignoring errors from setSocketOption. [#526](https://github.com/yesodweb/wai/issues/526). + ## 3.2.4 * Added `withApplication`, `testWithApplication`, and `openFreePort` +* Fixing reaper delay value of file info cache. ## 3.2.3 diff --git a/Network/Wai/Handler/Warp/File.hs b/Network/Wai/Handler/Warp/File.hs --- a/Network/Wai/Handler/Warp/File.hs +++ b/Network/Wai/Handler/Warp/File.hs @@ -7,25 +7,21 @@ , conditionalRequest , addContentHeadersForFilePart , parseByteRanges - , packInteger -- testing ) where import Control.Applicative ((<|>)) -import Control.Monad import Data.Array ((!)) import qualified Data.ByteString as B hiding (pack) import qualified Data.ByteString.Char8 as B (pack, readInteger) -import Data.ByteString.Internal (ByteString(..), unsafeCreate) +import Data.ByteString (ByteString) import Data.Maybe (fromMaybe) -import Data.Word8 (Word8) -import Foreign.Ptr (Ptr, plusPtr) -import Foreign.Storable (poke) import Network.HTTP.Date import qualified Network.HTTP.Types as H import qualified Network.HTTP.Types.Header as H import Network.Wai import qualified Network.Wai.Handler.Warp.FileInfoCache as I import Network.Wai.Handler.Warp.Header +import Network.Wai.Handler.Warp.PackInt import Numeric (showInt) #ifndef MIN_VERSION_http_types @@ -183,27 +179,8 @@ | otherwise = let !ctrng = contentRangeHeader off (off + len - 1) size in ctrng:hs' where - !lengthBS = packInteger len + !lengthBS = packIntegral len !hs' = (H.hContentLength, lengthBS) : (acceptRange,"bytes") : hs - --- | --- --- prop> packInteger (abs n) == B.pack (show (abs n)) --- prop> \(Large n) -> let n' = fromIntegral (abs n :: Int) in packInteger n' == B.pack (show n') - -packInteger :: Integer -> ByteString -packInteger 0 = "0" -packInteger n | n < 0 = error "packInteger" -packInteger n = unsafeCreate len go0 - where - n' = fromIntegral n + 1 :: Double - len = ceiling $ logBase 10 n' - go0 p = go n $ p `plusPtr` (len - 1) - go :: Integer -> Ptr Word8 -> IO () - go i p = do - let (d,r) = i `divMod` 10 - poke p (48 + fromIntegral r) - when (d /= 0) $ go d (p `plusPtr` (-1)) -- | -- diff --git a/Network/Wai/Handler/Warp/HTTP2/File.hs b/Network/Wai/Handler/Warp/HTTP2/File.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Handler/Warp/HTTP2/File.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns, RecordWildCards #-} + +module Network.Wai.Handler.Warp.HTTP2.File ( + RspFileInfo(..) + , conditionalRequest + , addContentHeadersForFilePart + , parseByteRanges + ) where + +import Control.Applicative ((<|>)) +import qualified Data.ByteString as B hiding (pack) +import qualified Data.ByteString.Char8 as B (pack, readInteger) +import Data.ByteString (ByteString) +import Data.Maybe (fromMaybe) +import Network.HTTP.Date +import qualified Network.HTTP.Types as H +import Network.Wai +import qualified Network.Wai.Handler.Warp.FileInfoCache as I +import Network.Wai.Handler.Warp.PackInt +import Numeric (showInt) +import Network.HPACK +import Network.HPACK.Token + +#ifndef MIN_VERSION_http_types +#define MIN_VERSION_http_types(x,y,z) 1 +#endif + +-- $setup +-- >>> import Test.QuickCheck + +---------------------------------------------------------------- + +data RspFileInfo = WithoutBody !H.Status + | WithBody !H.Status !TokenHeaderList !Integer !Integer + deriving (Eq,Show) + +---------------------------------------------------------------- + +conditionalRequest :: I.FileInfo + -> TokenHeaderList -- Response + -> ValueTable -- Request + -> RspFileInfo +conditionalRequest (I.FileInfo _ size mtime date) ths0 reqtbl = case condition of + nobody@(WithoutBody _) -> nobody + WithBody s _ off len -> let !hs = (tokenLastModified,date) : + addContentHeaders ths0 off len size + in WithBody s hs off len + where + !mcondition = ifmodified reqtbl size mtime + <|> ifunmodified reqtbl size mtime + <|> ifrange reqtbl size mtime + !condition = fromMaybe (unconditional reqtbl size) mcondition + +---------------------------------------------------------------- + +{-# INLINE ifModifiedSince #-} +ifModifiedSince :: ValueTable -> Maybe HTTPDate +ifModifiedSince reqtbl = getHeaderValue tokenIfModifiedSince reqtbl >>= parseHTTPDate + +{-# INLINE ifUnmodifiedSince #-} +ifUnmodifiedSince :: ValueTable -> Maybe HTTPDate +ifUnmodifiedSince reqtbl = getHeaderValue tokenIfUnmodifiedSince reqtbl >>= parseHTTPDate + +{-# INLINE ifRange #-} +ifRange :: ValueTable -> Maybe HTTPDate +ifRange reqtbl = getHeaderValue tokenIfRange reqtbl >>= parseHTTPDate + +---------------------------------------------------------------- + +{-# INLINE ifmodified #-} +ifmodified :: ValueTable -> Integer -> HTTPDate -> Maybe RspFileInfo +ifmodified reqtbl size mtime = do + date <- ifModifiedSince reqtbl + return $ if date /= mtime + then unconditional reqtbl size + else WithoutBody H.notModified304 + +{-# INLINE ifunmodified #-} +ifunmodified :: ValueTable -> Integer -> HTTPDate -> Maybe RspFileInfo +ifunmodified reqtbl size mtime = do + date <- ifUnmodifiedSince reqtbl + return $ if date == mtime + then unconditional reqtbl size + else WithoutBody H.preconditionFailed412 + +{-# INLINE ifrange #-} +ifrange :: ValueTable -> Integer -> HTTPDate -> Maybe RspFileInfo +ifrange reqtbl size mtime = do + date <- ifRange reqtbl + rng <- getHeaderValue tokenRange reqtbl + return $ if date == mtime + then parseRange rng size + else WithBody H.ok200 [] 0 size + +{-# INLINE unconditional #-} +unconditional :: ValueTable -> Integer -> RspFileInfo +unconditional reqtbl size = case getHeaderValue tokenRange reqtbl of + Nothing -> WithBody H.ok200 [] 0 size + Just rng -> parseRange rng size + +---------------------------------------------------------------- + +{-# INLINE parseRange #-} +parseRange :: ByteString -> Integer -> RspFileInfo +parseRange rng size = case parseByteRanges rng of + Nothing -> WithoutBody H.requestedRangeNotSatisfiable416 + Just [] -> WithoutBody H.requestedRangeNotSatisfiable416 + Just (r:_) -> let (!beg, !end) = checkRange r size + !len = end - beg + 1 + s = if beg == 0 && end == size - 1 then + H.ok200 + else + H.partialContent206 + in WithBody s [] beg len + +{-# INLINE checkRange #-} +checkRange :: H.ByteRange -> Integer -> (Integer, Integer) +checkRange (H.ByteRangeFrom beg) size = (beg, size - 1) +checkRange (H.ByteRangeFromTo beg end) size = (beg, min (size - 1) end) +checkRange (H.ByteRangeSuffix count) size = (max 0 (size - count), size - 1) + +{-# INLINE parseByteRanges #-} +-- | Parse the value of a Range header into a 'H.ByteRanges'. +parseByteRanges :: B.ByteString -> Maybe H.ByteRanges +parseByteRanges bs1 = do + bs2 <- stripPrefix "bytes=" bs1 + (r, bs3) <- range bs2 + ranges (r:) bs3 + where + range bs2 = do + (i, bs3) <- B.readInteger bs2 + if i < 0 -- has prefix "-" ("-0" is not valid, but here treated as "0-") + then Just (H.ByteRangeSuffix (negate i), bs3) + else do + bs4 <- stripPrefix "-" bs3 + case B.readInteger bs4 of + Just (j, bs5) | j >= i -> Just (H.ByteRangeFromTo i j, bs5) + _ -> Just (H.ByteRangeFrom i, bs4) + ranges front bs3 + | B.null bs3 = Just (front []) + | otherwise = do + bs4 <- stripPrefix "," bs3 + (r, bs5) <- range bs4 + ranges (front . (r:)) bs5 + + stripPrefix x y + | x `B.isPrefixOf` y = Just (B.drop (B.length x) y) + | otherwise = Nothing + +---------------------------------------------------------------- + +{-# INLINE contentRangeHeader #-} +-- | @contentRangeHeader beg end total@ constructs a Content-Range 'H.Header' +-- for the range specified. +contentRangeHeader :: Integer -> Integer -> Integer -> TokenHeader +contentRangeHeader beg end total = (tokenContentRange, range) + where + range = B.pack + -- building with ShowS + $ 'b' : 'y': 't' : 'e' : 's' : ' ' + : (if beg > end then ('*':) else + showInt beg + . ('-' :) + . showInt end) + ( '/' + : showInt total "") + +{-# INLINE addContentHeaders #-} +addContentHeaders :: TokenHeaderList -> Integer -> Integer -> Integer -> TokenHeaderList +addContentHeaders ths off len size + | len == size = ths' + | otherwise = let !ctrng = contentRangeHeader off (off + len - 1) size + in ctrng:ths' + where + !lengthBS = packIntegral len + !ths' = (tokenContentLength, lengthBS) : (tokenAcceptRanges,"bytes") : ths + +{-# INLINE addContentHeadersForFilePart #-} +-- | +-- +-- >>> addContentHeadersForFilePart [] (FilePart 2 10 16) +-- [(Token {ix = 20, shouldBeIndexed = True, isPseudo = False, tokenKey = "Content-Range"},"bytes 2-11/16"),(Token {ix = 18, shouldBeIndexed = False, isPseudo = False, tokenKey = "Content-Length"},"10"),(Token {ix = 8, shouldBeIndexed = True, isPseudo = False, tokenKey = "Accept-Ranges"},"bytes")] +-- >>> addContentHeadersForFilePart [] (FilePart 0 16 16) +-- [(Token {ix = 18, shouldBeIndexed = False, isPseudo = False, tokenKey = "Content-Length"},"16"),(Token {ix = 8, shouldBeIndexed = True, isPseudo = False, tokenKey = "Accept-Ranges"},"bytes")] +addContentHeadersForFilePart :: TokenHeaderList -> FilePart -> TokenHeaderList +addContentHeadersForFilePart hs part = addContentHeaders hs off len size + where + off = filePartOffset part + len = filePartByteCount part + size = filePartFileSize part 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,18 +1,22 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings, BangPatterns #-} {-# LANGUAGE NamedFieldPuns, RecordWildCards #-} -module Network.Wai.Handler.Warp.HTTP2.HPACK where +module Network.Wai.Handler.Warp.HTTP2.HPACK ( + hpackEncodeHeader + , hpackEncodeHeaderLoop + , hpackDecodeHeader + , just + ) where -import Control.Arrow (first) import qualified Control.Exception as E -import qualified Data.ByteString.Char8 as B8 -import Data.CaseInsensitive (foldedCase) +import Control.Monad (unless) +import Data.ByteString (ByteString) import Network.HPACK hiding (Buffer) +import Network.HPACK.Token import qualified Network.HTTP.Types as H import Network.HTTP2 import Network.Wai.Handler.Warp.HTTP2.Types -import Network.Wai.Handler.Warp.Header -import Network.Wai.Handler.Warp.Response +import Network.Wai.Handler.Warp.PackInt import qualified Network.Wai.Handler.Warp.Settings as S import Network.Wai.Handler.Warp.Types @@ -26,27 +30,56 @@ -- So, we don't need to split it. hpackEncodeHeader :: Context -> Buffer -> BufSize -> InternalInfo -> S.Settings - -> H.Status -> H.ResponseHeaders - -> 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 - getdate = getDate ii - rspidxhdr = indexResponseHeader hdr0 - defServer = S.settingsServerName settings - addServerAndDate = addDate getdate rspidxhdr . addServer defServer rspidxhdr + -> H.Status -> (TokenHeaderList,ValueTable) + -> IO (TokenHeaderList, Int) +hpackEncodeHeader Context{..} buf siz ii settings s (ths0,tbl) = do + let !defServer = S.settingsServerName settings + !ths1 = addHeader tokenServer defServer tbl ths0 + date <- getDate ii + let !ths2 = addHeader tokenDate date tbl ths1 + !status = packStatus s + !ths3 = (tokenStatus, status) : ths2 + encodeTokenHeader buf siz strategy True encodeDynamicTable ths3 -hpackEncodeHeaderLoop :: Context -> Buffer -> BufSize -> HeaderList - -> IO (HeaderList, Int) +{-# INLINE addHeader #-} +addHeader :: Token -> ByteString -> ValueTable -> TokenHeaderList -> TokenHeaderList +addHeader t v tbl ths = case getHeaderValue t tbl of + Nothing -> (t,v) : ths + Just _ -> ths + +hpackEncodeHeaderLoop :: Context -> Buffer -> BufSize -> TokenHeaderList + -> IO (TokenHeaderList, Int) hpackEncodeHeaderLoop Context{..} buf siz hs = - encodeHeaderBuffer buf siz strategy False encodeDynamicTable hs + encodeTokenHeader buf siz strategy False encodeDynamicTable hs ---------------------------------------------------------------- -hpackDecodeHeader :: HeaderBlockFragment -> Context -> IO HeaderList -hpackDecodeHeader hdrblk Context{..} = - decodeHeader decodeDynamicTable hdrblk `E.catch` \(E.SomeException _) -> +hpackDecodeHeader :: HeaderBlockFragment -> Context -> IO (TokenHeaderList, ValueTable) +hpackDecodeHeader hdrblk Context{..} = do + tbl@(_,vt) <- decodeTokenHeader decodeDynamicTable hdrblk `E.catch` handl + unless (checkRequestHeader vt) $ + E.throwIO $ ConnectionError ProtocolError "the header key is illegal" + return tbl + where + handl IllegalHeaderName = + E.throwIO $ ConnectionError ProtocolError "the header key is illegal" + handl _ = E.throwIO $ ConnectionError CompressionError "cannot decompress the header" + +{-# INLINE checkRequestHeader #-} +checkRequestHeader :: ValueTable -> Bool +checkRequestHeader reqvt + | getHeaderValue tokenStatus reqvt /= Nothing = False + | getHeaderValue tokenPath reqvt == Nothing = False + | getHeaderValue tokenMethod reqvt == Nothing = False + | getHeaderValue tokenAuthority reqvt == Nothing = False + | getHeaderValue tokenConnection reqvt /= Nothing = False + | just (getHeaderValue tokenTE reqvt) (/= "trailers") = False + | otherwise = True + +{-# INLINE just #-} +just :: Maybe a -> (a -> Bool) -> Bool +just Nothing _ = False +just (Just x) p + | p x = True + | otherwise = False diff --git a/Network/Wai/Handler/Warp/HTTP2/Receiver.hs b/Network/Wai/Handler/Warp/HTTP2/Receiver.hs --- a/Network/Wai/Handler/Warp/HTTP2/Receiver.hs +++ b/Network/Wai/Handler/Warp/HTTP2/Receiver.hs @@ -15,7 +15,8 @@ import Control.Monad (when, unless, void) import Data.ByteString (ByteString) import qualified Data.ByteString as BS -import Data.Maybe (isJust) +import Network.HPACK +import Network.HPACK.Token import Network.HTTP2 import Network.HTTP2.Priority (toPrecedence, delete, prepare) import Network.Wai.Handler.Warp.HTTP2.EncodeFrame @@ -23,6 +24,7 @@ import Network.Wai.Handler.Warp.HTTP2.Request import Network.Wai.Handler.Warp.HTTP2.Types import Network.Wai.Handler.Warp.IORef +import Network.Wai.Handler.Warp.ReadInt import Network.Wai.Handler.Warp.Types ---------------------------------------------------------------- @@ -103,30 +105,26 @@ state <- readIORef streamState state' <- stream ftyp header pl ctx state strm case state' of - Open (NoBody hdr pri) -> do + Open (NoBody tbl@(_,reqvt) pri) -> do resetContinued - case validateHeaders hdr of - Just vh -> do - when (isJust (vhCL vh) && vhCL vh /= Just 0) $ - E.throwIO $ StreamError ProtocolError streamId - writeIORef streamPrecedence $ toPrecedence pri - writeIORef streamState HalfClosed - let (!req, !ii) = mkreq vh (return "") - atomically $ writeTQueue inputQ $ Input strm req ii - Nothing -> E.throwIO $ StreamError ProtocolError streamId - Open (HasBody hdr pri) -> do + let mcl = readInt <$> getHeaderValue tokenContentLength reqvt + when (just mcl (== (0 :: Int))) $ + E.throwIO $ StreamError ProtocolError streamId + writeIORef streamPrecedence $ toPrecedence pri + writeIORef streamState HalfClosed + let (!req, !ii) = mkreq tbl (return "") + atomically $ writeTQueue inputQ $ Input strm req reqvt ii + Open (HasBody tbl@(_,reqvt) pri) -> do resetContinued - case validateHeaders hdr of - Just vh -> do - q <- newTQueueIO - writeIORef streamPrecedence $ toPrecedence pri - writeIORef streamState (Open (Body q)) - writeIORef streamContentLength $ vhCL vh - readQ <- newReadBody q - bodySource <- mkSource readQ - let (!req, !ii) = mkreq vh (readSource bodySource) - atomically $ writeTQueue inputQ $ Input strm req ii - Nothing -> E.throwIO $ StreamError ProtocolError streamId + q <- newTQueueIO + writeIORef streamPrecedence $ toPrecedence pri + writeIORef streamState (Open (Body q)) + let mcl = readInt <$> getHeaderValue tokenContentLength reqvt + writeIORef streamContentLength mcl + readQ <- newReadBody q + bodySource <- mkSource readQ + let (!req, !ii) = mkreq tbl (readSource bodySource) + atomically $ writeTQueue inputQ $ Input strm req reqvt ii s@(Open Continued{}) -> do setContinued writeIORef streamState s @@ -219,11 +217,14 @@ ---------------------------------------------------------------- +{-# INLINE guardIt #-} guardIt :: Either HTTP2Error a -> IO a guardIt x = case x of Left err -> E.throwIO err Right frame -> return frame + +{-# INLINE checkPriority #-} checkPriority :: Priority -> StreamId -> IO () checkPriority p me | dep == me = E.throwIO $ StreamError ProtocolError me @@ -242,11 +243,11 @@ let !endOfStream = testEndStream flags !endOfHeader = testEndHeader flags if endOfHeader then do - hdr <- hpackDecodeHeader frag ctx + tbl <- hpackDecodeHeader frag ctx -- fixme return $ if endOfStream then - Open (NoBody hdr pri) + Open (NoBody tbl pri) else - Open (HasBody hdr pri) + Open (HasBody tbl pri) else do let !siz = BS.length frag return $ Open $ Continued [frag] siz 1 endOfStream pri @@ -300,11 +301,11 @@ E.throwIO $ ConnectionError EnhanceYourCalm "Header is too fragmented" if endOfHeader then do let !hdrblk = BS.concat $ reverse rfrags' - hdr <- hpackDecodeHeader hdrblk ctx + tbl <- hpackDecodeHeader hdrblk ctx return $ if endOfStream then - Open (NoBody hdr pri) + Open (NoBody tbl pri) else - Open (HasBody hdr pri) + Open (HasBody tbl pri) else return $ Open $ Continued rfrags' siz' n' endOfStream pri @@ -350,11 +351,13 @@ ---------------------------------------------------------------- +{-# INLINE newReadBody #-} newReadBody :: TQueue ByteString -> IO (IO ByteString) newReadBody q = do ref <- newIORef False return $ readBody q ref +{-# INLINE readBody #-} readBody :: TQueue ByteString -> IORef Bool -> IO ByteString readBody q ref = do eof <- readIORef ref diff --git a/Network/Wai/Handler/Warp/HTTP2/Request.hs b/Network/Wai/Handler/Warp/HTTP2/Request.hs --- a/Network/Wai/Handler/Warp/HTTP2/Request.hs +++ b/Network/Wai/Handler/Warp/HTTP2/Request.hs @@ -4,163 +4,69 @@ module Network.Wai.Handler.Warp.HTTP2.Request ( mkRequest , MkReq - , ValidHeaders(..) - , validateHeaders ) where -#if __GLASGOW_HASKELL__ < 709 -import Control.Applicative ((<$>)) -#endif +import Control.Applicative ((<|>)) +import Control.Arrow (first) import Data.ByteString (ByteString) -import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as B8 -import Data.CaseInsensitive (mk) -import Data.Maybe (isJust) +import Data.Maybe (fromJust) import qualified Data.Vault.Lazy as Vault -#if __GLASGOW_HASKELL__ < 709 -import Data.Monoid (mempty) -#endif -import Data.Word8 (isUpper,_colon) import Network.HPACK -import Network.HTTP.Types (RequestHeaders) +import Network.HPACK.Token import qualified Network.HTTP.Types as H import Network.Socket (SockAddr) import Network.Wai import Network.Wai.Handler.Warp.HTTP2.Types import Network.Wai.Handler.Warp.HashMap (hashByteString) -import Network.Wai.Handler.Warp.ReadInt import Network.Wai.Handler.Warp.Request (pauseTimeoutKey, getFileInfoKey) -import Network.Wai.Handler.Warp.Types -import Network.Wai.Internal (Request(..)) import qualified Network.Wai.Handler.Warp.Settings as S (Settings, settingsNoParsePath) import qualified Network.Wai.Handler.Warp.Timeout as Timeout - -data ValidHeaders = ValidHeaders { - vhMethod :: !ByteString - , vhPath :: !ByteString - , vhAuth :: !(Maybe ByteString) - , vhRange :: !(Maybe ByteString) - , vhReferer :: !(Maybe ByteString) - , vhUA :: !(Maybe ByteString) - , vhCL :: !(Maybe Int) - , vhHeader :: !RequestHeaders - } deriving Show +import Network.Wai.Handler.Warp.Types +import Network.Wai.Internal (Request(..)) -type MkReq = ValidHeaders -> IO ByteString -> (Request,InternalInfo) +type MkReq = (TokenHeaderList,ValueTable) -> IO ByteString -> (Request,InternalInfo) mkRequest :: InternalInfo1 -> S.Settings -> SockAddr -> MkReq -mkRequest ii1 settings addr (ValidHeaders m p ma mrng mrr mua _ hdr) body = - (req,ii) +mkRequest ii1 settings addr (reqths,reqvt) body = (req,ii) where - (unparsedPath,query) = B8.break (=='?') p - !path = H.extractPath unparsedPath - !rawPath = if S.settingsNoParsePath settings then unparsedPath else path - !h = hashByteString rawPath !req = Request { - requestMethod = m + requestMethod = colonMethod , httpVersion = http2ver , rawPathInfo = rawPath , pathInfo = H.decodePathSegments path , rawQueryString = query , queryString = H.parseQuery query - , requestHeaders = case ma of - Nothing -> hdr - Just hv -> (mk "host", hv) : hdr + , requestHeaders = headers , isSecure = True , remoteHost = addr , requestBody = body , vault = vaultValue , requestBodyLength = ChunkedBody -- fixme - , requestHeaderHost = ma - , requestHeaderRange = mrng - , requestHeaderReferer = mrr - , requestHeaderUserAgent = mua + , requestHeaderHost = mHost + , requestHeaderRange = mRange + , requestHeaderReferer = mReferer + , requestHeaderUserAgent = mUserAgent } + headers = map (first tokenKey) ths + where + ths = case mHost of + Nothing -> (tokenHost, colonAuth) : reqths + Just _ -> reqths + !colonPath = fromJust $ getHeaderValue tokenPath reqvt + !colonMethod = fromJust $ getHeaderValue tokenMethod reqvt + !mAuth = getHeaderValue tokenAuthority reqvt + !colonAuth = fromJust $ mAuth + !mHost = getHeaderValue tokenHost reqvt <|> mAuth + !mRange = getHeaderValue tokenRange reqvt + !mReferer = getHeaderValue tokenReferer reqvt + !mUserAgent = getHeaderValue tokenUserAgent reqvt + (unparsedPath,query) = B8.break (=='?') colonPath + !path = H.extractPath unparsedPath + !rawPath = if S.settingsNoParsePath settings then unparsedPath else path + !h = hashByteString rawPath !ii = toInternalInfo ii1 h !th = threadHandle ii !vaultValue = Vault.insert pauseTimeoutKey (Timeout.pause th) $ Vault.insert getFileInfoKey (getFileInfo ii) Vault.empty - ----------------------------------------------------------------- - -data Special = Special { - colonMethod :: !(Maybe ByteString) - , colonPath :: !(Maybe ByteString) - , colonAuth :: !(Maybe ByteString) - , sRange :: !(Maybe ByteString) - , sReferer :: !(Maybe ByteString) - , sUA :: !(Maybe ByteString) - , contentLen :: !(Maybe ByteString) - } deriving Show - -emptySpecial :: Special -emptySpecial = Special Nothing Nothing Nothing Nothing Nothing Nothing Nothing - --- | --- --- >>> validateHeaders [(":method","GET"),(":path","path")] --- Just (ValidHeaders {vhMethod = "GET", vhPath = "path", vhAuth = Nothing, vhRange = Nothing, vhReferer = Nothing, vhUA = Nothing, vhCL = Nothing, vhHeader = []}) --- >>> validateHeaders [(":method","GET"),(":path","path"),(":authority","authority"),("accept-language","en")] --- Just (ValidHeaders {vhMethod = "GET", vhPath = "path", vhAuth = Just "authority", vhRange = Nothing, vhReferer = Nothing, vhUA = Nothing, vhCL = Nothing, vhHeader = [("accept-language","en")]}) --- >>> validateHeaders [(":method","GET"),(":path","path"),("cookie","a=b"),("accept-language","en"),("cookie","c=d"),("cookie","e=f")] --- Just (ValidHeaders {vhMethod = "GET", vhPath = "path", vhAuth = Nothing, vhRange = Nothing, vhReferer = Nothing, vhUA = Nothing, vhCL = Nothing, vhHeader = [("accept-language","en"),("cookie","a=b; c=d; e=f")]}) -validateHeaders :: HeaderList -> Maybe ValidHeaders -validateHeaders hs = case pseudo hs emptySpecial of - Just (Special (Just m) (Just p) ma mrng mrr mua mcl, !h) - -> Just $! ValidHeaders m p ma mrng mrr mua (readInt <$> mcl) h - _ -> Nothing - where - pseudo [] !s = Just (s,[]) - pseudo h@((k,v):kvs) !s - | k == ":method" = if isJust (colonMethod s) then - Nothing - else - pseudo kvs (s { colonMethod = Just v }) - | k == ":path" = if isJust (colonPath s) then - Nothing - else - pseudo kvs (s { colonPath = Just v }) - | k == ":authority" = if isJust (colonAuth s) then - Nothing - else - pseudo kvs (s { colonAuth = Just v }) - | k == ":scheme" = pseudo kvs s -- fixme: how to store :scheme? - | isPseudo k = Nothing - | otherwise = normal h (s,id,id) - - normal [] (!s,b,c) = Just (s, mkH b c) - normal ((k,v):kvs) (!s,b,c) - | isPseudo k = Nothing - | k == "connection" = Nothing - | k == "te" = if v == "trailers" then - normal kvs (s, b . ((mk k,v) :), c) - else - Nothing - | k == "range" - = normal kvs (s {sRange = Just v }, b . ((mk k,v) :), c) - | k == "referer" - = normal kvs (s { sReferer = Just v }, b . ((mk k,v) :), c) - | k == "user-agent" - = normal kvs (s { sUA = Just v }, b . ((mk k,v) :), c) - | k == "content-length" - = normal kvs (s { contentLen = Just v }, b . ((mk k,v) :), c) - | k == "host" = if isJust (colonAuth s) then - normal kvs (s, b, c) - else - normal kvs (s { colonAuth = Just v }, b, c) - | k == "cookie" = normal kvs (s, b, c . (v:)) - | otherwise = case BS.find isUpper k of - Nothing -> normal kvs (s, b . ((mk k,v) :), c) - Just _ -> Nothing - - mkH b c = h - where - !h = b anchor - !cookieList = c [] - !anchor - | null cookieList = [] - | otherwise = let !v = BS.intercalate "; " cookieList - in [("cookie",v)] - isPseudo "" = False - isPseudo k = BS.head k == _colon 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 @@ -44,14 +44,17 @@ ---------------------------------------------------------------- +{-# INLINE getStreamWindowSize #-} getStreamWindowSize :: Stream -> IO WindowSize getStreamWindowSize Stream{streamWindow} = atomically $ readTVar streamWindow +{-# INLINE waitStreamWindowSize #-} waitStreamWindowSize :: Stream -> STM () waitStreamWindowSize Stream{streamWindow} = do w <- readTVar streamWindow check (w > 0) +{-# INLINE waitStreaming #-} waitStreaming :: TBQueue a -> STM () waitStreaming tbq = do isEmpty <- isEmptyTBQueue tbq @@ -111,6 +114,7 @@ setLimit alist return off' + {-# INLINE setLimit #-} setLimit alist = case lookup SettingsHeaderTableSize alist of Nothing -> return () Just siz -> setLimitForEncoding siz encodeDynamicTable @@ -192,6 +196,7 @@ enqueueControl controlQ $ CFrame rst return off + {-# INLINE flushN #-} -- Flush the connection buffer to the socket, where the first 'n' bytes of -- the buffer are filled. flushN :: Int -> IO () @@ -212,8 +217,8 @@ fillFrameHeader FrameHeaders kvlen sid flag buf continue sid kvlen hs - bufHeaderPayload = connWriteBuffer `plusPtr` frameHeaderLength - headerPayloadLim = connBufferSize - frameHeaderLength + !bufHeaderPayload = connWriteBuffer `plusPtr` frameHeaderLength + !headerPayloadLim = connBufferSize - frameHeaderLength continue _ kvlen [] = return kvlen continue sid kvlen hs = do @@ -227,6 +232,7 @@ fillFrameHeader FrameContinuation kvlen' sid flag connWriteBuffer continue sid kvlen' hs' + {-# INLINE maybeEnqueueNext #-} -- Re-enqueue the stream in the output queue. maybeEnqueueNext :: Stream -> Maybe (TBQueue Sequence) -> Maybe DynaNext -> IO () maybeEnqueueNext _ _ Nothing = return () @@ -234,6 +240,7 @@ where !out = ONext strm next mtbq + {-# INLINE sendHeadersIfNecessary #-} -- Send headers if there is not room for a 1-byte data frame, and return -- the offset of the next frame's first header byte. sendHeadersIfNecessary off @@ -248,19 +255,21 @@ let !sid = streamNumber strm !buf = connWriteBuffer `plusPtr` off !off' = off + frameHeaderLength + datPayloadLen - flag = case mnext of - Nothing -> setEndStream defaultFlags - _ -> defaultFlags + !done = isNothing mnext + flag | done = setEndStream defaultFlags + | otherwise = defaultFlags fillFrameHeader FrameData datPayloadLen sid flag buf - when (isNothing mnext) $ closed ctx strm Finished + when done $ closed ctx strm Finished atomically $ modifyTVar' connectionWindow (subtract datPayloadLen) atomically $ modifyTVar' (streamWindow strm) (subtract datPayloadLen) return off' + {-# INLINE fillFrameHeader #-} fillFrameHeader ftyp len sid flag buf = encodeFrameHeaderBuf ftyp hinfo buf where hinfo = FrameHeader len flag sid + {-# INLINE ignore #-} ignore :: E.SomeException -> IO () ignore _ = return () @@ -456,6 +465,7 @@ Next len $ Just (fillBufFile fd start bytes refresh) #endif +{-# INLINE mini #-} mini :: Int -> Integer -> Int mini i n | fromIntegral i < n = i 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 @@ -41,7 +41,7 @@ ---------------------------------------------------------------- -data Input = Input Stream Request InternalInfo +data Input = Input Stream Request ValueTable InternalInfo ---------------------------------------------------------------- @@ -51,10 +51,10 @@ data Next = Next !BytesFilled (Maybe DynaNext) -data Rspn = RspnNobody H.Status H.ResponseHeaders - | RspnStreaming H.Status H.ResponseHeaders (TBQueue Sequence) - | RspnBuilder H.Status H.ResponseHeaders Builder - | RspnFile H.Status H.ResponseHeaders FilePath (Maybe FilePart) +data Rspn = RspnNobody H.Status (TokenHeaderList, ValueTable) + | RspnStreaming H.Status (TokenHeaderList, ValueTable) (TBQueue Sequence) + | RspnBuilder H.Status (TokenHeaderList, ValueTable) Builder + | RspnFile H.Status (TokenHeaderList, ValueTable) FilePath (Maybe FilePart) rspnStatus :: Rspn -> H.Status rspnStatus (RspnNobody s _) = s @@ -62,11 +62,11 @@ rspnStatus (RspnBuilder s _ _) = s rspnStatus (RspnFile s _ _ _ ) = s -rspnHeaders :: Rspn -> H.ResponseHeaders -rspnHeaders (RspnNobody _ h) = h -rspnHeaders (RspnStreaming _ h _) = h -rspnHeaders (RspnBuilder _ h _) = h -rspnHeaders (RspnFile _ h _ _ ) = h +rspnHeaders :: Rspn -> (TokenHeaderList, ValueTable) +rspnHeaders (RspnNobody _ t) = t +rspnHeaders (RspnStreaming _ t _) = t +rspnHeaders (RspnBuilder _ t _) = t +rspnHeaders (RspnFile _ t _ _ ) = t data Output = ORspn !Stream !Rspn !InternalInfo | ONext !Stream !DynaNext !(Maybe (TBQueue Sequence)) @@ -144,8 +144,8 @@ !Int -- The number of continuation frames !Bool -- End of stream !Priority - | NoBody HeaderList !Priority - | HasBody HeaderList !Priority + | NoBody (TokenHeaderList,ValueTable) !Priority + | HasBody (TokenHeaderList,ValueTable) !Priority | Body !(TQueue ByteString) data ClosedCode = Finished diff --git a/Network/Wai/Handler/Warp/HTTP2/Worker.hs b/Network/Wai/Handler/Warp/HTTP2/Worker.hs --- a/Network/Wai/Handler/Warp/HTTP2/Worker.hs +++ b/Network/Wai/Handler/Warp/HTTP2/Worker.hs @@ -22,13 +22,13 @@ import Data.ByteString.Builder (byteString) import qualified Network.HTTP.Types as H import Network.HTTP2 +import Network.HPACK import Network.Wai -import Network.Wai.Handler.Warp.File import Network.Wai.Handler.Warp.FileInfoCache import Network.Wai.Handler.Warp.HTTP2.EncodeFrame +import Network.Wai.Handler.Warp.HTTP2.File import Network.Wai.Handler.Warp.HTTP2.Manager import Network.Wai.Handler.Warp.HTTP2.Types -import Network.Wai.Handler.Warp.Header import Network.Wai.Handler.Warp.IORef import qualified Network.Wai.Handler.Warp.Response as R import qualified Network.Wai.Handler.Warp.Settings as S @@ -41,14 +41,15 @@ -- | The wai definition is 'type Application = Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived'. -- This type implements the second argument (Response -> IO ResponseReceived) -- with extra arguments. -type Responder = InternalInfo -> ThreadContinue -> Stream -> Request -> +type Responder = InternalInfo -> ValueTable -> + ThreadContinue -> Stream -> Request -> Response -> IO ResponseReceived -- | This function is passed to workers. -- They also pass 'Response's from 'Application's to this function. -- This function enqueues commands for the HTTP/2 sender. response :: S.Settings -> Context -> Manager -> Responder -response settings Context{outputQ} mgr ii tconf strm req rsp = case rsp of +response settings Context{outputQ} mgr ii reqvt tconf strm req rsp = case rsp of ResponseStream s0 hs0 strmbdy | noBody s0 -> responseNoBody s0 hs0 | isHead -> responseNoBody s0 hs0 @@ -73,18 +74,21 @@ -- log message are written here even the window size of streams -- is 0. - responseNoBody s hs = do + responseNoBody s hs0 = toHeaderTable hs0 >>= responseNoBody' s + + responseNoBody' s tbl = do logger req s Nothing setThreadContinue tconf True - let rspn = RspnNobody s hs + let rspn = RspnNobody s tbl out = ORspn strm rspn ii enqueueOutput outputQ out return ResponseReceived - responseBuilderBody s hs bdy = do + responseBuilderBody s hs0 bdy = do logger req s Nothing setThreadContinue tconf True - let rspn = RspnBuilder s hs bdy + tbl <- toHeaderTable hs0 + let rspn = RspnBuilder s tbl bdy out = ORspn strm rspn ii enqueueOutput outputQ out return ResponseReceived @@ -93,20 +97,24 @@ efinfo <- E.try $ getFileInfo ii path case efinfo of Left (_ex :: E.IOException) -> response404 hs0 - Right finfo -> case conditionalRequest finfo hs0 (indexRequestHeader (requestHeaders req)) of - WithoutBody s -> responseNoBody s hs0 - WithBody s hs beg len -> responseFile2XX s hs path (Just (FilePart beg len (fileInfoSize finfo))) + Right finfo -> do + (rspths0,vt) <- toHeaderTable hs0 + case conditionalRequest finfo rspths0 reqvt of + WithoutBody s -> responseNoBody s hs0 + WithBody s rspths beg len -> responseFile2XX s (rspths,vt) path (Just (FilePart beg len (fileInfoSize finfo))) - responseFileXXX s0 hs0 path mpart = responseFile2XX s0 hs0 path mpart + responseFileXXX s0 hs0 path mpart = do + tbl <- toHeaderTable hs0 + responseFile2XX s0 tbl path mpart - responseFile2XX s hs path mpart + responseFile2XX s tbl path mpart | isHead = do logger req s Nothing - responseNoBody s hs + responseNoBody' s tbl | otherwise = do logger req s (filePartByteCount <$> mpart) setThreadContinue tconf True - let rspn = RspnFile s hs path mpart + let rspn = RspnFile s tbl path mpart out = ORspn strm rspn ii enqueueOutput outputQ out return ResponseReceived @@ -131,7 +139,8 @@ -- Since 'StreamingBody' is loop, we cannot control it. -- So, let's serialize 'Builder' with a designated queue. tbq <- newTBQueueIO 10 -- fixme: hard coding: 10 - let rspn = RspnStreaming s0 hs0 tbq + tbl <- toHeaderTable hs0 + let rspn = RspnStreaming s0 tbl tbq out = ORspn strm rspn ii enqueueOutput outputQ out let push b = do @@ -153,11 +162,11 @@ setThreadContinue tcont True ex <- E.try $ do T.pause th - inp@(Input strm req ii) <- atomically $ readTQueue inputQ + inp@(Input strm req reqvt ii) <- atomically $ readTQueue inputQ setStreamInfo sinfo inp T.resume th T.tickle th - app req $ responder ii tcont strm req + app req $ responder ii reqvt tcont strm req cont1 <- case ex of Right ResponseReceived -> return True Left e@(SomeException _) @@ -177,7 +186,7 @@ minp <- getStreamInfo sinfo case minp of Nothing -> return () - Just (Input strm req _ii) -> do + Just (Input strm req _reqvt _ii) -> do closed ctx strm Killed let frame = resetFrame InternalError (streamNumber strm) enqueueControl controlQ $ CFrame frame @@ -196,12 +205,15 @@ -- Otherwise, the worker get finished. newtype ThreadContinue = ThreadContinue (IORef Bool) +{-# INLINE newThreadContinue #-} newThreadContinue :: IO ThreadContinue newThreadContinue = ThreadContinue <$> newIORef True +{-# INLINE setThreadContinue #-} setThreadContinue :: ThreadContinue -> Bool -> IO () setThreadContinue (ThreadContinue ref) x = writeIORef ref x +{-# INLINE getThreadContinue #-} getThreadContinue :: ThreadContinue -> IO Bool getThreadContinue (ThreadContinue ref) = readIORef ref @@ -210,14 +222,18 @@ -- | The type to store enough information for 'settingsOnException'. newtype StreamInfo = StreamInfo (IORef (Maybe Input)) +{-# INLINE newStreamInfo #-} newStreamInfo :: IO StreamInfo newStreamInfo = StreamInfo <$> newIORef Nothing +{-# INLINE clearStreamInfo #-} clearStreamInfo :: StreamInfo -> IO () clearStreamInfo (StreamInfo ref) = writeIORef ref Nothing +{-# INLINE setStreamInfo #-} setStreamInfo :: StreamInfo -> Input -> IO () setStreamInfo (StreamInfo ref) inp = writeIORef ref $ Just inp +{-# INLINE getStreamInfo #-} getStreamInfo :: StreamInfo -> IO (Maybe Input) getStreamInfo (StreamInfo ref) = readIORef ref diff --git a/Network/Wai/Handler/Warp/HashMap.hs b/Network/Wai/Handler/Warp/HashMap.hs --- a/Network/Wai/Handler/Warp/HashMap.hs +++ b/Network/Wai/Handler/Warp/HashMap.hs @@ -6,6 +6,7 @@ import qualified Data.IntMap.Strict as I import Data.Map.Strict (Map) import qualified Data.Map.Strict as M +import Prelude hiding (lookup) type Hash = Int newtype HashMap k v = HashMap (IntMap (Map k v)) @@ -24,6 +25,8 @@ where m = M.singleton k v f = M.union -- fimxe +{-# SPECIALIZE insert :: Hash -> String -> v -> HashMap String v -> HashMap String v #-} lookup :: Ord k => Hash -> k -> HashMap k v -> Maybe v lookup h k (HashMap hm) = I.lookup h hm >>= M.lookup k +{-# SPECIALIZE lookup :: Hash -> String -> HashMap String v -> Maybe v #-} diff --git a/Network/Wai/Handler/Warp/PackInt.hs b/Network/Wai/Handler/Warp/PackInt.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Handler/Warp/PackInt.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE OverloadedStrings, BangPatterns #-} + +module Network.Wai.Handler.Warp.PackInt where + +import Control.Monad (when) +import Data.ByteString.Internal (ByteString(..), unsafeCreate) +import Data.Word8 (Word8) +import Foreign.Ptr (Ptr, plusPtr) +import Foreign.Storable (poke) +import qualified Network.HTTP.Types as H + +-- $setup +-- >>> import Data.ByteString.Char8 as B +-- >>> import Test.QuickCheck (Large(..)) + +-- | +-- +-- prop> packIntegral (abs n) == B.pack (show (abs n)) +-- prop> \(Large n) -> let n' = fromIntegral (abs n :: Int) in packIntegral n' == B.pack (show n') + +packIntegral :: Integral a => a -> ByteString +packIntegral 0 = "0" +packIntegral n | n < 0 = error "packIntegral" +packIntegral n = unsafeCreate len go0 + where + n' = fromIntegral n + 1 :: Double + len = ceiling $ logBase 10 n' + go0 p = go n $ p `plusPtr` (len - 1) + go :: Integral a => a -> Ptr Word8 -> IO () + go i p = do + let (d,r) = i `divMod` 10 + poke p (48 + fromIntegral r) + when (d /= 0) $ go d (p `plusPtr` (-1)) + +{-# SPECIALIZE packIntegral :: Int -> ByteString #-} +{-# SPECIALIZE packIntegral :: Integer -> ByteString #-} + +-- | +-- +-- >>> packStatus H.status200 +-- "200" +-- >>> packStatus H.preconditionFailed412 +-- "412" + +packStatus :: H.Status -> ByteString +packStatus 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 = fromIntegral $ H.statusCode status + (!q0,!r0) = s `divMod` 10 + (!q1,!r1) = q0 `divMod` 10 + !r2 = q1 `mod` 10 diff --git a/warp.cabal b/warp.cabal --- a/warp.cabal +++ b/warp.cabal @@ -1,5 +1,5 @@ Name: warp -Version: 3.2.5 +Version: 3.2.6 Synopsis: A fast, light-weight web server for WAI applications. License: MIT License-file: LICENSE @@ -44,7 +44,7 @@ , ghc-prim , http-types >= 0.8.5 , iproute >= 1.3.1 - , http2 >= 1.5 && < 1.6 + , http2 >= 1.6 && < 1.7 , simple-sendfile >= 0.2.7 && < 0.3 , unix-compat >= 0.2 , wai >= 3.2 && < 3.3 @@ -72,6 +72,7 @@ Network.Wai.Handler.Warp.HashMap Network.Wai.Handler.Warp.HTTP2 Network.Wai.Handler.Warp.HTTP2.EncodeFrame + Network.Wai.Handler.Warp.HTTP2.File Network.Wai.Handler.Warp.HTTP2.HPACK Network.Wai.Handler.Warp.HTTP2.Manager Network.Wai.Handler.Warp.HTTP2.Receiver @@ -82,6 +83,7 @@ Network.Wai.Handler.Warp.Header Network.Wai.Handler.Warp.IO Network.Wai.Handler.Warp.IORef + Network.Wai.Handler.Warp.PackInt Network.Wai.Handler.Warp.ReadInt Network.Wai.Handler.Warp.Recv Network.Wai.Handler.Warp.Request @@ -167,7 +169,7 @@ , directory , process , containers - , http2 >= 1.5 && < 1.6 + , http2 >= 1.6 && < 1.7 , word8 , hashable , http-date