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 2022-10-13 15:44:19 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-warp (Old) and /work/SRC/openSUSE:Factory/.ghc-warp.new.2275 (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-warp" Thu Oct 13 15:44:19 2022 rev:12 rq:1009719 version:3.3.23 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-warp/ghc-warp.changes 2022-08-10 17:14:41.797926715 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-warp.new.2275/ghc-warp.changes 2022-10-13 15:44:56.603065671 +0200 @@ -1,0 +2,24 @@ +Wed Sep 28 00:40:33 UTC 2022 - Peter Simons <[email protected]> + +- Update warp to version 3.3.23. + ## 3.3.23 + + * Add `setAccept` for hooking the socket `accept` call. + [#912](https://github.com/yesodweb/wai/pull/912) + * Removed some package dependencies from test suite + [#902](https://github.com/yesodweb/wai/pull/902) + * Factored out `Network.Wai.Handler.Warp.Recv` to its own package `recv`. + [#899](https://github.com/yesodweb/wai/pull/899) + +------------------------------------------------------------------- +Tue Aug 9 01:16:33 UTC 2022 - Peter Simons <[email protected]> + +- Update warp to version 3.3.22. + ## 3.3.22 + + * Creating a bigger buffer when the current one is too small to fit the Builder + [#895](https://github.com/yesodweb/wai/pull/895) + * Using InvalidRequest instead of HTTP2Error + [#890](https://github.com/yesodweb/wai/pull/890) + +------------------------------------------------------------------- Old: ---- warp-3.3.21.tar.gz New: ---- warp-3.3.23.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-warp.spec ++++++ --- /var/tmp/diff_new_pack.xwNMmk/_old 2022-10-13 15:44:57.315067061 +0200 +++ /var/tmp/diff_new_pack.xwNMmk/_new 2022-10-13 15:44:57.319067069 +0200 @@ -19,7 +19,7 @@ %global pkg_name warp %bcond_with tests Name: ghc-%{pkg_name} -Version: 3.3.21 +Version: 3.3.23 Release: 0 Summary: A fast, light-weight web server for WAI applications License: MIT @@ -38,6 +38,7 @@ BuildRequires: ghc-http2-devel BuildRequires: ghc-iproute-devel BuildRequires: ghc-network-devel +BuildRequires: ghc-recv-devel BuildRequires: ghc-rpm-macros BuildRequires: ghc-simple-sendfile-devel BuildRequires: ghc-stm-devel @@ -53,14 +54,11 @@ BuildRequires: ghc-x509-devel ExcludeArch: %{ix86} %if %{with tests} -BuildRequires: ghc-HUnit-devel BuildRequires: ghc-QuickCheck-devel -BuildRequires: ghc-async-devel BuildRequires: ghc-directory-devel BuildRequires: ghc-hspec-devel BuildRequires: ghc-http-client-devel BuildRequires: ghc-process-devel -BuildRequires: ghc-time-devel %endif %description ++++++ warp-3.3.21.tar.gz -> warp-3.3.23.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/warp-3.3.21/ChangeLog.md new/warp-3.3.23/ChangeLog.md --- old/warp-3.3.21/ChangeLog.md 2001-09-09 03:46:40.000000000 +0200 +++ new/warp-3.3.23/ChangeLog.md 2001-09-09 03:46:40.000000000 +0200 @@ -1,5 +1,21 @@ # ChangeLog for warp +## 3.3.23 + +* Add `setAccept` for hooking the socket `accept` call. + [#912](https://github.com/yesodweb/wai/pull/912) +* Removed some package dependencies from test suite + [#902](https://github.com/yesodweb/wai/pull/902) +* Factored out `Network.Wai.Handler.Warp.Recv` to its own package `recv`. + [#899](https://github.com/yesodweb/wai/pull/899) + +## 3.3.22 + +* Creating a bigger buffer when the current one is too small to fit the Builder + [#895](https://github.com/yesodweb/wai/pull/895) +* Using InvalidRequest instead of HTTP2Error + [#890](https://github.com/yesodweb/wai/pull/890) + ## 3.3.21 * Support GHC 9.4 [#889](https://github.com/yesodweb/wai/pull/889) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/warp-3.3.21/Network/Wai/Handler/Warp/Buffer.hs new/warp-3.3.23/Network/Wai/Handler/Warp/Buffer.hs --- old/warp-3.3.21/Network/Wai/Handler/Warp/Buffer.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/warp-3.3.23/Network/Wai/Handler/Warp/Buffer.hs 2001-09-09 03:46:40.000000000 +0200 @@ -1,37 +1,38 @@ {-# LANGUAGE BangPatterns #-} module Network.Wai.Handler.Warp.Buffer ( - bufferSize + createWriteBuffer , allocateBuffer , freeBuffer - , mallocBS - , newBufferPool - , withBufferPool , toBuilderBuffer - , copy , bufferIO ) where -import qualified Data.ByteString as BS -import Data.ByteString.Internal (memcpy) -import Data.ByteString.Unsafe (unsafeTake, unsafeDrop) -import Data.IORef (newIORef, readIORef, writeIORef) +import Data.IORef (IORef, readIORef) import qualified Data.Streaming.ByteString.Builder.Buffer as B (Buffer (..)) import Foreign.ForeignPtr -import Foreign.Marshal.Alloc (mallocBytes, free, finalizerFree) -import Foreign.Ptr (castPtr, plusPtr) +import Foreign.Marshal.Alloc (mallocBytes, free) +import Foreign.Ptr (plusPtr) +import Network.Socket.BufferPool import Network.Wai.Handler.Warp.Imports import Network.Wai.Handler.Warp.Types ---------------------------------------------------------------- --- | The default size of the write buffer: 16384 (2^14 = 1024 * 16). --- This is the maximum size of TLS record. --- This is also the maximum size of HTTP/2 frame payload --- (excluding frame header). -bufferSize :: BufSize -bufferSize = 16384 +-- | Allocate a buffer of the given size and wrap it in a 'WriteBuffer' +-- containing that size and a finalizer. +createWriteBuffer :: BufSize -> IO WriteBuffer +createWriteBuffer size = do + bytes <- allocateBuffer size + return + WriteBuffer + { bufBuffer = bytes, + bufSize = size, + bufFree = freeBuffer bytes + } + +---------------------------------------------------------------- -- | Allocating a buffer with malloc(). allocateBuffer :: Int -> IO Buffer @@ -42,67 +43,18 @@ freeBuffer = free ---------------------------------------------------------------- - -largeBufferSize :: Int -largeBufferSize = 16384 - -minBufferSize :: Int -minBufferSize = 2048 - -newBufferPool :: IO BufferPool -newBufferPool = newIORef BS.empty - -mallocBS :: Int -> IO ByteString -mallocBS size = do - ptr <- allocateBuffer size - fptr <- newForeignPtr finalizerFree ptr - return $! PS fptr 0 size -{-# INLINE mallocBS #-} - -usefulBuffer :: ByteString -> Bool -usefulBuffer buffer = BS.length buffer >= minBufferSize -{-# INLINE usefulBuffer #-} - -getBuffer :: BufferPool -> IO ByteString -getBuffer pool = do - buffer <- readIORef pool - if usefulBuffer buffer then return buffer else mallocBS largeBufferSize -{-# INLINE getBuffer #-} - -putBuffer :: BufferPool -> ByteString -> IO () -putBuffer pool buffer = writeIORef pool buffer -{-# INLINE putBuffer #-} - -withForeignBuffer :: ByteString -> ((Buffer, BufSize) -> IO Int) -> IO Int -withForeignBuffer (PS ps s l) f = withForeignPtr ps $ \p -> f (castPtr p `plusPtr` s, l) -{-# INLINE withForeignBuffer #-} - -withBufferPool :: BufferPool -> ((Buffer, BufSize) -> IO Int) -> IO ByteString -withBufferPool pool f = do - buffer <- getBuffer pool - consumed <- withForeignBuffer buffer f - putBuffer pool $! unsafeDrop consumed buffer - return $! unsafeTake consumed buffer -{-# INLINE withBufferPool #-} - ----------------------------------------------------------------- -- -- Utilities -- -toBuilderBuffer :: Buffer -> BufSize -> IO B.Buffer -toBuilderBuffer ptr size = do +toBuilderBuffer :: IORef WriteBuffer -> IO B.Buffer +toBuilderBuffer writeBufferRef = do + writeBuffer <- readIORef writeBufferRef + let ptr = bufBuffer writeBuffer + size = bufSize writeBuffer fptr <- newForeignPtr_ ptr return $ B.Buffer fptr ptr ptr (ptr `plusPtr` size) --- | Copying the bytestring to the buffer. --- This function returns the point where the next copy should start. -copy :: Buffer -> ByteString -> IO Buffer -copy !ptr (PS fp o l) = withForeignPtr fp $ \p -> do - memcpy ptr (p `plusPtr` o) (fromIntegral l) - return $! ptr `plusPtr` l -{-# INLINE copy #-} - bufferIO :: Buffer -> Int -> (ByteString -> IO ()) -> IO () bufferIO ptr siz io = do fptr <- newForeignPtr_ ptr diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/warp-3.3.21/Network/Wai/Handler/Warp/HTTP2/Types.hs new/warp-3.3.23/Network/Wai/Handler/Warp/HTTP2/Types.hs --- old/warp-3.3.21/Network/Wai/Handler/Warp/HTTP2/Types.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/warp-3.3.23/Network/Wai/Handler/Warp/HTTP2/Types.hs 2001-09-09 03:46:40.000000000 +0200 @@ -1,12 +1,11 @@ -{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} module Network.Wai.Handler.Warp.HTTP2.Types where import qualified Data.ByteString as BS import qualified Network.HTTP.Types as H -import Network.HTTP2 +import Network.HTTP2.Frame import qualified Network.HTTP2.Server as H2 import Network.Wai.Handler.Warp.Imports diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/warp-3.3.21/Network/Wai/Handler/Warp/HTTP2.hs new/warp-3.3.23/Network/Wai/Handler/Warp/HTTP2.hs --- old/warp-3.3.21/Network/Wai/Handler/Warp/HTTP2.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/warp-3.3.23/Network/Wai/Handler/Warp/HTTP2.hs 2001-09-09 03:46:40.000000000 +0200 @@ -9,16 +9,17 @@ , http2server ) where -import qualified UnliftIO import qualified Data.ByteString as BS -import Data.IORef (IORef, newIORef, writeIORef) +import Data.IORef (IORef, newIORef, writeIORef, readIORef) import qualified Data.IORef as I import qualified Network.HTTP2.Frame as H2 import qualified Network.HTTP2.Server as H2 import Network.Socket (SockAddr) +import Network.Socket.BufferPool import Network.Wai import Network.Wai.Internal (ResponseReceived(..)) import qualified System.TimeManager as T +import qualified UnliftIO import Network.Wai.Handler.Warp.HTTP2.File import Network.Wai.Handler.Warp.HTTP2.PushPromise @@ -27,7 +28,6 @@ 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 ---------------------------------------------------------------- @@ -35,6 +35,7 @@ http2 settings ii conn transport app origAddr th bs = do istatus <- newIORef False rawRecvN <- makeReceiveN bs (connRecv conn) (connRecvBuf conn) + writeBuffer <- readIORef $ connWriteBuffer 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 @@ -45,8 +46,8 @@ 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 + confWriteBuffer = bufBuffer writeBuffer + , confBufferSize = bufSize writeBuffer , confSendAll = sendBS , confReadN = recvN , confPositionReadMaker = pReadMaker ii @@ -114,7 +115,7 @@ wrappedRecvN :: T.Handle -> IORef Bool -> Int -> (BufSize -> IO ByteString) -> (BufSize -> IO ByteString) wrappedRecvN th istatus slowlorisSize readN bufsize = do - bs <- readN bufsize + bs <- UnliftIO.handleAny handler $ readN bufsize unless (BS.null bs) $ do writeIORef istatus True -- TODO: think about the slowloris protection in HTTP2: current code @@ -124,6 +125,9 @@ -- deployments with large NATs may be trickier). when (BS.length bs >= slowlorisSize || bufsize <= slowlorisSize) $ T.tickle th return bs + where + handler :: UnliftIO.SomeException -> IO ByteString + handler _ = return "" -- connClose must not be called here since Run:fork calls it goaway :: Connection -> H2.ErrorCodeId -> ByteString -> IO () diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/warp-3.3.21/Network/Wai/Handler/Warp/IO.hs new/warp-3.3.23/Network/Wai/Handler/Warp/IO.hs --- old/warp-3.3.21/Network/Wai/Handler/Warp/IO.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/warp-3.3.23/Network/Wai/Handler/Warp/IO.hs 2001-09-09 03:46:40.000000000 +0200 @@ -3,28 +3,46 @@ module Network.Wai.Handler.Warp.IO where +import Control.Exception (mask_) import Data.ByteString.Builder (Builder) -import Data.ByteString.Builder.Extra (runBuilder, Next(Done, More, Chunk)) - +import Data.ByteString.Builder.Extra (Next (Chunk, Done, More), runBuilder) +import Data.IORef (IORef, readIORef, writeIORef) import Network.Wai.Handler.Warp.Buffer import Network.Wai.Handler.Warp.Imports import Network.Wai.Handler.Warp.Types -toBufIOWith :: Buffer -> BufSize -> (ByteString -> IO ()) -> Builder -> IO () -toBufIOWith buf !size io builder = loop firstWriter +toBufIOWith :: Int -> IORef WriteBuffer -> (ByteString -> IO ()) -> Builder -> IO () +toBufIOWith maxRspBufSize writeBufferRef io builder = do + writeBuffer <- readIORef writeBufferRef + loop writeBuffer firstWriter where firstWriter = runBuilder builder - runIO len = bufferIO buf len io - loop writer = do - (len, signal) <- writer buf size - case signal of - Done -> runIO len - More minSize next - | size < minSize -> error "toBufIOWith: BufferFull: minSize" - | otherwise -> do - runIO len - loop next - Chunk bs next -> do - runIO len - io bs - loop next + loop writeBuffer writer = do + let buf = bufBuffer writeBuffer + size = bufSize writeBuffer + (len, signal) <- writer buf size + bufferIO buf len io + case signal of + Done -> return () + More minSize next + | size < minSize -> do + when (minSize > maxRspBufSize) $ + error $ "Sending a Builder response required a buffer of size " + ++ show minSize ++ " which is bigger than the specified maximum of " + ++ show maxRspBufSize ++ "!" + -- The current WriteBuffer is too small to fit the next + -- batch of bytes from the Builder so we free it and + -- create a new bigger one. Freeing the current buffer, + -- creating a new one and writing it to the IORef need + -- to be performed atomically to prevent both double + -- frees and missed frees. So we mask async exceptions: + biggerWriteBuffer <- mask_ $ do + bufFree writeBuffer + biggerWriteBuffer <- createWriteBuffer minSize + writeIORef writeBufferRef biggerWriteBuffer + return biggerWriteBuffer + loop biggerWriteBuffer next + | otherwise -> loop writeBuffer next + Chunk bs next -> do + io bs + loop writeBuffer next diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/warp-3.3.21/Network/Wai/Handler/Warp/Imports.hs new/warp-3.3.23/Network/Wai/Handler/Warp/Imports.hs --- old/warp-3.3.21/Network/Wai/Handler/Warp/Imports.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/warp-3.3.23/Network/Wai/Handler/Warp/Imports.hs 2001-09-09 03:46:40.000000000 +0200 @@ -4,7 +4,6 @@ , module Control.Applicative , module Control.Monad , module Data.Bits - , module Data.List , module Data.Int , module Data.Monoid , module Data.Ord @@ -18,7 +17,6 @@ import Data.Bits import Data.ByteString.Internal (ByteString(..)) import Data.Int -import Data.List import Data.List.NonEmpty (NonEmpty(..)) import Data.Maybe import Data.Monoid diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/warp-3.3.21/Network/Wai/Handler/Warp/Internal.hs new/warp-3.3.23/Network/Wai/Handler/Warp/Internal.hs --- old/warp-3.3.21/Network/Wai/Handler/Warp/Internal.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/warp-3.3.23/Network/Wai/Handler/Warp/Internal.hs 2001-09-09 03:46:40.000000000 +0200 @@ -19,7 +19,8 @@ -- ** Buffer , Buffer , BufSize - , bufferSize + , WriteBuffer(..) + , createWriteBuffer , allocateBuffer , freeBuffer , copy @@ -73,6 +74,7 @@ , pReadMaker ) where +import Network.Socket.BufferPool import System.TimeManager import Network.Wai.Handler.Warp.Buffer @@ -82,7 +84,6 @@ import Network.Wai.Handler.Warp.HTTP2 import Network.Wai.Handler.Warp.HTTP2.File import Network.Wai.Handler.Warp.Header -import Network.Wai.Handler.Warp.Recv import Network.Wai.Handler.Warp.Request import Network.Wai.Handler.Warp.Response import Network.Wai.Handler.Warp.Run diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/warp-3.3.21/Network/Wai/Handler/Warp/Recv.hs new/warp-3.3.23/Network/Wai/Handler/Warp/Recv.hs --- old/warp-3.3.21/Network/Wai/Handler/Warp/Recv.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/warp-3.3.23/Network/Wai/Handler/Warp/Recv.hs 1970-01-01 01:00:00.000000000 +0100 @@ -1,160 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface, OverloadedStrings #-} -{-# LANGUAGE CPP #-} - -module Network.Wai.Handler.Warp.Recv ( - receive - , receiveBuf - , makeReceiveN - , makePlainReceiveN - , spell - ) where - -import qualified UnliftIO -import qualified Data.ByteString as BS -import Data.IORef -import Foreign.C.Error (eAGAIN, getErrno, throwErrno) -import Foreign.C.Types -import Foreign.ForeignPtr (withForeignPtr) -import Foreign.Ptr (Ptr, castPtr, plusPtr) -import GHC.Conc (threadWaitRead) -import qualified GHC.IO.Exception as E -import Network.Socket (Socket) -import qualified System.IO.Error as E -#if MIN_VERSION_network(3,1,0) -import Network.Socket (withFdSocket) -#else -import Network.Socket (fdSocket) -#endif -import System.Posix.Types (Fd(..)) - -import Network.Wai.Handler.Warp.Buffer -import Network.Wai.Handler.Warp.Imports -import Network.Wai.Handler.Warp.Types - -#ifdef mingw32_HOST_OS -import GHC.IO.FD (FD(..), readRawBufferPtr) -import Network.Wai.Handler.Warp.Windows -#endif - ----------------------------------------------------------------- - -makeReceiveN :: ByteString -> Recv -> RecvBuf -> IO (BufSize -> IO ByteString) -makeReceiveN bs0 recv recvBuf = do - ref <- newIORef bs0 - return $ receiveN ref recv recvBuf - --- | This function returns a receiving function --- based on two receiving functions. --- The returned function efficiently manages received data --- which is initialized by the first argument. --- The returned function may allocate a byte string with malloc(). -makePlainReceiveN :: Socket -> ByteString -> IO (BufSize -> IO ByteString) -makePlainReceiveN s bs0 = do - ref <- newIORef bs0 - pool <- newBufferPool - return $ receiveN ref (receive s pool) (receiveBuf s) - -receiveN :: IORef ByteString -> Recv -> RecvBuf -> BufSize -> IO ByteString -receiveN ref recv recvBuf size = UnliftIO.handleAny handler $ do - cached <- readIORef ref - (bs, leftover) <- spell cached size recv recvBuf - writeIORef ref leftover - return bs - where - handler :: UnliftIO.SomeException -> IO ByteString - handler _ = return "" - ----------------------------------------------------------------- - -spell :: ByteString -> BufSize -> IO ByteString -> RecvBuf -> IO (ByteString, ByteString) -spell init0 siz0 recv recvBuf - | siz0 <= len0 = return $ BS.splitAt siz0 init0 - -- fixme: hard coding 4096 - | siz0 <= 4096 = loop [init0] (siz0 - len0) - | otherwise = do - bs@(PS fptr _ _) <- mallocBS siz0 - withForeignPtr fptr $ \ptr -> do - ptr' <- copy ptr init0 - full <- recvBuf ptr' (siz0 - len0) - if full then - return (bs, "") - else - return ("", "") -- fixme - where - len0 = BS.length init0 - loop bss siz = do - bs <- recv - let len = BS.length bs - if len == 0 then - return ("", "") - else if len >= siz then do - let (consume, leftover) = BS.splitAt siz bs - ret = BS.concat $ reverse (consume : bss) - return (ret, leftover) - else do - let bss' = bs : bss - siz' = siz - len - loop bss' siz' - --- The timeout manager may close the socket. --- In that case, an error of "Bad file descriptor" occurs. --- We ignores it because we expect TimeoutThread. -receive :: Socket -> BufferPool -> Recv -receive sock pool = UnliftIO.handleIO handler $ withBufferPool pool $ \ (ptr, size) -> do -#if MIN_VERSION_network(3,1,0) - withFdSocket sock $ \fd -> do -#elif MIN_VERSION_network(3,0,0) - fd <- fdSocket sock -#else - let fd = fdSocket sock -#endif - let size' = fromIntegral size - fromIntegral <$> receiveloop fd ptr size' - where - handler :: UnliftIO.IOException -> IO ByteString - handler e - | E.ioeGetErrorType e == E.InvalidArgument = return "" - | otherwise = UnliftIO.throwIO e - -receiveBuf :: Socket -> RecvBuf -receiveBuf sock buf0 siz0 = do -#if MIN_VERSION_network(3,1,0) - withFdSocket sock $ \fd -> do -#elif MIN_VERSION_network(3,0,0) - fd <- fdSocket sock -#else - let fd = fdSocket sock -#endif - loop fd buf0 siz0 - where - loop _ _ 0 = return True - loop fd buf siz = do - n <- fromIntegral <$> receiveloop fd buf (fromIntegral siz) - -- fixme: what should we do in the case of n == 0 - if n == 0 then - return False - else - loop fd (buf `plusPtr` n) (siz - n) - -receiveloop :: CInt -> Ptr Word8 -> CSize -> IO CInt -receiveloop sock ptr size = do -#ifdef mingw32_HOST_OS - bytes <- windowsThreadBlockHack $ fromIntegral <$> readRawBufferPtr "recv" (FD sock 1) (castPtr ptr) 0 size -#else - bytes <- c_recv sock (castPtr ptr) size 0 -#endif - if bytes == -1 then do - errno <- getErrno - if errno == eAGAIN then do - threadWaitRead (Fd sock) - receiveloop sock ptr size - else - throwErrno "receiveloop" - else - return bytes - -#ifndef mingw32_HOST_OS --- fixme: the type of the return value -foreign import ccall unsafe "recv" - c_recv :: CInt -> Ptr CChar -> CSize -> CInt -> IO CInt -#endif diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/warp-3.3.21/Network/Wai/Handler/Warp/Request.hs new/warp-3.3.23/Network/Wai/Handler/Warp/Request.hs --- old/warp-3.3.21/Network/Wai/Handler/Warp/Request.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/warp-3.3.23/Network/Wai/Handler/Warp/Request.hs 2001-09-09 03:46:40.000000000 +0200 @@ -39,7 +39,7 @@ import Network.Wai.Handler.Warp.Conduit import Network.Wai.Handler.Warp.FileInfoCache import Network.Wai.Handler.Warp.Header -import Network.Wai.Handler.Warp.Imports hiding (readInt, lines) +import Network.Wai.Handler.Warp.Imports hiding (readInt) import Network.Wai.Handler.Warp.ReadInt import Network.Wai.Handler.Warp.RequestHeader import Network.Wai.Handler.Warp.Settings (Settings, settingsNoParsePath, settingsMaxTotalHeaderLength) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/warp-3.3.21/Network/Wai/Handler/Warp/Response.hs new/warp-3.3.23/Network/Wai/Handler/Warp/Response.hs --- old/warp-3.3.21/Network/Wai/Handler/Warp/Response.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/warp-3.3.23/Network/Wai/Handler/Warp/Response.hs 2001-09-09 03:46:40.000000000 +0200 @@ -23,6 +23,7 @@ import qualified Data.ByteString.Char8 as C8 import qualified Data.CaseInsensitive as CI import Data.Function (on) +import Data.List (deleteBy) import Data.Streaming.ByteString.Builder (newByteStringBuilderRecv, reuseBufferStrategy) import Data.Version (showVersion) import Data.Word8 (_cr, _lf) @@ -117,20 +118,21 @@ -- and status, the response to HEAD is processed here. -- -- See definition of rsp below for proper body stripping. - (ms, mlen) <- sendRsp conn ii th ver s hs rspidxhdr rsp + (ms, mlen) <- sendRsp conn ii th ver s hs rspidxhdr maxRspBufSize rsp case ms of Nothing -> return () Just realStatus -> logger req realStatus mlen T.tickle th return ret else do - _ <- sendRsp conn ii th ver s hs rspidxhdr RspNoBody + _ <- sendRsp conn ii th ver s hs rspidxhdr maxRspBufSize RspNoBody logger req s Nothing T.tickle th return isPersist where defServer = settingsServerName settings logger = settingsLogger settings + maxRspBufSize = settingsMaxBuilderResponseBufferSize settings ver = httpVersion req s = responseStatus response hs0 = sanitizeHeaders $ responseHeaders response @@ -199,12 +201,13 @@ -> H.Status -> H.ResponseHeaders -> IndexedHeader -- Response + -> Int -- maxBuilderResponseBufferSize -> Rsp -> IO (Maybe H.Status, Maybe Integer) ---------------------------------------------------------------- -sendRsp conn _ _ ver s hs _ RspNoBody = do +sendRsp conn _ _ ver s hs _ _ RspNoBody = do -- Not adding Content-Length. -- User agents treats it as Content-Length: 0. composeHeader ver s hs >>= connSendAll conn @@ -212,23 +215,22 @@ ---------------------------------------------------------------- -sendRsp conn _ th ver s hs _ (RspBuilder body needsChunked) = do +sendRsp conn _ th ver s hs _ maxRspBufSize (RspBuilder body needsChunked) = do header <- composeHeaderBuilder ver s hs needsChunked let hdrBdy | needsChunked = header <> chunkedTransferEncoding body <> chunkedTransferTerminator | otherwise = header <> body - buffer = connWriteBuffer conn - size = connBufferSize conn - toBufIOWith buffer size (\bs -> connSendAll conn bs >> T.tickle th) hdrBdy + writeBufferRef = connWriteBuffer conn + toBufIOWith maxRspBufSize writeBufferRef (\bs -> connSendAll conn bs >> T.tickle th) hdrBdy return (Just s, Nothing) -- fixme: can we tell the actual sent bytes? ---------------------------------------------------------------- -sendRsp conn _ th ver s hs _ (RspStream streamingBody needsChunked) = do +sendRsp conn _ th ver s hs _ _ (RspStream streamingBody needsChunked) = do header <- composeHeaderBuilder ver s hs needsChunked (recv, finish) <- newByteStringBuilderRecv $ reuseBufferStrategy - $ toBuilderBuffer (connWriteBuffer conn) (connBufferSize conn) + $ toBuilderBuffer $ connWriteBuffer conn let send builder = do popper <- recv builder let loop = do @@ -249,7 +251,7 @@ ---------------------------------------------------------------- -sendRsp conn _ th _ _ _ _ (RspRaw withApp src) = do +sendRsp conn _ th _ _ _ _ _ (RspRaw withApp src) = do withApp recv send return (Nothing, Nothing) where @@ -263,8 +265,8 @@ -- Sophisticated WAI applications. -- We respect s0. s0 MUST be a proper value. -sendRsp conn ii th ver s0 hs0 rspidxhdr (RspFile path (Just part) _ isHead hook) = - sendRspFile2XX conn ii th ver s0 hs rspidxhdr path beg len isHead hook +sendRsp conn ii th ver s0 hs0 rspidxhdr maxRspBufSize (RspFile path (Just part) _ isHead hook) = + sendRspFile2XX conn ii th ver s0 hs rspidxhdr maxRspBufSize path beg len isHead hook where beg = filePartOffset part len = filePartByteCount part @@ -274,17 +276,17 @@ -- Simple WAI applications. -- Status is ignored -sendRsp conn ii th ver _ hs0 rspidxhdr (RspFile path Nothing reqidxhdr isHead hook) = do +sendRsp conn ii th ver _ hs0 rspidxhdr maxRspBufSize (RspFile path Nothing reqidxhdr isHead hook) = do efinfo <- UnliftIO.tryIO $ getFileInfo ii path case efinfo of Left (_ex :: UnliftIO.IOException) -> #ifdef WARP_DEBUG print _ex >> #endif - sendRspFile404 conn ii th ver hs0 rspidxhdr + sendRspFile404 conn ii th ver hs0 rspidxhdr maxRspBufSize Right finfo -> case conditionalRequest finfo hs0 rspidxhdr reqidxhdr of - WithoutBody s -> sendRsp conn ii th ver s hs0 rspidxhdr RspNoBody - WithBody s hs beg len -> sendRspFile2XX conn ii th ver s hs rspidxhdr path beg len isHead hook + WithoutBody s -> sendRsp conn ii th ver s hs0 rspidxhdr maxRspBufSize RspNoBody + WithBody s hs beg len -> sendRspFile2XX conn ii th ver s hs rspidxhdr maxRspBufSize path beg len isHead hook ---------------------------------------------------------------- @@ -295,14 +297,15 @@ -> H.Status -> H.ResponseHeaders -> IndexedHeader + -> Int -> FilePath -> Integer -> Integer -> Bool -> IO () -> IO (Maybe H.Status, Maybe Integer) -sendRspFile2XX conn ii th ver s hs rspidxhdr path beg len isHead hook - | isHead = sendRsp conn ii th ver s hs rspidxhdr RspNoBody +sendRspFile2XX conn ii th ver s hs rspidxhdr maxRspBufSize path beg len isHead hook + | isHead = sendRsp conn ii th ver s hs rspidxhdr maxRspBufSize RspNoBody | otherwise = do lheader <- composeHeader ver s hs (mfd, fresher) <- getFd ii path @@ -317,8 +320,9 @@ -> H.HttpVersion -> H.ResponseHeaders -> IndexedHeader + -> Int -> IO (Maybe H.Status, Maybe Integer) -sendRspFile404 conn ii th ver hs0 rspidxhdr = sendRsp conn ii th ver s hs rspidxhdr (RspBuilder body True) +sendRspFile404 conn ii th ver hs0 rspidxhdr maxRspBufSize = sendRsp conn ii th ver s hs rspidxhdr maxRspBufSize (RspBuilder body True) where s = H.notFound404 hs = replaceHeader H.hContentType "text/plain; charset=utf-8" hs0 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/warp-3.3.21/Network/Wai/Handler/Warp/ResponseHeader.hs new/warp-3.3.23/Network/Wai/Handler/Warp/ResponseHeader.hs --- old/warp-3.3.21/Network/Wai/Handler/Warp/ResponseHeader.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/warp-3.3.23/Network/Wai/Handler/Warp/ResponseHeader.hs 2001-09-09 03:46:40.000000000 +0200 @@ -6,11 +6,12 @@ import qualified Data.ByteString as S import Data.ByteString.Internal (create) import qualified Data.CaseInsensitive as CI +import Data.List (foldl') import Foreign.Ptr import GHC.Storable import qualified Network.HTTP.Types as H +import Network.Socket.BufferPool (copy) -import Network.Wai.Handler.Warp.Buffer (copy) import Network.Wai.Handler.Warp.Imports ---------------------------------------------------------------- diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/warp-3.3.21/Network/Wai/Handler/Warp/Run.hs new/warp-3.3.23/Network/Wai/Handler/Warp/Run.hs --- old/warp-3.3.21/Network/Wai/Handler/Warp/Run.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/warp-3.3.23/Network/Wai/Handler/Warp/Run.hs 2001-09-09 03:46:40.000000000 +0200 @@ -8,25 +8,26 @@ module Network.Wai.Handler.Warp.Run where import Control.Arrow (first) -import Control.Exception (allowInterrupt) import qualified Control.Exception -import qualified UnliftIO -import UnliftIO (toException) +import Control.Exception (allowInterrupt) import qualified Data.ByteString as S import Data.IORef (newIORef, readIORef) import Data.Streaming.Network (bindPortTCP) import Foreign.C.Error (Errno(..), eCONNABORTED, eMFILE) import GHC.IO.Exception (IOException(..), IOErrorType(..)) -import Network.Socket (Socket, close, accept, withSocketsDo, SockAddr, setSocketOption, SocketOption(..)) +import Network.Socket (Socket, close, withSocketsDo, SockAddr, setSocketOption, SocketOption(..)) #if MIN_VERSION_network(3,1,1) import Network.Socket (gracefulClose) #endif +import Network.Socket.BufferPool import qualified Network.Socket.ByteString as Sock import Network.Wai import System.Environment (lookupEnv) import System.IO.Error (ioeGetErrorType) import qualified System.TimeManager as T import System.Timeout (timeout) +import qualified UnliftIO +import UnliftIO (toException) import Network.Wai.Handler.Warp.Buffer import Network.Wai.Handler.Warp.Counter @@ -37,7 +38,6 @@ import Network.Wai.Handler.Warp.HTTP2 (http2) import Network.Wai.Handler.Warp.HTTP2.Types (isHTTP2) import Network.Wai.Handler.Warp.Imports hiding (readInt) -import Network.Wai.Handler.Warp.Recv import Network.Wai.Handler.Warp.SendFile import Network.Wai.Handler.Warp.Settings import Network.Wai.Handler.Warp.Types @@ -56,14 +56,14 @@ #else socketConnection _ s = do #endif - bufferPool <- newBufferPool - writeBuf <- allocateBuffer bufferSize - let sendall = sendAll' s + bufferPool <- newBufferPool 2048 16384 + writeBuffer <- createWriteBuffer 16384 + writeBufferRef <- newIORef writeBuffer isH2 <- newIORef False -- HTTP/1.x return Connection { connSendMany = Sock.sendMany s , connSendAll = sendall - , connSendFile = sendFile s writeBuf bufferSize sendall + , connSendFile = sendfile writeBufferRef #if MIN_VERSION_network(3,1,1) , connClose = do h2 <- readIORef isH2 @@ -76,14 +76,26 @@ #else , connClose = close s #endif - , connFree = freeBuffer writeBuf - , connRecv = receive s bufferPool + , connRecv = receive' s bufferPool , connRecvBuf = receiveBuf s - , connWriteBuffer = writeBuf - , connBufferSize = bufferSize + , connWriteBuffer = writeBufferRef , connHTTP2 = isH2 } where + receive' sock pool = UnliftIO.handleIO handler $ receive sock pool + where + handler :: UnliftIO.IOException -> IO ByteString + handler e + | ioeGetErrorType e == InvalidArgument = return "" + | otherwise = UnliftIO.throwIO e + + sendfile writeBufferRef fid offset len hook headers = do + writeBuffer <- readIORef writeBufferRef + sendFile s (bufBuffer writeBuffer) (bufSize writeBuffer) sendall + fid offset len hook headers + + sendall = sendAll' s + sendAll' sock bs = UnliftIO.handleJust (\ e -> if ioeGetErrorType e == ResourceVanished then Just ConnectionClosedByPeer @@ -137,16 +149,12 @@ -- Note that the 'settingsPort' will still be passed to 'Application's via the -- 'serverPort' record. runSettingsSocket :: Settings -> Socket -> Application -> IO () -runSettingsSocket set socket app = do +runSettingsSocket set@Settings{settingsAccept = accept'} socket app = do settingsInstallShutdownHandler set closeListenSocket runSettingsConnection set getConn app where getConn = do -#if WINDOWS - (s, sa) <- windowsThreadBlockHack $ accept socket -#else - (s, sa) <- accept socket -#endif + (s, sa) <- accept' socket setSocketCloseOnExec s -- NoDelay causes an error for AF_UNIX. setSocketOption s NoDelay 1 `UnliftIO.catchAny` \(UnliftIO.SomeException _) -> return () @@ -309,7 +317,9 @@ -- fact that async exceptions are still masked. UnliftIO.bracket mkConn cleanUp (serve unmask) where - cleanUp (conn, _) = connClose conn `UnliftIO.finally` connFree conn + cleanUp (conn, _) = connClose conn `UnliftIO.finally` do + writeBuffer <- readIORef $ connWriteBuffer conn + bufFree writeBuffer -- We need to register a timeout handler for this thread, and -- cancel that handler as soon as we exit. diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/warp-3.3.21/Network/Wai/Handler/Warp/SendFile.hs new/warp-3.3.23/Network/Wai/Handler/Warp/SendFile.hs --- old/warp-3.3.21/Network/Wai/Handler/Warp/SendFile.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/warp-3.3.23/Network/Wai/Handler/Warp/SendFile.hs 2001-09-09 03:46:40.000000000 +0200 @@ -11,6 +11,7 @@ import qualified Data.ByteString as BS import Network.Socket (Socket) +import Network.Socket.BufferPool #ifdef WINDOWS import Foreign.ForeignPtr (newForeignPtr_) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/warp-3.3.21/Network/Wai/Handler/Warp/Settings.hs new/warp-3.3.23/Network/Wai/Handler/Warp/Settings.hs --- old/warp-3.3.21/Network/Wai/Handler/Warp/Settings.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/warp-3.3.23/Network/Wai/Handler/Warp/Settings.hs 2001-09-09 03:46:40.000000000 +0200 @@ -10,15 +10,13 @@ import UnliftIO (SomeException, fromException) 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 import qualified Data.Text.IO as TIO import Data.Version (showVersion) import GHC.IO.Exception (IOErrorType(..), AsyncException (ThreadKilled)) import qualified Network.HTTP.Types as H -import Network.HTTP2.Frame (HTTP2Error (..), ErrorCodeId (..)) -import Network.Socket (SockAddr) +import Network.Socket (Socket, SockAddr, accept) import Network.Wai import qualified Paths_warp import System.IO (stderr) @@ -27,6 +25,7 @@ import Network.Wai.Handler.Warp.Imports import Network.Wai.Handler.Warp.Types +import Network.Wai.Handler.Warp.Windows (windowsThreadBlockHack) -- | Various Warp server settings. This is purposely kept as an abstract data -- type so that new settings can be added without breaking backwards @@ -69,6 +68,16 @@ -- -- Since 3.0.4 + , settingsAccept :: Socket -> IO (Socket, SockAddr) + -- ^ Code to accept a new connection. + -- + -- Useful if you need to provide connected sockets from something other + -- than a standard accept call. + -- + -- Default: 'defaultAccept' + -- + -- Since 3.3.24 + , settingsNoParsePath :: Bool -- ^ Perform no parsing on the rawPathInfo. -- @@ -140,6 +149,20 @@ -- Default: Nothing -- -- Since 3.3.11 + , settingsMaxBuilderResponseBufferSize :: Int + -- ^ Determines the maxium buffer size when sending `Builder` responses + -- (See `responseBuilder`). + -- + -- When sending a builder response warp uses a 16 KiB buffer to write the + -- builder to. When that buffer is too small to fit the builder warp will + -- free it and create a new one that will fit the builder. + -- + -- To protect against allocating too large a buffer warp will error if the + -- builder requires more than this maximum. + -- + -- Default: 1049_000_000 = 1 MiB. + -- + -- Since 3.3.22 } -- | Specify usage of the PROXY protocol. @@ -166,6 +189,7 @@ , settingsFileInfoCacheDuration = 0 , settingsBeforeMainLoop = return () , settingsFork = defaultFork + , settingsAccept = defaultAccept , settingsNoParsePath = False , settingsInstallShutdownHandler = const $ return () , settingsServerName = C8.pack $ "Warp/" ++ showVersion Paths_warp.version @@ -180,6 +204,7 @@ , settingsGracefulCloseTimeout2 = 2000 , settingsMaxTotalHeaderLength = 50 * 1024 , settingsAltSvc = Nothing + , settingsMaxBuilderResponseBufferSize = 1049000000 } -- | Apply the logic provided by 'defaultOnException' to determine if an @@ -213,18 +238,18 @@ -- Since 3.2.27 defaultOnExceptionResponse :: SomeException -> Response defaultOnExceptionResponse e + | Just PayloadTooLarge <- + fromException e = responseLBS H.status413 + [(H.hContentType, "text/plain; charset=utf-8")] + "Payload too large" + | Just RequestHeaderFieldsTooLarge <- + fromException e = responseLBS H.status431 + [(H.hContentType, "text/plain; charset=utf-8")] + "Request header fields too large" | Just (_ :: InvalidRequest) <- fromException e = responseLBS H.badRequest400 [(H.hContentType, "text/plain; charset=utf-8")] "Bad Request" - | Just (ConnectionError (UnknownErrorCode 413) t) <- - fromException e = responseLBS H.status413 - [(H.hContentType, "text/plain; charset=utf-8")] - (fromStrict t) - | Just (ConnectionError (UnknownErrorCode 431) t) <- - fromException e = responseLBS H.status431 - [(H.hContentType, "text/plain; charset=utf-8")] - (fromStrict t) | otherwise = responseLBS H.internalServerError500 [(H.hContentType, "text/plain; charset=utf-8")] "Something went wrong" @@ -262,3 +287,14 @@ (# s1, _tid #) -> (# s1, () #) #endif + +-- | Standard "accept" call for a listening socket. +-- +-- @since 3.3.24 +defaultAccept :: Socket -> IO (Socket, SockAddr) +defaultAccept = +#if WINDOWS + windowsThreadBlockHack . accept +#else + accept +#endif diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/warp-3.3.21/Network/Wai/Handler/Warp/Types.hs new/warp-3.3.23/Network/Wai/Handler/Warp/Types.hs --- old/warp-3.3.21/Network/Wai/Handler/Warp/Types.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/warp-3.3.23/Network/Wai/Handler/Warp/Types.hs 2001-09-09 03:46:40.000000000 +0200 @@ -11,7 +11,7 @@ #ifdef MIN_VERSION_x509 import Data.X509 #endif -import Foreign.Ptr (Ptr) +import Network.Socket.BufferPool import System.Posix.Types (Fd) import qualified System.TimeManager as T @@ -40,6 +40,8 @@ | ConnectionClosedByPeer | OverLargeHeader | BadProxyHeader String + | PayloadTooLarge -- ^ Since 3.3.22 + | RequestHeaderFieldsTooLarge -- ^ Since 3.3.22 deriving (Eq, Typeable) instance Show InvalidRequest where @@ -50,6 +52,8 @@ show ConnectionClosedByPeer = "Warp: Client closed connection prematurely" show OverLargeHeader = "Warp: Request headers too large, possible memory attack detected. Closing connection." show (BadProxyHeader s) = "Warp: Invalid PROXY protocol header: " ++ show s + show RequestHeaderFieldsTooLarge = "Request header fields too large" + show PayloadTooLarge = "Payload too large" instance UnliftIO.Exception InvalidRequest @@ -84,21 +88,16 @@ -- Since: 3.1.0 type SendFile = FileId -> Integer -> Integer -> IO () -> [ByteString] -> IO () --- | Type for read buffer pool -type BufferPool = IORef ByteString - --- | Type for buffer -type Buffer = Ptr Word8 - --- | Type for buffer size -type BufSize = Int - --- | Type for the action to receive input data -type Recv = IO ByteString - --- | Type for the action to receive input data with a buffer. --- The result boolean indicates whether or not the buffer is fully filled. -type RecvBuf = Buffer -> BufSize -> IO Bool +-- | A write buffer of a specified size +-- containing bytes and a way to free the buffer. +data WriteBuffer = WriteBuffer { + bufBuffer :: Buffer + -- | The size of the write buffer. + , bufSize :: !BufSize + -- | Free the allocated buffer. Warp guarantees it will only be + -- called once, and no other functions will be called after it. + , bufFree :: IO () + } -- | Data type to manipulate IO actions for connections. -- This is used to abstract IO actions for plain HTTP and HTTP over TLS. @@ -113,18 +112,16 @@ -- called once. Other functions (like 'connRecv') may be called after -- 'connClose' is called. , connClose :: IO () - -- | Free any buffers allocated. Warp guarantees it will only be - -- called once, and no other functions will be called after it. - , connFree :: IO () - -- | The connection receiving function. This returns "" for EOF. + -- | The connection receiving function. This returns "" for EOF or exceptions. , connRecv :: Recv -- | The connection receiving function. This tries to fill the buffer. -- This returns when the buffer is filled or reaches EOF. , connRecvBuf :: RecvBuf - -- | The write buffer. - , connWriteBuffer :: Buffer - -- | The size of the write buffer. - , connBufferSize :: BufSize + -- | Reference to a write buffer. When during sending of a 'Builder' + -- response it's detected the current 'WriteBuffer' is too small it will be + -- freed and a new bigger buffer will be created and written to this + -- reference. + , connWriteBuffer :: IORef WriteBuffer -- | Is this connection HTTP/2? , connHTTP2 :: IORef Bool } diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/warp-3.3.21/Network/Wai/Handler/Warp.hs new/warp-3.3.23/Network/Wai/Handler/Warp.hs --- old/warp-3.3.21/Network/Wai/Handler/Warp.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/warp-3.3.23/Network/Wai/Handler/Warp.hs 2001-09-09 03:46:40.000000000 +0200 @@ -64,6 +64,7 @@ , setServerName , setMaximumBodyFlush , setFork + , setAccept , setProxyProtocolNone , setProxyProtocolRequired , setProxyProtocolOptional @@ -76,6 +77,7 @@ , setGracefulCloseTimeout2 , setMaxTotalHeaderLength , setAltSvc + , setMaxBuilderResponseBufferSize -- ** Getters , getPort , getHost @@ -134,7 +136,7 @@ import Data.X509 #endif import qualified Network.HTTP.Types as H -import Network.Socket (SockAddr) +import Network.Socket (Socket, SockAddr) import Network.Wai (Request, Response, vault) import System.TimeManager @@ -369,6 +371,17 @@ setFork :: (((forall a. IO a -> IO a) -> IO ()) -> IO ()) -> Settings -> Settings setFork fork' s = s { settingsFork = fork' } +-- | Code to accept a new connection. +-- +-- Useful if you need to provide connected sockets from something other +-- than a standard accept call. +-- +-- Default: 'defaultAccept' +-- +-- Since 3.3.24 +setAccept :: (Socket -> IO (Socket, SockAddr)) -> Settings -> Settings +setAccept accept' s = s { settingsAccept = accept' } + -- | Do not use the PROXY protocol. -- -- Since 3.0.5 @@ -462,6 +475,12 @@ setAltSvc :: ByteString -> Settings -> Settings setAltSvc altsvc settings = settings { settingsAltSvc = Just altsvc } +-- | Set the maximum buffer size for sending `Builder` responses. +-- +-- Since 3.3.22 +setMaxBuilderResponseBufferSize :: Int -> Settings -> Settings +setMaxBuilderResponseBufferSize maxRspBufSize settings = settings { settingsMaxBuilderResponseBufferSize = maxRspBufSize } + -- | Explicitly pause the slowloris timeout. -- -- This is useful for cases where you partially consume a request body. For diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/warp-3.3.21/test/BufferPoolSpec.hs new/warp-3.3.23/test/BufferPoolSpec.hs --- old/warp-3.3.21/test/BufferPoolSpec.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/warp-3.3.23/test/BufferPoolSpec.hs 1970-01-01 01:00:00.000000000 +0100 @@ -1,47 +0,0 @@ -module BufferPoolSpec where - -import qualified Data.ByteString as B -import qualified Data.ByteString.Internal as B (ByteString(PS)) -import Foreign.ForeignPtr (withForeignPtr) -import Foreign.Marshal.Utils (copyBytes) -import Foreign.Ptr (plusPtr) - -import Test.Hspec (Spec, hspec, shouldBe, describe, it) - -import Network.Wai.Handler.Warp.Buffer - ( bufferSize - , newBufferPool - , withBufferPool - ) -import Network.Wai.Handler.Warp.Types (Buffer, BufSize) - -main :: IO () -main = hspec spec - --- Two ByteStrings each big enough to fill a 'bufferSize' buffer (16K). -wantData, otherData :: B.ByteString -wantData = B.replicate bufferSize 0xac -otherData = B.replicate bufferSize 0x77 - -spec :: Spec -spec = describe "withBufferPool" $ do - it "does not clobber buffers" $ do - pool <- newBufferPool - -- 'pool' contains B.empty; prime it to contain a real buffer. - _ <- withBufferPool pool $ const $ return 0 - -- 'pool' contains a 16K buffer; fill it with \xac and keep the result. - got <- withBufferPool pool $ blitBuffer wantData - got `shouldBe` wantData - -- 'pool' should now be empty and reallocate, rather than clobber the - -- previous buffer. - _ <- withBufferPool pool $ blitBuffer otherData - got `shouldBe` wantData - --- Fill the Buffer with the contents of the ByteString and return the number of --- bytes written. To be used with 'withBufferPool'. -blitBuffer :: B.ByteString -> (Buffer, BufSize) -> IO Int -blitBuffer (B.PS fp off len) (dst, len') = withForeignPtr fp $ \ptr -> do - let src = ptr `plusPtr` off - n = min len len' - copyBytes dst src n - return n diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/warp-3.3.21/test/RunSpec.hs new/warp-3.3.23/test/RunSpec.hs --- old/warp-3.3.21/test/RunSpec.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/warp-3.3.23/test/RunSpec.hs 2001-09-09 03:46:40.000000000 +0200 @@ -41,7 +41,7 @@ } msWrite :: MySocket -> ByteString -> IO () -msWrite ms bs = sendAll (msSocket ms) bs +msWrite = sendAll . msSocket msRead :: MySocket -> Int -> IO ByteString msRead (MySocket s ref) expected = do @@ -83,9 +83,9 @@ incr :: MonadIO m => Counter -> m () incr icount = liftIO $ I.atomicModifyIORef icount $ \ecount -> - ((case ecount of + (case ecount of Left s -> Left s - Right i -> Right $ i + 1), ()) + Right i -> Right $ i + 1, ()) err :: (MonadIO m, Show a) => Counter -> a -> m () err icount msg = liftIO $ I.writeIORef icount $ Left $ show msg @@ -99,14 +99,14 @@ -> err icount ("Invalid hello" :: String, body) | requestMethod req == "GET" && L.fromChunks body /= "" -> err icount ("Invalid GET" :: String, body) - | not $ requestMethod req `elem` ["GET", "POST"] + | requestMethod req `notElem` ["GET", "POST"] -> err icount ("Invalid request method (readBody)" :: String, requestMethod req) | otherwise -> incr icount f $ responseLBS status200 [] "Read the body" ignoreBody :: CounterApplication ignoreBody icount req f = do - if (requestMethod req `elem` ["GET", "POST"]) + if requestMethod req `elem` ["GET", "POST"] then incr icount else err icount ("Invalid request method" :: String, requestMethod req) f $ responseLBS status200 [] "Ignored the body" @@ -177,7 +177,7 @@ withApp (setOnException onExc defaultSettings) dummyApp $ withMySocket $ \ms -> do msWrite ms input msClose ms -- explicitly - threadDelay 1000 + threadDelay 5000 res <- I.readIORef ref show res `shouldBe` show (Just expected) @@ -206,14 +206,10 @@ [ singlePostHello , singleGet ] - it "chunked body, read" $ runTest 2 readBody $ concat - [ singleChunkedPostHello - , [singleGet] - ] - it "chunked body, ignore" $ runTest 2 ignoreBody $ concat - [ singleChunkedPostHello - , [singleGet] - ] + it "chunked body, read" $ runTest 2 readBody $ + singleChunkedPostHello ++ [singleGet] + it "chunked body, ignore" $ runTest 2 ignoreBody $ + singleChunkedPostHello ++ [singleGet] describe "pipelining" $ do it "no body, read" $ runTest 5 readBody [S.concat $ replicate 5 singleGet] it "no body, ignore" $ runTest 5 ignoreBody [S.concat $ replicate 5 singleGet] @@ -239,7 +235,8 @@ describe "connection termination" $ do -- it "ConnectionClosedByPeer" $ runTerminateTest ConnectionClosedByPeer "GET / HTTP/1.1\r\ncontent-length: 10\r\n\r\nhello" - it "IncompleteHeaders" $ runTerminateTest IncompleteHeaders "GET / HTTP/1.1\r\ncontent-length: 10\r\n" + it "IncompleteHeaders" $ + runTerminateTest IncompleteHeaders "GET / HTTP/1.1\r\ncontent-length: 10\r\n" describe "special input" $ do it "multiline headers" $ do @@ -252,7 +249,7 @@ [ "GET / HTTP/1.1\r\nfoo: bar\r\n baz\r\n\tbin\r\n\r\n" ] msWrite ms input - threadDelay 1000 + threadDelay 5000 headers <- I.readIORef iheaders headers `shouldBe` [ ("foo", "bar baz\tbin") @@ -267,7 +264,7 @@ [ "GET / HTTP/1.1\r\nfoo:bar\r\n\r\n" ] msWrite ms input - threadDelay 1000 + threadDelay 5000 headers <- I.readIORef iheaders headers `shouldBe` [ ("foo", "bar") @@ -309,7 +306,7 @@ withApp defaultSettings app $ withMySocket $ \ms -> do let input = concat $ replicate 2 $ ["POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"] ++ - (replicate 50 "5\r\n12345\r\n") ++ + replicate 50 "5\r\n12345\r\n" ++ ["0\r\n\r\n"] mapM_ (msWrite ms) input atomically $ do @@ -334,7 +331,7 @@ , "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n" , "b\r\nHello World\r\n0\r\n\r\n" ] - mapM_ (msWrite ms) $ map S.singleton $ S.unpack input + mapM_ (msWrite ms . S.singleton) $ S.unpack input atomically $ do count <- readTVar countVar check $ count == 2 @@ -346,7 +343,7 @@ it "timeout in request body" $ do ifront <- I.newIORef id let app req f = do - bss <- (consumeBody $ getRequestBodyChunk req) `onException` + bss <- consumeBody (getRequestBodyChunk req) `onException` liftIO (I.atomicModifyIORef ifront (\front -> (front . ("consume interrupted":), ()))) liftIO $ threadDelay 4000000 `E.catch` \e -> do I.atomicModifyIORef ifront (\front -> diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/warp-3.3.21/warp.cabal new/warp-3.3.23/warp.cabal --- old/warp-3.3.21/warp.cabal 2001-09-09 03:46:40.000000000 +0200 +++ new/warp-3.3.23/warp.cabal 2001-09-09 03:46:40.000000000 +0200 @@ -1,5 +1,5 @@ Name: warp -Version: 3.3.21 +Version: 3.3.23 Synopsis: A fast, light-weight web server for WAI applications. License: MIT License-file: LICENSE @@ -48,8 +48,9 @@ , hashable , http-date , http-types >= 0.12 - , http2 >= 3.0 && < 3.1 + , http2 >= 3.0 && < 5 , iproute >= 1.3.1 + , recv , simple-sendfile >= 0.2.7 && < 0.3 , stm >= 2.3 , streaming-commons >= 0.1.10 @@ -91,7 +92,6 @@ Network.Wai.Handler.Warp.Imports Network.Wai.Handler.Warp.PackInt Network.Wai.Handler.Warp.ReadInt - Network.Wai.Handler.Warp.Recv Network.Wai.Handler.Warp.Request Network.Wai.Handler.Warp.RequestHeader Network.Wai.Handler.Warp.Response @@ -135,8 +135,7 @@ Test-Suite spec Main-Is: Spec.hs - Other-modules: BufferPoolSpec - ConduitSpec + Other-modules: ConduitSpec ExceptionSpec FdCacheSpec FileSpec @@ -170,7 +169,6 @@ Network.Wai.Handler.Warp.MultiMap Network.Wai.Handler.Warp.PackInt Network.Wai.Handler.Warp.ReadInt - Network.Wai.Handler.Warp.Recv Network.Wai.Handler.Warp.Request Network.Wai.Handler.Warp.RequestHeader Network.Wai.Handler.Warp.Response @@ -189,10 +187,8 @@ Ghc-Options: -Wall -threaded Build-Tool-Depends: hspec-discover:hspec-discover Build-Depends: base >= 4.8 && < 5 - , HUnit , QuickCheck , array - , async , auto-update , bsb-http-chunked < 0.1 , bytestring >= 0.9.1.4 @@ -205,15 +201,15 @@ , http-client , http-date , http-types >= 0.12 - , http2 >= 3.0 && < 3.1 + , http2 >= 3.0 && < 5 , iproute >= 1.3.1 , network , process + , recv , simple-sendfile >= 0.2.4 && < 0.3 , stm >= 2.3 , streaming-commons >= 0.1.10 , text - , time , time-manager , unix-compat >= 0.2 , vault @@ -227,11 +223,13 @@ , transformers if (os(linux) || os(freebsd) || os(darwin)) && flag(allow-sendfilefd) - Cpp-Options: -DSENDFILEFD - Build-Depends: unix + Cpp-Options: -DSENDFILEFD if os(windows) - Cpp-Options: -DWINDOWS - Build-Depends: time + Cpp-Options: -DWINDOWS + Build-Depends: time + else + Build-Depends: unix + Other-modules: Network.Wai.Handler.Warp.MultiMap if impl(ghc >= 8) Default-Extensions: Strict StrictData Default-Language: Haskell2010 @@ -257,6 +255,7 @@ , http-types , network , network + , recv , time-manager , unix-compat , unliftio
