warp 3.3.13 → 3.3.14
raw patch · 8 files changed
+347/−292 lines, 8 filesdep ~base
Dependency ranges changed: base
Files
- ChangeLog.md +8/−0
- Network/Wai/Handler/Warp/HTTP1.hs +220/−0
- Network/Wai/Handler/Warp/HTTP2.hs +53/−19
- Network/Wai/Handler/Warp/Request.hs +42/−23
- Network/Wai/Handler/Warp/Run.hs +6/−245
- Network/Wai/Handler/Warp/Settings.hs +2/−2
- test/RequestSpec.hs +12/−1
- warp.cabal +4/−2
ChangeLog.md view
@@ -1,3 +1,11 @@+## 3.3.14++* Drop support for GHC < 8.2.+* Fix header length calculation for `settingsMaxTotalHeaderLength`+ [#838](https://github.com/yesodweb/wai/pull/838)+* UTF-8 encoding in `exceptionResponseForDebug`.+ [#836](https://github.com/yesodweb/wai/pull/836)+ ## 3.3.13 * pReadMaker is exported from the Internal module.
+ Network/Wai/Handler/Warp/HTTP1.hs view
@@ -0,0 +1,220 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Network.Wai.Handler.Warp.HTTP1 (+ http1+ ) where++import "iproute" Data.IP (toHostAddress, toHostAddress6)+import qualified Control.Concurrent as Conc (yield)+import Control.Exception as E+import qualified Data.ByteString as BS+import Data.Char (chr)+import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import Network.Socket (SockAddr(SockAddrInet, SockAddrInet6))+import Network.Wai+import Network.Wai.Internal (ResponseReceived (ResponseReceived))+import qualified System.TimeManager as T++import Network.Wai.Handler.Warp.Header+import Network.Wai.Handler.Warp.Imports hiding (readInt)+import Network.Wai.Handler.Warp.ReadInt+import Network.Wai.Handler.Warp.Request+import Network.Wai.Handler.Warp.Response+import Network.Wai.Handler.Warp.Settings+import Network.Wai.Handler.Warp.Types++http1 :: Settings -> InternalInfo -> Connection -> Transport -> Application -> SockAddr -> T.Handle -> ByteString -> IO ()+http1 settings ii conn transport app origAddr th bs0 = do+ istatus <- newIORef True+ src <- mkSource (wrappedRecv conn istatus (settingsSlowlorisSize settings))+ leftoverSource src bs0+ addr <- getProxyProtocolAddr src+ http1server settings ii conn transport app addr th istatus src+ where+ wrappedRecv Connection { connRecv = recv } istatus slowlorisSize = do+ bs <- recv+ unless (BS.null bs) $ do+ writeIORef istatus True+ when (BS.length bs >= slowlorisSize) $ T.tickle th+ return bs++ getProxyProtocolAddr src =+ case settingsProxyProtocol settings of+ ProxyProtocolNone ->+ return origAddr+ ProxyProtocolRequired -> do+ seg <- readSource src+ parseProxyProtocolHeader src seg+ ProxyProtocolOptional -> do+ seg <- readSource src+ if BS.isPrefixOf "PROXY " seg+ then parseProxyProtocolHeader src seg+ else do leftoverSource src seg+ return origAddr++ parseProxyProtocolHeader src seg = do+ let (header,seg') = BS.break (== 0x0d) seg -- 0x0d == CR+ maybeAddr = case BS.split 0x20 header of -- 0x20 == space+ ["PROXY","TCP4",clientAddr,_,clientPort,_] ->+ case [x | (x, t) <- reads (decodeAscii clientAddr), null t] of+ [a] -> Just (SockAddrInet (readInt clientPort)+ (toHostAddress a))+ _ -> Nothing+ ["PROXY","TCP6",clientAddr,_,clientPort,_] ->+ case [x | (x, t) <- reads (decodeAscii clientAddr), null t] of+ [a] -> Just (SockAddrInet6 (readInt clientPort)+ 0+ (toHostAddress6 a)+ 0)+ _ -> Nothing+ ("PROXY":"UNKNOWN":_) ->+ Just origAddr+ _ ->+ Nothing+ case maybeAddr of+ Nothing -> throwIO (BadProxyHeader (decodeAscii header))+ Just a -> do leftoverSource src (BS.drop 2 seg') -- drop CRLF+ return a++ decodeAscii = map (chr . fromEnum) . BS.unpack++http1server :: Settings -> InternalInfo -> Connection -> Transport -> Application -> SockAddr -> T.Handle -> IORef Bool -> Source -> IO ()+http1server settings ii conn transport app addr th istatus src =+ loop True `E.catch` handler+ where+ handler e+ -- See comment below referencing+ -- https://github.com/yesodweb/wai/issues/618+ | Just NoKeepAliveRequest <- fromException e = return ()+ -- No valid request+ | Just (BadFirstLine _) <- fromException e = return ()+ | otherwise = do+ _ <- sendErrorResponse settings ii conn th istatus defaultRequest { remoteHost = addr } e+ throwIO e++ loop firstRequest = do+ (req, mremainingRef, idxhdr, nextBodyFlush) <- recvRequest firstRequest settings conn ii th addr src transport+ keepAlive <- processRequest settings ii conn app th istatus src req mremainingRef idxhdr nextBodyFlush+ `E.catch` \e -> do+ settingsOnException settings (Just req) e+ -- Don't throw the error again to prevent calling settingsOnException twice.+ return False++ -- When doing a keep-alive connection, the other side may just+ -- close the connection. We don't want to treat that as an+ -- exceptional situation, so we pass in False to http1 (which+ -- in turn passes in False to recvRequest), indicating that+ -- this is not the first request. If, when trying to read the+ -- request headers, no data is available, recvRequest will+ -- throw a NoKeepAliveRequest exception, which we catch here+ -- and ignore. See: https://github.com/yesodweb/wai/issues/618++ when keepAlive $ loop False++processRequest :: Settings -> InternalInfo -> Connection -> Application -> T.Handle -> IORef Bool -> Source -> Request -> Maybe (IORef Int) -> IndexedHeader -> IO ByteString -> IO Bool+processRequest settings ii conn app th istatus src req mremainingRef idxhdr nextBodyFlush = do+ -- Let the application run for as long as it wants+ T.pause th++ -- In the event that some scarce resource was acquired during+ -- creating the request, we need to make sure that we don't get+ -- an async exception before calling the ResponseSource.+ keepAliveRef <- newIORef $ error "keepAliveRef not filled"+ r <- E.try $ app req $ \res -> do+ T.resume th+ -- FIXME consider forcing evaluation of the res here to+ -- send more meaningful error messages to the user.+ -- However, it may affect performance.+ writeIORef istatus False+ keepAlive <- sendResponse settings conn ii th req idxhdr (readSource src) res+ writeIORef keepAliveRef keepAlive+ return ResponseReceived+ case r of+ Right ResponseReceived -> return ()+ Left e@(SomeException _)+ | Just (ExceptionInsideResponseBody e') <- fromException e -> throwIO e'+ | otherwise -> do+ keepAlive <- sendErrorResponse settings ii conn th istatus req e+ settingsOnException settings (Just req) e+ writeIORef keepAliveRef keepAlive++ keepAlive <- readIORef keepAliveRef++ -- We just send a Response and it takes a time to+ -- receive a Request again. If we immediately call recv,+ -- it is likely to fail and cause the IO manager to do some work.+ -- It is very costly, so we yield to another Haskell+ -- thread hoping that the next Request will arrive+ -- when this Haskell thread will be re-scheduled.+ -- This improves performance at least when+ -- the number of cores is small.+ Conc.yield++ if keepAlive+ then+ -- If there is an unknown or large amount of data to still be read+ -- from the request body, simple drop this connection instead of+ -- reading it all in to satisfy a keep-alive request.+ case settingsMaximumBodyFlush settings of+ Nothing -> do+ flushEntireBody nextBodyFlush+ T.resume th+ return True+ Just maxToRead -> do+ let tryKeepAlive = do+ -- flush the rest of the request body+ isComplete <- flushBody nextBodyFlush maxToRead+ if isComplete then do+ T.resume th+ return True+ else+ return False+ case mremainingRef of+ Just ref -> do+ remaining <- readIORef ref+ if remaining <= maxToRead then+ tryKeepAlive+ else+ return False+ Nothing -> tryKeepAlive+ else+ return False++sendErrorResponse :: Settings -> InternalInfo -> Connection -> T.Handle -> IORef Bool -> Request -> SomeException -> IO Bool+sendErrorResponse settings ii conn th istatus req e = do+ status <- readIORef istatus+ if shouldSendErrorResponse e && status then+ sendResponse settings conn ii th req defaultIndexRequestHeader (return BS.empty) errorResponse+ else+ return False+ where+ shouldSendErrorResponse se+ | Just ConnectionClosedByPeer <- fromException se = False+ | otherwise = True+ errorResponse = settingsOnExceptionResponse settings e++flushEntireBody :: IO ByteString -> IO ()+flushEntireBody src =+ loop+ where+ loop = do+ bs <- src+ unless (BS.null bs) loop++flushBody :: IO ByteString -- ^ get next chunk+ -> Int -- ^ maximum to flush+ -> IO Bool -- ^ True == flushed the entire body, False == we didn't+flushBody src = loop+ where+ loop toRead = do+ bs <- src+ let toRead' = toRead - BS.length bs+ case () of+ ()+ | BS.null bs -> return True+ | toRead' >= 0 -> loop toRead'+ | otherwise -> return False
Network/Wai/Handler/Warp/HTTP2.hs view
@@ -9,8 +9,11 @@ , http2server ) where -import qualified Data.IORef as I import qualified Control.Exception as E+import qualified Data.ByteString as BS+import Data.IORef (IORef, newIORef, writeIORef)+import qualified Data.IORef as I+import qualified Network.HTTP2 as H2 import qualified Network.HTTP2.Server as H2 import Network.Socket (SockAddr) import Network.Wai@@ -24,28 +27,38 @@ import Network.Wai.Handler.Warp.Imports import qualified Network.Wai.Handler.Warp.Settings as S import Network.Wai.Handler.Warp.Types+import Network.Wai.Handler.Warp.Recv ---------------------------------------------------------------- -http2 :: S.Settings- -> InternalInfo- -> Connection- -> Transport- -> SockAddr- -> (BufSize -> IO ByteString)- -> (ByteString -> IO ())- -> Application- -> IO ()-http2 settings ii conn transport addr readN send app =- H2.run conf $ http2server settings ii transport addr app+http2 :: S.Settings -> InternalInfo -> Connection -> Transport -> Application -> SockAddr -> T.Handle -> ByteString -> IO ()+http2 settings ii conn transport app origAddr th bs = do+ istatus <- newIORef False+ rawRecvN <- makeReceiveN bs (connRecv conn) (connRecvBuf conn)+ -- This thread becomes the sender in http2 library.+ -- In the case of event source, one request comes and one+ -- worker gets busy. But it is likely that the receiver does+ -- not receive any data at all while the sender is sending+ -- output data from the worker. It's not good enough to tickle+ -- the time handler in the receiver only. So, we should tickle+ -- the time handler in both the receiver and the sender.+ let recvN = wrappedRecvN th istatus (S.settingsSlowlorisSize settings) rawRecvN+ sendBS x = connSendAll conn x >> T.tickle th+ conf = H2.Config {+ confWriteBuffer = connWriteBuffer conn+ , confBufferSize = connBufferSize conn+ , confSendAll = sendBS+ , confReadN = recvN+ , confPositionReadMaker = pReadMaker ii+ }+ checkTLS+ setConnHTTP2 conn True+ H2.run conf $ http2server settings ii transport origAddr app where- conf = H2.Config {- confWriteBuffer = connWriteBuffer conn- , confBufferSize = connBufferSize conn- , confSendAll = send- , confReadN = readN- , confPositionReadMaker = pReadMaker ii- }+ checkTLS = case transport of+ TCP -> return () -- direct+ tls -> unless (tls12orLater tls) $ goaway conn H2.InadequateSecurity "Weak TLS"+ tls12orLater tls = tlsMajorVersion tls == 3 && tlsMinorVersion tls >= 3 -- | Converting WAI application to the server type of http2 library. --@@ -102,3 +115,24 @@ !siz = case H2.responseBodySize $ H2.promiseResponse pp of Nothing -> 0 Just s -> fromIntegral s++wrappedRecvN :: T.Handle -> IORef Bool -> Int -> (BufSize -> IO ByteString) -> (BufSize -> IO ByteString)+wrappedRecvN th istatus slowlorisSize readN bufsize = do+ bs <- readN bufsize+ unless (BS.null bs) $ do+ writeIORef istatus True+ -- TODO: think about the slowloris protection in HTTP2: current code+ -- might open a slow-loris attack vector. Rather than timing we should+ -- consider limiting the per-client connections assuming that in HTTP2+ -- we should allow only few connections per host (real-world+ -- deployments with large NATs may be trickier).+ when (BS.length bs >= slowlorisSize || bufsize <= slowlorisSize) $ T.tickle th+ return bs++-- connClose must not be called here since Run:fork calls it+goaway :: Connection -> H2.ErrorCodeId -> ByteString -> IO ()+goaway Connection{..} etype debugmsg = connSendAll bytestream+ where+ einfo = H2.encodeInfo id 0+ frame = H2.GoAwayFrame 0 etype debugmsg+ bytestream = H2.encodeFrame einfo frame
Network/Wai/Handler/Warp/Request.hs view
@@ -110,7 +110,7 @@ -- lack of data as a real exception. See the http1 function in -- the Run module for more details. then if firstRequest then throwIO ConnectionClosedByPeer else throwIO NoKeepAliveRequest- else push maxTotalHeaderLength src (THStatus 0 id id) bs+ else push maxTotalHeaderLength src (THStatus 0 0 id id) bs data NoKeepAliveRequest = NoKeepAliveRequest deriving (Show, Typeable)@@ -209,7 +209,8 @@ type BSEndoList = [ByteString] -> [ByteString] data THStatus = THStatus- {-# UNPACK #-} !Int -- running total byte count+ !Int -- running total byte count (excluding current header chunk)+ !Int -- current header chunk byte count BSEndoList -- previously parsed lines BSEndo -- bytestrings to be prepended @@ -221,29 +222,41 @@ -} push :: Int -> Source -> THStatus -> ByteString -> IO [ByteString]-push maxTotalHeaderLength src (THStatus len lines prepend) bs'+push maxTotalHeaderLength src (THStatus totalLen chunkLen lines prepend) bs' -- Too many bytes- | len > maxTotalHeaderLength = throwIO OverLargeHeader- | otherwise = push' mnl+ | currentTotal > maxTotalHeaderLength = throwIO OverLargeHeader+ | otherwise = push' mNL where+ currentTotal = totalLen + chunkLen+ -- bs: current header chunk, plus maybe (parts of) next header bs = prepend bs' bsLen = S.length bs- mnl = do- nl <- S.elemIndex 10 bs+ -- Maybe newline+ -- Returns: Maybe+ -- ( length of this chunk up to newline+ -- , position of newline in relation to entire current header+ -- , is this part of a multiline header+ -- )+ mNL = do+ -- 10 is the code point for newline (\n)+ chunkNL <- S.elemIndex 10 bs'+ let headerNL = chunkNL + S.length (prepend "")+ chunkNLlen = chunkNL + 1 -- check if there are two more bytes in the bs -- if so, see if the second of those is a horizontal space- if bsLen > nl + 1 then- let c = S.index bs (nl + 1)- b = case nl of+ if bsLen > headerNL + 1 then+ let c = S.index bs (headerNL + 1)+ b = case headerNL of 0 -> True 1 -> S.index bs 0 == 13 _ -> False- in Just (nl, not b && (c == 32 || c == 9))+ isMultiline = not b && (c == 32 || c == 9)+ in Just (chunkNLlen, headerNL, isMultiline) else- Just (nl, False)+ Just (chunkNLlen, headerNL, False) {-# INLINE push' #-}- push' :: Maybe (Int, Bool) -> IO [ByteString]+ push' :: Maybe (Int, Int, Bool) -> IO [ByteString] -- No newline find in this chunk. Add it to the prepend, -- update the length, and continue processing. push' Nothing = do@@ -251,26 +264,32 @@ when (S.null bst) $ throwIO IncompleteHeaders push maxTotalHeaderLength src status bst where- len' = len + bsLen prepend' = S.append bs- status = THStatus len' lines prepend'+ thisChunkLen = S.length bs'+ newChunkLen = chunkLen + thisChunkLen+ status = THStatus totalLen newChunkLen lines prepend' -- Found a newline, but next line continues as a multiline header- push' (Just (end, True)) = push maxTotalHeaderLength src status rest+ push' (Just (chunkNLlen, end, True)) =+ push maxTotalHeaderLength src status rest where rest = S.drop (end + 1) bs prepend' = S.append (SU.unsafeTake (checkCR bs end) bs)- len' = len + end- status = THStatus len' lines prepend'+ -- If we'd just update the entire current chunk up to newline+ -- we wouldn't count all the dropped newlines in between.+ -- So update 'chunkLen' with current chunk up to newline+ -- and use 'chunkLen' later on to add to 'totalLen'.+ newChunkLen = chunkLen + chunkNLlen+ status = THStatus totalLen newChunkLen lines prepend' -- Found a newline at position end.- push' (Just (end, False))+ push' (Just (chunkNLlen, end, False)) -- leftover | S.null line = do when (start < bsLen) $ leftoverSource src (SU.unsafeDrop start bs) return (lines []) -- more headers- | otherwise = let len' = len + start- lines' = lines . (line:)- status = THStatus len' lines' id+ | otherwise = let lines' = lines . (line:)+ newTotalLength = totalLen + chunkLen + chunkNLlen+ status = THStatus newTotalLength 0 lines' id in if start < bsLen then -- more bytes in this chunk, push again let bs'' = SU.unsafeDrop start bs@@ -286,7 +305,7 @@ {-# INLINE checkCR #-} checkCR :: ByteString -> Int -> Int-checkCR bs pos = if pos > 0 && 13 == S.index bs p then p else pos -- 13 is CR+checkCR bs pos = if pos > 0 && 13 == S.index bs p then p else pos -- 13 is CR (\r) where !p = pos - 1
Network/Wai/Handler/Warp/Run.hs view
@@ -1,34 +1,25 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PackageImports #-}-{-# LANGUAGE PatternGuards #-}-{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-}-{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} module Network.Wai.Handler.Warp.Run where -import "iproute" Data.IP (toHostAddress, toHostAddress6) import Control.Arrow (first)-import qualified Control.Concurrent as Conc (yield) import Control.Exception as E import qualified Data.ByteString as S-import Data.Char (chr)-import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import Data.IORef (newIORef, readIORef) import Data.Streaming.Network (bindPortTCP) import Foreign.C.Error (Errno(..), eCONNABORTED) import GHC.IO.Exception (IOException(..), IOErrorType(..))-import qualified Network.HTTP2 as H2-import Network.Socket (Socket, close, accept, withSocketsDo, SockAddr(SockAddrInet, SockAddrInet6), setSocketOption, SocketOption(..))+import Network.Socket (Socket, close, accept, withSocketsDo, SockAddr, setSocketOption, SocketOption(..)) #if MIN_VERSION_network(3,1,1) import Network.Socket (gracefulClose) #endif import qualified Network.Socket.ByteString as Sock import Network.Wai-import Network.Wai.Internal (ResponseReceived (ResponseReceived)) import System.Environment (lookupEnv) import System.IO.Error (ioeGetErrorType) import qualified System.TimeManager as T@@ -39,14 +30,11 @@ import qualified Network.Wai.Handler.Warp.Date as D import qualified Network.Wai.Handler.Warp.FdCache as F import qualified Network.Wai.Handler.Warp.FileInfoCache as I+import Network.Wai.Handler.Warp.HTTP1 (http1) import Network.Wai.Handler.Warp.HTTP2 (http2) import Network.Wai.Handler.Warp.HTTP2.Types (isHTTP2)-import Network.Wai.Handler.Warp.Header import Network.Wai.Handler.Warp.Imports hiding (readInt)-import Network.Wai.Handler.Warp.ReadInt import Network.Wai.Handler.Warp.Recv-import Network.Wai.Handler.Warp.Request-import Network.Wai.Handler.Warp.Response import Network.Wai.Handler.Warp.SendFile import Network.Wai.Handler.Warp.Settings import Network.Wai.Handler.Warp.Types@@ -248,7 +236,7 @@ -- ensure that no async exception is throw between the call to -- acceptNewConnection and the registering of connClose. --- -- acceptLoop can be broken by closing the listing socket.+ -- acceptLoop can be broken by closing the listening socket. void $ mask_ acceptLoop -- In some cases, we want to stop Warp here without graceful shutdown. -- So, async exceptions are allowed here.@@ -351,237 +339,10 @@ return (True, bs0) else return (False, bs0)- istatus <- newIORef False if settingsHTTP2Enabled settings && h2 then do- rawRecvN <- makeReceiveN bs (connRecv conn) (connRecvBuf conn)- -- This thread becomes the sender in http2 library.- -- In the case of event source, one request comes and one- -- worker gets busy. But it is likely that the receiver does- -- not receive any data at all while the sender is sending- -- output data from the worker. It's not good enough to tickle- -- the time handler in the receiver only. So, we should tickle- -- the time handler in both the receiver and the sender.- let recvN = wrappedRecvN th istatus (settingsSlowlorisSize settings) rawRecvN- sendBS x = connSendAll conn x >> T.tickle th- -- fixme: origAddr- checkTLS- setConnHTTP2 conn True- http2 settings ii conn transport origAddr recvN sendBS app+ http2 settings ii conn transport app origAddr th bs else do- src <- mkSource (wrappedRecv conn th istatus (settingsSlowlorisSize settings))- writeIORef istatus True- leftoverSource src bs- addr <- getProxyProtocolAddr src- http1 True addr istatus src `E.catch` \e ->- case () of- ()- -- See comment below referencing- -- https://github.com/yesodweb/wai/issues/618- | Just NoKeepAliveRequest <- fromException e -> return ()- -- No valid request- | Just (BadFirstLine _) <- fromException e -> return ()- | otherwise -> do- _ <- sendErrorResponse (dummyreq addr) istatus e- throwIO e-- where- getProxyProtocolAddr src =- case settingsProxyProtocol settings of- ProxyProtocolNone ->- return origAddr- ProxyProtocolRequired -> do- seg <- readSource src- parseProxyProtocolHeader src seg- ProxyProtocolOptional -> do- seg <- readSource src- if S.isPrefixOf "PROXY " seg- then parseProxyProtocolHeader src seg- else do leftoverSource src seg- return origAddr-- parseProxyProtocolHeader src seg = do- let (header,seg') = S.break (== 0x0d) seg -- 0x0d == CR- maybeAddr = case S.split 0x20 header of -- 0x20 == space- ["PROXY","TCP4",clientAddr,_,clientPort,_] ->- case [x | (x, t) <- reads (decodeAscii clientAddr), null t] of- [a] -> Just (SockAddrInet (readInt clientPort)- (toHostAddress a))- _ -> Nothing- ["PROXY","TCP6",clientAddr,_,clientPort,_] ->- case [x | (x, t) <- reads (decodeAscii clientAddr), null t] of- [a] -> Just (SockAddrInet6 (readInt clientPort)- 0- (toHostAddress6 a)- 0)- _ -> Nothing- ("PROXY":"UNKNOWN":_) ->- Just origAddr- _ ->- Nothing- case maybeAddr of- Nothing -> throwIO (BadProxyHeader (decodeAscii header))- Just a -> do leftoverSource src (S.drop 2 seg') -- drop CRLF- return a-- decodeAscii = map (chr . fromEnum) . S.unpack-- shouldSendErrorResponse se- | Just ConnectionClosedByPeer <- fromException se = False- | otherwise = True-- sendErrorResponse req istatus e = do- status <- readIORef istatus- if shouldSendErrorResponse e && status- then do- sendResponse settings conn ii th req defaultIndexRequestHeader (return S.empty) (errorResponse e)- else return False-- dummyreq addr = defaultRequest { remoteHost = addr }-- errorResponse e = settingsOnExceptionResponse settings e-- http1 firstRequest addr istatus src = do- (req, mremainingRef, idxhdr, nextBodyFlush) <- recvRequest firstRequest settings conn ii th addr src transport- keepAlive <- processRequest istatus src req mremainingRef idxhdr nextBodyFlush- `E.catch` \e -> do- settingsOnException settings (Just req) e- -- Don't throw the error again to prevent calling settingsOnException twice.- return False-- -- When doing a keep-alive connection, the other side may just- -- close the connection. We don't want to treat that as an- -- exceptional situation, so we pass in False to http1 (which- -- in turn passes in False to recvRequest), indicating that- -- this is not the first request. If, when trying to read the- -- request headers, no data is available, recvRequest will- -- throw a NoKeepAliveRequest exception, which we catch here- -- and ignore. See: https://github.com/yesodweb/wai/issues/618- when keepAlive $ http1 False addr istatus src-- processRequest istatus src req mremainingRef idxhdr nextBodyFlush = do- -- Let the application run for as long as it wants- T.pause th-- -- In the event that some scarce resource was acquired during- -- creating the request, we need to make sure that we don't get- -- an async exception before calling the ResponseSource.- keepAliveRef <- newIORef $ error "keepAliveRef not filled"- r <- E.try $ app req $ \res -> do- T.resume th- -- FIXME consider forcing evaluation of the res here to- -- send more meaningful error messages to the user.- -- However, it may affect performance.- writeIORef istatus False- keepAlive <- sendResponse settings conn ii th req idxhdr (readSource src) res- writeIORef keepAliveRef keepAlive- return ResponseReceived- case r of- Right ResponseReceived -> return ()- Left e@(SomeException _)- | Just (ExceptionInsideResponseBody e') <- fromException e -> throwIO e'- | otherwise -> do- keepAlive <- sendErrorResponse req istatus e- settingsOnException settings (Just req) e- writeIORef keepAliveRef keepAlive-- keepAlive <- readIORef keepAliveRef-- -- We just send a Response and it takes a time to- -- receive a Request again. If we immediately call recv,- -- it is likely to fail and cause the IO manager to do some work.- -- It is very costly, so we yield to another Haskell- -- thread hoping that the next Request will arrive- -- when this Haskell thread will be re-scheduled.- -- This improves performance at least when- -- the number of cores is small.- Conc.yield-- if keepAlive- then- -- If there is an unknown or large amount of data to still be read- -- from the request body, simple drop this connection instead of- -- reading it all in to satisfy a keep-alive request.- case settingsMaximumBodyFlush settings of- Nothing -> do- flushEntireBody nextBodyFlush- T.resume th- return True- Just maxToRead -> do- let tryKeepAlive = do- -- flush the rest of the request body- isComplete <- flushBody nextBodyFlush maxToRead- if isComplete then do- T.resume th- return True- else- return False- case mremainingRef of- Just ref -> do- remaining <- readIORef ref- if remaining <= maxToRead then- tryKeepAlive- else- return False- Nothing -> tryKeepAlive- else- return False-- checkTLS = case transport of- TCP -> return () -- direct- tls -> unless (tls12orLater tls) $ goaway conn H2.InadequateSecurity "Weak TLS"- tls12orLater tls = tlsMajorVersion tls == 3 && tlsMinorVersion tls >= 3---- connClose must not be called here since Run:fork calls it-goaway :: Connection -> H2.ErrorCodeId -> ByteString -> IO ()-goaway Connection{..} etype debugmsg = connSendAll bytestream- where- einfo = H2.encodeInfo id 0- frame = H2.GoAwayFrame 0 etype debugmsg- bytestream = H2.encodeFrame einfo frame--flushEntireBody :: IO ByteString -> IO ()-flushEntireBody src =- loop- where- loop = do- bs <- src- unless (S.null bs) loop--flushBody :: IO ByteString -- ^ get next chunk- -> Int -- ^ maximum to flush- -> IO Bool -- ^ True == flushed the entire body, False == we didn't-flushBody src =- loop- where- loop toRead = do- bs <- src- let toRead' = toRead - S.length bs- case () of- ()- | S.null bs -> return True- | toRead' >= 0 -> loop toRead'- | otherwise -> return False--wrappedRecv :: Connection -> T.Handle -> IORef Bool -> Int -> IO ByteString-wrappedRecv Connection { connRecv = recv } th istatus slowlorisSize = do- bs <- recv- unless (S.null bs) $ do- writeIORef istatus True- when (S.length bs >= slowlorisSize) $ T.tickle th- return bs--wrappedRecvN :: T.Handle -> IORef Bool -> Int -> (BufSize -> IO ByteString) -> (BufSize -> IO ByteString)-wrappedRecvN th istatus slowlorisSize readN bufsize = do- bs <- readN bufsize- unless (S.null bs) $ do- writeIORef istatus True- -- TODO: think about the slowloris protection in HTTP2: current code- -- might open a slow-loris attack vector. Rather than timing we should- -- consider limiting the per-client connections assuming that in HTTP2- -- we should allow only few connections per host (real-world- -- deployments with large NATs may be trickier).- when (S.length bs >= slowlorisSize || bufsize <= slowlorisSize) $ T.tickle th- return bs+ http1 settings ii conn transport app origAddr th bs -- | Set flag FileCloseOnExec flag on a socket (on Unix) --
Network/Wai/Handler/Warp/Settings.hs view
@@ -6,8 +6,8 @@ import Control.Concurrent (forkIOWithUnmask) import Control.Exception-import Data.ByteString.Builder (byteString) import qualified Data.ByteString.Char8 as C8+import qualified Data.ByteString.Builder as Builder import Data.ByteString.Lazy (fromStrict) import Data.Streaming.Network (HostPreference) import qualified Data.Text as T@@ -235,4 +235,4 @@ exceptionResponseForDebug e = responseBuilder H.internalServerError500 [(H.hContentType, "text/plain; charset=utf-8")]- $ byteString . C8.pack $ "Exception: " ++ show e+ $ "Exception: " <> Builder.stringUtf8 (show e)
test/RequestSpec.hs view
@@ -65,7 +65,7 @@ test "bytes=0-0,-1" $ Just [HH.ByteRangeFromTo 0 0, HH.ByteRangeSuffix 1] describe "headerLines" $ do- it "can handle a nomarl case" $ do+ it "can handle a normal case" $ do src <- mkSourceFunc ["Status: 200\r\nContent-Type: text/plain\r\n\r\n"] >>= mkSource x <- headerLines defaultMaxTotalHeaderLength True src x `shouldBe` ["Status: 200", "Content-Type: text/plain"]@@ -91,6 +91,17 @@ x `shouldBe` [] y <- headerLines defaultMaxTotalHeaderLength True src y `shouldBe` ["Status: 200", "Content-Type: text/plain"]++ -- Length is 39, this shouldn't fail+ let testLengthHeaders = ["Sta", "tus: 200\r", "\n", "Content-Type: ", "text/plain\r\n\r\n"]+ it "doesn't throw on correct length" $ do+ src <- mkSourceFunc testLengthHeaders >>= mkSource+ x <- headerLines 39 True src+ x `shouldBe` ["Status: 200", "Content-Type: text/plain"]+ -- Length is still 39, this should fail+ it "throws error on correct length too long" $ do+ src <- mkSourceFunc testLengthHeaders >>= mkSource+ headerLines 38 True src `shouldThrow` (== OverLargeHeader) where blankSafe = headerLinesList ["f", "oo\n", "bar\nbaz\n\r\n"]
warp.cabal view
@@ -1,5 +1,5 @@ Name: warp-Version: 3.3.13+Version: 3.3.14 Synopsis: A fast, light-weight web server for WAI applications. License: MIT License-file: LICENSE@@ -33,7 +33,7 @@ Default: False Library- Build-Depends: base >= 4.8 && < 5+ Build-Depends: base >= 4.10 && < 5 , array , async , auto-update >= 0.1.3 && < 0.2@@ -74,6 +74,7 @@ Network.Wai.Handler.Warp.File Network.Wai.Handler.Warp.FileInfoCache Network.Wai.Handler.Warp.HashMap+ Network.Wai.Handler.Warp.HTTP1 Network.Wai.Handler.Warp.HTTP2 Network.Wai.Handler.Warp.HTTP2.File Network.Wai.Handler.Warp.HTTP2.PushPromise@@ -150,6 +151,7 @@ Network.Wai.Handler.Warp.FdCache Network.Wai.Handler.Warp.File Network.Wai.Handler.Warp.FileInfoCache+ Network.Wai.Handler.Warp.HTTP1 Network.Wai.Handler.Warp.HTTP2 Network.Wai.Handler.Warp.HTTP2.File Network.Wai.Handler.Warp.HTTP2.PushPromise