diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,12 @@ # ChangeLog for warp +## 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 --git a/Network/Wai/Handler/Warp.hs b/Network/Wai/Handler/Warp.hs --- a/Network/Wai/Handler/Warp.hs +++ b/Network/Wai/Handler/Warp.hs @@ -76,6 +76,7 @@ , setGracefulCloseTimeout2 , setMaxTotalHeaderLength , setAltSvc + , setMaxBuilderResponseBufferSize -- ** Getters , getPort , getHost @@ -461,6 +462,12 @@ -- Since 3.3.11 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. -- diff --git a/Network/Wai/Handler/Warp/Buffer.hs b/Network/Wai/Handler/Warp/Buffer.hs --- a/Network/Wai/Handler/Warp/Buffer.hs +++ b/Network/Wai/Handler/Warp/Buffer.hs @@ -1,7 +1,8 @@ {-# LANGUAGE BangPatterns #-} module Network.Wai.Handler.Warp.Buffer ( - bufferSize + createWriteBuffer + , bufferSize , allocateBuffer , freeBuffer , mallocBS @@ -15,7 +16,7 @@ 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, newIORef, readIORef, writeIORef) import qualified Data.Streaming.ByteString.Builder.Buffer as B (Buffer (..)) import Foreign.ForeignPtr import Foreign.Marshal.Alloc (mallocBytes, free, finalizerFree) @@ -26,6 +27,20 @@ ---------------------------------------------------------------- +-- | 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 + } + +---------------------------------------------------------------- + -- | 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 @@ -90,8 +105,11 @@ -- 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) diff --git a/Network/Wai/Handler/Warp/HTTP2.hs b/Network/Wai/Handler/Warp/HTTP2.hs --- a/Network/Wai/Handler/Warp/HTTP2.hs +++ b/Network/Wai/Handler/Warp/HTTP2.hs @@ -11,7 +11,7 @@ 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 @@ -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 diff --git a/Network/Wai/Handler/Warp/HTTP2/Types.hs b/Network/Wai/Handler/Warp/HTTP2/Types.hs --- a/Network/Wai/Handler/Warp/HTTP2/Types.hs +++ b/Network/Wai/Handler/Warp/HTTP2/Types.hs @@ -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 --git a/Network/Wai/Handler/Warp/IO.hs b/Network/Wai/Handler/Warp/IO.hs --- a/Network/Wai/Handler/Warp/IO.hs +++ b/Network/Wai/Handler/Warp/IO.hs @@ -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 --git a/Network/Wai/Handler/Warp/Internal.hs b/Network/Wai/Handler/Warp/Internal.hs --- a/Network/Wai/Handler/Warp/Internal.hs +++ b/Network/Wai/Handler/Warp/Internal.hs @@ -19,6 +19,8 @@ -- ** Buffer , Buffer , BufSize + , WriteBuffer(..) + , createWriteBuffer , bufferSize , allocateBuffer , freeBuffer diff --git a/Network/Wai/Handler/Warp/Response.hs b/Network/Wai/Handler/Warp/Response.hs --- a/Network/Wai/Handler/Warp/Response.hs +++ b/Network/Wai/Handler/Warp/Response.hs @@ -117,20 +117,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 +200,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 +214,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 +250,7 @@ ---------------------------------------------------------------- -sendRsp conn _ th _ _ _ _ (RspRaw withApp src) = do +sendRsp conn _ th _ _ _ _ _ (RspRaw withApp src) = do withApp recv send return (Nothing, Nothing) where @@ -263,8 +264,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 +275,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 +296,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 +319,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 --git a/Network/Wai/Handler/Warp/Run.hs b/Network/Wai/Handler/Warp/Run.hs --- a/Network/Wai/Handler/Warp/Run.hs +++ b/Network/Wai/Handler/Warp/Run.hs @@ -57,13 +57,13 @@ socketConnection _ s = do #endif bufferPool <- newBufferPool - writeBuf <- allocateBuffer bufferSize - let sendall = sendAll' s + writeBuffer <- createWriteBuffer bufferSize + 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,19 @@ #else , connClose = close s #endif - , connFree = freeBuffer writeBuf , connRecv = receive s bufferPool , connRecvBuf = receiveBuf s - , connWriteBuffer = writeBuf - , connBufferSize = bufferSize + , connWriteBuffer = writeBufferRef , connHTTP2 = isH2 } where + 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 @@ -309,7 +314,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 --git a/Network/Wai/Handler/Warp/Settings.hs b/Network/Wai/Handler/Warp/Settings.hs --- a/Network/Wai/Handler/Warp/Settings.hs +++ b/Network/Wai/Handler/Warp/Settings.hs @@ -10,14 +10,12 @@ 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.Wai import qualified Paths_warp @@ -140,6 +138,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. @@ -180,6 +192,7 @@ , settingsGracefulCloseTimeout2 = 2000 , settingsMaxTotalHeaderLength = 50 * 1024 , settingsAltSvc = Nothing + , settingsMaxBuilderResponseBufferSize = 1049000000 } -- | Apply the logic provided by 'defaultOnException' to determine if an @@ -213,18 +226,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" diff --git a/Network/Wai/Handler/Warp/Types.hs b/Network/Wai/Handler/Warp/Types.hs --- a/Network/Wai/Handler/Warp/Types.hs +++ b/Network/Wai/Handler/Warp/Types.hs @@ -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 @@ -90,6 +94,17 @@ -- | Type for buffer type Buffer = Ptr Word8 +-- | 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 () + } + -- | Type for buffer size type BufSize = Int @@ -113,18 +128,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. , 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 --git a/test/RunSpec.hs b/test/RunSpec.hs --- a/test/RunSpec.hs +++ b/test/RunSpec.hs @@ -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 --git a/warp.cabal b/warp.cabal --- a/warp.cabal +++ b/warp.cabal @@ -1,5 +1,5 @@ Name: warp -Version: 3.3.21 +Version: 3.3.22 Synopsis: A fast, light-weight web server for WAI applications. License: MIT License-file: LICENSE @@ -48,7 +48,7 @@ , hashable , http-date , http-types >= 0.12 - , http2 >= 3.0 && < 3.1 + , http2 >= 3.0 && < 5 , iproute >= 1.3.1 , simple-sendfile >= 0.2.7 && < 0.3 , stm >= 2.3 @@ -205,7 +205,7 @@ , http-client , http-date , http-types >= 0.12 - , http2 >= 3.0 && < 3.1 + , http2 >= 3.0 && < 5 , iproute >= 1.3.1 , network , process