warp 3.2.6 → 3.2.7
raw patch · 14 files changed
+577/−202 lines, 14 filesdep ~auto-updatedep ~criteriondep ~network
Dependency ranges changed: auto-update, criterion, network, unix-compat
Files
- ChangeLog.md +7/−0
- Network/Wai/Handler/Warp.hs +58/−4
- Network/Wai/Handler/Warp/HTTP2/HPACK.hs +32/−18
- Network/Wai/Handler/Warp/HTTP2/Receiver.hs +76/−61
- Network/Wai/Handler/Warp/HTTP2/Request.hs +49/−9
- Network/Wai/Handler/Warp/HTTP2/Sender.hs +91/−39
- Network/Wai/Handler/Warp/HTTP2/Types.hs +94/−19
- Network/Wai/Handler/Warp/HTTP2/Worker.hs +96/−19
- Network/Wai/Handler/Warp/Response.hs +0/−2
- Network/Wai/Handler/Warp/Run.hs +24/−19
- Network/Wai/Handler/Warp/Settings.hs +11/−0
- Network/Wai/Handler/Warp/WithApplication.hs +20/−4
- bench/Parser.hs +6/−6
- warp.cabal +13/−2
ChangeLog.md view
@@ -1,3 +1,10 @@+## 3.2.7++* Adding new APIs for HTTP/2 server push: getHTTP2Data and setHTTP2Data [#510](https://github.com/yesodweb/wai/pull/510)+* Better accept(2) error handling [#553](https://github.com/yesodweb/wai/pull/553)+* Adding getGracefulShutdownTimeout.+* Add {test,}withApplicationSettings [#531](https://github.com/yesodweb/wai/pull/531)+ ## 3.2.6 * Using token based APIs of http2 1.6.
Network/Wai/Handler/Warp.hs view
@@ -70,12 +70,15 @@ , setSlowlorisSize , setHTTP2Disabled , setLogger+ , setServerPushLogger+ , setGracefulShutdownTimeout -- ** Getters , getPort , getHost , getOnOpen , getOnClose , getOnException+ , getGracefulShutdownTimeout -- ** Exception handler , defaultOnException , defaultShouldDisplayException@@ -91,10 +94,26 @@ , FileInfo(..) , getFileInfo , withApplication+ , withApplicationSettings , testWithApplication+ , testWithApplicationSettings , openFreePort -- * Version , warpVersion+ -- * HTTP/2+ -- ** HTTP2 data+ , HTTP2Data+ , http2dataPushPromise+ , defaultHTTP2Data+ , getHTTP2Data+ , setHTTP2Data+ -- ** Push promise+ , PushPromise+ , promisedPath+ , promisedFile+ , promisedResponseHeaders+ , promisedWeight+ , defaultPushPromise ) where import Control.Exception (SomeException, throwIO)@@ -110,6 +129,8 @@ import Network.Wai.Handler.Warp.Response (warpVersion) import Network.Wai.Handler.Warp.Run import Network.Wai.Handler.Warp.Settings+import Network.Wai.Handler.Warp.HTTP2.Request (getHTTP2Data, setHTTP2Data)+import Network.Wai.Handler.Warp.HTTP2.Types import Network.Wai.Handler.Warp.Timeout import Network.Wai.Handler.Warp.Types hiding (getFileInfo) import Network.Wai.Handler.Warp.WithApplication@@ -134,9 +155,18 @@ setOnException x y = y { settingsOnException = x } -- | A function to create a `Response` when an exception occurs.--- -- Default: 'defaultOnExceptionResponse' --+-- Note that an application can handle its own exceptions without interfering with Warp:+--+-- > myApp :: Application+-- > myApp request respond = innerApp `catch` onError+-- > where+-- > onError = respond . response500 request+-- >+-- > response500 :: Request -> SomeException -> Response+-- > response500 req someEx = responseLBS status500 -- ...+-- -- Since 2.1.0 setOnExceptionResponse :: (SomeException -> Response) -> Settings -> Settings setOnExceptionResponse x y = y { settingsOnExceptionResponse = x }@@ -242,6 +272,12 @@ getOnException :: Settings -> Maybe Request -> SomeException -> IO () getOnException = settingsOnException +-- | Get the graceful shutdown timeout+--+-- Since 3.2.8+getGracefulShutdownTimeout :: Settings -> Maybe Int+getGracefulShutdownTimeout = settingsGracefulShutdownTimeout+ -- | A code to install shutdown handler. -- -- For instance, this code should set up a UNIX signal@@ -338,12 +374,30 @@ setHTTP2Disabled :: Settings -> Settings setHTTP2Disabled y = y { settingsHTTP2Enabled = False } --- | Setting a log function. `Integer` is the body length of a response.+-- | Setting a log function. -- -- Since 3.X.X-setLogger :: (Request -> H.Status -> Maybe Integer -> IO ())- -> Settings -> Settings+setLogger :: (Request -> H.Status -> Maybe Integer -> IO ()) -- ^ request, status, maybe file-size+ -> Settings+ -> Settings setLogger lgr y = y { settingsLogger = lgr }++-- | Setting a log function for HTTP/2 server push.+--+-- Since: 3.2.7+setServerPushLogger :: (Request -> ByteString -> Integer -> IO ()) -- ^ request, path, file-size+ -> Settings+ -> Settings+setServerPushLogger lgr y = y { settingsServerPushLogger = lgr }++-- | Set the graceful shutdown timeout. A timeout of `Nothing' will+-- wait indefinitely, and a number, if provided, will be treated as seconds+-- to wait for requests to finish, before shutting down the server entirely.+--+-- Since 3.2.8+setGracefulShutdownTimeout :: Maybe Int+ -> Settings -> Settings+setGracefulShutdownTimeout time y = y { settingsGracefulShutdownTimeout = time } -- | Explicitly pause the slowloris timeout. --
Network/Wai/Handler/Warp/HTTP2/HPACK.hs view
@@ -6,6 +6,7 @@ , hpackEncodeHeaderLoop , hpackDecodeHeader , just+ , addNecessaryHeaders ) where import qualified Control.Exception as E@@ -13,7 +14,6 @@ import Data.ByteString (ByteString) import Network.HPACK hiding (Buffer) import Network.HPACK.Token-import qualified Network.HTTP.Types as H import Network.HTTP2 import Network.Wai.Handler.Warp.HTTP2.Types import Network.Wai.Handler.Warp.PackInt@@ -23,31 +23,45 @@ -- $setup -- >>> :set -XOverloadedStrings +----------------------------------------------------------------++{-# INLINE addHeader #-}+addHeader :: Token -> ByteString -> ValueTable -> TokenHeaderList -> TokenHeaderList+addHeader t v tbl ths = case getHeaderValue t tbl of+ Nothing -> (t,v) : ths+ Just _ -> ths++addNecessaryHeaders :: Context+ -> Rspn+ -> InternalInfo+ -> S.Settings+ -> IO TokenHeaderList+addNecessaryHeaders Context{..} rspn ii settings = do+ date <- getDate ii+ let !s = rspnStatus rspn+ !status = packStatus s+ !defServer = S.settingsServerName settings+ (!ths0,tbl) = rspnHeaders rspn+ !ths1 = addHeader tokenServer defServer tbl ths0+ !ths2 = addHeader tokenDate date tbl ths1+ !ths3 = (tokenStatus, status) : ths2+ return ths3++----------------------------------------------------------------+ strategy :: EncodeStrategy strategy = EncodeStrategy { compressionAlgo = Linear, useHuffman = False } -- Set-Cookie: contains only one cookie value. -- So, we don't need to split it. hpackEncodeHeader :: Context -> Buffer -> BufSize- -> InternalInfo -> S.Settings- -> H.Status -> (TokenHeaderList,ValueTable)+ -> TokenHeaderList -> IO (TokenHeaderList, Int)-hpackEncodeHeader Context{..} buf siz ii settings s (ths0,tbl) = do- let !defServer = S.settingsServerName settings- !ths1 = addHeader tokenServer defServer tbl ths0- date <- getDate ii- let !ths2 = addHeader tokenDate date tbl ths1- !status = packStatus s- !ths3 = (tokenStatus, status) : ths2- encodeTokenHeader buf siz strategy True encodeDynamicTable ths3--{-# INLINE addHeader #-}-addHeader :: Token -> ByteString -> ValueTable -> TokenHeaderList -> TokenHeaderList-addHeader t v tbl ths = case getHeaderValue t tbl of- Nothing -> (t,v) : ths- Just _ -> ths+hpackEncodeHeader Context{..} buf siz ths =+ encodeTokenHeader buf siz strategy True encodeDynamicTable ths -hpackEncodeHeaderLoop :: Context -> Buffer -> BufSize -> TokenHeaderList+hpackEncodeHeaderLoop :: Context -> Buffer -> BufSize+ -> TokenHeaderList -> IO (TokenHeaderList, Int) hpackEncodeHeaderLoop Context{..} buf siz hs = encodeTokenHeader buf siz strategy False encodeDynamicTable hs
Network/Wai/Handler/Warp/HTTP2/Receiver.hs view
@@ -36,13 +36,13 @@ , streamTable , concurrency , continued- , currentStreamId+ , clientStreamId , inputQ , controlQ } = ctx sendGoaway e | Just (ConnectionError err msg) <- E.fromException e = do- csid <- readIORef currentStreamId+ csid <- readIORef clientStreamId let !frame = goawayFrame csid err msg enqueueControl controlQ $ CGoaway frame | otherwise = return ()@@ -64,8 +64,10 @@ cont <- processStreamGuardingError $ decodeFrameHeader hd when cont $ loop (n + 1) - processStreamGuardingError (_, FrameHeader{streamId})- | isResponse streamId = E.throwIO $ ConnectionError ProtocolError "stream id should be odd"+ processStreamGuardingError (fid, FrameHeader{streamId})+ | isResponse streamId &&+ (fid `notElem` [FramePriority,FrameRSTStream,FrameWindowUpdate]) =+ E.throwIO $ ConnectionError ProtocolError "stream id should be odd" processStreamGuardingError (FrameUnknown _, FrameHeader{payloadLength}) = do mx <- readIORef continued case mx of@@ -100,38 +102,46 @@ control ftyp header pl ctx | otherwise = do checkContinued- !strm@Stream{streamState,streamContentLength,streamPrecedence} <- getStream+ !mstrm <- getStream pl <- recvN payloadLength- state <- readIORef streamState- state' <- stream ftyp header pl ctx state strm- case state' of- Open (NoBody tbl@(_,reqvt) pri) -> do- resetContinued- let mcl = readInt <$> getHeaderValue tokenContentLength reqvt- when (just mcl (== (0 :: Int))) $- E.throwIO $ StreamError ProtocolError streamId- writeIORef streamPrecedence $ toPrecedence pri- writeIORef streamState HalfClosed- let (!req, !ii) = mkreq tbl (return "")- atomically $ writeTQueue inputQ $ Input strm req reqvt ii- Open (HasBody tbl@(_,reqvt) pri) -> do- resetContinued- q <- newTQueueIO- writeIORef streamPrecedence $ toPrecedence pri- writeIORef streamState (Open (Body q))- let mcl = readInt <$> getHeaderValue tokenContentLength reqvt- writeIORef streamContentLength mcl- readQ <- newReadBody q- bodySource <- mkSource readQ- let (!req, !ii) = mkreq tbl (readSource bodySource)- atomically $ writeTQueue inputQ $ Input strm req reqvt ii- s@(Open Continued{}) -> do- setContinued- writeIORef streamState s- s -> do -- Idle, Open Body, HalfClosed, Closed- resetContinued- writeIORef streamState s- return True+ case mstrm of+ Nothing -> do+ -- for h2spec only+ when (ftyp == FramePriority) $ do+ PriorityFrame newpri <- guardIt $ decodePriorityFrame header pl+ checkPriority newpri streamId+ return True -- just ignore this frame+ Just strm@Stream{streamState,streamPrecedence} -> do+ state <- readIORef streamState+ state' <- stream ftyp header pl ctx state strm+ case state' of+ Open (NoBody tbl@(_,reqvt) pri) -> do+ resetContinued+ let mcl = readInt <$> getHeaderValue tokenContentLength reqvt+ when (just mcl (== (0 :: Int))) $+ E.throwIO $ StreamError ProtocolError streamId+ writeIORef streamPrecedence $ toPrecedence pri+ writeIORef streamState HalfClosed+ (!req, !ii) <- mkreq tbl (return "")+ atomically $ writeTQueue inputQ $ Input strm req reqvt ii+ Open (HasBody tbl@(_,reqvt) pri) -> do+ resetContinued+ q <- newTQueueIO+ let !mcl = readInt <$> getHeaderValue tokenContentLength reqvt+ writeIORef streamPrecedence $ toPrecedence pri+ bodyLength <- newIORef 0+ writeIORef streamState $ Open (Body q mcl bodyLength)+ readQ <- newReadBody q+ bodySource <- mkSource readQ+ (!req, !ii) <- mkreq tbl (readSource bodySource)+ atomically $ writeTQueue inputQ $ Input strm req reqvt ii+ s@(Open Continued{}) -> do+ setContinued+ writeIORef streamState s+ s -> do -- Idle, Open Body, HalfClosed, Closed+ resetContinued+ writeIORef streamState s+ return True where setContinued = writeIORef continued (Just streamId) resetContinued = writeIORef continued Nothing@@ -145,33 +155,38 @@ getStream = do mstrm0 <- search streamTable streamId case mstrm0 of- Just strm0 -> do+ js@(Just strm0) -> do when (ftyp == FrameHeaders) $ do st <- readIORef $ streamState strm0 when (isHalfClosed st) $ E.throwIO $ ConnectionError StreamClosed "header must not be sent to half closed"- return strm0- Nothing -> do- -- checkme- when (ftyp `notElem` [FrameHeaders,FramePriority]) $- E.throwIO $ ConnectionError ProtocolError "this frame is not allowed in an idel stream"- csid <- readIORef currentStreamId- when (streamId <= csid) $- E.throwIO $ ConnectionError ProtocolError "stream identifier must not decrease"- when (ftyp == FrameHeaders) $ do- writeIORef currentStreamId streamId- cnt <- readIORef concurrency- when (cnt >= recommendedConcurrency) $- E.throwIO $ StreamError RefusedStream streamId- ws <- initialWindowSize <$> readIORef http2settings- newstrm <- newStream streamId (fromIntegral ws)- when (ftyp == FrameHeaders) $ opened ctx newstrm- insert streamTable streamId newstrm- return newstrm+ return js+ Nothing+ | isResponse streamId -> return Nothing+ | otherwise -> do+ when (ftyp `notElem` [FrameHeaders,FramePriority]) $+ E.throwIO $ ConnectionError ProtocolError "this frame is not allowed in an idel stream"+ csid <- readIORef clientStreamId+ when (streamId <= csid) $+ E.throwIO $ ConnectionError ProtocolError "stream identifier must not decrease"+ when (ftyp == FrameHeaders) $ do+ writeIORef clientStreamId streamId+ cnt <- readIORef concurrency+ -- Checking the limitation of concurrency+ when (cnt >= maxConcurrency) $+ E.throwIO $ StreamError RefusedStream streamId+ ws <- initialWindowSize <$> readIORef http2settings+ newstrm <- newStream streamId (fromIntegral ws)+ when (ftyp == FrameHeaders) $ opened ctx newstrm+ insert streamTable streamId newstrm+ return $ Just newstrm consume = void . recvN +maxConcurrency :: Int+maxConcurrency = recommendedConcurrency+ initialFrame :: ByteString-initialFrame = settingsFrame id [(SettingsMaxConcurrentStreams,recommendedConcurrency)]+initialFrame = settingsFrame id [(SettingsMaxConcurrentStreams,maxConcurrency)] ---------------------------------------------------------------- @@ -181,6 +196,7 @@ case checkSettingsList alist of Just x -> E.throwIO x Nothing -> return ()+ -- HTTP/2 Setting from a browser unless (testAck flags) $ do modifyIORef' http2settings $ \old -> updateSettings old alist let !frame = settingsFrame setAck []@@ -252,7 +268,7 @@ let !siz = BS.length frag return $ Open $ Continued [frag] siz 1 endOfStream pri -stream FrameHeaders header@FrameHeader{flags} bs _ (Open (Body q)) _ = do+stream FrameHeaders header@FrameHeader{flags} bs _ (Open (Body q _ _)) _ = do -- trailer is not supported. -- let's read and ignore it. HeadersFrame _ _ <- guardIt $ decodeHeadersFrame header bs@@ -267,13 +283,13 @@ stream FrameData header@FrameHeader{flags,payloadLength,streamId} bs- Context{controlQ} s@(Open (Body q))- Stream{streamNumber,streamBodyLength,streamContentLength} = do+ Context{controlQ} s@(Open (Body q mcl bodyLength))+ Stream{streamNumber} = do DataFrame body <- guardIt $ decodeDataFrame header bs let !endOfStream = testEndStream flags- len0 <- readIORef streamBodyLength+ len0 <- readIORef bodyLength let !len = len0 + payloadLength- writeIORef streamBodyLength len+ writeIORef bodyLength len when (payloadLength /= 0) $ do let !frame1 = windowUpdateFrame 0 payloadLength !frame2 = windowUpdateFrame streamNumber payloadLength@@ -281,7 +297,6 @@ enqueueControl controlQ $ CFrame frame atomically $ writeTQueue q body if endOfStream then do- mcl <- readIORef streamContentLength case mcl of Nothing -> return () Just cl -> when (cl /= len) $ E.throwIO $ StreamError ProtocolError streamId
Network/Wai/Handler/Warp/HTTP2/Request.hs view
@@ -4,6 +4,8 @@ module Network.Wai.Handler.Warp.HTTP2.Request ( mkRequest , MkReq+ , getHTTP2Data+ , setHTTP2Data ) where import Control.Applicative ((<|>))@@ -19,16 +21,25 @@ import Network.Wai import Network.Wai.Handler.Warp.HTTP2.Types import Network.Wai.Handler.Warp.HashMap (hashByteString)+import Network.Wai.Handler.Warp.IORef import Network.Wai.Handler.Warp.Request (pauseTimeoutKey, getFileInfoKey) import qualified Network.Wai.Handler.Warp.Settings as S (Settings, settingsNoParsePath) import qualified Network.Wai.Handler.Warp.Timeout as Timeout import Network.Wai.Handler.Warp.Types import Network.Wai.Internal (Request(..))+import System.IO.Unsafe (unsafePerformIO) -type MkReq = (TokenHeaderList,ValueTable) -> IO ByteString -> (Request,InternalInfo)+type MkReq = (TokenHeaderList,ValueTable) -> IO ByteString -> IO (Request,InternalInfo) mkRequest :: InternalInfo1 -> S.Settings -> SockAddr -> MkReq-mkRequest ii1 settings addr (reqths,reqvt) body = (req,ii)+mkRequest ii1 settings addr (reqths,reqvt) body = do+ ref <- newIORef Nothing+ mkRequest' ii1 settings addr ref (reqths,reqvt) body++mkRequest' :: InternalInfo1 -> S.Settings -> SockAddr+ -> IORef (Maybe HTTP2Data)+ -> MkReq+mkRequest' ii1 settings addr ref (reqths,reqvt) body = return (req,ii) where !req = Request { requestMethod = colonMethod@@ -43,7 +54,7 @@ , requestBody = body , vault = vaultValue , requestBodyLength = ChunkedBody -- fixme- , requestHeaderHost = mHost+ , requestHeaderHost = mHost <|> mAuth , requestHeaderRange = mRange , requestHeaderReferer = mReferer , requestHeaderUserAgent = mUserAgent@@ -51,13 +62,14 @@ headers = map (first tokenKey) ths where ths = case mHost of- Nothing -> (tokenHost, colonAuth) : reqths Just _ -> reqths- !colonPath = fromJust $ getHeaderValue tokenPath reqvt- !colonMethod = fromJust $ getHeaderValue tokenMethod reqvt- !mAuth = getHeaderValue tokenAuthority reqvt- !colonAuth = fromJust $ mAuth- !mHost = getHeaderValue tokenHost reqvt <|> mAuth+ Nothing -> case mAuth of+ Just auth -> (tokenHost, auth) : reqths+ _ -> reqths+ !colonPath = fromJust $ getHeaderValue tokenPath reqvt -- MUST+ !colonMethod = fromJust $ getHeaderValue tokenMethod reqvt -- MUST+ !mAuth = getHeaderValue tokenAuthority reqvt -- SHOULD+ !mHost = getHeaderValue tokenHost reqvt !mRange = getHeaderValue tokenRange reqvt !mReferer = getHeaderValue tokenReferer reqvt !mUserAgent = getHeaderValue tokenUserAgent reqvt@@ -69,4 +81,32 @@ !th = threadHandle ii !vaultValue = Vault.insert pauseTimeoutKey (Timeout.pause th) $ Vault.insert getFileInfoKey (getFileInfo ii)+ $ Vault.insert getHTTP2DataKey (readIORef ref)+ $ Vault.insert setHTTP2DataKey (writeIORef ref) Vault.empty++getHTTP2DataKey :: Vault.Key (IO (Maybe HTTP2Data))+getHTTP2DataKey = unsafePerformIO Vault.newKey+{-# NOINLINE getHTTP2Data #-}++-- | Getting 'HTTP2Data' through vault of the request.+-- Warp uses this to receive 'HTTP2Data' from 'Middleware'.+--+-- Since: 3.2.7+getHTTP2Data :: Request -> IO (Maybe HTTP2Data)+getHTTP2Data req = case Vault.lookup getHTTP2DataKey (vault req) of+ Nothing -> return Nothing+ Just getter -> getter++setHTTP2DataKey :: Vault.Key (Maybe HTTP2Data -> IO ())+setHTTP2DataKey = unsafePerformIO Vault.newKey+{-# NOINLINE setHTTP2Data #-}++-- | Setting 'HTTP2Data' through vault of the request.+-- 'Middleware' should use this.+--+-- Since: 3.2.7+setHTTP2Data :: Request -> Maybe HTTP2Data -> IO ()+setHTTP2Data req mh2d = case Vault.lookup setHTTP2DataKey (vault req) of+ Nothing -> return ()+ Just setter -> setter mh2d
Network/Wai/Handler/Warp/HTTP2/Sender.hs view
@@ -10,11 +10,14 @@ import Control.Concurrent.STM import qualified Control.Exception as E import Control.Monad (void, when)+import Data.Bits import qualified Data.ByteString as BS import Data.ByteString.Builder (Builder) import qualified Data.ByteString.Builder.Extra as B import Data.Maybe (isNothing)-import Foreign.Ptr+import Data.Word (Word8, Word32)+import Foreign.Ptr (Ptr, plusPtr)+import Foreign.Storable (poke) import Network.HPACK (setLimitForEncoding) import Network.HTTP2 import Network.HTTP2.Priority (isEmptySTM, dequeueSTM, Precedence)@@ -49,14 +52,14 @@ getStreamWindowSize Stream{streamWindow} = atomically $ readTVar streamWindow {-# INLINE waitStreamWindowSize #-}-waitStreamWindowSize :: Stream -> STM ()-waitStreamWindowSize Stream{streamWindow} = do+waitStreamWindowSize :: Stream -> IO ()+waitStreamWindowSize Stream{streamWindow} = atomically $ do w <- readTVar streamWindow check (w > 0) {-# INLINE waitStreaming #-}-waitStreaming :: TBQueue a -> STM ()-waitStreaming tbq = do+waitStreaming :: TBQueue a -> IO ()+waitStreaming tbq = atomically $ do isEmpty <- isEmptyTBQueue tbq check (isEmpty == False) @@ -92,7 +95,7 @@ O (_,pre,out) -> do let strm = outputStream out writeIORef (streamPrecedence strm) pre- off' <- whenReadyOrEnqueueAgain out off $ output out off+ off' <- outputOrEnqueueAgain out off case off' of 0 -> loop 0 _ | off' > 15872 -> flushN off' >> loop 0 -- fixme: hard-coding@@ -119,22 +122,23 @@ Nothing -> return () Just siz -> setLimitForEncoding siz encodeDynamicTable - output (ONext strm curr mtbq) off0 lim = do+ output (ONext strm curr mtbq tell) off0 lim = do -- Data frame payload let !buf = connWriteBuffer `plusPtr` off0 !siz = connBufferSize - off0 Next datPayloadLen mnext <- curr buf siz lim- off <- fillDataHeader strm off0 datPayloadLen mnext- maybeEnqueueNext strm mtbq mnext+ off <- fillDataHeader strm off0 datPayloadLen mnext tell+ maybeEnqueueNext strm mtbq mnext tell return off - output (ORspn strm rspn ii) off0 lim = do+ output (ORspn strm rspn ii tell) off0 lim = do -- Header frame and Continuation frame- let sid = streamNumber strm- endOfStream = case rspn of+ let !sid = streamNumber strm+ !endOfStream = case rspn of RspnNobody _ _ -> True _ -> False- kvlen <- headerContinue sid rspn endOfStream off0 ii+ ths <- addNecessaryHeaders ctx rspn ii settings+ kvlen <- headerContinue sid ths endOfStream off0 off <- sendHeadersIfNecessary $ off0 + frameHeaderLength + kvlen case rspn of RspnNobody _ _ -> do@@ -145,32 +149,48 @@ let payloadOff = off + frameHeaderLength Next datPayloadLen mnext <- fillFileBodyGetNext conn ii payloadOff lim path mpart- off' <- fillDataHeader strm off datPayloadLen mnext- maybeEnqueueNext strm Nothing mnext+ off' <- fillDataHeader strm off datPayloadLen mnext tell+ maybeEnqueueNext strm Nothing mnext tell return off' RspnBuilder _ _ builder -> do -- Data frame payload let payloadOff = off + frameHeaderLength Next datPayloadLen mnext <- fillBuilderBodyGetNext conn ii payloadOff lim builder- off' <- fillDataHeader strm off datPayloadLen mnext- maybeEnqueueNext strm Nothing mnext+ off' <- fillDataHeader strm off datPayloadLen mnext tell+ maybeEnqueueNext strm Nothing mnext tell return off' RspnStreaming _ _ tbq -> do let payloadOff = off + frameHeaderLength Next datPayloadLen mnext <- fillStreamBodyGetNext conn payloadOff lim tbq strm- off' <- fillDataHeader strm off datPayloadLen mnext- maybeEnqueueNext strm (Just tbq) mnext+ off' <- fillDataHeader strm off datPayloadLen mnext tell+ maybeEnqueueNext strm (Just tbq) mnext tell return off' - whenReadyOrEnqueueAgain out off body = E.handle resetStream $ do+ output (OPush strm ths rspn ii tell pid) off0 lim = do+ -- Creating a push promise header+ -- Frame id should be associated stream id from the client.+ let !sid = streamNumber strm+ len <- pushPromise pid sid ths off0+ off <- sendHeadersIfNecessary $ off0 + frameHeaderLength + len+ output (ORspn strm rspn ii tell) off lim++ output _ _ _ = undefined -- never reach++ outputOrEnqueueAgain out off = E.handle resetStream $ do state <- readIORef $ streamState strm if isClosed state then return off- else case mtbq of- Just tbq -> checkStreaming tbq- _ -> checkStreamWindowSize+ else case out of+ OWait strm' rsp ii wait -> do+ -- Checking if all push are done.+ let out' = ORspn strm' rsp ii (return ())+ forkAndEnqueueWhenReady wait outputQ out' mgr+ return off+ _ -> case mtbq of+ Just tbq -> checkStreaming tbq+ _ -> checkStreamWindowSize where strm = outputStream out mtbq = outputMaybeTBQueue out@@ -189,7 +209,7 @@ else do cws <- atomically $ readTVar connectionWindow -- not 0 let !lim = min cws sws- body lim+ output out off lim resetStream e = do closed ctx strm (ResetByMe e) let !rst = resetFrame InternalError $ streamNumber strm@@ -202,13 +222,11 @@ flushN :: Int -> IO () flushN n = bufferIO connWriteBuffer n connSendAll - headerContinue sid rspn endOfStream off ii = do- let !s = rspnStatus rspn- !h = rspnHeaders rspn+ headerContinue sid ths endOfStream off = do let !offkv = off + frameHeaderLength let !bufkv = connWriteBuffer `plusPtr` offkv !limkv = connBufferSize - offkv- (hs,kvlen) <- hpackEncodeHeader ctx bufkv limkv ii settings s h+ (hs,kvlen) <- hpackEncodeHeader ctx bufkv limkv ths let flag0 = case hs of [] -> setEndHeader defaultFlags _ -> defaultFlags@@ -221,24 +239,25 @@ !headerPayloadLim = connBufferSize - frameHeaderLength continue _ kvlen [] = return kvlen- continue sid kvlen hs = do+ continue sid kvlen ths = do flushN $ kvlen + frameHeaderLength -- Now off is 0- (hs', kvlen') <- hpackEncodeHeaderLoop ctx bufHeaderPayload headerPayloadLim hs- when (hs == hs') $ E.throwIO $ ConnectionError CompressionError "cannot compress the header"- let flag = case hs' of+ (ths', kvlen') <- hpackEncodeHeaderLoop ctx bufHeaderPayload headerPayloadLim ths+ when (ths == ths') $ E.throwIO $ ConnectionError CompressionError "cannot compress the header"+ let flag = case ths' of [] -> setEndHeader defaultFlags _ -> defaultFlags fillFrameHeader FrameContinuation kvlen' sid flag connWriteBuffer- continue sid kvlen' hs'+ continue sid kvlen' ths' {-# INLINE maybeEnqueueNext #-} -- Re-enqueue the stream in the output queue.- maybeEnqueueNext :: Stream -> Maybe (TBQueue Sequence) -> Maybe DynaNext -> IO ()- maybeEnqueueNext _ _ Nothing = return ()- maybeEnqueueNext strm mtbq (Just next) = enqueueOutput outputQ out+ maybeEnqueueNext :: Stream -> Maybe (TBQueue Sequence)+ -> Maybe DynaNext -> IO () -> IO ()+ maybeEnqueueNext _ _ Nothing _ = return ()+ maybeEnqueueNext strm mtbq (Just next) tell = enqueueOutput outputQ out where- !out = ONext strm next mtbq+ !out = ONext strm next mtbq tell {-# INLINE sendHeadersIfNecessary #-} -- Send headers if there is not room for a 1-byte data frame, and return@@ -250,7 +269,7 @@ flushN off return 0 - fillDataHeader strm off datPayloadLen mnext = do+ fillDataHeader strm off datPayloadLen mnext tell = do -- Data frame header let !sid = streamNumber strm !buf = connWriteBuffer `plusPtr` off@@ -259,11 +278,27 @@ flag | done = setEndStream defaultFlags | otherwise = defaultFlags fillFrameHeader FrameData datPayloadLen sid flag buf- when done $ closed ctx strm Finished+ when done $ do+ void $ tell+ closed ctx strm Finished atomically $ modifyTVar' connectionWindow (subtract datPayloadLen) atomically $ modifyTVar' (streamWindow strm) (subtract datPayloadLen) return off' + pushPromise pid sid ths off = do+ let !offsid = off + frameHeaderLength+ !bufsid = connWriteBuffer `plusPtr` offsid+ poke32 bufsid $ fromIntegral sid+ let !offkv = offsid + 4+ !bufkv = connWriteBuffer `plusPtr` offkv+ !limkv = connBufferSize - offkv+ (_,kvlen) <- hpackEncodeHeader ctx bufkv limkv ths+ let !flag = setEndHeader defaultFlags -- No EndStream flag+ !buf = connWriteBuffer `plusPtr` off+ !len = kvlen + 4+ fillFrameHeader FramePushPromise len pid flag buf+ return len+ {-# INLINE fillFrameHeader #-} fillFrameHeader ftyp len sid flag buf = encodeFrameHeaderBuf ftyp hinfo buf where@@ -470,3 +505,20 @@ mini i n | fromIntegral i < n = i | otherwise = fromIntegral n+++----------------------------------------------------------------++poke32 :: Ptr Word8 -> Word32 -> IO ()+poke32 ptr i = do+ poke ptr w0+ poke8 ptr 1 w1+ poke8 ptr 2 w2+ poke8 ptr 3 w3+ where+ w0 = fromIntegral ((i `shiftR` 24) .&. 0xff)+ w1 = fromIntegral ((i `shiftR` 16) .&. 0xff)+ w2 = fromIntegral ((i `shiftR` 8) .&. 0xff)+ w3 = fromIntegral (i .&. 0xff)+ poke8 :: Ptr Word8 -> Int -> Word8 -> IO ()+ poke8 ptr0 n w = poke (ptr0 `plusPtr` n) w
Network/Wai/Handler/Warp/HTTP2/Types.hs view
@@ -68,17 +68,27 @@ rspnHeaders (RspnBuilder _ t _) = t rspnHeaders (RspnFile _ t _ _ ) = t -data Output = ORspn !Stream !Rspn !InternalInfo- | ONext !Stream !DynaNext !(Maybe (TBQueue Sequence))+data Output = ORspn !Stream !Rspn !InternalInfo (IO ()) -- done+ | OWait !Stream !Rspn !InternalInfo (IO ()) -- done+ | OPush !Stream -- stream for this push from this server+ TokenHeaderList+ !Rspn {- RspnFile only-}+ !InternalInfo (IO ()) -- wait for done+ !StreamId -- associated stream id from client+ | ONext !Stream !DynaNext !(Maybe (TBQueue Sequence)) (IO ()) -- done outputStream :: Output -> Stream-outputStream (ORspn strm _ _) = strm-outputStream (ONext strm _ _) = strm+outputStream (ORspn strm _ _ _) = strm+outputStream (OPush strm _ _ _ _ _) = strm+outputStream (OWait strm _ _ _) = strm+outputStream (ONext strm _ _ _) = strm outputMaybeTBQueue :: Output -> Maybe (TBQueue Sequence)-outputMaybeTBQueue (ORspn _ (RspnStreaming _ _ tbq) _) = Just tbq-outputMaybeTBQueue (ORspn _ _ _) = Nothing-outputMaybeTBQueue (ONext _ _ mtbq) = mtbq+outputMaybeTBQueue (ORspn _ (RspnStreaming _ _ tbq) _ _) = Just tbq+outputMaybeTBQueue (ORspn _ _ _ _) = Nothing+outputMaybeTBQueue (OPush _ _ _ _ _ _) = Nothing+outputMaybeTBQueue (OWait _ _ _ _) = Nothing+outputMaybeTBQueue (ONext _ _ mtbq _) = mtbq data Control = CFinish | CGoaway !ByteString@@ -96,6 +106,7 @@ -- | The context for HTTP/2 connection. data Context = Context {+ -- HTTP/2 settings received from a browser http2settings :: !(IORef Settings) , firstSettings :: !(IORef Bool) , streamTable :: !StreamTable@@ -106,12 +117,14 @@ -- frames that might follow". This field is used to implement -- this requirement. , continued :: !(IORef (Maybe StreamId))- , currentStreamId :: !(IORef StreamId)+ , clientStreamId :: !(IORef StreamId)+ , serverStreamId :: !(IORef StreamId) , inputQ :: !(TQueue Input) , outputQ :: !(PriorityTree Output) , controlQ :: !(TQueue Control) , encodeDynamicTable :: !DynamicTable , decodeDynamicTable :: !DynamicTable+ -- the connection window for data from a server to a browser. , connectionWindow :: !(TVar WindowSize) } @@ -125,6 +138,7 @@ <*> newIORef 0 <*> newIORef Nothing <*> newIORef 0+ <*> newIORef 0 <*> newTQueueIO <*> newPriorityTree <*> newTQueueIO@@ -147,6 +161,9 @@ | NoBody (TokenHeaderList,ValueTable) !Priority | HasBody (TokenHeaderList,ValueTable) !Priority | Body !(TQueue ByteString)+ !(Maybe Int) -- received Content-Length+ -- compared the body length for error checking+ !(IORef Int) -- actual body length data ClosedCode = Finished | Killed@@ -159,6 +176,7 @@ | Open !OpenState | HalfClosed | Closed !ClosedCode+ | Reserved isIdle :: StreamState -> Bool isIdle Idle = True@@ -181,17 +199,15 @@ show Open{} = "Open" show HalfClosed = "HalfClosed" show (Closed e) = "Closed: " ++ show e+ show Reserved = "Reserved" ---------------------------------------------------------------- data Stream = Stream {- streamNumber :: !StreamId- , streamState :: !(IORef StreamState)- -- Next two fields are for error checking.- , streamContentLength :: !(IORef (Maybe Int))- , streamBodyLength :: !(IORef Int)- , streamWindow :: !(TVar WindowSize)- , streamPrecedence :: !(IORef Precedence)+ streamNumber :: !StreamId+ , streamState :: !(IORef StreamState)+ , streamWindow :: !(TVar WindowSize)+ , streamPrecedence :: !(IORef Precedence) } instance Show Stream where@@ -199,11 +215,18 @@ newStream :: StreamId -> WindowSize -> IO Stream newStream sid win = Stream sid <$> newIORef Idle- <*> newIORef Nothing- <*> newIORef 0 <*> newTVarIO win <*> newIORef defaultPrecedence +newPushStream :: Context -> WindowSize -> Precedence -> IO Stream+newPushStream Context{serverStreamId} win pre = do+ sid <- atomicModifyIORef' serverStreamId inc2+ Stream sid <$> newIORef Reserved+ <*> newTVarIO win+ <*> newIORef pre+ where+ inc2 x = let !x' = x + 2 in (x', x')+ ---------------------------------------------------------------- opened :: Context -> Stream -> IO ()@@ -238,10 +261,10 @@ search (StreamTable ref) k = M.lookup k <$> readIORef ref {-# INLINE forkAndEnqueueWhenReady #-}-forkAndEnqueueWhenReady :: STM () -> PriorityTree Output -> Output -> Manager -> IO ()+forkAndEnqueueWhenReady :: IO () -> PriorityTree Output -> Output -> Manager -> IO () forkAndEnqueueWhenReady wait outQ out mgr = bracket setup teardown $ \_ -> void . forkIO $ do- atomically wait+ wait enqueueOutput outQ out where setup = addMyId mgr@@ -257,3 +280,55 @@ {-# INLINE enqueueControl #-} enqueueControl :: TQueue Control -> Control -> IO () enqueueControl ctlQ ctl = atomically $ writeTQueue ctlQ ctl++----------------------------------------------------------------++-- | HTTP/2 specific data.+--+-- Since: 3.2.7+newtype HTTP2Data = HTTP2Data {+ -- | Accessor for 'PushPromise' in 'HTTP2Data'.+ --+ -- Since: 3.2.7+ http2dataPushPromise :: [PushPromise]+ } deriving (Eq,Show)++-- | Default HTTP/2 specific data.+--+-- Since: 3.2.7+defaultHTTP2Data :: HTTP2Data+defaultHTTP2Data = HTTP2Data []++-- | HTTP/2 push promise or sever push.+--+-- Since: 3.2.7+data PushPromise = PushPromise {+ -- | Accessor for a URL path in 'PushPromise'.+ -- E.g. \"\/style\/default.css\".+ --+ -- Since: 3.2.7+ promisedPath :: ByteString+ -- | Accessor for 'FilePath' in 'PushPromise'.+ -- E.g. \"FILE_PATH/default.css\".+ --+ -- Since: 3.2.7+ , promisedFile :: FilePath+ -- | Accessor for 'H.ResponseHeaders' in 'PushPromise'+ -- \"content-type\" must be specified.+ -- Default value: [].+ --+ --+ -- Since: 3.2.7+ , promisedResponseHeaders :: H.ResponseHeaders+ -- | Accessor for 'Weight' in 'PushPromise'.+ -- Default value: 16.+ --+ -- Since: 3.2.7+ , promisedWeight :: Weight+ } deriving (Eq,Ord,Show)++-- | Default push promise.+--+-- Since: 3.2.7+defaultPushPromise :: PushPromise+defaultPushPromise = PushPromise "" "" [] 16
Network/Wai/Handler/Warp/HTTP2/Worker.hs view
@@ -15,6 +15,8 @@ import Control.Applicative import Data.Monoid (mempty) #endif+import Control.Applicative ((<|>))+import Data.Maybe (fromJust) import Control.Concurrent.STM import Control.Exception (SomeException(..), AsyncException(..)) import qualified Control.Exception as E@@ -22,13 +24,16 @@ import Data.ByteString.Builder (byteString) import qualified Network.HTTP.Types as H import Network.HTTP2+import Network.HTTP2.Priority import Network.HPACK+import Network.HPACK.Token import Network.Wai import Network.Wai.Handler.Warp.FileInfoCache import Network.Wai.Handler.Warp.HTTP2.EncodeFrame import Network.Wai.Handler.Warp.HTTP2.File import Network.Wai.Handler.Warp.HTTP2.Manager import Network.Wai.Handler.Warp.HTTP2.Types+import Network.Wai.Handler.Warp.HTTP2.Request import Network.Wai.Handler.Warp.IORef import qualified Network.Wai.Handler.Warp.Response as R import qualified Network.Wai.Handler.Warp.Settings as S@@ -41,32 +46,104 @@ -- | 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 = InternalInfo -> ValueTable ->- ThreadContinue -> Stream -> Request ->- Response -> IO ResponseReceived+type Responder = InternalInfo+ -> ValueTable -- for Request+ -> ThreadContinue+ -> Stream+ -> Request+ -> Response+ -> IO ResponseReceived +pushStream :: Context -> S.Settings+ -> StreamId -> ValueTable -> Request -> InternalInfo+ -> Maybe HTTP2Data+ -> IO (Stream -> Rspn -> InternalInfo -> IO () -> Output, IO ())+pushStream _ _ _ _ _ _ Nothing = return (ORspn, return ())+pushStream ctx@Context{http2settings,outputQ,streamTable}+ settings pid reqvt req ii (Just h2d)+ | len == 0 = return (ORspn, return ())+ | otherwise = do+ pushable <- enablePush <$> readIORef http2settings+ if pushable then do+ tvar <- newTVarIO 0+ lim <- push tvar pps0 0+ if lim == 0 then+ return (ORspn, return ())+ else+ return (OWait, waiter lim tvar)+ else+ return (ORspn, return ())+ where+ !pps0 = http2dataPushPromise h2d+ !len = length pps0+ !pushLogger = S.settingsServerPushLogger settings+ increment tvar = atomically $ modifyTVar' tvar (+1)+ waiter lim tvar = atomically $ do+ n <- readTVar tvar+ check (n >= lim)+ push _ [] !n = return (n :: Int)+ push tvar (pp:pps) !n = do+ let !file = promisedFile pp+ efinfo <- E.try $ getFileInfo ii file+ case efinfo of+ Left (_ex :: E.IOException) -> push tvar pps n+ Right (FileInfo _ size _ date) -> do+ ws <- initialWindowSize <$> readIORef http2settings+ let !w = promisedWeight pp+ !pri = defaultPriority { weight = w }+ !pre = toPrecedence pri+ strm <- newPushStream ctx ws pre+ let !sid = streamNumber strm+ insert streamTable sid strm+ (ths0, vt) <- toHeaderTable (promisedResponseHeaders pp)+ let !scheme = fromJust $ getHeaderValue tokenScheme reqvt+ -- fixme: this value can be Nothing+ !auth = fromJust (getHeaderValue tokenHost reqvt+ <|> getHeaderValue tokenAuthority reqvt)+ !path = promisedPath pp+ !promisedRequest = [(tokenMethod, H.methodGet)+ ,(tokenScheme, scheme)+ ,(tokenAuthority, auth)+ ,(tokenPath, path)]+ !part = FilePart 0 size size+ !rsp = RspnFile H.ok200 (ths,vt) file (Just part)+ !ths = (tokenLastModified,date) :+ addContentHeadersForFilePart ths0 part+ pushLogger req path size+ let out = OPush strm promisedRequest rsp ii (increment tvar) pid+ enqueueOutput outputQ out+ push tvar pps (n + 1)++ -- | 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 :: S.Settings -> Context -> Manager -> Responder-response settings Context{outputQ} mgr ii reqvt tconf strm req rsp = case rsp of+response settings ctx@Context{outputQ} mgr ii reqvt tconf strm req rsp = case rsp of ResponseStream s0 hs0 strmbdy | noBody s0 -> responseNoBody s0 hs0 | isHead -> responseNoBody s0 hs0- | otherwise -> responseStreaming s0 hs0 strmbdy+ | otherwise -> getHTTP2Data req+ >>= pushStream ctx settings sid reqvt req ii+ >>= responseStreaming s0 hs0 strmbdy ResponseBuilder s0 hs0 b | noBody s0 -> responseNoBody s0 hs0 | isHead -> responseNoBody s0 hs0- | otherwise -> responseBuilderBody s0 hs0 b+ | otherwise -> getHTTP2Data req+ >>= pushStream ctx settings sid reqvt req ii+ >>= responseBuilderBody s0 hs0 b ResponseFile s0 hs0 p mp | noBody s0 -> responseNoBody s0 hs0- | otherwise -> responseFileXXX s0 hs0 p mp+ | otherwise -> getHTTP2Data req+ >>= pushStream ctx settings sid reqvt req ii+ >>= responseFileXXX s0 hs0 p mp ResponseRaw _ _ -> error "HTTP/2 does not support ResponseRaw" where noBody = not . R.hasBody !isHead = requestMethod req == H.methodHead !logger = S.settingsLogger settings !th = threadHandle ii+ sid = streamNumber strm -- Ideally, log messages should be written when responses are -- actually sent. But there is no way to keep good memory usage@@ -80,20 +157,20 @@ logger req s Nothing setThreadContinue tconf True let rspn = RspnNobody s tbl- out = ORspn strm rspn ii+ out = ORspn strm rspn ii (return ()) enqueueOutput outputQ out return ResponseReceived - responseBuilderBody s hs0 bdy = do+ responseBuilderBody s hs0 bdy (rspnOrWait,tell) = do logger req s Nothing setThreadContinue tconf True tbl <- toHeaderTable hs0 let rspn = RspnBuilder s tbl bdy- out = ORspn strm rspn ii+ out = rspnOrWait strm rspn ii tell enqueueOutput outputQ out return ResponseReceived - responseFileXXX _ hs0 path Nothing = do+ responseFileXXX _ hs0 path Nothing aux = do efinfo <- E.try $ getFileInfo ii path case efinfo of Left (_ex :: E.IOException) -> response404 hs0@@ -101,13 +178,13 @@ (rspths0,vt) <- toHeaderTable hs0 case conditionalRequest finfo rspths0 reqvt of WithoutBody s -> responseNoBody s hs0- WithBody s rspths beg len -> responseFile2XX s (rspths,vt) path (Just (FilePart beg len (fileInfoSize finfo)))+ WithBody s rspths beg len -> responseFile2XX s (rspths,vt) path (Just (FilePart beg len (fileInfoSize finfo))) aux - responseFileXXX s0 hs0 path mpart = do+ responseFileXXX s0 hs0 path mpart aux = do tbl <- toHeaderTable hs0- responseFile2XX s0 tbl path mpart+ responseFile2XX s0 tbl path mpart aux - responseFile2XX s tbl path mpart+ responseFile2XX s tbl path mpart (rspnOrWait,tell) | isHead = do logger req s Nothing responseNoBody' s tbl@@ -115,17 +192,17 @@ logger req s (filePartByteCount <$> mpart) setThreadContinue tconf True let rspn = RspnFile s tbl path mpart- out = ORspn strm rspn ii+ out = rspnOrWait strm rspn ii tell enqueueOutput outputQ out return ResponseReceived - response404 hs0 = responseBuilderBody s hs body+ response404 hs0 = responseBuilderBody s hs body (ORspn, return ()) where s = H.notFound404 hs = R.replaceHeader H.hContentType "text/plain; charset=utf-8" hs0 body = byteString "File not found" - responseStreaming s0 hs0 strmbdy = do+ responseStreaming s0 hs0 strmbdy (rspnOrWait,tell) = do logger req s0 Nothing -- We must not exit this WAI application. -- If the application exits, streaming would be also closed.@@ -141,7 +218,7 @@ tbq <- newTBQueueIO 10 -- fixme: hard coding: 10 tbl <- toHeaderTable hs0 let rspn = RspnStreaming s0 tbl tbq- out = ORspn strm rspn ii+ out = rspnOrWait strm rspn ii tell enqueueOutput outputQ out let push b = do atomically $ writeTBQueue tbq (SBuilder b)
Network/Wai/Handler/Warp/Response.hs view
@@ -8,8 +8,6 @@ sendResponse , sanitizeHeaderValue -- for testing , warpVersion- , addDate- , addServer , hasBody , replaceHeader ) where
Network/Wai/Handler/Warp/Run.hs view
@@ -1,9 +1,10 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE PatternGuards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-}-{-# LANGUAGE PatternGuards #-}-{-# LANGUAGE BangPatterns #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} module Network.Wai.Handler.Warp.Run where@@ -12,16 +13,17 @@ import Control.Applicative ((<$>)) #endif import Control.Arrow (first)-import Control.Concurrent (threadDelay) import qualified Control.Concurrent as Conc (yield) import Control.Exception as E import Control.Monad (when, unless, void) import Data.ByteString (ByteString) import qualified Data.ByteString as S import Data.Char (chr)-import Data.IP (toHostAddress, toHostAddress6)+import "iproute" Data.IP (toHostAddress, toHostAddress6) import Data.IORef (IORef, newIORef, readIORef, writeIORef) import Data.Streaming.Network (bindPortTCP)+import Foreign.C.Error (Errno(..), eCONNABORTED)+import GHC.IO.Exception (IOException(..)) import Network (sClose, Socket) import Network.Socket (accept, withSocketsDo, SockAddr(SockAddrInet, SockAddrInet6), setSocketOption, SocketOption(..)) import qualified Network.Socket.ByteString as Sock@@ -43,7 +45,7 @@ import Network.Wai.Handler.Warp.Types import Network.Wai.Internal (ResponseReceived (ResponseReceived)) import System.Environment (getEnvironment)-import System.IO.Error (isFullErrorType, ioeGetErrorType)+import System.Timeout (timeout) #if WINDOWS import Network.Wai.Handler.Warp.Windows@@ -217,7 +219,7 @@ -- ensure that no async exception is throw between the call to -- acceptNewConnection and the registering of connClose. void $ mask_ acceptLoop- gracefulShutdown counter+ gracefulShutdown set counter where acceptLoop = do -- Allow async exceptions before receiving the next connection maker.@@ -241,17 +243,14 @@ ex <- try getConnMaker case ex of Right x -> return $ Just x- Left e -> do- settingsOnException set Nothing $ toException e- if isFullErrorType (ioeGetErrorType e) then do- -- "resource exhausted (Too many open files)" may- -- happen by accept(). Wait a second hoping that- -- resource will be available.- threadDelay 1000000- acceptNewConnection- else- -- Assuming the listen socket is closed.- return Nothing+ Left e -> do+ let eConnAborted = getErrno eCONNABORTED+ getErrno (Errno cInt) = cInt+ if ioe_errno e == Just eConnAborted+ then acceptNewConnection+ else do+ settingsOnException set Nothing $ toException e+ return Nothing -- Fork a new worker thread for this connection maker, and ask for a -- function to unmask (i.e., allow async exceptions to be thrown).@@ -497,5 +496,11 @@ setSocketCloseOnExec socket = F.setFileCloseOnExec $ fromIntegral $ fdSocket socket #endif -gracefulShutdown :: Counter -> IO ()-gracefulShutdown counter = waitForZero counter+gracefulShutdown :: Settings -> Counter -> IO ()+gracefulShutdown set counter =+ case settingsGracefulShutdownTimeout set of+ Nothing ->+ waitForZero counter+ (Just seconds) ->+ void (timeout (seconds * microsPerSecond) (waitForZero counter))+ where microsPerSecond = 1000000
Network/Wai/Handler/Warp/Settings.hs view
@@ -101,6 +101,15 @@ -- ^ A log function. Default: no action. -- -- Since 3.X.X.+ , settingsServerPushLogger :: Request -> ByteString -> Integer -> IO ()+ -- ^ A HTTP/2 server push log function. Default: no action.+ --+ -- Since 3.X.X.+ , settingsGracefulShutdownTimeout :: Maybe Int+ -- ^ An optional timeout to limit the time (in seconds) waiting for+ -- a graceful shutdown of the web server.+ --+ -- Since 3.2.8 } -- | Specify usage of the PROXY protocol.@@ -135,6 +144,8 @@ , settingsSlowlorisSize = 2048 , settingsHTTP2Enabled = True , settingsLogger = \_ _ _ -> return ()+ , settingsServerPushLogger = \_ _ _ -> return ()+ , settingsGracefulShutdownTimeout = Nothing } -- | Apply the logic provided by 'defaultOnException' to determine if an
Network/Wai/Handler/Warp/WithApplication.hs view
@@ -1,7 +1,9 @@ module Network.Wai.Handler.Warp.WithApplication ( withApplication,+ withApplicationSettings, testWithApplication,+ testWithApplicationSettings, openFreePort, withFreePort, ) where@@ -21,13 +23,21 @@ -- -- @since 3.2.4 withApplication :: IO Application -> (Port -> IO a) -> IO a-withApplication mkApp action = do+withApplication = withApplicationSettings defaultSettings++-- | 'withApplication' with given 'Settings'. This will ignore the port value+-- set by 'setPort' in 'Settings'.+--+-- @since 3.2.7+withApplicationSettings :: Settings -> IO Application -> (Port -> IO a) -> IO a+withApplicationSettings settings' mkApp action = do app <- mkApp withFreePort $ \ (port, sock) -> do started <- mkWaiter let settings =- defaultSettings{- settingsBeforeMainLoop = notify started ()+ settings' {+ settingsBeforeMainLoop+ = notify started () >> settingsBeforeMainLoop settings' } result <- race (runSettingsSocket settings sock app)@@ -50,7 +60,13 @@ -- -- @since 3.2.4 testWithApplication :: IO Application -> (Port -> IO a) -> IO a-testWithApplication mkApp action = do+testWithApplication = testWithApplicationSettings defaultSettings++-- | 'testWithApplication' with given 'Settings'.+--+-- @since 3.2.7+testWithApplicationSettings :: Settings -> IO Application -> (Port -> IO a) -> IO a+testWithApplicationSettings _settings mkApp action = do callingThread <- myThreadId app <- mkApp let wrappedApp request respond =
bench/Parser.hs view
@@ -32,15 +32,15 @@ defaultMain [ bgroup "requestLine1" [ bench "parseRequestLine3" $ whnf parseRequestLine3 requestLine1- , bench "parseRequestLine2" $ parseRequestLine2 requestLine1- , bench "parseRequestLine1" $ parseRequestLine1 requestLine1- , bench "parseRequestLine0" $ parseRequestLine0 requestLine1+ , bench "parseRequestLine2" $ whnfIO $ parseRequestLine2 requestLine1+ , bench "parseRequestLine1" $ whnfIO $ parseRequestLine1 requestLine1+ , bench "parseRequestLine0" $ whnfIO $ parseRequestLine0 requestLine1 ] , bgroup "requestLine2" [ bench "parseRequestLine3" $ whnf parseRequestLine3 requestLine2- , bench "parseRequestLine2" $ parseRequestLine2 requestLine2- , bench "parseRequestLine1" $ parseRequestLine1 requestLine2- , bench "parseRequestLine0" $ parseRequestLine0 requestLine2+ , bench "parseRequestLine2" $ whnfIO $ parseRequestLine2 requestLine2+ , bench "parseRequestLine1" $ whnfIO $ parseRequestLine1 requestLine2+ , bench "parseRequestLine0" $ whnfIO $ parseRequestLine0 requestLine2 ] ]
warp.cabal view
@@ -1,5 +1,5 @@ Name: warp-Version: 3.2.6+Version: 3.2.7 Synopsis: A fast, light-weight web server for WAI applications. License: MIT License-file: LICENSE@@ -185,11 +185,22 @@ Main-Is: Parser.hs HS-Source-Dirs: bench . Build-Depends: base+ , auto-update , bytestring- , criterion+ , containers+ , criterion >= 1+ , hashable+ , http-date , http-types , network , network+ , unix-compat++ if (os(linux) || os(freebsd) || os(darwin)) && flag(allow-sendfilefd)+ Cpp-Options: -DSENDFILEFD+ Build-Depends: unix+ if os(windows)+ Cpp-Options: -DWINDOWS Source-Repository head Type: git