warp 3.2.5 → 3.2.6
raw patch · 12 files changed
+452/−245 lines, 12 filesdep ~http2
Dependency ranges changed: http2
Files
- ChangeLog.md +9/−0
- Network/Wai/Handler/Warp/File.hs +3/−26
- Network/Wai/Handler/Warp/HTTP2/File.hs +192/−0
- Network/Wai/Handler/Warp/HTTP2/HPACK.hs +58/−25
- Network/Wai/Handler/Warp/HTTP2/Receiver.hs +32/−29
- Network/Wai/Handler/Warp/HTTP2/Request.hs +31/−125
- Network/Wai/Handler/Warp/HTTP2/Sender.hs +16/−6
- Network/Wai/Handler/Warp/HTTP2/Types.hs +12/−12
- Network/Wai/Handler/Warp/HTTP2/Worker.hs +35/−19
- Network/Wai/Handler/Warp/HashMap.hs +3/−0
- Network/Wai/Handler/Warp/PackInt.hs +56/−0
- warp.cabal +5/−3
ChangeLog.md view
@@ -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
Network/Wai/Handler/Warp/File.hs view
@@ -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)) -- | --
+ Network/Wai/Handler/Warp/HTTP2/File.hs view
@@ -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
Network/Wai/Handler/Warp/HTTP2/HPACK.hs view
@@ -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
Network/Wai/Handler/Warp/HTTP2/Receiver.hs view
@@ -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
Network/Wai/Handler/Warp/HTTP2/Request.hs view
@@ -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
Network/Wai/Handler/Warp/HTTP2/Sender.hs view
@@ -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
Network/Wai/Handler/Warp/HTTP2/Types.hs view
@@ -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
Network/Wai/Handler/Warp/HTTP2/Worker.hs view
@@ -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
Network/Wai/Handler/Warp/HashMap.hs view
@@ -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 #-}
+ Network/Wai/Handler/Warp/PackInt.hs view
@@ -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
warp.cabal view
@@ -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