Script 'mail_helper' called by obssrc Hello community, here is the log from the commit of package ghc-warp for openSUSE:Factory checked in at 2021-02-16 22:39:10 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-warp (Old) and /work/SRC/openSUSE:Factory/.ghc-warp.new.28504 (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-warp" Tue Feb 16 22:39:10 2021 rev:5 rq:870883 version:3.3.14 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-warp/ghc-warp.changes 2020-12-22 11:48:58.577984326 +0100 +++ /work/SRC/openSUSE:Factory/.ghc-warp.new.28504/ghc-warp.changes 2021-02-16 22:48:46.398572070 +0100 @@ -1,0 +2,12 @@ +Thu Feb 4 10:33:08 UTC 2021 - [email protected] + +- Update warp to version 3.3.14. + ## 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) + +------------------------------------------------------------------- Old: ---- warp-3.3.13.tar.gz New: ---- warp-3.3.14.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-warp.spec ++++++ --- /var/tmp/diff_new_pack.UgF18M/_old 2021-02-16 22:48:47.278572758 +0100 +++ /var/tmp/diff_new_pack.UgF18M/_new 2021-02-16 22:48:47.282572761 +0100 @@ -1,7 +1,7 @@ # # spec file for package ghc-warp # -# Copyright (c) 2020 SUSE LLC +# Copyright (c) 2021 SUSE LLC # # All modifications and additions to the file contributed by third parties # remain the property of their copyright owners, unless otherwise agreed @@ -19,7 +19,7 @@ %global pkg_name warp %bcond_with tests Name: ghc-%{pkg_name} -Version: 3.3.13 +Version: 3.3.14 Release: 0 Summary: A fast, light-weight web server for WAI applications License: MIT ++++++ warp-3.3.13.tar.gz -> warp-3.3.14.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/warp-3.3.13/ChangeLog.md new/warp-3.3.14/ChangeLog.md --- old/warp-3.3.13/ChangeLog.md 2020-06-25 04:08:37.000000000 +0200 +++ new/warp-3.3.14/ChangeLog.md 2021-02-04 01:28:05.000000000 +0100 @@ -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. diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/warp-3.3.13/Network/Wai/Handler/Warp/HTTP1.hs new/warp-3.3.14/Network/Wai/Handler/Warp/HTTP1.hs --- old/warp-3.3.13/Network/Wai/Handler/Warp/HTTP1.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/warp-3.3.14/Network/Wai/Handler/Warp/HTTP1.hs 2021-02-04 01:28:05.000000000 +0100 @@ -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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/warp-3.3.13/Network/Wai/Handler/Warp/HTTP2.hs new/warp-3.3.14/Network/Wai/Handler/Warp/HTTP2.hs --- old/warp-3.3.13/Network/Wai/Handler/Warp/HTTP2.hs 2020-06-25 04:08:37.000000000 +0200 +++ new/warp-3.3.14/Network/Wai/Handler/Warp/HTTP2.hs 2021-02-04 01:28:05.000000000 +0100 @@ -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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/warp-3.3.13/Network/Wai/Handler/Warp/Request.hs new/warp-3.3.14/Network/Wai/Handler/Warp/Request.hs --- old/warp-3.3.13/Network/Wai/Handler/Warp/Request.hs 2020-06-25 04:08:37.000000000 +0200 +++ new/warp-3.3.14/Network/Wai/Handler/Warp/Request.hs 2021-02-04 01:28:05.000000000 +0100 @@ -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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/warp-3.3.13/Network/Wai/Handler/Warp/Run.hs new/warp-3.3.14/Network/Wai/Handler/Warp/Run.hs --- old/warp-3.3.13/Network/Wai/Handler/Warp/Run.hs 2020-06-25 04:08:37.000000000 +0200 +++ new/warp-3.3.14/Network/Wai/Handler/Warp/Run.hs 2021-02-04 01:28:05.000000000 +0100 @@ -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) -- diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/warp-3.3.13/Network/Wai/Handler/Warp/Settings.hs new/warp-3.3.14/Network/Wai/Handler/Warp/Settings.hs --- old/warp-3.3.13/Network/Wai/Handler/Warp/Settings.hs 2020-06-25 04:08:37.000000000 +0200 +++ new/warp-3.3.14/Network/Wai/Handler/Warp/Settings.hs 2021-02-04 01:28:05.000000000 +0100 @@ -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) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/warp-3.3.13/test/RequestSpec.hs new/warp-3.3.14/test/RequestSpec.hs --- old/warp-3.3.13/test/RequestSpec.hs 2020-06-25 04:08:37.000000000 +0200 +++ new/warp-3.3.14/test/RequestSpec.hs 2021-02-04 01:28:05.000000000 +0100 @@ -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"] @@ -92,6 +92,17 @@ 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"] whiteSafe = headerLinesList ["foo\r\nbar\r\nbaz\r\n\r\n hi there"] diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/warp-3.3.13/warp.cabal new/warp-3.3.14/warp.cabal --- old/warp-3.3.13/warp.cabal 2020-06-25 04:08:37.000000000 +0200 +++ new/warp-3.3.14/warp.cabal 2021-02-04 01:28:05.000000000 +0100 @@ -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
