warp 3.1.2 → 3.1.3
raw patch · 13 files changed
+164/−158 lines, 13 filesdep ~blaze-builderdep ~bytestringdep ~http2
Dependency ranges changed: blaze-builder, bytestring, http2
Files
- ChangeLog.md +10/−0
- Network/Wai/Handler/Warp/Buffer.hs +3/−3
- Network/Wai/Handler/Warp/HTTP2/HPACK.hs +1/−1
- Network/Wai/Handler/Warp/HTTP2/Manager.hs +1/−1
- Network/Wai/Handler/Warp/HTTP2/Receiver.hs +16/−6
- Network/Wai/Handler/Warp/HTTP2/Sender.hs +42/−42
- Network/Wai/Handler/Warp/HTTP2/Types.hs +35/−6
- Network/Wai/Handler/Warp/HTTP2/Worker.hs +24/−21
- Network/Wai/Handler/Warp/IO.hs +2/−38
- Network/Wai/Handler/Warp/Response.hs +9/−8
- Network/Wai/Handler/Warp/Settings.hs +5/−4
- test/RunSpec.hs +11/−11
- warp.cabal +5/−17
ChangeLog.md view
@@ -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
Network/Wai/Handler/Warp/Buffer.hs view
@@ -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)
Network/Wai/Handler/Warp/HTTP2/HPACK.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}+{-# LANGUAGE NamedFieldPuns #-} module Network.Wai.Handler.Warp.HTTP2.HPACK where
Network/Wai/Handler/Warp/HTTP2/Manager.hs view
@@ -51,7 +51,7 @@ where next = do action <- readIORef ref- newtid <- forkIO $ action+ newtid <- forkIO action add tset newtid go q tset ref
Network/Wai/Handler/Warp/HTTP2/Receiver.hs view
@@ -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
Network/Wai/Handler/Warp/HTTP2/Sender.hs view
@@ -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)) ----------------------------------------------------------------
Network/Wai/Handler/Warp/HTTP2/Types.hs view
@@ -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
Network/Wai/Handler/Warp/HTTP2/Worker.hs view
@@ -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 ----------------------------------------------------------------
Network/Wai/Handler/Warp/IO.hs view
@@ -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) */
Network/Wai/Handler/Warp/Response.hs view
@@ -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
Network/Wai/Handler/Warp/Settings.hs view
@@ -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
test/RunSpec.hs view
@@ -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"
warp.cabal view
@@ -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