Hello community, here is the log from the commit of package ghc-warp for openSUSE:Factory checked in at 2016-07-12 23:52:58 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-warp (Old) and /work/SRC/openSUSE:Factory/.ghc-warp.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-warp" Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-warp/ghc-warp.changes 2016-05-31 12:24:41.000000000 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-warp.new/ghc-warp.changes 2016-07-12 23:53:01.000000000 +0200 @@ -1,0 +2,9 @@ +Sun Jul 10 16:12:00 UTC 2016 - [email protected] + +- update to 3.2.7 +* Adding new APIs for HTTP/2 server push: getHTTP2Data and setHTTP2Data +* Better accept(2) error handling +* Adding getGracefulShutdownTimeout. +* Add {test,}withApplicationSettings + +------------------------------------------------------------------- Old: ---- warp-3.2.6.tar.gz New: ---- warp-3.2.7.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-warp.spec ++++++ --- /var/tmp/diff_new_pack.UlrmCW/_old 2016-07-12 23:53:03.000000000 +0200 +++ /var/tmp/diff_new_pack.UlrmCW/_new 2016-07-12 23:53:03.000000000 +0200 @@ -1,7 +1,7 @@ # # spec file for package ghc-warp # -# Copyright (c) 2015 SUSE LINUX GmbH, Nuernberg, Germany. +# Copyright (c) 2016 SUSE LINUX GmbH, Nuernberg, Germany. # # All modifications and additions to the file contributed by third parties # remain the property of their copyright owners, unless otherwise agreed @@ -21,7 +21,7 @@ %bcond_with tests Name: ghc-warp -Version: 3.2.6 +Version: 3.2.7 Release: 0 Summary: A fast, light-weight web server for WAI applications License: MIT ++++++ warp-3.2.6.tar.gz -> warp-3.2.7.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/warp-3.2.6/ChangeLog.md new/warp-3.2.7/ChangeLog.md --- old/warp-3.2.6/ChangeLog.md 2016-04-07 07:01:48.000000000 +0200 +++ new/warp-3.2.7/ChangeLog.md 2016-07-04 09:23:09.000000000 +0200 @@ -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. diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/warp-3.2.6/Network/Wai/Handler/Warp/HTTP2/HPACK.hs new/warp-3.2.7/Network/Wai/Handler/Warp/HTTP2/HPACK.hs --- old/warp-3.2.6/Network/Wai/Handler/Warp/HTTP2/HPACK.hs 2016-04-07 07:01:48.000000000 +0200 +++ new/warp-3.2.7/Network/Wai/Handler/Warp/HTTP2/HPACK.hs 2016-07-04 09:23:09.000000000 +0200 @@ -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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/warp-3.2.6/Network/Wai/Handler/Warp/HTTP2/Receiver.hs new/warp-3.2.7/Network/Wai/Handler/Warp/HTTP2/Receiver.hs --- old/warp-3.2.6/Network/Wai/Handler/Warp/HTTP2/Receiver.hs 2016-04-07 07:01:48.000000000 +0200 +++ new/warp-3.2.7/Network/Wai/Handler/Warp/HTTP2/Receiver.hs 2016-07-04 09:23:09.000000000 +0200 @@ -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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/warp-3.2.6/Network/Wai/Handler/Warp/HTTP2/Request.hs new/warp-3.2.7/Network/Wai/Handler/Warp/HTTP2/Request.hs --- old/warp-3.2.6/Network/Wai/Handler/Warp/HTTP2/Request.hs 2016-04-07 07:01:48.000000000 +0200 +++ new/warp-3.2.7/Network/Wai/Handler/Warp/HTTP2/Request.hs 2016-07-04 09:23:09.000000000 +0200 @@ -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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/warp-3.2.6/Network/Wai/Handler/Warp/HTTP2/Sender.hs new/warp-3.2.7/Network/Wai/Handler/Warp/HTTP2/Sender.hs --- old/warp-3.2.6/Network/Wai/Handler/Warp/HTTP2/Sender.hs 2016-04-07 07:01:48.000000000 +0200 +++ new/warp-3.2.7/Network/Wai/Handler/Warp/HTTP2/Sender.hs 2016-07-04 09:23:09.000000000 +0200 @@ -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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/warp-3.2.6/Network/Wai/Handler/Warp/HTTP2/Types.hs new/warp-3.2.7/Network/Wai/Handler/Warp/HTTP2/Types.hs --- old/warp-3.2.6/Network/Wai/Handler/Warp/HTTP2/Types.hs 2016-04-07 07:01:48.000000000 +0200 +++ new/warp-3.2.7/Network/Wai/Handler/Warp/HTTP2/Types.hs 2016-07-04 09:23:09.000000000 +0200 @@ -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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/warp-3.2.6/Network/Wai/Handler/Warp/HTTP2/Worker.hs new/warp-3.2.7/Network/Wai/Handler/Warp/HTTP2/Worker.hs --- old/warp-3.2.6/Network/Wai/Handler/Warp/HTTP2/Worker.hs 2016-04-07 07:01:48.000000000 +0200 +++ new/warp-3.2.7/Network/Wai/Handler/Warp/HTTP2/Worker.hs 2016-07-04 09:23:09.000000000 +0200 @@ -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) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/warp-3.2.6/Network/Wai/Handler/Warp/Response.hs new/warp-3.2.7/Network/Wai/Handler/Warp/Response.hs --- old/warp-3.2.6/Network/Wai/Handler/Warp/Response.hs 2016-04-07 07:01:48.000000000 +0200 +++ new/warp-3.2.7/Network/Wai/Handler/Warp/Response.hs 2016-07-04 09:23:09.000000000 +0200 @@ -8,8 +8,6 @@ sendResponse , sanitizeHeaderValue -- for testing , warpVersion - , addDate - , addServer , hasBody , replaceHeader ) where diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/warp-3.2.6/Network/Wai/Handler/Warp/Run.hs new/warp-3.2.7/Network/Wai/Handler/Warp/Run.hs --- old/warp-3.2.6/Network/Wai/Handler/Warp/Run.hs 2016-04-07 07:01:48.000000000 +0200 +++ new/warp-3.2.7/Network/Wai/Handler/Warp/Run.hs 2016-07-04 09:23:09.000000000 +0200 @@ -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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/warp-3.2.6/Network/Wai/Handler/Warp/Settings.hs new/warp-3.2.7/Network/Wai/Handler/Warp/Settings.hs --- old/warp-3.2.6/Network/Wai/Handler/Warp/Settings.hs 2016-04-07 07:01:48.000000000 +0200 +++ new/warp-3.2.7/Network/Wai/Handler/Warp/Settings.hs 2016-07-04 09:23:09.000000000 +0200 @@ -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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/warp-3.2.6/Network/Wai/Handler/Warp/WithApplication.hs new/warp-3.2.7/Network/Wai/Handler/Warp/WithApplication.hs --- old/warp-3.2.6/Network/Wai/Handler/Warp/WithApplication.hs 2016-04-07 07:01:48.000000000 +0200 +++ new/warp-3.2.7/Network/Wai/Handler/Warp/WithApplication.hs 2016-07-04 09:23:09.000000000 +0200 @@ -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 = diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/warp-3.2.6/Network/Wai/Handler/Warp.hs new/warp-3.2.7/Network/Wai/Handler/Warp.hs --- old/warp-3.2.6/Network/Wai/Handler/Warp.hs 2016-04-07 07:01:48.000000000 +0200 +++ new/warp-3.2.7/Network/Wai/Handler/Warp.hs 2016-07-04 09:23:09.000000000 +0200 @@ -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,13 +374,31 @@ 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. -- -- This is useful for cases where you partially consume a request body. For diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/warp-3.2.6/bench/Parser.hs new/warp-3.2.7/bench/Parser.hs --- old/warp-3.2.6/bench/Parser.hs 2016-04-07 07:01:48.000000000 +0200 +++ new/warp-3.2.7/bench/Parser.hs 2016-07-04 09:23:09.000000000 +0200 @@ -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 ] ] diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/warp-3.2.6/warp.cabal new/warp-3.2.7/warp.cabal --- old/warp-3.2.6/warp.cabal 2016-04-07 07:01:48.000000000 +0200 +++ new/warp-3.2.7/warp.cabal 2016-07-04 09:23:09.000000000 +0200 @@ -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
