diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,6 +1,16 @@ +## 3.1.3 + +* Warp now supports blaze-builder v0.4 or later only. +* HTTP/2 code was improved: dynamic priority change, efficient queuing and sender loop continuation. [#423](https://github.com/yesodweb/wai/pull/423) [#424](https://github.com/yesodweb/wai/pull/424) + ## 3.1.2 * Configurable Slowloris size [#418](https://github.com/yesodweb/wai/pull/418) + +## 3.1.1 + +* Fixing a bug of HTTP/2 when no FD cache is used [#411](https://github.com/yesodweb/wai/pull/411) +* Fixing a buffer-pool bug [#406](https://github.com/yesodweb/wai/pull/406) [#407](https://github.com/yesodweb/wai/pull/407) ## 3.1.0 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 @@ -7,7 +7,7 @@ , mallocBS , newBufferPool , withBufferPool - , toBlazeBuffer + , toBuilderBuffer , copy , bufferIO ) where @@ -88,8 +88,8 @@ -- Utilities -- -toBlazeBuffer :: Buffer -> BufSize -> IO B.Buffer -toBlazeBuffer ptr size = do +toBuilderBuffer :: Buffer -> BufSize -> IO B.Buffer +toBuilderBuffer ptr size = do fptr <- newForeignPtr_ ptr return $ B.Buffer fptr ptr ptr (ptr `plusPtr` size) diff --git a/Network/Wai/Handler/Warp/HTTP2/HPACK.hs b/Network/Wai/Handler/Warp/HTTP2/HPACK.hs --- a/Network/Wai/Handler/Warp/HTTP2/HPACK.hs +++ b/Network/Wai/Handler/Warp/HTTP2/HPACK.hs @@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards, NamedFieldPuns #-} +{-# LANGUAGE NamedFieldPuns #-} module Network.Wai.Handler.Warp.HTTP2.HPACK where diff --git a/Network/Wai/Handler/Warp/HTTP2/Manager.hs b/Network/Wai/Handler/Warp/HTTP2/Manager.hs --- a/Network/Wai/Handler/Warp/HTTP2/Manager.hs +++ b/Network/Wai/Handler/Warp/HTTP2/Manager.hs @@ -51,7 +51,7 @@ where next = do action <- readIORef ref - newtid <- forkIO $ action + newtid <- forkIO action add tset newtid go q tset ref diff --git a/Network/Wai/Handler/Warp/HTTP2/Receiver.hs b/Network/Wai/Handler/Warp/HTTP2/Receiver.hs --- a/Network/Wai/Handler/Warp/HTTP2/Receiver.hs +++ b/Network/Wai/Handler/Warp/HTTP2/Receiver.hs @@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards, NamedFieldPuns #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE PatternGuards #-} @@ -92,7 +92,7 @@ control ftyp header pl ctx | otherwise = do checkContinued - strm@Stream{streamState,streamContentLength} <- getStream + strm@Stream{streamState,streamContentLength,streamPriority} <- getStream pl <- recvN payloadLength state <- readIORef streamState state' <- stream ftyp header pl ctx state strm @@ -103,21 +103,23 @@ Just vh -> do when (isJust (vhCL vh) && vhCL vh /= Just 0) $ E.throwIO $ StreamError ProtocolError streamId + writeIORef streamPriority pri writeIORef streamState HalfClosed let req = mkreq vh (return "") - atomically $ writeTQueue inputQ $ Input strm req pri + atomically $ writeTQueue inputQ $ Input strm req Nothing -> E.throwIO $ StreamError ProtocolError streamId Open (HasBody hdr pri) -> do resetContinued case validateHeaders hdr of Just vh -> do q <- newTQueueIO + writeIORef streamPriority pri writeIORef streamState (Open (Body q)) writeIORef streamContentLength $ vhCL vh readQ <- newReadBody q bodySource <- mkSource readQ let req = mkreq vh (readSource bodySource) - atomically $ writeTQueue inputQ $ Input strm req pri + atomically $ writeTQueue inputQ $ Input strm req Nothing -> E.throwIO $ StreamError ProtocolError streamId s@(Open Continued{}) -> do setContinued @@ -314,10 +316,18 @@ closed ctx strm cc return $ Closed cc -- will be written to streamState again -stream FramePriority header bs Context{outputQ} s Stream{streamNumber} = do +stream FramePriority header bs Context{outputQ} s Stream{streamNumber,streamPriority} = do PriorityFrame p <- guardIt $ decodePriorityFrame header bs checkPriority p streamNumber - prepare outputQ streamNumber p + -- checkme: this should be tested + -- fixme: This works well when the priority gets lower because + -- the old higher priority value comes out from the queue quickly + -- and the new lower priority is used when enqueuing again. + -- But when the priority get higher, it takes time to use the new + -- priority. + writeIORef streamPriority p + -- checkme: this should be tested + when (isIdle s) $ prepare outputQ streamNumber p return s -- this ordering is important diff --git a/Network/Wai/Handler/Warp/HTTP2/Sender.hs b/Network/Wai/Handler/Warp/HTTP2/Sender.hs --- a/Network/Wai/Handler/Warp/HTTP2/Sender.hs +++ b/Network/Wai/Handler/Warp/HTTP2/Sender.hs @@ -1,13 +1,12 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE BangPatterns, CPP #-} -{-# LANGUAGE RecordWildCards, NamedFieldPuns #-} +{-# LANGUAGE NamedFieldPuns #-} module Network.Wai.Handler.Warp.HTTP2.Sender (frameSender) where #if __GLASGOW_HASKELL__ < 709 import Control.Applicative #endif -import Control.Concurrent (forkIO) import Control.Concurrent.STM import qualified Control.Exception as E import Control.Monad (unless, void, when) @@ -58,22 +57,16 @@ let rst = resetFrame InternalError streamNumber connSendAll rst -checkWindowSize :: TVar WindowSize -> TVar WindowSize -> PriorityTree Output -> Output -> Priority -> (WindowSize -> IO ()) -> IO () -checkWindowSize connWindow strmWindow outQ out pri body = do +getWindowSize :: TVar WindowSize -> TVar WindowSize -> IO WindowSize +getWindowSize connWindow strmWindow = do + -- Waiting that the connection window gets open. cw <- atomically $ do w <- readTVar connWindow check (w > 0) return w + -- This stream window is greater than 0 thanks to the invariant. sw <- atomically $ readTVar strmWindow - if sw == 0 then - void $ forkIO $ do - -- checkme: if connection is closed? GC throws dead lock error? - atomically $ do - x <- readTVar strmWindow - check (x > 0) - enqueue outQ out pri - else - body (min cw sw) + return $ min cw sw frameSender :: Context -> Connection -> InternalInfo -> S.Settings -> IO () frameSender ctx@Context{outputQ,connectionWindow} @@ -89,18 +82,20 @@ connSendAll initialFrame loop - loop = dequeue outputQ >>= \(out, pri) -> switch out pri + -- ignoring the old priority because the value might be changed. + loop = dequeue outputQ >>= \(out, _) -> switch out ignore :: E.SomeException -> IO () ignore _ = return () - switch OFinish _ = return () - switch (OGoaway frame) _ = connSendAll frame - switch (OFrame frame) _ = do + switch OFinish = return () + switch (OGoaway frame) = connSendAll frame + switch (OFrame frame) = do connSendAll frame loop - switch out@(OResponse strm rsp aux) pri = unlessClosed ctx conn strm $ do - checkWindowSize connectionWindow (streamWindow strm) outputQ out pri $ \lim -> do + switch (OResponse strm rsp aux) = do + unlessClosed ctx conn strm $ do + lim <- getWindowSize connectionWindow (streamWindow strm) -- Header frame and Continuation frame let sid = streamNumber strm endOfStream = case aux of @@ -116,7 +111,7 @@ Next datPayloadLen mnext <- fillResponseBodyGetNext conn ii payloadOff lim rsp fillDataHeaderSend strm total datPayloadLen mnext - maybeEnqueueNext strm mnext pri + maybeEnqueueNext strm mnext Oneshot False -> do -- "closed" must be before "connSendAll". If not, -- the context would be switched to the receiver, @@ -127,21 +122,22 @@ (off, needSend) <- sendHeadersIfNecessary total let payloadOff = off + frameHeaderLength Next datPayloadLen mnext <- - fillStreamBodyGetNext conn payloadOff lim sq tvar + fillStreamBodyGetNext conn payloadOff lim sq tvar strm -- If no data was immediately available, avoid sending an -- empty data frame. if datPayloadLen > 0 then fillDataHeaderSend strm total datPayloadLen mnext else when needSend $ flushN off - maybeEnqueueNext strm mnext pri + maybeEnqueueNext strm mnext loop - switch out@(ONext strm curr) pri = unlessClosed ctx conn strm $ do - checkWindowSize connectionWindow (streamWindow strm) outputQ out pri $ \lim -> do + switch (ONext strm curr) = do + unlessClosed ctx conn strm $ do + lim <- getWindowSize connectionWindow (streamWindow strm) -- Data frame payload Next datPayloadLen mnext <- curr lim fillDataHeaderSend strm 0 datPayloadLen mnext - maybeEnqueueNext strm mnext pri + maybeEnqueueNext strm mnext loop -- Flush the connection buffer to the socket, where the first 'n' bytes of @@ -183,12 +179,15 @@ canFitDataFrame total = total + frameHeaderLength < connBufferSize -- Re-enqueue the stream in the output queue if more output is immediately - -- available; do nothing otherwise. If the stream is not finished, it must - -- already have been written to the 'TVar' owned by 'waiter', which will + -- available; do nothing otherwise. + maybeEnqueueNext :: Stream -> Control DynaNext -> IO () + maybeEnqueueNext strm (CNext next) = do + let out = ONext strm next + enqueueOrSpawnTemporaryWaiter strm outputQ out + -- If the streaming is not finished, it must already have been + -- written to the 'TVar' owned by 'waiter', which will -- put it back into the queue when more output becomes available. - maybeEnqueueNext :: Stream -> Control DynaNext -> Priority -> IO () - maybeEnqueueNext strm (CNext next) = enqueue outputQ (ONext strm next) - maybeEnqueueNext _ _ = const $ return () + maybeEnqueueNext _ _ = return () -- Send headers if there is not room for a 1-byte data frame, and return @@ -282,13 +281,13 @@ ---------------------------------------------------------------- -fillStreamBodyGetNext :: Connection -> Int -> WindowSize -> TBQueue Sequence -> TVar Sync -> IO Next +fillStreamBodyGetNext :: Connection -> Int -> WindowSize -> TBQueue Sequence -> TVar Sync -> Stream -> IO Next fillStreamBodyGetNext Connection{connWriteBuffer,connBufferSize} - off lim sq tvar = do + off lim sq tvar strm = do let datBuf = connWriteBuffer `plusPtr` off room = min (connBufferSize - off) lim (leftover, cont, len) <- runStreamBuilder datBuf room sq - nextForStream connWriteBuffer connBufferSize sq tvar leftover cont len + nextForStream connWriteBuffer connBufferSize sq tvar strm leftover cont len ---------------------------------------------------------------- @@ -342,8 +341,8 @@ Just SFlush -> return (LZero, True, total) Just SFinish -> return (LZero, False, total) -fillBufStream :: Buffer -> BufSize -> Leftover -> TBQueue Sequence -> TVar Sync -> DynaNext -fillBufStream buf0 siz0 leftover0 sq tvar lim0 = do +fillBufStream :: Buffer -> BufSize -> Leftover -> TBQueue Sequence -> TVar Sync -> Stream -> DynaNext +fillBufStream buf0 siz0 leftover0 sq tvar strm lim0 = do let payloadBuf = buf0 `plusPtr` frameHeaderLength room0 = min (siz0 - frameHeaderLength) lim0 case leftover0 of @@ -361,7 +360,7 @@ void $ copy payloadBuf bs1 getNext (LTwo bs2 writer) True room0 where - getNext = nextForStream buf0 siz0 sq tvar + getNext = nextForStream buf0 siz0 sq tvar strm write writer1 buf room sofar = do (len, signal) <- writer1 buf room case signal of @@ -376,17 +375,18 @@ let !total = sofar + len getNext (LTwo bs writer) True total -nextForStream :: Buffer -> BufSize -> TBQueue Sequence -> TVar Sync +nextForStream :: Buffer -> BufSize -> TBQueue Sequence -> TVar Sync -> Stream -> Leftover -> Bool -> BytesFilled -> IO Next -nextForStream _ _ _ tvar _ False len = do +nextForStream _ _ _ tvar _ _ False len = do atomically $ writeTVar tvar SyncFinish return $ Next len CFinish -nextForStream buf siz sq tvar LZero True len = do - atomically $ writeTVar tvar $ SyncNext (fillBufStream buf siz LZero sq tvar) +nextForStream buf siz sq tvar strm LZero True len = do + let out = ONext strm (fillBufStream buf siz LZero sq tvar strm) + atomically $ writeTVar tvar $ SyncNext out return $ Next len CNone -nextForStream buf siz sq tvar leftover True len = - return $ Next len (CNext (fillBufStream buf siz leftover sq tvar)) +nextForStream buf siz sq tvar strm leftover True len = + return $ Next len (CNext (fillBufStream buf siz leftover sq tvar strm)) ---------------------------------------------------------------- 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,13 @@ {-# LANGUAGE OverloadedStrings, CPP #-} -{-# LANGUAGE RecordWildCards, NamedFieldPuns #-} +{-# LANGUAGE NamedFieldPuns #-} module Network.Wai.Handler.Warp.HTTP2.Types where -import Blaze.ByteString.Builder (Builder) +import Data.ByteString.Builder (Builder) #if __GLASGOW_HASKELL__ < 709 import Control.Applicative ((<$>),(<*>)) #endif +import Control.Concurrent (forkIO) import Control.Concurrent.STM import Control.Exception (SomeException) import Control.Monad (void) @@ -39,7 +40,7 @@ ---------------------------------------------------------------- -data Input = Input Stream Request Priority +data Input = Input Stream Request ---------------------------------------------------------------- @@ -64,6 +65,11 @@ | OResponse Stream Response Aux | ONext Stream DynaNext +outputStream :: Output -> Stream +outputStream (OResponse strm _ _) = strm +outputStream (ONext strm _) = strm +outputStream _ = error "outputStream" + ---------------------------------------------------------------- data Sequence = SFinish @@ -72,7 +78,7 @@ data Sync = SyncNone | SyncFinish - | SyncNext DynaNext + | SyncNext Output data Aux = Oneshot Bool | Persist (TBQueue Sequence) (TVar Sync) @@ -170,6 +176,7 @@ , streamContentLength :: IORef (Maybe Int) , streamBodyLength :: IORef Int , streamWindow :: TVar WindowSize + , streamPriority :: IORef Priority } instance Show Stream where @@ -180,17 +187,18 @@ <*> newIORef Nothing <*> newIORef 0 <*> newTVarIO win + <*> newIORef defaultPriority ---------------------------------------------------------------- opened :: Context -> Stream -> IO () opened Context{concurrency} Stream{streamState} = do - atomicModifyIORef' concurrency (\x -> ((x+1),())) + atomicModifyIORef' concurrency (\x -> (x+1,())) writeIORef streamState (Open JustOpened) closed :: Context -> Stream -> ClosedCode -> IO () closed Context{concurrency} Stream{streamState} cc = do - atomicModifyIORef' concurrency (\x -> ((x-1),())) + atomicModifyIORef' concurrency (\x -> (x-1,())) writeIORef streamState (Closed cc) ---------------------------------------------------------------- @@ -227,3 +235,24 @@ search :: StreamTable -> M.Key -> IO (Maybe Stream) search strmtbl k = M.lookup k <$> reaperRead strmtbl + + +-- INVARIANT: streams in the output queue have non-zero window size. +enqueueWhenWindowIsOpen :: PriorityTree Output -> Output -> IO () +enqueueWhenWindowIsOpen outQ out = do + let strm = outputStream out + atomically $ do + x <- readTVar $ streamWindow strm + check (x > 0) + pri <- readIORef $ streamPriority strm + enqueue outQ out pri + +enqueueOrSpawnTemporaryWaiter :: Stream -> PriorityTree Output -> Output -> IO () +enqueueOrSpawnTemporaryWaiter strm outQ out = do + sw <- atomically $ readTVar $ streamWindow strm + if sw == 0 then + -- This waiter waits only for the stream window. + void $ forkIO $ enqueueWhenWindowIsOpen outQ out + else do + pri <- readIORef $ streamPriority strm + enqueue outQ out pri diff --git a/Network/Wai/Handler/Warp/HTTP2/Worker.hs b/Network/Wai/Handler/Warp/HTTP2/Worker.hs --- a/Network/Wai/Handler/Warp/HTTP2/Worker.hs +++ b/Network/Wai/Handler/Warp/HTTP2/Worker.hs @@ -1,6 +1,6 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE RecordWildCards, NamedFieldPuns #-} -{-# LANGUAGE PatternGuards, BangPatterns #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PatternGuards #-} {-# LANGUAGE CPP #-} module Network.Wai.Handler.Warp.HTTP2.Worker ( @@ -36,14 +36,14 @@ -- | The wai definition is 'type Application = Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived'. -- This type implements the second argument (Response -> IO ResponseReceived) -- with extra arguments. -type Responder = ThreadContinue -> T.Handle -> Stream -> Priority -> Request -> +type Responder = ThreadContinue -> T.Handle -> Stream -> Request -> Response -> IO ResponseReceived -- | This function is passed to workers. -- They also pass 'Response's from 'Application's to this function. -- This function enqueues commands for the HTTP/2 sender. response :: Context -> Manager -> Responder -response Context{outputQ} mgr tconf th strm pri req rsp = do +response Context{outputQ} mgr tconf th strm req rsp = do case rsp of ResponseStream _ _ strmbdy -> do -- We must not exit this WAI application. @@ -59,22 +59,24 @@ -- So, let's serialize 'Builder' with a designated queue. sq <- newTBQueueIO 10 -- fixme: hard coding: 10 tvar <- newTVarIO SyncNone - enqueue outputQ (OResponse strm rsp (Persist sq tvar)) pri + let out = OResponse strm rsp (Persist sq tvar) + -- Since we must not enqueue an empty queue to the priority + -- queue, we spawn a thread to ensure that the designated + -- queue is not empty. + void $ forkIO $ waiter tvar sq outputQ + atomically $ writeTVar tvar (SyncNext out) let push b = do atomically $ writeTBQueue sq (SBuilder b) T.tickle th flush = atomically $ writeTBQueue sq SFlush - -- Since we must not enqueue an empty queue to the priority - -- queue, we spawn a thread to ensure that the designated - -- queue is not empty. - void $ forkIO $ waiter tvar sq (enqueue outputQ) strm pri strmbdy push flush atomically $ writeTBQueue sq SFinish _ -> do setThreadContinue tconf True let hasBody = requestMethod req /= H.methodHead && R.hasBody (responseStatus rsp) - enqueue outputQ (OResponse strm rsp (Oneshot hasBody)) pri + out = OResponse strm rsp (Oneshot hasBody) + enqueueOrSpawnTemporaryWaiter strm outputQ out return ResponseReceived data Break = Break deriving (Show, Typeable) @@ -93,11 +95,11 @@ setThreadContinue tcont True ex <- E.try $ do T.pause th - Input strm req pri <- atomically $ readTQueue inputQ + Input strm req <- atomically $ readTQueue inputQ setStreamInfo sinfo strm req T.resume th T.tickle th - app req $ responder tcont th strm pri req + app req $ responder tcont th strm req cont1 <- case ex of Right ResponseReceived -> return True Left e@(SomeException _) @@ -126,26 +128,27 @@ Just e -> S.settingsOnException set (Just req) e clearStreamInfo sinfo -waiter :: TVar Sync -> TBQueue Sequence - -> (Output -> Priority -> IO ()) -> Stream -> Priority - -> IO () -waiter tvar sq enq strm pri = do +waiter :: TVar Sync -> TBQueue Sequence -> PriorityTree Output -> IO () +waiter tvar sq outQ = do + -- waiting for actions other than SyncNone mx <- atomically $ do mout <- readTVar tvar case mout of SyncNone -> retry - SyncNext nxt -> do + SyncNext out -> do writeTVar tvar SyncNone - return $ Just nxt + return $ Just out SyncFinish -> return Nothing case mx of Nothing -> return () - Just next -> do + Just out -> do + -- ensuring that the streaming queue is not empty. atomically $ do isEmpty <- isEmptyTBQueue sq when isEmpty retry - enq (ONext strm next) pri - waiter tvar sq enq strm pri + -- ensuring that stream window is greater than 0. + enqueueWhenWindowIsOpen outQ out + waiter tvar sq outQ ---------------------------------------------------------------- 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 @@ -4,19 +4,11 @@ module Network.Wai.Handler.Warp.IO where import Data.ByteString (ByteString) +import Data.ByteString.Builder (Builder) +import Data.ByteString.Builder.Extra (runBuilder, Next(Done, More, Chunk)) import Network.Wai.Handler.Warp.Buffer import Network.Wai.Handler.Warp.Types --- Support for doctest, where cabal macros are not available -#ifndef MIN_VERSION_blaze_builder -#define MIN_VERSION_blaze_builder(x, y, z) 1 -#endif - -#if MIN_VERSION_blaze_builder(0,4,0) - -import Blaze.ByteString.Builder (Builder) -import Data.ByteString.Builder.Extra (runBuilder, Next(Done, More, Chunk)) - toBufIOWith :: Buffer -> BufSize -> (ByteString -> IO ()) -> Builder -> IO () toBufIOWith buf !size io builder = loop firstWriter where @@ -35,31 +27,3 @@ runIO len io bs loop next - -#else /* !MIN_VERSION_blaze_builder(0,4,0) */ - -import Blaze.ByteString.Builder.Internal.Types (Builder(..), BuildSignal(..), BufRange(..), runBuildStep, buildStep) -import Foreign.Ptr (plusPtr, minusPtr) - -toBufIOWith :: Buffer -> BufSize -> (ByteString -> IO ()) -> Builder -> IO () -toBufIOWith buf !size io (Builder build) = loop firstStep - where - firstStep = build (buildStep finalStep) - finalStep (BufRange p _) = return $ Done p () - bufRange = BufRange buf (buf `plusPtr` size) - runIO ptr = toBS buf (ptr `minusPtr` buf) >>= io - loop step = do - signal <- runBuildStep step bufRange - case signal of - Done ptr _ -> runIO ptr - BufferFull minSize ptr next - | size < minSize -> error "toBufIOWith: BufferFull: minSize" - | otherwise -> do - runIO ptr - loop next - InsertByteString ptr bs next -> do - runIO ptr - io bs - loop next - -#endif /* !MIN_VERSION_blaze_builder(0,4,0) */ 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 @@ -18,17 +18,17 @@ #define MIN_VERSION_base(x,y,z) 1 #endif -import Blaze.ByteString.Builder (fromByteString, Builder, flush) import Blaze.ByteString.Builder.HTTP (chunkedTransferEncoding, chunkedTransferTerminator) #if __GLASGOW_HASKELL__ < 709 import Control.Applicative #endif import Control.Exception +import Control.Monad (unless, when) import Data.Array ((!)) import Data.ByteString (ByteString) -import Data.Streaming.Blaze (newBlazeRecv, reuseBufferStrategy) import qualified Data.ByteString as S -import Control.Monad (unless, when) +import Data.ByteString.Builder (byteString, Builder) +import Data.ByteString.Builder.Extra (flush) import qualified Data.ByteString.Char8 as B (pack) import qualified Data.CaseInsensitive as CI import Data.Function (on) @@ -42,10 +42,11 @@ #else import Data.Monoid (mappend, mempty) #endif +import Data.Streaming.Blaze (newBlazeRecv, reuseBufferStrategy) import Data.Version (showVersion) import qualified Network.HTTP.Types as H import Network.Wai -import Network.Wai.Handler.Warp.Buffer (toBlazeBuffer) +import Network.Wai.Handler.Warp.Buffer (toBuilderBuffer) import qualified Network.Wai.Handler.Warp.Date as D import qualified Network.Wai.Handler.Warp.FdCache as F import Network.Wai.Handler.Warp.Header @@ -268,7 +269,7 @@ hs = addAcceptRanges hs0 s2 = H.status404 hs2 = replaceHeader H.hContentType "text/plain; charset=utf-8" hs0 - body = fromByteString "File not found" + body = byteString "File not found" ---------------------------------------------------------------- @@ -287,7 +288,7 @@ sendRsp conn _ ver s hs (RspStream streamingBody needsChunked th) = do header <- composeHeaderBuilder ver s hs needsChunked (recv, finish) <- newBlazeRecv $ reuseBufferStrategy - $ toBlazeBuffer (connWriteBuffer conn) (connBufferSize conn) + $ toBuilderBuffer (connWriteBuffer conn) (connBufferSize conn) let send builder = do popper <- recv builder let loop = do @@ -448,6 +449,6 @@ composeHeaderBuilder :: H.HttpVersion -> H.Status -> H.ResponseHeaders -> Bool -> IO Builder composeHeaderBuilder ver s hs True = - fromByteString <$> composeHeader ver s (addTransferEncoding hs) + byteString <$> composeHeader ver s (addTransferEncoding hs) composeHeaderBuilder ver s hs False = - fromByteString <$> composeHeader ver s hs + byteString <$> composeHeader ver s hs 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 @@ -4,13 +4,12 @@ module Network.Wai.Handler.Warp.Settings where -import Blaze.ByteString.Builder (copyByteString) -import Blaze.ByteString.Builder.Char.Utf8 (fromShow) import Control.Concurrent (forkIOWithUnmask) import Control.Exception import Control.Monad (when, void) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as S8 +import Data.ByteString.Builder (byteString) #if __GLASGOW_HASKELL__ < 709 import Data.Monoid (mappend) #endif @@ -162,5 +161,7 @@ -- -- Since: 2.0.3.2 exceptionResponseForDebug :: SomeException -> Response -exceptionResponseForDebug e = responseBuilder H.internalServerError500 [(H.hContentType, "text/plain; charset=utf-8")] - $ copyByteString "Exception: " `mappend` fromShow e +exceptionResponseForDebug e = + responseBuilder H.internalServerError500 + [(H.hContentType, "text/plain; charset=utf-8")] + $ byteString . S8.pack $ "Exception: " ++ show e diff --git a/test/RunSpec.hs b/test/RunSpec.hs --- a/test/RunSpec.hs +++ b/test/RunSpec.hs @@ -5,29 +5,29 @@ module RunSpec (main, spec, withApp) where import Control.Concurrent (forkIO, killThread, threadDelay) +import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar) +import qualified Control.Exception as E +import Control.Exception.Lifted (bracket, try, IOException, onException) import Control.Monad (forM_, replicateM_, unless) -import System.Timeout (timeout) import Control.Monad.IO.Class (MonadIO, liftIO) import Data.ByteString (ByteString, hPutStr, hGetSome) -import qualified Control.Exception as E import qualified Data.ByteString as S +import Data.ByteString.Builder (byteString) import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L import qualified Data.IORef as I +import Data.Streaming.Network (bindPortTCP, getSocketTCP, safeRecv) import Network (connectTo, PortID (PortNumber)) +import qualified Network.HTTP as HTTP import Network.HTTP.Types +import Network.Socket (sClose) +import Network.Socket.ByteString (sendAll) import Network.Wai import Network.Wai.Handler.Warp import System.IO (hFlush, hClose) import System.IO.Unsafe (unsafePerformIO) +import System.Timeout (timeout) import Test.Hspec -import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar) -import Control.Exception.Lifted (bracket, try, IOException, onException) -import Data.Streaming.Network (bindPortTCP, getSocketTCP, safeRecv) -import Network.Socket (sClose) -import qualified Network.HTTP as HTTP -import Blaze.ByteString.Builder (fromByteString) -import Network.Socket.ByteString (sendAll) main :: IO () main = hspec spec @@ -360,7 +360,7 @@ let loop = do bs <- requestBody req unless (S.null bs) $ do - write $ fromByteString bs + write $ byteString bs loop loop withApp defaultSettings app $ \port -> do @@ -373,7 +373,7 @@ it "streaming response with length" $ do let app _ f = f $ responseStream status200 [("content-length", "20")] $ \write _ -> do - replicateM_ 4 $ write $ fromByteString "Hello" + replicateM_ 4 $ write $ byteString "Hello" withApp defaultSettings app $ \port -> do Right res <- HTTP.simpleHTTP (HTTP.getRequest $ "http://127.0.0.1:" ++ show port) HTTP.rspBody res `shouldBe` "HelloHelloHelloHello" diff --git a/warp.cabal b/warp.cabal --- a/warp.cabal +++ b/warp.cabal @@ -1,5 +1,5 @@ Name: warp -Version: 3.1.2 +Version: 3.1.3 Synopsis: A fast, light-weight web server for WAI applications. License: MIT License-file: LICENSE @@ -30,16 +30,13 @@ Description: print debug output. not suitable for production Default: False -Flag use-bytestring-builder - description: Use bytestring-builder package - default: False - Library Build-Depends: base >= 3 && < 5 , array , auto-update >= 0.1.1 && < 0.2 - , blaze-builder >= 0.3.3 && < 0.5 + , blaze-builder >= 0.4 , bytestring >= 0.9.1.4 + , bytestring-builder , case-insensitive >= 0.2 , containers , ghc-prim @@ -59,11 +56,6 @@ , network-bytestring >= 0.1.3 && < 0.1.4 else Build-Depends: network >= 2.3 - if flag(use-bytestring-builder) - Build-Depends: bytestring < 0.10.2.0 - , bytestring-builder - else - Build-Depends: bytestring >= 0.10.2.0 Exposed-modules: Network.Wai.Handler.Warp Network.Wai.Handler.Warp.Internal Other-modules: Network.Wai.Handler.Warp.Buffer @@ -140,8 +132,9 @@ Build-Depends: base >= 4 && < 5 , array , auto-update - , blaze-builder >= 0.3.3 && < 0.5 + , blaze-builder >= 0.4 , bytestring >= 0.9.1.4 + , bytestring-builder , case-insensitive >= 0.2 , ghc-prim , HTTP @@ -168,11 +161,6 @@ , containers , http2 >= 1.0.2 , word8 - if flag(use-bytestring-builder) - Build-Depends: bytestring < 0.10.2.0 - , bytestring-builder - else - Build-Depends: bytestring >= 0.10.2.0 if (os(linux) || os(freebsd) || os(darwin)) && flag(allow-sendfilefd) Cpp-Options: -DSENDFILEFD