diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,10 @@ +## 3.3.0 + +* Switching from the original implementation to HTTP/2 server library. + [#752](https://github.com/yesodweb/wai/pull/752) +* Breaking change: The type of `http2dataTrailers` is now + `HTTP2Data -> TrailersMaker`. + ## 3.2.28 * Using the Strict and StrictData language extensions for GHC >8. diff --git a/Network/Wai/Handler/Warp/HTTP2.hs b/Network/Wai/Handler/Warp/HTTP2.hs --- a/Network/Wai/Handler/Warp/HTTP2.hs +++ b/Network/Wai/Handler/Warp/HTTP2.hs @@ -1,69 +1,76 @@ -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE ScopedTypeVariables #-} -module Network.Wai.Handler.Warp.HTTP2 (isHTTP2, http2) where +module Network.Wai.Handler.Warp.HTTP2 (http2) where -import Control.Concurrent (forkIO, killThread) import qualified Control.Exception as E -import Network.HTTP2 +import qualified Network.HTTP2.Server as H2 import Network.Socket (SockAddr) import Network.Wai +import Network.Wai.Internal (ResponseReceived(..)) +import qualified System.TimeManager as T -import Network.Wai.Handler.Warp.HTTP2.EncodeFrame -import Network.Wai.Handler.Warp.HTTP2.Manager -import Network.Wai.Handler.Warp.HTTP2.Receiver +import Network.Wai.Handler.Warp.HTTP2.File +import Network.Wai.Handler.Warp.HTTP2.PushPromise import Network.Wai.Handler.Warp.HTTP2.Request -import Network.Wai.Handler.Warp.HTTP2.Sender -import Network.Wai.Handler.Warp.HTTP2.Types -import Network.Wai.Handler.Warp.HTTP2.Worker +import Network.Wai.Handler.Warp.HTTP2.Response import Network.Wai.Handler.Warp.Imports -import qualified Network.Wai.Handler.Warp.Settings as S (Settings) +import qualified Network.Wai.Handler.Warp.Settings as S import Network.Wai.Handler.Warp.Types ---------------------------------------------------------------- -http2 :: Connection -> InternalInfo -> SockAddr -> Transport -> S.Settings -> (BufSize -> IO ByteString) -> Application -> IO () -http2 conn ii addr transport settings readN app = do - checkTLS - ok <- checkPreface - when ok $ do - ctx <- newContext - -- Workers, worker manager and timer manager - mgr <- start settings - let responder = response settings ctx mgr - action = worker ctx settings app responder - setAction mgr action - -- The number of workers is 3. - -- This was carefully chosen based on a lot of benchmarks. - -- If it is 1, we cannot avoid head-of-line blocking. - -- If it is large, huge memory is consumed and many - -- context switches happen. - replicateM_ 3 $ spawnAction mgr - -- Receiver - let mkreq = mkRequest ii settings addr - tid <- forkIO $ frameReceiver ctx ii mkreq readN - -- Sender - -- frameSender is the main thread because it ensures to send - -- a goway frame. - frameSender ctx conn settings mgr `E.finally` do - clearContext ctx - stop mgr - killThread tid +http2 :: Connection -> InternalInfo -> SockAddr -> S.Settings -> (BufSize -> IO ByteString) -> Application -> IO () +http2 conn ii addr settings readN app = + H2.run conf http2server where - checkTLS = case transport of - TCP -> return () -- direct - tls -> unless (tls12orLater tls) $ goaway conn InadequateSecurity "Weak TLS" - tls12orLater tls = tlsMajorVersion tls == 3 && tlsMinorVersion tls >= 3 - checkPreface = do - preface <- readN connectionPrefaceLength - if connectionPreface /= preface then do - goaway conn ProtocolError "Preface mismatch" - return False - else - return True + conf = H2.Config { + confWriteBuffer = connWriteBuffer conn + , confBufferSize = connBufferSize conn + , confSendAll = connSendAll conn + , confReadN = readN + , confPositionReadMaker = pReadMaker ii + } --- connClose must not be called here since Run:fork calls it -goaway :: Connection -> ErrorCodeId -> ByteString -> IO () -goaway Connection{..} etype debugmsg = connSendAll bytestream - where - bytestream = goawayFrame 0 etype debugmsg + http2server h2req aux response = do + req <- toWAIRequest h2req aux + ResponseReceived <- app req $ \rsp -> do + h2rsp <- fromResponse settings ii req rsp + pps <- fromPushPromises ii req + ex <- E.try $ response h2rsp pps + case ex of + Right () -> do + logResponse h2rsp req + mapM_ (logPushPromise req) pps + Left e@(E.SomeException _) + -- killed by the local worker manager + | Just E.ThreadKilled <- E.fromException e -> return () + -- killed by the local timeout manager + | Just T.TimeoutThread <- E.fromException e -> return () + | otherwise -> S.settingsOnException settings (Just req) e + return ResponseReceived + return () + + toWAIRequest h2req aux = toRequest ii settings addr hdr bdylen bdy th + where + !hdr = H2.requestHeaders h2req + !bdy = H2.getRequestBodyChunk h2req + !bdylen = H2.requestBodySize h2req + !th = H2.auxTimeHandle aux + + logResponse h2rsp req = logger req st msiz + where + !logger = S.settingsLogger settings + !st = H2.responseStatus h2rsp + !msiz = fromIntegral <$> H2.responseBodySize h2rsp + + logPushPromise req pp = logger req path siz + where + !logger = S.settingsServerPushLogger settings + !path = H2.promiseRequestPath pp + !siz = case H2.responseBodySize $ H2.promiseResponse pp of + Nothing -> 0 + Just s -> fromIntegral s diff --git a/Network/Wai/Handler/Warp/HTTP2/EncodeFrame.hs b/Network/Wai/Handler/Warp/HTTP2/EncodeFrame.hs deleted file mode 100644 --- a/Network/Wai/Handler/Warp/HTTP2/EncodeFrame.hs +++ /dev/null @@ -1,34 +0,0 @@ -module Network.Wai.Handler.Warp.HTTP2.EncodeFrame where - -import Network.HTTP2 - -import Network.Wai.Handler.Warp.Imports - ----------------------------------------------------------------- - -goawayFrame :: StreamId -> ErrorCodeId -> ByteString -> ByteString -goawayFrame sid etype debugmsg = encodeFrame einfo frame - where - einfo = encodeInfo id 0 - frame = GoAwayFrame sid etype debugmsg - -resetFrame :: ErrorCodeId -> StreamId -> ByteString -resetFrame etype sid = encodeFrame einfo frame - where - einfo = encodeInfo id sid - frame = RSTStreamFrame etype - -settingsFrame :: (FrameFlags -> FrameFlags) -> SettingsList -> ByteString -settingsFrame func alist = encodeFrame einfo $ SettingsFrame alist - where - einfo = encodeInfo func 0 - -pingFrame :: ByteString -> ByteString -pingFrame bs = encodeFrame einfo $ PingFrame bs - where - einfo = encodeInfo setAck 0 - -windowUpdateFrame :: StreamId -> WindowSize -> ByteString -windowUpdateFrame sid winsiz = encodeFrame einfo $ WindowUpdateFrame winsiz - where - einfo = encodeInfo id sid diff --git a/Network/Wai/Handler/Warp/HTTP2/File.hs b/Network/Wai/Handler/Warp/HTTP2/File.hs --- a/Network/Wai/Handler/Warp/HTTP2/File.hs +++ b/Network/Wai/Handler/Warp/HTTP2/File.hs @@ -1,157 +1,26 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE BangPatterns #-} -module Network.Wai.Handler.Warp.HTTP2.File ( - RspFileInfo(..) - , conditionalRequest - , addContentHeadersForFilePart - , H.parseByteRanges - ) where - -import qualified Data.ByteString.Char8 as C8 (pack) -import Network.HPACK -import Network.HPACK.Token -import Network.HTTP.Date -import qualified Network.HTTP.Types as H -import Network.Wai - -import qualified Network.Wai.Handler.Warp.FileInfoCache as I -import Network.Wai.Handler.Warp.Imports -import Network.Wai.Handler.Warp.PackInt - --- $setup --- >>> import Test.QuickCheck - ----------------------------------------------------------------- - -data RspFileInfo = WithoutBody !H.Status - | WithBody !H.Status !TokenHeaderList !Integer !Integer - deriving (Eq,Show) - ----------------------------------------------------------------- - -conditionalRequest :: I.FileInfo - -> TokenHeaderList -- Response - -> ValueTable -- Request - -> RspFileInfo -conditionalRequest (I.FileInfo _ size mtime date) ths0 reqtbl = case condition of - nobody@(WithoutBody _) -> nobody - WithBody s _ off len -> let !hs = (tokenLastModified,date) : - addContentHeaders ths0 off len size - in WithBody s hs off len - where - !mcondition = ifmodified reqtbl size mtime - <|> ifunmodified reqtbl size mtime - <|> ifrange reqtbl size mtime - !condition = fromMaybe (unconditional reqtbl size) mcondition - ----------------------------------------------------------------- - -{-# INLINE ifModifiedSince #-} -ifModifiedSince :: ValueTable -> Maybe HTTPDate -ifModifiedSince reqtbl = getHeaderValue tokenIfModifiedSince reqtbl >>= parseHTTPDate - -{-# INLINE ifUnmodifiedSince #-} -ifUnmodifiedSince :: ValueTable -> Maybe HTTPDate -ifUnmodifiedSince reqtbl = getHeaderValue tokenIfUnmodifiedSince reqtbl >>= parseHTTPDate - -{-# INLINE ifRange #-} -ifRange :: ValueTable -> Maybe HTTPDate -ifRange reqtbl = getHeaderValue tokenIfRange reqtbl >>= parseHTTPDate - ----------------------------------------------------------------- - -{-# INLINE ifmodified #-} -ifmodified :: ValueTable -> Integer -> HTTPDate -> Maybe RspFileInfo -ifmodified reqtbl size mtime = do - date <- ifModifiedSince reqtbl - return $ if date /= mtime - then unconditional reqtbl size - else WithoutBody H.notModified304 - -{-# INLINE ifunmodified #-} -ifunmodified :: ValueTable -> Integer -> HTTPDate -> Maybe RspFileInfo -ifunmodified reqtbl size mtime = do - date <- ifUnmodifiedSince reqtbl - return $ if date == mtime - then unconditional reqtbl size - else WithoutBody H.preconditionFailed412 - -{-# INLINE ifrange #-} -ifrange :: ValueTable -> Integer -> HTTPDate -> Maybe RspFileInfo -ifrange reqtbl size mtime = do - date <- ifRange reqtbl - rng <- getHeaderValue tokenRange reqtbl - return $ if date == mtime - then parseRange rng size - else WithBody H.ok200 [] 0 size - -{-# INLINE unconditional #-} -unconditional :: ValueTable -> Integer -> RspFileInfo -unconditional reqtbl size = case getHeaderValue tokenRange reqtbl of - Nothing -> WithBody H.ok200 [] 0 size - Just rng -> parseRange rng size - ----------------------------------------------------------------- - -{-# INLINE parseRange #-} -parseRange :: ByteString -> Integer -> RspFileInfo -parseRange rng size = case H.parseByteRanges rng of - Nothing -> WithoutBody H.requestedRangeNotSatisfiable416 - Just [] -> WithoutBody H.requestedRangeNotSatisfiable416 - Just (r:_) -> let (!beg, !end) = checkRange r size - !len = end - beg + 1 - s = if beg == 0 && end == size - 1 then - H.ok200 - else - H.partialContent206 - in WithBody s [] beg len - -{-# INLINE checkRange #-} -checkRange :: H.ByteRange -> Integer -> (Integer, Integer) -checkRange (H.ByteRangeFrom beg) size = (beg, size - 1) -checkRange (H.ByteRangeFromTo beg end) size = (beg, min (size - 1) end) -checkRange (H.ByteRangeSuffix count) size = (max 0 (size - count), size - 1) +module Network.Wai.Handler.Warp.HTTP2.File where ----------------------------------------------------------------- +import Network.HTTP2.Server -{-# INLINE contentRangeHeader #-} --- | @contentRangeHeader beg end total@ constructs a Content-Range 'H.Header' --- for the range specified. -contentRangeHeader :: Integer -> Integer -> Integer -> TokenHeader -contentRangeHeader beg end total = (tokenContentRange, range) - where - range = C8.pack - -- building with ShowS - $ 'b' : 'y': 't' : 'e' : 's' : ' ' - : (if beg > end then ('*':) else - showInt beg - . ('-' :) - . showInt end) - ( '/' - : showInt total "") +import Network.Wai.Handler.Warp.Types -{-# INLINE addContentHeaders #-} -addContentHeaders :: TokenHeaderList -> Integer -> Integer -> Integer -> TokenHeaderList -addContentHeaders ths off len size - | len == size = ths' - | otherwise = let !ctrng = contentRangeHeader off (off + len - 1) size - in ctrng:ths' - where - !lengthBS = packIntegral len - !ths' = (tokenContentLength, lengthBS) : (tokenAcceptRanges,"bytes") : ths +#ifdef WINDOWS +pReadMaker :: InternalInfo -> PositionReadMaker +pReadMaker _ = defaultPositionReadMaker +#else +import Network.Wai.Handler.Warp.FdCache +import Network.Wai.Handler.Warp.SendFile (positionRead) -{-# INLINE addContentHeadersForFilePart #-} --- | --- --- >>> addContentHeadersForFilePart [] (FilePart 2 10 16) --- [(Token {ix = 20, shouldBeIndexed = True, isPseudo = False, tokenKey = "Content-Range"},"bytes 2-11/16"),(Token {ix = 18, shouldBeIndexed = False, isPseudo = False, tokenKey = "Content-Length"},"10"),(Token {ix = 8, shouldBeIndexed = True, isPseudo = False, tokenKey = "Accept-Ranges"},"bytes")] --- >>> addContentHeadersForFilePart [] (FilePart 0 16 16) --- [(Token {ix = 18, shouldBeIndexed = False, isPseudo = False, tokenKey = "Content-Length"},"16"),(Token {ix = 8, shouldBeIndexed = True, isPseudo = False, tokenKey = "Accept-Ranges"},"bytes")] -addContentHeadersForFilePart :: TokenHeaderList -> FilePart -> TokenHeaderList -addContentHeadersForFilePart hs part = addContentHeaders hs off len size +pReadMaker :: InternalInfo -> PositionReadMaker +pReadMaker ii path = do + (Just fd, refresh) <- getFd ii path + return (pread fd, Refresher refresh) where - off = filePartOffset part - len = filePartByteCount part - size = filePartFileSize part + pread :: Fd -> PositionRead + pread fd off bytes buf = fromIntegral <$> positionRead fd buf bytes' off' + where + bytes' = fromIntegral bytes + off' = fromIntegral off +#endif diff --git a/Network/Wai/Handler/Warp/HTTP2/HPACK.hs b/Network/Wai/Handler/Warp/HTTP2/HPACK.hs deleted file mode 100644 --- a/Network/Wai/Handler/Warp/HTTP2/HPACK.hs +++ /dev/null @@ -1,130 +0,0 @@ -{-# LANGUAGE OverloadedStrings, BangPatterns #-} -{-# LANGUAGE NamedFieldPuns, RecordWildCards #-} - -module Network.Wai.Handler.Warp.HTTP2.HPACK ( - hpackEncodeHeader - , hpackEncodeHeaderLoop - , hpackDecodeHeader - , just - , fixHeaders - , addHeader -- testing - , deleteUnnecessaryHeaders - ) where - -import qualified Control.Exception as E -import Network.HPACK hiding (Buffer) -import Network.HPACK.Token -import Network.HTTP2 - -import Network.Wai.Handler.Warp.HTTP2.Types -import Network.Wai.Handler.Warp.Imports -import Network.Wai.Handler.Warp.PackInt -import qualified Network.Wai.Handler.Warp.Settings as S -import Network.Wai.Handler.Warp.Types - --- $setup --- >>> :set -XOverloadedStrings - ----------------------------------------------------------------- - -{-# INLINE addHeader #-} -addHeader :: Token -> ByteString -> ValueTable -> TokenHeaderList -> TokenHeaderList -addHeader t "" _ ths - | t == tokenServer = filter ((/= tokenServer) . fst) ths -addHeader t v tbl ths = case getHeaderValue t tbl of - Nothing -> (t,v) : ths - _ -> ths - -fixHeaders :: Context - -> Rspn - -> InternalInfo - -> S.Settings - -> IO TokenHeaderList -fixHeaders 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 - !ths4 = deleteUnnecessaryHeaders ths3 tbl - return ths4 - -deleteUnnecessaryHeaders :: TokenHeaderList -> ValueTable -> TokenHeaderList -deleteUnnecessaryHeaders htl0 tbl0 = loop headersToBeRemoved htl0 - where - loop [] thl = thl - loop (t:ts) thl = case getHeaderValue t tbl0 of - Nothing -> thl - _ -> let !thl' = filter ((/= t) . fst) thl - in loop ts thl' - -headersToBeRemoved :: [Token] -headersToBeRemoved = [ tokenConnection - , tokenTransferEncoding - -- Keep-Alive: - -- Proxy-Connection: - -- Upgrade: - ] - ----------------------------------------------------------------- - -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 - -> TokenHeaderList - -> IO (TokenHeaderList, Int) -hpackEncodeHeader Context{..} buf siz ths = - encodeTokenHeader buf siz strategy True encodeDynamicTable ths - -hpackEncodeHeaderLoop :: Context -> Buffer -> BufSize - -> TokenHeaderList - -> IO (TokenHeaderList, Int) -hpackEncodeHeaderLoop Context{..} buf siz hs = - encodeTokenHeader buf siz strategy False encodeDynamicTable hs - ----------------------------------------------------------------- - -hpackDecodeHeader :: HeaderBlockFragment -> Context -> IO (TokenHeaderList, ValueTable) -hpackDecodeHeader hdrblk Context{..} = do - tbl@(_,vt) <- decodeTokenHeader decodeDynamicTable hdrblk `E.catch` handl - unless (checkRequestHeader vt) $ - E.throwIO $ ConnectionError ProtocolError "the header key is illegal" - return tbl - where - handl IllegalHeaderName = - E.throwIO $ ConnectionError ProtocolError "the header key is illegal" - handl _ = - E.throwIO $ ConnectionError CompressionError "cannot decompress the header" - -{-# INLINE checkRequestHeader #-} -checkRequestHeader :: ValueTable -> Bool -checkRequestHeader reqvt - | just mMethod (== "CONNECT") = isNothing mPath && isNothing mScheme - | isJust mStatus = False - | isNothing mMethod = False - | isNothing mScheme = False - | isNothing mPath = False - | mPath == Just "" = False - | isJust mConnection = False - | just mTE (/= "trailers") = False - | otherwise = True - where - mStatus = getHeaderValue tokenStatus reqvt - mScheme = getHeaderValue tokenScheme reqvt - mPath = getHeaderValue tokenPath reqvt - mMethod = getHeaderValue tokenMethod reqvt - mConnection = getHeaderValue tokenConnection reqvt - mTE = getHeaderValue tokenTE reqvt - -{-# INLINE just #-} -just :: Maybe a -> (a -> Bool) -> Bool -just Nothing _ = False -just (Just x) p - | p x = True - | otherwise = False diff --git a/Network/Wai/Handler/Warp/HTTP2/Manager.hs b/Network/Wai/Handler/Warp/HTTP2/Manager.hs deleted file mode 100644 --- a/Network/Wai/Handler/Warp/HTTP2/Manager.hs +++ /dev/null @@ -1,95 +0,0 @@ -{-# LANGUAGE CPP, BangPatterns #-} - --- | A thread pool manager. --- The manager has responsibility to spawn and kill --- worker threads. -module Network.Wai.Handler.Warp.HTTP2.Manager ( - Manager - , start - , setAction - , stop - , spawnAction - , addMyId - , deleteMyId - ) where - -import Control.Concurrent -import Control.Concurrent.STM -import Data.Foldable -import Data.IORef -import Data.Set (Set) -import qualified Data.Set as Set -import qualified System.TimeManager as T - -import Network.Wai.Handler.Warp.Imports -import Network.Wai.Handler.Warp.Settings - ----------------------------------------------------------------- - -type Action = T.Manager -> IO () - -data Command = Stop | Spawn | Add ThreadId | Delete ThreadId - -data Manager = Manager (TQueue Command) (IORef Action) - --- | Starting a thread pool manager. --- Its action is initially set to 'return ()' and should be set --- by 'setAction'. This allows that the action can include --- the manager itself. -start :: Settings -> IO Manager -start set = do - q <- newTQueueIO - ref <- newIORef (\_ -> return ()) - timmgr <- T.initialize $ settingsTimeout set * 1000000 - void $ forkIO $ go q Set.empty ref timmgr - return $ Manager q ref - where - go q !tset0 ref timmgr = do - x <- atomically $ readTQueue q - case x of - Stop -> kill tset0 >> T.killManager timmgr - Spawn -> next tset0 - Add newtid -> let !tset = add newtid tset0 - in go q tset ref timmgr - Delete oldtid -> let !tset = del oldtid tset0 - in go q tset ref timmgr - where - next tset = do - action <- readIORef ref - newtid <- forkIO (action timmgr) - let !tset' = add newtid tset - go q tset' ref timmgr - -setAction :: Manager -> Action -> IO () -setAction (Manager _ ref) action = writeIORef ref action - -stop :: Manager -> IO () -stop (Manager q _) = atomically $ writeTQueue q Stop - -spawnAction :: Manager -> IO () -spawnAction (Manager q _) = atomically $ writeTQueue q Spawn - -addMyId :: Manager -> IO () -addMyId (Manager q _) = do - tid <- myThreadId - atomically $ writeTQueue q $ Add tid - -deleteMyId :: Manager -> IO () -deleteMyId (Manager q _) = do - tid <- myThreadId - atomically $ writeTQueue q $ Delete tid - ----------------------------------------------------------------- - -add :: ThreadId -> Set ThreadId -> Set ThreadId -add tid set = set' - where - !set' = Set.insert tid set - -del :: ThreadId -> Set ThreadId -> Set ThreadId -del tid set = set' - where - !set' = Set.delete tid set - -kill :: Set ThreadId -> IO () -kill set = traverse_ killThread set diff --git a/Network/Wai/Handler/Warp/HTTP2/PushPromise.hs b/Network/Wai/Handler/Warp/HTTP2/PushPromise.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Handler/Warp/HTTP2/PushPromise.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Network.Wai.Handler.Warp.HTTP2.PushPromise where + +import qualified Control.Exception as E +import qualified Network.HTTP.Types as H +import qualified Network.HTTP2.Server as H2 + +import Network.Wai +import Network.Wai.Handler.Warp.FileInfoCache +import Network.Wai.Handler.Warp.HTTP2.Request (getHTTP2Data) +import Network.Wai.Handler.Warp.HTTP2.Types +import Network.Wai.Handler.Warp.Imports +import Network.Wai.Handler.Warp.Types + +fromPushPromises :: InternalInfo -> Request -> IO [H2.PushPromise] +fromPushPromises ii req = do + mh2data <- getHTTP2Data req + let pp = case mh2data of + Nothing -> [] + Just h2data -> http2dataPushPromise h2data + catMaybes <$> mapM (fromPushPromise ii) pp + +fromPushPromise :: InternalInfo -> PushPromise -> IO (Maybe H2.PushPromise) +fromPushPromise ii (PushPromise path file rsphdr w) = do + efinfo <- E.try $ getFileInfo ii file + case efinfo of + Left (_ex :: E.IOException) -> return Nothing + Right finfo -> do + let !siz = fromIntegral $ fileInfoSize finfo + !fileSpec = H2.FileSpec file 0 siz + !rsp = H2.responseFile H.ok200 rsphdr fileSpec + !pp = H2.pushPromise path rsp w + return $ Just pp diff --git a/Network/Wai/Handler/Warp/HTTP2/Receiver.hs b/Network/Wai/Handler/Warp/HTTP2/Receiver.hs deleted file mode 100644 --- a/Network/Wai/Handler/Warp/HTTP2/Receiver.hs +++ /dev/null @@ -1,418 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE PatternGuards #-} - -module Network.Wai.Handler.Warp.HTTP2.Receiver (frameReceiver) where - -import Control.Concurrent -import Control.Concurrent.STM -import qualified Control.Exception as E -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as C8 -import Data.IORef -import Network.HPACK -import Network.HPACK.Token -import Network.HTTP2 -import Network.HTTP2.Priority (toPrecedence, delete, prepare) - -import Network.Wai.Handler.Warp.HTTP2.EncodeFrame -import Network.Wai.Handler.Warp.HTTP2.HPACK -import Network.Wai.Handler.Warp.HTTP2.Request -import Network.Wai.Handler.Warp.HTTP2.Types -import Network.Wai.Handler.Warp.Imports hiding (delete, insert, readInt) -import Network.Wai.Handler.Warp.ReadInt -import Network.Wai.Handler.Warp.Types - ----------------------------------------------------------------- - -frameReceiver :: Context -> InternalInfo -> MkReq -> (BufSize -> IO ByteString) -> IO () -frameReceiver ctx ii mkreq recvN = loop 0 `E.catch` sendGoaway - where - Context{ http2settings - , streamTable - , concurrency - , continued - , clientStreamId - , inputQ - , controlQ - } = ctx - sendGoaway e - | Just (ConnectionError err msg) <- E.fromException e = do - csid <- readIORef clientStreamId - let !frame = goawayFrame csid err msg - enqueueControl controlQ $ CGoaway frame - | otherwise = return () - - sendReset err sid = do - let !frame = resetFrame err sid - enqueueControl controlQ $ CFrame frame - - loop :: Int -> IO () - loop !n - | n == 6 = do - yield - loop 0 - | otherwise = do - hd <- recvN frameHeaderLength - if BS.null hd then - enqueueControl controlQ CFinish - else do - cont <- processStreamGuardingError $ decodeFrameHeader hd - when cont $ loop (n + 1) - - 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 - Nothing -> do - -- ignoring unknown frame - consume payloadLength - return True - Just _ -> E.throwIO $ ConnectionError ProtocolError "unknown frame" - processStreamGuardingError (FramePushPromise, _) = - E.throwIO $ ConnectionError ProtocolError "push promise is not allowed" - processStreamGuardingError typhdr@(ftyp, header@FrameHeader{payloadLength}) = do - settings <- readIORef http2settings - case checkFrameHeader settings typhdr of - Left h2err -> case h2err of - StreamError err sid -> do - sendReset err sid - consume payloadLength - return True - connErr -> E.throwIO connErr - Right _ -> do - ex <- E.try $ controlOrStream ftyp header - case ex of - Left (StreamError err sid) -> do - sendReset err sid - return True - Left connErr -> E.throw connErr - Right cont -> return cont - - controlOrStream ftyp header@FrameHeader{streamId, payloadLength} - | isControl streamId = do - pl <- recvN payloadLength - control ftyp header pl ctx - | otherwise = do - checkContinued - !mstrm <- getStream - pl <- recvN payloadLength - 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{streamPrecedence} -> do - state <- readStreamState strm - 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 - halfClosedRemote ctx strm - !req <- mkreq tbl (Just 0, 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 - setStreamState ctx strm $ Open (Body q mcl bodyLength) - readQ <- newReadBody q - bodySource <- mkSource readQ - !req <- mkreq tbl (mcl, readSource bodySource) - atomically $ writeTQueue inputQ $ Input strm req reqvt ii - s@(Open Continued{}) -> do - setContinued - setStreamState ctx strm s - HalfClosedRemote -> do - resetContinued - halfClosedRemote ctx strm - s -> do -- Idle, Open Body, Closed - resetContinued - setStreamState ctx strm s - return True - where - setContinued = writeIORef continued (Just streamId) - resetContinued = writeIORef continued Nothing - checkContinued = do - mx <- readIORef continued - case mx of - Nothing -> return () - Just sid - | sid == streamId && ftyp == FrameContinuation -> return () - | otherwise -> E.throwIO $ ConnectionError ProtocolError "continuation frame must follow" - getStream = do - mstrm0 <- search streamTable streamId - case mstrm0 of - js@(Just strm0) -> do - when (ftyp == FrameHeaders) $ do - st <- readStreamState strm0 - when (isHalfClosedRemote st) $ E.throwIO $ ConnectionError StreamClosed "header must not be sent to half or fully closed stream" - -- Priority made an idele stream - when (isIdle st) $ opened ctx strm0 - return js - Nothing - | isResponse streamId -> return Nothing - | otherwise -> do - csid <- readIORef clientStreamId - if streamId <= csid then -- consider the stream closed - if ftyp `elem` [FrameWindowUpdate, FrameRSTStream, FramePriority] then - return Nothing -- will be ignored - else - E.throwIO $ ConnectionError ProtocolError "stream identifier must not decrease" - else do -- consider the stream idle - when (ftyp `notElem` [FrameHeaders,FramePriority]) $ - E.throwIO $ ConnectionError ProtocolError $ "this frame is not allowed in an idle stream: " `BS.append` C8.pack (show ftyp) - 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,maxConcurrency)] - ----------------------------------------------------------------- - -control :: FrameTypeId -> FrameHeader -> ByteString -> Context -> IO Bool -control FrameSettings header@FrameHeader{flags} bs Context{http2settings, controlQ, firstSettings, streamTable} = do - SettingsFrame alist <- guardIt $ decodeSettingsFrame header bs - case checkSettingsList alist of - Just x -> E.throwIO x - Nothing -> return () - -- HTTP/2 Setting from a browser - unless (testAck flags) $ do - oldws <- initialWindowSize <$> readIORef http2settings - modifyIORef' http2settings $ \old -> updateSettings old alist - newws <- initialWindowSize <$> readIORef http2settings - let diff = newws - oldws - when (diff /= 0) $ updateAllStreamWindow (+ diff) streamTable - let !frame = settingsFrame setAck [] - sent <- readIORef firstSettings - let !setframe - | sent = CSettings frame alist - | otherwise = CSettings0 initialFrame frame alist - unless sent $ writeIORef firstSettings True - enqueueControl controlQ setframe - return True - -control FramePing FrameHeader{flags} bs Context{controlQ} = - if testAck flags then - return True -- just ignore - else do - let !frame = pingFrame bs - enqueueControl controlQ $ CFrame frame - return True - -control FrameGoAway _ _ Context{controlQ} = do - enqueueControl controlQ CFinish - return False - -control FrameWindowUpdate header bs Context{connectionWindow} = do - WindowUpdateFrame n <- guardIt $ decodeWindowUpdateFrame header bs - !w <- atomically $ do - w0 <- readTVar connectionWindow - let !w1 = w0 + n - writeTVar connectionWindow w1 - return w1 - when (isWindowOverflow w) $ E.throwIO $ ConnectionError FlowControlError "control window should be less than 2^31" - return True - -control _ _ _ _ = - -- must not reach here - return False - ----------------------------------------------------------------- - -{-# INLINE guardIt #-} -guardIt :: Either HTTP2Error a -> IO a -guardIt x = case x of - Left err -> E.throwIO err - Right frame -> return frame - - -{-# INLINE checkPriority #-} -checkPriority :: Priority -> StreamId -> IO () -checkPriority p me - | dep == me = E.throwIO $ StreamError ProtocolError me - | otherwise = return () - where - dep = streamDependency p - -stream :: FrameTypeId -> FrameHeader -> ByteString -> Context -> StreamState -> Stream -> IO StreamState -stream FrameHeaders header@FrameHeader{flags} bs ctx (Open JustOpened) Stream{streamNumber} = do - HeadersFrame mp frag <- guardIt $ decodeHeadersFrame header bs - pri <- case mp of - Nothing -> return defaultPriority - Just p -> do - checkPriority p streamNumber - return p - let !endOfStream = testEndStream flags - !endOfHeader = testEndHeader flags - if endOfHeader then do - tbl <- hpackDecodeHeader frag ctx -- fixme - return $ if endOfStream then - Open (NoBody tbl pri) - else - Open (HasBody tbl pri) - else do - let !siz = BS.length frag - return $ Open $ Continued [frag] siz 1 endOfStream pri - -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 - let !endOfStream = testEndStream flags - if endOfStream then do - atomically $ writeTQueue q "" - return HalfClosedRemote - else - -- we don't support continuation here. - E.throwIO $ ConnectionError ProtocolError "continuation in trailer is not supported" - --- ignore data-frame except for flow-control when we're done locally -stream FrameData - FrameHeader{flags,payloadLength} - _bs - Context{controlQ} s@(HalfClosedLocal _) - Stream{streamNumber} = do - let !endOfStream = testEndStream flags - when (payloadLength /= 0) $ do - let !frame1 = windowUpdateFrame 0 payloadLength - !frame2 = windowUpdateFrame streamNumber payloadLength - !frame = frame1 `BS.append` frame2 - enqueueControl controlQ $ CFrame frame - if endOfStream then do - return HalfClosedRemote - else - return s - -stream FrameData - header@FrameHeader{flags,payloadLength,streamId} - bs - Context{controlQ} s@(Open (Body q mcl bodyLength)) - Stream{streamNumber} = do - DataFrame body <- guardIt $ decodeDataFrame header bs - let !endOfStream = testEndStream flags - len0 <- readIORef bodyLength - let !len = len0 + payloadLength - writeIORef bodyLength len - when (payloadLength /= 0) $ do - let !frame1 = windowUpdateFrame 0 payloadLength - !frame2 = windowUpdateFrame streamNumber payloadLength - !frame = frame1 `BS.append` frame2 - enqueueControl controlQ $ CFrame frame - atomically $ writeTQueue q body - if endOfStream then do - case mcl of - Nothing -> return () - Just cl -> when (cl /= len) $ E.throwIO $ StreamError ProtocolError streamId - atomically $ writeTQueue q "" - return HalfClosedRemote - else - return s - -stream FrameContinuation FrameHeader{flags} frag ctx (Open (Continued rfrags siz n endOfStream pri)) _ = do - let !endOfHeader = testEndHeader flags - !rfrags' = frag : rfrags - !siz' = siz + BS.length frag - !n' = n + 1 - when (siz' > 51200) $ -- fixme: hard coding: 50K - E.throwIO $ ConnectionError EnhanceYourCalm "Header is too big" - when (n' > 10) $ -- fixme: hard coding - E.throwIO $ ConnectionError EnhanceYourCalm "Header is too fragmented" - if endOfHeader then do - let !hdrblk = BS.concat $ reverse rfrags' - tbl <- hpackDecodeHeader hdrblk ctx - return $ if endOfStream then - Open (NoBody tbl pri) - else - Open (HasBody tbl pri) - else - return $ Open $ Continued rfrags' siz' n' endOfStream pri - -stream FrameWindowUpdate header@FrameHeader{streamId} bs _ s Stream{streamWindow} = do - WindowUpdateFrame n <- guardIt $ decodeWindowUpdateFrame header bs - !w <- atomically $ do - w0 <- readTVar streamWindow - let !w1 = w0 + n - writeTVar streamWindow w1 - return w1 - when (isWindowOverflow w) $ - E.throwIO $ StreamError FlowControlError streamId - return s - -stream FrameRSTStream header bs ctx _ strm = do - RSTStreamFrame e <- guardIt $ decoderstStreamFrame header bs - let !cc = Reset e - closed ctx strm cc - return $ Closed cc -- will be written to streamState again - -stream FramePriority header bs Context{outputQ,priorityTreeSize} s Stream{streamNumber,streamPrecedence} = do - PriorityFrame newpri <- guardIt $ decodePriorityFrame header bs - checkPriority newpri streamNumber - oldpre <- readIORef streamPrecedence - let !newpre = toPrecedence newpri - writeIORef streamPrecedence newpre - if isIdle s then do - n <- atomicModifyIORef' priorityTreeSize (\x -> (x+1,x+1)) - -- fixme hard coding - when (n >= 20) $ E.throwIO $ ConnectionError EnhanceYourCalm "too many idle priority frames" - prepare outputQ streamNumber newpri - else do - mx <- delete outputQ streamNumber oldpre - case mx of - Nothing -> return () - Just out -> enqueueOutput outputQ out - return s - --- this ordering is important -stream FrameContinuation _ _ _ _ _ = E.throwIO $ ConnectionError ProtocolError "continue frame cannot come here" -stream _ _ _ _ (Open Continued{}) _ = E.throwIO $ ConnectionError ProtocolError "an illegal frame follows header/continuation frames" --- Ignore frames to streams we have just reset, per section 5.1. -stream _ _ _ _ st@(Closed (ResetByMe _)) _ = return st -stream FrameData FrameHeader{streamId} _ _ _ _ = E.throwIO $ StreamError StreamClosed streamId -stream _ FrameHeader{streamId} _ _ _ _ = E.throwIO $ StreamError ProtocolError streamId - ----------------------------------------------------------------- - -{-# INLINE newReadBody #-} -newReadBody :: TQueue ByteString -> IO (IO ByteString) -newReadBody q = do - ref <- newIORef False - return $ readBody q ref - -{-# INLINE readBody #-} -readBody :: TQueue ByteString -> IORef Bool -> IO ByteString -readBody q ref = do - eof <- readIORef ref - if eof then - return "" - else do - bs <- atomically $ readTQueue q - when (bs == "") $ writeIORef ref True - return bs diff --git a/Network/Wai/Handler/Warp/HTTP2/Request.hs b/Network/Wai/Handler/Warp/HTTP2/Request.hs --- a/Network/Wai/Handler/Warp/HTTP2/Request.hs +++ b/Network/Wai/Handler/Warp/HTTP2/Request.hs @@ -1,9 +1,7 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} module Network.Wai.Handler.Warp.HTTP2.Request ( - mkRequest - , MkReq + toRequest , getHTTP2Data , setHTTP2Data , modifyHTTP2Data @@ -20,28 +18,31 @@ import Network.Wai import Network.Wai.Internal (Request(..)) import System.IO.Unsafe (unsafePerformIO) +import qualified System.TimeManager as T import Network.Wai.Handler.Warp.HTTP2.Types import Network.Wai.Handler.Warp.Imports -import Network.Wai.Handler.Warp.Request (getFileInfoKey) +import Network.Wai.Handler.Warp.Request (getFileInfoKey, pauseTimeoutKey) import qualified Network.Wai.Handler.Warp.Settings as S (Settings, settingsNoParsePath) import Network.Wai.Handler.Warp.Types -type MkReq = (TokenHeaderList,ValueTable) -> (Maybe Int,IO ByteString) -> IO (Request) +type ToReq = (TokenHeaderList,ValueTable) -> Maybe Int -> IO ByteString -> T.Handle -> IO Request -mkRequest :: InternalInfo -> S.Settings -> SockAddr -> MkReq -mkRequest ii1 settings addr (reqths,reqvt) (bodylen,body) = do +---------------------------------------------------------------- + +toRequest :: InternalInfo -> S.Settings -> SockAddr -> ToReq +toRequest ii settings addr ht bodylen body th = do ref <- newIORef Nothing - mkRequest' ii1 settings addr ref (reqths,reqvt) (bodylen,body) + toRequest' ii settings addr ref ht bodylen body th -mkRequest' :: InternalInfo -> S.Settings -> SockAddr +toRequest' :: InternalInfo -> S.Settings -> SockAddr -> IORef (Maybe HTTP2Data) - -> MkReq -mkRequest' ii settings addr ref (reqths,reqvt) (bodylen,body) = return req + -> ToReq +toRequest' ii settings addr ref (reqths,reqvt) bodylen body th = return req where !req = Request { requestMethod = colonMethod - , httpVersion = http2ver + , httpVersion = H.http20 , rawPathInfo = rawPath , pathInfo = H.decodePathSegments path , rawQueryString = query @@ -76,10 +77,12 @@ (unparsedPath,query) = C8.break (=='?') $ fromJust (mPath <|> mAuth) !path = H.extractPath unparsedPath !rawPath = if S.settingsNoParsePath settings then unparsedPath else path + -- fixme: pauseTimeout. th is not available here. !vaultValue = Vault.insert getFileInfoKey (getFileInfo ii) $ Vault.insert getHTTP2DataKey (readIORef ref) $ Vault.insert setHTTP2DataKey (writeIORef ref) $ Vault.insert modifyHTTP2DataKey (modifyIORef' ref) + $ Vault.insert pauseTimeoutKey (T.pause th) Vault.empty getHTTP2DataKey :: Vault.Key (IO (Maybe HTTP2Data)) diff --git a/Network/Wai/Handler/Warp/HTTP2/Response.hs b/Network/Wai/Handler/Warp/HTTP2/Response.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Handler/Warp/HTTP2/Response.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Network.Wai.Handler.Warp.HTTP2.Response ( + fromResponse + ) where + +import qualified Control.Exception as E +import qualified Data.ByteString.Builder as BB +import qualified Network.HTTP.Types as H +import qualified Network.HTTP2.Server as H2 +import Network.Wai hiding (responseFile, responseBuilder, responseStream) +import Network.Wai.Internal (Response(..)) + +import Network.Wai.Handler.Warp.File +import Network.Wai.Handler.Warp.HTTP2.Request (getHTTP2Data) +import Network.Wai.Handler.Warp.HTTP2.Types +import Network.Wai.Handler.Warp.Header +import qualified Network.Wai.Handler.Warp.Response as R +import qualified Network.Wai.Handler.Warp.Settings as S +import Network.Wai.Handler.Warp.Types + +---------------------------------------------------------------- + +fromResponse :: S.Settings -> InternalInfo -> Request -> Response -> IO H2.Response +fromResponse settings ii req rsp = do + date <- getDate ii + h2rsp <- case rsp of + ResponseFile st rsphdr path mpart -> do + let rsphdr' = add date svr rsphdr + responseFile st rsphdr' isHead path mpart ii reqhdr + ResponseBuilder st rsphdr builder -> do + let rsphdr' = add date svr rsphdr + return $ responseBuilder st rsphdr' isHead builder + ResponseStream st rsphdr strmbdy -> do + let rsphdr' = add date svr rsphdr + return $ responseStream st rsphdr' isHead strmbdy + _ -> error "ResponseRaw is not supported in HTTP/2" + mh2data <- getHTTP2Data req + case mh2data of + Nothing -> return h2rsp + Just h2data -> do + let !trailers = http2dataTrailers h2data + return $ H2.setResponseTrailersMaker h2rsp trailers + where + !isHead = requestMethod req == H.methodHead + !reqhdr = requestHeaders req + !svr = S.settingsServerName settings + add date server rsphdr = (H.hDate, date) : (H.hServer, server) : rsphdr + -- fixme: not adding svr if already exists + +---------------------------------------------------------------- + +responseFile :: H.Status -> H.ResponseHeaders -> Bool + -> FilePath -> Maybe FilePart -> InternalInfo -> H.RequestHeaders + -> IO H2.Response +responseFile st rsphdr _ _ _ _ _ + | noBody st = return $ responseNoBody st rsphdr + +responseFile st rsphdr isHead path (Just fp) _ _ = + return $ responseFile2XX st rsphdr isHead fileSpec + where + !off' = fromIntegral $ filePartOffset fp + !bytes' = fromIntegral $ filePartByteCount fp + !fileSpec = H2.FileSpec path off' bytes' + +responseFile _ rsphdr isHead path Nothing ii reqhdr = do + efinfo <- E.try $ getFileInfo ii path + case efinfo of + Left (_ex :: E.IOException) -> return $ response404 rsphdr + Right finfo -> do + let reqidx = indexRequestHeader reqhdr + case conditionalRequest finfo rsphdr reqidx of + WithoutBody s -> return $ responseNoBody s rsphdr + WithBody s rsphdr' off bytes -> do + let !off' = fromIntegral off + !bytes' = fromIntegral bytes + !fileSpec = H2.FileSpec path off' bytes' + return $ responseFile2XX s rsphdr' isHead fileSpec + +---------------------------------------------------------------- + +responseFile2XX :: H.Status -> H.ResponseHeaders -> Bool -> H2.FileSpec -> H2.Response +responseFile2XX st rsphdr isHead fileSpec + | isHead = responseNoBody st rsphdr + | otherwise = H2.responseFile st rsphdr fileSpec + +---------------------------------------------------------------- + +responseBuilder :: H.Status -> H.ResponseHeaders -> Bool + -> BB.Builder + -> H2.Response +responseBuilder st rsphdr isHead builder + | noBody st = responseNoBody st rsphdr + | isHead = responseNoBody st rsphdr + | otherwise = H2.responseBuilder st rsphdr builder + +---------------------------------------------------------------- + +responseStream :: H.Status -> H.ResponseHeaders -> Bool + -> StreamingBody + -> H2.Response +responseStream st rsphdr isHead strmbdy + | noBody st = responseNoBody st rsphdr + | isHead = responseNoBody st rsphdr + | otherwise = H2.responseStreaming st rsphdr strmbdy + +---------------------------------------------------------------- + +responseNoBody :: H.Status -> H.ResponseHeaders -> H2.Response +responseNoBody st rsphdr = H2.responseNoBody st rsphdr + +---------------------------------------------------------------- + +response404 :: H.ResponseHeaders -> H2.Response +response404 rsphdr = H2.responseBuilder H.notFound404 rsphdr' body + where + !rsphdr' = R.replaceHeader H.hContentType "text/plain; charset=utf-8" rsphdr + !body = BB.byteString "File not found" + +---------------------------------------------------------------- + +noBody :: H.Status -> Bool +noBody = not . R.hasBody diff --git a/Network/Wai/Handler/Warp/HTTP2/Sender.hs b/Network/Wai/Handler/Warp/HTTP2/Sender.hs deleted file mode 100644 --- a/Network/Wai/Handler/Warp/HTTP2/Sender.hs +++ /dev/null @@ -1,536 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE BangPatterns, CPP #-} -{-# LANGUAGE NamedFieldPuns #-} - -module Network.Wai.Handler.Warp.HTTP2.Sender (frameSender) where - -import Control.Concurrent.STM -import qualified Control.Exception as E -import qualified Data.ByteString as BS -import Data.ByteString.Builder (Builder) -import qualified Data.ByteString.Builder.Extra as B -import Data.IORef -import Foreign.Ptr (Ptr, plusPtr) -import Foreign.Storable (poke) -import Network.HPACK (setLimitForEncoding, toHeaderTable) -import Network.HTTP2 -import Network.HTTP2.Priority (isEmptySTM, dequeueSTM, Precedence) -import Network.Wai - -#ifdef WINDOWS -import qualified System.IO as IO -#else -import Network.Wai.Handler.Warp.FdCache -import Network.Wai.Handler.Warp.SendFile (positionRead) -import qualified System.TimeManager as T -#endif - -import Network.Wai.Handler.Warp.Buffer -import Network.Wai.Handler.Warp.HTTP2.EncodeFrame -import Network.Wai.Handler.Warp.HTTP2.HPACK -import Network.Wai.Handler.Warp.HTTP2.Manager (Manager) -import Network.Wai.Handler.Warp.HTTP2.Types -import Network.Wai.Handler.Warp.Imports hiding (readInt) -import qualified Network.Wai.Handler.Warp.Settings as S -import Network.Wai.Handler.Warp.Types - ----------------------------------------------------------------- - -data Leftover = LZero - | LOne B.BufferWriter - | LTwo ByteString B.BufferWriter - ----------------------------------------------------------------- - -{-# INLINE getStreamWindowSize #-} -getStreamWindowSize :: Stream -> IO WindowSize -getStreamWindowSize Stream{streamWindow} = atomically $ readTVar streamWindow - -{-# INLINE waitStreamWindowSize #-} -waitStreamWindowSize :: Stream -> IO () -waitStreamWindowSize Stream{streamWindow} = atomically $ do - w <- readTVar streamWindow - check (w > 0) - -{-# INLINE waitStreaming #-} -waitStreaming :: TBQueue a -> IO () -waitStreaming tbq = atomically $ do - isEmpty <- isEmptyTBQueue tbq - check (not isEmpty) - -data Switch = C Control - | O (StreamId,Precedence,Output) - | Flush - -frameSender :: Context -> Connection -> S.Settings -> Manager -> IO () -frameSender ctx@Context{outputQ,controlQ,connectionWindow,encodeDynamicTable} - conn@Connection{connWriteBuffer,connBufferSize,connSendAll} - settings mgr = loop 0 `E.catch` ignore - where - dequeue off = do - isEmpty <- isEmptyTQueue controlQ - if isEmpty then do - w <- readTVar connectionWindow - check (w > 0) - emp <- isEmptySTM outputQ - if emp then - if off /= 0 then return Flush else retry - else - O <$> dequeueSTM outputQ - else - C <$> readTQueue controlQ - - loop off = do - x <- atomically $ dequeue off - case x of - C ctl -> do - when (off /= 0) $ flushN off - off' <- control ctl off - when (off' >= 0) $ loop off' - O (_,pre,out) -> do - let strm = outputStream out - writeIORef (streamPrecedence strm) pre - off' <- outputOrEnqueueAgain out off - case off' of - 0 -> loop 0 - _ | off' > 15872 -> flushN off' >> loop 0 -- fixme: hard-coding - | otherwise -> loop off' - Flush -> flushN off >> loop 0 - - control CFinish _ = return (-1) - control (CGoaway frame) _ = connSendAll frame >> return (-1) - control (CFrame frame) _ = connSendAll frame >> return 0 - control (CSettings frame alist) _ = do - connSendAll frame - setLimit alist - return 0 - control (CSettings0 frame1 frame2 alist) off = do -- off == 0, just in case - let !buf = connWriteBuffer `plusPtr` off - !off' = off + BS.length frame1 + BS.length frame2 - buf' <- copy buf frame1 - void $ copy buf' frame2 - setLimit alist - return off' - - {-# INLINE setLimit #-} - setLimit alist = case lookup SettingsHeaderTableSize alist of - Nothing -> return () - Just siz -> setLimitForEncoding siz encodeDynamicTable - - output out@(Output strm _ _ tell getH2D (ONext curr)) 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 tell getH2D - maybeEnqueueNext out mnext - return off - - output out@(Output strm rspn ii tell getH2D ORspn) off0 lim = do - -- Header frame and Continuation frame - let !sid = streamNumber strm - !endOfStream = case rspn of - RspnNobody _ _ -> True - _ -> False - ths <- fixHeaders ctx rspn ii settings - kvlen <- headerContinue sid ths endOfStream off0 - off <- sendHeadersIfNecessary $ off0 + frameHeaderLength + kvlen - case rspn of - RspnNobody _ _ -> do - halfClosedLocal ctx strm Finished - return off - RspnFile _ _ path mpart -> do - -- Data frame payload - let payloadOff = off + frameHeaderLength - Next datPayloadLen mnext <- - fillFileBodyGetNext conn ii payloadOff lim path mpart - off' <- fillDataHeader strm off datPayloadLen mnext tell getH2D - maybeEnqueueNext out mnext - 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 tell getH2D - maybeEnqueueNext out mnext - return off' - RspnStreaming _ _ tbq -> do - let payloadOff = off + frameHeaderLength - Next datPayloadLen mnext <- - fillStreamBodyGetNext conn payloadOff lim tbq strm - off' <- fillDataHeader strm off datPayloadLen mnext tell getH2D - maybeEnqueueNext out mnext - return off' - - output out@(Output strm _ _ _ _ (OPush ths 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 out{ outputType = ORspn } off lim - - output _ _ _ = undefined -- never reach - - outputOrEnqueueAgain out off = E.handle resetStream $ do - state <- readStreamState strm - if isHalfClosedLocal state then - return off - else case out of - Output _ _ _ wait _ OWait -> do - -- Checking if all push are done. - let out' = out { - outputHook = return () - , outputType = ORspn - } - forkAndEnqueueWhenReady wait outputQ out' mgr - return off - _ -> case mtbq of - Just tbq -> checkStreaming tbq - _ -> checkStreamWindowSize - where - strm = outputStream out - mtbq = outputMaybeTBQueue out - checkStreaming tbq = do - isEmpty <- atomically $ isEmptyTBQueue tbq - if isEmpty then do - forkAndEnqueueWhenReady (waitStreaming tbq) outputQ out mgr - return off - else - checkStreamWindowSize - checkStreamWindowSize = do - sws <- getStreamWindowSize strm - if sws == 0 then do - forkAndEnqueueWhenReady (waitStreamWindowSize strm) outputQ out mgr - return off - else do - cws <- atomically $ readTVar connectionWindow -- not 0 - let !lim = min cws sws - output out off lim - resetStream e = do - closed ctx strm (ResetByMe e) - let !rst = resetFrame InternalError $ streamNumber strm - enqueueControl controlQ $ CFrame rst - return off - - {-# INLINE flushN #-} - -- Flush the connection buffer to the socket, where the first 'n' bytes of - -- the buffer are filled. - flushN :: Int -> IO () - flushN n = bufferIO connWriteBuffer n connSendAll - - headerContinue sid ths endOfStream off = do - let !offkv = off + frameHeaderLength - let !bufkv = connWriteBuffer `plusPtr` offkv - !limkv = connBufferSize - offkv - (hs,kvlen) <- hpackEncodeHeader ctx bufkv limkv ths - let flag0 = case hs of - [] -> setEndHeader defaultFlags - _ -> defaultFlags - flag = if endOfStream then setEndStream flag0 else flag0 - let buf = connWriteBuffer `plusPtr` off - fillFrameHeader FrameHeaders kvlen sid flag buf - continue sid kvlen hs - - !bufHeaderPayload = connWriteBuffer `plusPtr` frameHeaderLength - !headerPayloadLim = connBufferSize - frameHeaderLength - - continue _ kvlen [] = return kvlen - continue sid kvlen ths = do - flushN $ kvlen + frameHeaderLength - -- Now off is 0 - (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' ths' - - {-# INLINE maybeEnqueueNext #-} - -- Re-enqueue the stream in the output queue. - maybeEnqueueNext :: Output -> Maybe DynaNext -> IO () - maybeEnqueueNext _ Nothing = return () - maybeEnqueueNext out (Just next) = enqueueOutput outputQ out' - where - !out' = out { outputType = ONext next } - - {-# INLINE sendHeadersIfNecessary #-} - -- Send headers if there is not room for a 1-byte data frame, and return - -- the offset of the next frame's first header byte. - sendHeadersIfNecessary off - -- True if the connection buffer has room for a 1-byte data frame. - | off + frameHeaderLength < connBufferSize = return off - | otherwise = do - flushN off - return 0 - - fillDataHeader strm@Stream{streamWindow,streamNumber} - off datPayloadLen mnext tell getH2D = do - -- Data frame header - mh2d <- getH2D - let (!trailers,!noTrailers) = case http2dataTrailers <$> mh2d of - Nothing -> ([], True) - Just ts -> (ts, null ts) - !buf = connWriteBuffer `plusPtr` off - !off' = off + frameHeaderLength + datPayloadLen - !noMoreBody = isNothing mnext - flag | noMoreBody && noTrailers = setEndStream defaultFlags - | otherwise = defaultFlags - fillFrameHeader FrameData datPayloadLen streamNumber flag buf - off'' <- handleEndOfBody noMoreBody off' noTrailers trailers - atomically $ modifyTVar' connectionWindow (subtract datPayloadLen) - atomically $ modifyTVar' streamWindow (subtract datPayloadLen) - return off'' - where - handleTrailers True off0 _ = return off0 - handleTrailers _ off0 trailers = do - (ths,_) <- toHeaderTable trailers - kvlen <- headerContinue streamNumber ths True off0 - sendHeadersIfNecessary $ off0 + frameHeaderLength + kvlen - handleEndOfBody True off0 noTrailers trailers = do - off1 <- handleTrailers noTrailers off0 trailers - void tell - halfClosedLocal ctx strm Finished - return off1 - handleEndOfBody False off0 _ _ = return off0 - - - 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 - hinfo = FrameHeader len flag sid - - {-# INLINE ignore #-} - ignore :: E.SomeException -> IO () - ignore _ = return () - ----------------------------------------------------------------- - -{- -ResponseFile Status ResponseHeaders FilePath (Maybe FilePart) -ResponseBuilder Status ResponseHeaders Builder -ResponseStream Status ResponseHeaders StreamingBody -ResponseRaw (IO ByteString -> (ByteString -> IO ()) -> IO ()) Response --} - -fillBuilderBodyGetNext :: Connection -> InternalInfo -> Int -> WindowSize -> Builder -> IO Next -fillBuilderBodyGetNext Connection{connWriteBuffer,connBufferSize} - _ off lim bb = do - let datBuf = connWriteBuffer `plusPtr` off - room = min (connBufferSize - off) lim - (len, signal) <- B.runBuilder bb datBuf room - return $ nextForBuilder len signal - -fillFileBodyGetNext :: Connection -> InternalInfo -> Int -> WindowSize -> FilePath -> Maybe FilePart -> IO Next -#ifdef WINDOWS -fillFileBodyGetNext Connection{connWriteBuffer,connBufferSize} - _ off lim path mpart = do - let datBuf = connWriteBuffer `plusPtr` off - room = min (connBufferSize - off) lim - (start, bytes) <- fileStartEnd path mpart - -- fixme: how to close Handle? GC does it at this moment. - hdl <- IO.openBinaryFile path IO.ReadMode - IO.hSeek hdl IO.AbsoluteSeek start - len <- IO.hGetBufSome hdl datBuf (mini room bytes) - let bytes' = bytes - fromIntegral len - -- fixme: connWriteBuffer connBufferSize - return $ nextForFile len hdl bytes' (return ()) -#else -fillFileBodyGetNext Connection{connWriteBuffer,connBufferSize} - ii off lim path mpart = do - (mfd, refresh') <- getFd ii path - (fd, refresh) <- case mfd of - Nothing -> do - fd' <- openFile path - th <- T.register (timeoutManager ii) (closeFile fd') - return (fd', T.tickle th) - Just fd -> return (fd, refresh') - let datBuf = connWriteBuffer `plusPtr` off - room = min (connBufferSize - off) lim - (start, bytes) <- fileStartEnd path mpart - len <- positionRead fd datBuf (mini room bytes) start - refresh - let len' = fromIntegral len - return $ nextForFile len fd (start + len') (bytes - len') refresh -#endif - -fileStartEnd :: FilePath -> Maybe FilePart -> IO (Integer, Integer) -fileStartEnd _ (Just part) = - return (filePartOffset part, filePartByteCount part) -fileStartEnd _ _ = error "fileStartEnd" - ----------------------------------------------------------------- - -fillStreamBodyGetNext :: Connection -> Int -> WindowSize -> TBQueue Sequence -> Stream -> IO Next -fillStreamBodyGetNext Connection{connWriteBuffer,connBufferSize} - off lim sq strm = do - let datBuf = connWriteBuffer `plusPtr` off - room = min (connBufferSize - off) lim - (leftover, cont, len) <- runStreamBuilder datBuf room sq - return $ nextForStream sq strm leftover cont len - ----------------------------------------------------------------- - -fillBufBuilder :: Leftover -> DynaNext -fillBufBuilder leftover buf0 siz0 lim = do - let payloadBuf = buf0 `plusPtr` frameHeaderLength - room = min (siz0 - frameHeaderLength) lim - case leftover of - LZero -> error "fillBufBuilder: LZero" - LOne writer -> do - (len, signal) <- writer payloadBuf room - getNext len signal - LTwo bs writer - | BS.length bs <= room -> do - buf1 <- copy payloadBuf bs - let len1 = BS.length bs - (len2, signal) <- writer buf1 (room - len1) - getNext (len1 + len2) signal - | otherwise -> do - let (bs1,bs2) = BS.splitAt room bs - void $ copy payloadBuf bs1 - getNext room (B.Chunk bs2 writer) - where - getNext l s = return $ nextForBuilder l s - -nextForBuilder :: BytesFilled -> B.Next -> Next -nextForBuilder len B.Done - = Next len Nothing -nextForBuilder len (B.More _ writer) - = Next len $ Just (fillBufBuilder (LOne writer)) -nextForBuilder len (B.Chunk bs writer) - = Next len $ Just (fillBufBuilder (LTwo bs writer)) - ----------------------------------------------------------------- - -runStreamBuilder :: Buffer -> BufSize -> TBQueue Sequence - -> IO (Leftover, Bool, BytesFilled) -runStreamBuilder buf0 room0 sq = loop buf0 room0 0 - where - loop !buf !room !total = do - mbuilder <- atomically $ tryReadTBQueue sq - case mbuilder of - Nothing -> return (LZero, True, total) - Just (SBuilder builder) -> do - (len, signal) <- B.runBuilder builder buf room - let !total' = total + len - case signal of - B.Done -> loop (buf `plusPtr` len) (room - len) total' - B.More _ writer -> return (LOne writer, True, total') - B.Chunk bs writer -> return (LTwo bs writer, True, total') - Just SFlush -> return (LZero, True, total) - Just SFinish -> return (LZero, False, total) - -fillBufStream :: Leftover -> TBQueue Sequence -> Stream -> DynaNext -fillBufStream leftover0 sq strm buf0 siz0 lim0 = do - let payloadBuf = buf0 `plusPtr` frameHeaderLength - room0 = min (siz0 - frameHeaderLength) lim0 - case leftover0 of - LZero -> do - (leftover, cont, len) <- runStreamBuilder payloadBuf room0 sq - getNext leftover cont len - LOne writer -> write writer payloadBuf room0 0 - LTwo bs writer - | BS.length bs <= room0 -> do - buf1 <- copy payloadBuf bs - let len = BS.length bs - write writer buf1 (room0 - len) len - | otherwise -> do - let (bs1,bs2) = BS.splitAt room0 bs - void $ copy payloadBuf bs1 - getNext (LTwo bs2 writer) True room0 - where - getNext l b r = return $ nextForStream sq strm l b r - write writer1 buf room sofar = do - (len, signal) <- writer1 buf room - case signal of - B.Done -> do - (leftover, cont, extra) <- runStreamBuilder (buf `plusPtr` len) (room - len) sq - let !total = sofar + len + extra - getNext leftover cont total - B.More _ writer -> do - let !total = sofar + len - getNext (LOne writer) True total - B.Chunk bs writer -> do - let !total = sofar + len - getNext (LTwo bs writer) True total - -nextForStream :: TBQueue Sequence -> Stream - -> Leftover -> Bool -> BytesFilled - -> Next -nextForStream _ _ _ False len = Next len Nothing -nextForStream sq strm leftOrZero True len = - Next len $ Just (fillBufStream leftOrZero sq strm) - ----------------------------------------------------------------- - -#ifdef WINDOWS -fillBufFile :: IO.Handle -> Integer -> IO () -> DynaNext -fillBufFile h bytes refresh buf siz lim = do - let payloadBuf = buf `plusPtr` frameHeaderLength - room = min (siz - frameHeaderLength) lim - len <- IO.hGetBufSome h payloadBuf room - refresh - let bytes' = bytes - fromIntegral len - return $ nextForFile len h bytes' refresh - -nextForFile :: BytesFilled -> IO.Handle -> Integer -> IO () -> Next -nextForFile 0 _ _ _ = Next 0 Nothing -nextForFile len _ 0 _ = Next len Nothing -nextForFile len h bytes refresh = - Next len $ Just (fillBufFile h bytes refresh) -#else -fillBufFile :: Fd -> Integer -> Integer -> IO () -> DynaNext -fillBufFile fd start bytes refresh buf siz lim = do - let payloadBuf = buf `plusPtr` frameHeaderLength - room = min (siz - frameHeaderLength) lim - len <- positionRead fd payloadBuf (mini room bytes) start - let len' = fromIntegral len - refresh - return $ nextForFile len fd (start + len') (bytes - len') refresh - -nextForFile :: BytesFilled -> Fd -> Integer -> Integer -> IO () -> Next -nextForFile 0 _ _ _ _ = Next 0 Nothing -nextForFile len _ _ 0 _ = Next len Nothing -nextForFile len fd start bytes refresh = - Next len $ Just (fillBufFile fd start bytes refresh) -#endif - -{-# INLINE mini #-} -mini :: Int -> Integer -> Int -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 --git a/Network/Wai/Handler/Warp/HTTP2/Types.hs b/Network/Wai/Handler/Warp/HTTP2/Types.hs --- a/Network/Wai/Handler/Warp/HTTP2/Types.hs +++ b/Network/Wai/Handler/Warp/HTTP2/Types.hs @@ -1,32 +1,19 @@ -{-# LANGUAGE OverloadedStrings, CPP #-} -{-# LANGUAGE NamedFieldPuns, RecordWildCards #-} -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} module Network.Wai.Handler.Warp.HTTP2.Types where -import Control.Concurrent (forkIO) -import Control.Concurrent.STM -import Control.Exception (SomeException, bracket) import qualified Data.ByteString as BS -import Data.ByteString.Builder (Builder) -import Data.IORef -import Data.IntMap.Strict (IntMap, IntMap) -import qualified Data.IntMap.Strict as M -import Network.HPACK hiding (Buffer) import qualified Network.HTTP.Types as H import Network.HTTP2 -import Network.HTTP2.Priority -import Network.Wai (Request, FilePart) +import qualified Network.HTTP2.Server as H2 -import Network.Wai.Handler.Warp.HTTP2.Manager import Network.Wai.Handler.Warp.Imports import Network.Wai.Handler.Warp.Types ---------------------------------------------------------------- -http2ver :: H.HttpVersion -http2ver = H.HttpVersion 2 0 - isHTTP2 :: Transport -> Bool isHTTP2 TCP = False isHTTP2 tls = useHTTP2 @@ -37,290 +24,6 @@ ---------------------------------------------------------------- -data Input = Input Stream Request ValueTable InternalInfo - ----------------------------------------------------------------- - -type DynaNext = Buffer -> BufSize -> WindowSize -> IO Next - -type BytesFilled = Int - -data Next = Next !BytesFilled (Maybe DynaNext) - -data Rspn = RspnNobody H.Status (TokenHeaderList, ValueTable) - | RspnStreaming H.Status (TokenHeaderList, ValueTable) (TBQueue Sequence) - | RspnBuilder H.Status (TokenHeaderList, ValueTable) Builder - | RspnFile H.Status (TokenHeaderList, ValueTable) FilePath (Maybe FilePart) - -rspnStatus :: Rspn -> H.Status -rspnStatus (RspnNobody s _) = s -rspnStatus (RspnStreaming s _ _) = s -rspnStatus (RspnBuilder s _ _) = s -rspnStatus (RspnFile s _ _ _ ) = s - -rspnHeaders :: Rspn -> (TokenHeaderList, ValueTable) -rspnHeaders (RspnNobody _ t) = t -rspnHeaders (RspnStreaming _ t _) = t -rspnHeaders (RspnBuilder _ t _) = t -rspnHeaders (RspnFile _ t _ _ ) = t - -data Output = Output { - outputStream :: !Stream - , outputRspn :: !Rspn - , outputII :: !InternalInfo - , outputHook :: IO () -- OPush: wait for done, O*: telling done - , outputH2Data :: IO (Maybe HTTP2Data) - , outputType :: !OutputType - } - -data OutputType = ORspn - | OWait - | OPush !TokenHeaderList !StreamId -- associated stream id from client - | ONext !DynaNext - -outputMaybeTBQueue :: Output -> Maybe (TBQueue Sequence) -outputMaybeTBQueue (Output _ (RspnStreaming _ _ tbq) _ _ _ _) = Just tbq -outputMaybeTBQueue _ = Nothing - -data Control = CFinish - | CGoaway !ByteString - | CFrame !ByteString - | CSettings !ByteString !SettingsList - | CSettings0 !ByteString !ByteString !SettingsList - ----------------------------------------------------------------- - -data Sequence = SFinish - | SFlush - | SBuilder Builder - ----------------------------------------------------------------- - --- | The context for HTTP/2 connection. -data Context = Context { - -- HTTP/2 settings received from a browser - http2settings :: !(IORef Settings) - , firstSettings :: !(IORef Bool) - , streamTable :: !StreamTable - , concurrency :: !(IORef Int) - , priorityTreeSize :: !(IORef Int) - -- | RFC 7540 says "Other frames (from any stream) MUST NOT - -- occur between the HEADERS frame and any CONTINUATION - -- frames that might follow". This field is used to implement - -- this requirement. - , continued :: !(IORef (Maybe 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) - } - ----------------------------------------------------------------- - -newContext :: IO Context -newContext = Context <$> newIORef defaultSettings - <*> newIORef False - <*> newStreamTable - <*> newIORef 0 - <*> newIORef 0 - <*> newIORef Nothing - <*> newIORef 0 - <*> newIORef 0 - <*> newTQueueIO - <*> newPriorityTree - <*> newTQueueIO - <*> newDynamicTableForEncoding defaultDynamicTableSize - <*> newDynamicTableForDecoding defaultDynamicTableSize 4096 - <*> newTVarIO defaultInitialWindowSize - -clearContext :: Context -> IO () -clearContext _ctx = return () - ----------------------------------------------------------------- - -data OpenState = - JustOpened - | Continued [HeaderBlockFragment] - !Int -- Total size - !Int -- The number of continuation frames - !Bool -- End of stream - !Priority - | 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 - | Reset !ErrorCodeId - | ResetByMe SomeException - deriving Show - -data StreamState = - Idle - | Open !OpenState - | HalfClosedRemote - | HalfClosedLocal !ClosedCode - | Closed !ClosedCode - | Reserved - -isIdle :: StreamState -> Bool -isIdle Idle = True -isIdle _ = False - -isOpen :: StreamState -> Bool -isOpen Open{} = True -isOpen _ = False - -isHalfClosedRemote :: StreamState -> Bool -isHalfClosedRemote HalfClosedRemote = True -isHalfClosedRemote (Closed _) = True -isHalfClosedRemote _ = False - -isHalfClosedLocal :: StreamState -> Bool -isHalfClosedLocal (HalfClosedLocal _) = True -isHalfClosedLocal (Closed _) = True -isHalfClosedLocal _ = False - -isClosed :: StreamState -> Bool -isClosed Closed{} = True -isClosed _ = False - -instance Show StreamState where - show Idle = "Idle" - show Open{} = "Open" - show HalfClosedRemote = "HalfClosedRemote" - show (HalfClosedLocal e) = "HalfClosedLocal: " ++ show e - show (Closed e) = "Closed: " ++ show e - show Reserved = "Reserved" - ----------------------------------------------------------------- - -data Stream = Stream { - streamNumber :: !StreamId - , streamState :: !(IORef StreamState) - , streamWindow :: !(TVar WindowSize) - , streamPrecedence :: !(IORef Precedence) - } - -instance Show Stream where - show s = show (streamNumber s) - -newStream :: StreamId -> WindowSize -> IO Stream -newStream sid win = Stream sid <$> newIORef Idle - <*> 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') - ----------------------------------------------------------------- - -{-# INLINE readStreamState #-} -readStreamState :: Stream -> IO StreamState -readStreamState Stream{streamState} = - readIORef streamState - -{-# INLINE setStreamState #-} -setStreamState :: Context -> Stream -> StreamState -> IO () -setStreamState _ Stream{streamState} val = writeIORef streamState val - -opened :: Context -> Stream -> IO () -opened ctx@Context{concurrency} strm = do - atomicModifyIORef' concurrency (\x -> (x+1,())) - setStreamState ctx strm (Open JustOpened) - -halfClosedRemote :: Context -> Stream -> IO () -halfClosedRemote ctx stream@Stream{streamState} = do - !closingCode <- atomicModifyIORef streamState closeHalf - case closingCode of - Nothing -> return () - Just cc -> closed ctx stream cc - where - closeHalf :: StreamState -> (StreamState, Maybe ClosedCode) - closeHalf x@(Closed _) = (x, Nothing) - closeHalf (HalfClosedLocal cc) = (Closed cc, Just cc) - closeHalf _ = (HalfClosedRemote, Nothing) - -halfClosedLocal :: Context -> Stream -> ClosedCode -> IO () -halfClosedLocal ctx stream@Stream{streamState} cc = do - shouldFinalize <- atomicModifyIORef streamState closeHalf - when shouldFinalize $ - closed ctx stream cc - where - closeHalf :: StreamState -> (StreamState, Bool) - closeHalf x@(Closed _) = (x, False) - closeHalf HalfClosedRemote = (Closed cc, True) - closeHalf _ = (HalfClosedLocal cc, False) - -closed :: Context -> Stream -> ClosedCode -> IO () -closed ctx@Context{concurrency,streamTable} strm@Stream{streamNumber} cc = do - remove streamTable streamNumber - -- TODO: prevent double-counting - atomicModifyIORef' concurrency (\x -> (x-1,())) - setStreamState ctx strm (Closed cc) -- anyway - ----------------------------------------------------------------- - -newtype StreamTable = StreamTable (IORef (IntMap Stream)) - -newStreamTable :: IO StreamTable -newStreamTable = StreamTable <$> newIORef M.empty - -insert :: StreamTable -> M.Key -> Stream -> IO () -insert (StreamTable ref) k v = atomicModifyIORef' ref $ \m -> - let !m' = M.insert k v m - in (m', ()) - -remove :: StreamTable -> M.Key -> IO () -remove (StreamTable ref) k = atomicModifyIORef' ref $ \m -> - let !m' = M.delete k m - in (m', ()) - -search :: StreamTable -> M.Key -> IO (Maybe Stream) -search (StreamTable ref) k = M.lookup k <$> readIORef ref - -updateAllStreamWindow :: (WindowSize -> WindowSize) -> StreamTable -> IO () -updateAllStreamWindow adst (StreamTable ref) = do - strms <- M.elems <$> readIORef ref - forM_ strms $ \strm -> atomically $ modifyTVar (streamWindow strm) adst - -{-# INLINE forkAndEnqueueWhenReady #-} -forkAndEnqueueWhenReady :: IO () -> PriorityTree Output -> Output -> Manager -> IO () -forkAndEnqueueWhenReady wait outQ out mgr = bracket setup teardown $ \_ -> - void . forkIO $ do - wait - enqueueOutput outQ out - where - setup = addMyId mgr - teardown _ = deleteMyId mgr - -{-# INLINE enqueueOutput #-} -enqueueOutput :: PriorityTree Output -> Output -> IO () -enqueueOutput outQ out = do - let Stream{..} = outputStream out - pre <- readIORef streamPrecedence - enqueue outQ streamNumber pre out - -{-# INLINE enqueueControl #-} -enqueueControl :: TQueue Control -> Control -> IO () -enqueueControl ctlQ ctl = atomically $ writeTQueue ctlQ ctl - ----------------------------------------------------------------- - -- | HTTP/2 specific data. -- -- Since: 3.2.7 @@ -329,17 +32,21 @@ -- -- Since: 3.2.7 http2dataPushPromise :: [PushPromise] - -- Since: 3.2.8 - , http2dataTrailers :: H.ResponseHeaders - } deriving (Eq,Show) + -- | Accessor for 'H2.TrailersMaker' in 'HTTP2Data'. + -- + -- Since: 3.2.8 but the type changed in 3.3.0 + , http2dataTrailers :: H2.TrailersMaker + } -- | Default HTTP/2 specific data. -- -- Since: 3.2.7 defaultHTTP2Data :: HTTP2Data -defaultHTTP2Data = HTTP2Data [] [] +defaultHTTP2Data = HTTP2Data [] H2.defaultTrailersMaker -- | HTTP/2 push promise or sever push. +-- This allows files only for backward-compatibility +-- while the HTTP/2 library supports other types. -- -- Since: 3.2.7 data PushPromise = PushPromise { diff --git a/Network/Wai/Handler/Warp/HTTP2/Worker.hs b/Network/Wai/Handler/Warp/HTTP2/Worker.hs deleted file mode 100644 --- a/Network/Wai/Handler/Warp/HTTP2/Worker.hs +++ /dev/null @@ -1,331 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE BangPatterns #-} - -module Network.Wai.Handler.Warp.HTTP2.Worker ( - Responder - , response - , worker - ) where - -import Control.Concurrent.STM -import Control.Exception (SomeException(..), AsyncException(..)) -import qualified Control.Exception as E -import Data.ByteString.Builder (byteString) -import Data.IORef -import qualified Data.Vault.Lazy as Vault -import Network.HPACK -import Network.HPACK.Token -import qualified Network.HTTP.Types as H -import Network.HTTP2 -import Network.HTTP2.Priority -import Network.Wai -import Network.Wai.Internal (Response(..), ResponseReceived(..), ResponseReceived(..), getRequestBodyChunk) -import qualified System.TimeManager as T - -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.Request -import Network.Wai.Handler.Warp.HTTP2.Types -import Network.Wai.Handler.Warp.Imports hiding (insert) -import Network.Wai.Handler.Warp.Request (pauseTimeoutKey) -import qualified Network.Wai.Handler.Warp.Response as R -import qualified Network.Wai.Handler.Warp.Settings as S -import Network.Wai.Handler.Warp.Types - ----------------------------------------------------------------- - --- | 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 - -> T.Handle - -> ValueTable -- for Request - -> ThreadContinue - -> Stream - -> Request - -> Response - -> IO ResponseReceived - -pushStream :: Context -> S.Settings - -> StreamId -> ValueTable -> Request -> InternalInfo - -> Maybe HTTP2Data - -> IO (OutputType, 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) - !h2data = getHTTP2Data req - 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 !ot = OPush promisedRequest pid - !out = Output strm rsp ii (increment tvar) h2data ot - 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 ctx@Context{outputQ} mgr ii th reqvt tconf strm req rsp = E.handle (E.throwIO . ExceptionInsideResponseBody) $ case rsp of - ResponseStream s0 hs0 strmbdy - | noBody s0 -> responseNoBody s0 hs0 - | isHead -> responseNoBody s0 hs0 - | 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 -> getHTTP2Data req - >>= pushStream ctx settings sid reqvt req ii - >>= responseBuilderBody s0 hs0 b - ResponseFile s0 hs0 p mp - | noBody s0 -> responseNoBody s0 hs0 - | 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 - sid = streamNumber strm - !h2data = getHTTP2Data req - - -- Ideally, log messages should be written when responses are - -- actually sent. But there is no way to keep good memory usage - -- (resist to Request leak) and throughput. By compromise, - -- log message are written here even the window size of streams - -- is 0. - - responseNoBody s hs0 = toHeaderTable hs0 >>= responseNoBody' s - - responseNoBody' s tbl = do - logger req s Nothing - setThreadContinue tconf True - let !rspn = RspnNobody s tbl - !out = Output strm rspn ii (return ()) h2data ORspn - enqueueOutput outputQ out - return ResponseReceived - - responseBuilderBody s hs0 bdy (rspnOrWait,tell) = do - logger req s Nothing - setThreadContinue tconf True - tbl <- toHeaderTable hs0 - let !rspn = RspnBuilder s tbl bdy - !out = Output strm rspn ii tell h2data rspnOrWait - enqueueOutput outputQ out - return ResponseReceived - - responseFileXXX _ hs0 path Nothing aux = do - efinfo <- E.try $ getFileInfo ii path - case efinfo of - Left (_ex :: E.IOException) -> response404 hs0 - Right finfo -> do - (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))) aux - - responseFileXXX s0 hs0 path mpart aux = do - tbl <- toHeaderTable hs0 - responseFile2XX s0 tbl path mpart aux - - responseFile2XX s tbl path mpart (rspnOrWait,tell) - | isHead = do - logger req s Nothing - responseNoBody' s tbl - | otherwise = do - logger req s (filePartByteCount <$> mpart) - setThreadContinue tconf True - let !rspn = RspnFile s tbl path mpart - !out = Output strm rspn ii tell h2data rspnOrWait - enqueueOutput outputQ out - return ResponseReceived - - 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 (rspnOrWait,tell) = do - logger req s0 Nothing - -- We must not exit this WAI application. - -- If the application exits, streaming would be also closed. - -- So, this work occupies this thread. - -- - -- We need to increase the number of workers. - spawnAction mgr - -- After this work, this thread stops to decease - -- the number of workers. - setThreadContinue tconf False - -- Since 'StreamingBody' is loop, we cannot control it. - -- So, let's serialize 'Builder' with a designated queue. - tbq <- newTBQueueIO 10 -- fixme: hard coding: 10 - tbl <- toHeaderTable hs0 - let !rspn = RspnStreaming s0 tbl tbq - !out = Output strm rspn ii tell h2data rspnOrWait - enqueueOutput outputQ out - let push b = do - T.pause th - atomically $ writeTBQueue tbq (SBuilder b) - T.resume th - flush = atomically $ writeTBQueue tbq SFlush - _ <- strmbdy push flush - atomically $ writeTBQueue tbq SFinish - deleteMyId mgr - return ResponseReceived - -worker :: Context -> S.Settings -> Application -> Responder -> T.Manager -> IO () -worker ctx@Context{inputQ,controlQ} set app responder tm = do - sinfo <- newStreamInfo - tcont <- newThreadContinue - let timeoutAction = return () -- cannot close the shared connection - E.bracket (T.registerKillThread tm timeoutAction) T.cancel $ go sinfo tcont - where - go sinfo tcont th = do - setThreadContinue tcont True - ex <- E.try $ do - T.pause th - inp@(Input strm req reqvt ii) <- atomically $ readTQueue inputQ - setStreamInfo sinfo inp - T.resume th - T.tickle th - let !body = getRequestBodyChunk req - !body' = do - T.pause th - bs <- body - T.resume th - return bs - !vaultValue = Vault.insert pauseTimeoutKey (T.pause th) $ vault req - !req' = req { vault = vaultValue, requestBody = body' } - mr <- E.try $ app req' $ responder ii th reqvt tcont strm req' - case mr of - Right ok -> return ok - Left e@(SomeException _) - | Just (ExceptionInsideResponseBody e') <- E.fromException e -> E.throwIO e' - | otherwise -> responder ii th reqvt tcont strm req' (S.settingsOnExceptionResponse set e) - cont1 <- case ex of - Right ResponseReceived -> return True - Left e@(SomeException _) - -- killed by the local worker manager - | Just ThreadKilled <- E.fromException e -> return False - -- killed by the local timeout manager - | Just T.TimeoutThread <- E.fromException e -> do - cleanup sinfo Nothing - return True - | otherwise -> do - cleanup sinfo $ Just e - return True - cont2 <- getThreadContinue tcont - clearStreamInfo sinfo - when (cont1 && cont2) $ go sinfo tcont th - cleanup sinfo me = do - minp <- getStreamInfo sinfo - case minp of - Nothing -> return () - Just (Input strm req _reqvt _ii) -> do - closed ctx strm Killed - let !frame = resetFrame InternalError (streamNumber strm) - enqueueControl controlQ $ CFrame frame - case me of - Nothing -> return () - Just e -> S.settingsOnException set (Just req) e - ----------------------------------------------------------------- - --- | It would nice if responders could return values to workers. --- Unfortunately, 'ResponseReceived' is already defined in WAI 2.0. --- It is not wise to change this type. --- So, a reference is shared by a responder and its worker. --- The reference refers a value of this type as a return value. --- If 'True', the worker continue to serve requests. --- Otherwise, the worker get finished. -newtype ThreadContinue = ThreadContinue (IORef Bool) - -{-# INLINE newThreadContinue #-} -newThreadContinue :: IO ThreadContinue -newThreadContinue = ThreadContinue <$> newIORef True - -{-# INLINE setThreadContinue #-} -setThreadContinue :: ThreadContinue -> Bool -> IO () -setThreadContinue (ThreadContinue ref) x = writeIORef ref x - -{-# INLINE getThreadContinue #-} -getThreadContinue :: ThreadContinue -> IO Bool -getThreadContinue (ThreadContinue ref) = readIORef ref - ----------------------------------------------------------------- - --- | The type to store enough information for 'settingsOnException'. -newtype StreamInfo = StreamInfo (IORef (Maybe Input)) - -{-# INLINE newStreamInfo #-} -newStreamInfo :: IO StreamInfo -newStreamInfo = StreamInfo <$> newIORef Nothing - -{-# INLINE clearStreamInfo #-} -clearStreamInfo :: StreamInfo -> IO () -clearStreamInfo (StreamInfo ref) = writeIORef ref Nothing - -{-# INLINE setStreamInfo #-} -setStreamInfo :: StreamInfo -> Input -> IO () -setStreamInfo (StreamInfo ref) inp = writeIORef ref $ Just inp - -{-# INLINE getStreamInfo #-} -getStreamInfo :: StreamInfo -> IO (Maybe Input) -getStreamInfo (StreamInfo ref) = readIORef ref diff --git a/Network/Wai/Handler/Warp/Run.hs b/Network/Wai/Handler/Warp/Run.hs --- a/Network/Wai/Handler/Warp/Run.hs +++ b/Network/Wai/Handler/Warp/Run.hs @@ -3,6 +3,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} @@ -19,20 +20,22 @@ import Data.Streaming.Network (bindPortTCP) import Foreign.C.Error (Errno(..), eCONNABORTED) import GHC.IO.Exception (IOException(..)) +import qualified Network.HTTP2 as H2 import Network.Socket (Socket, close, accept, withSocketsDo, SockAddr(SockAddrInet, SockAddrInet6), setSocketOption, SocketOption(..)) import qualified Network.Socket.ByteString as Sock import Network.Wai import Network.Wai.Internal (ResponseReceived (ResponseReceived)) import System.Environment (lookupEnv) -import System.Timeout (timeout) import qualified System.TimeManager as T +import System.Timeout (timeout) import Network.Wai.Handler.Warp.Buffer import Network.Wai.Handler.Warp.Counter import qualified Network.Wai.Handler.Warp.Date as D import qualified Network.Wai.Handler.Warp.FdCache as F import qualified Network.Wai.Handler.Warp.FileInfoCache as I -import Network.Wai.Handler.Warp.HTTP2 (http2, isHTTP2) +import Network.Wai.Handler.Warp.HTTP2 (http2) +import Network.Wai.Handler.Warp.HTTP2.Types (isHTTP2) import Network.Wai.Handler.Warp.Header import Network.Wai.Handler.Warp.Imports hiding (readInt) import Network.Wai.Handler.Warp.ReadInt @@ -332,7 +335,8 @@ rawRecvN <- makeReceiveN bs (connRecv conn) (connRecvBuf conn) let recvN = wrappedRecvN th istatus (settingsSlowlorisSize settings) rawRecvN -- fixme: origAddr - http2 conn ii origAddr transport settings recvN app + checkTLS + http2 conn ii origAddr settings recvN app else do src <- mkSource (wrappedRecv conn th istatus (settingsSlowlorisSize settings)) writeIORef istatus True @@ -489,6 +493,19 @@ Nothing -> tryKeepAlive else return False + + checkTLS = case transport of + TCP -> return () -- direct + tls -> unless (tls12orLater tls) $ goaway conn H2.InadequateSecurity "Weak TLS" + tls12orLater tls = tlsMajorVersion tls == 3 && tlsMinorVersion tls >= 3 + +-- connClose must not be called here since Run:fork calls it +goaway :: Connection -> H2.ErrorCodeId -> ByteString -> IO () +goaway Connection{..} etype debugmsg = connSendAll bytestream + where + einfo = H2.encodeInfo id 0 + frame = H2.GoAwayFrame 0 etype debugmsg + bytestream = H2.encodeFrame einfo frame flushEntireBody :: IO ByteString -> IO () flushEntireBody src = diff --git a/test/ResponseHeaderSpec.hs b/test/ResponseHeaderSpec.hs --- a/test/ResponseHeaderSpec.hs +++ b/test/ResponseHeaderSpec.hs @@ -7,9 +7,6 @@ import Network.Wai.Handler.Warp.ResponseHeader import Network.Wai.Handler.Warp.Response import Network.Wai.Handler.Warp.Header -import Network.Wai.Handler.Warp.HTTP2.HPACK -import Network.HPACK -import Network.HPACK.Token import Test.Hspec main :: IO () @@ -37,36 +34,6 @@ let hdrs = [("Server","MyServer")] rspidxhdr = indexResponseHeader hdrs addServer "" rspidxhdr hdrs `shouldBe` [] - describe "addHeader" $ do - it "adds Server if not exist" $ do - let v = "MyServer" - hdrs = [] - hdrs1 = [("Server",v)] - (thl, vt) <- toHeaderTable hdrs - (thl1, _) <- toHeaderTable hdrs1 - addHeader tokenServer v vt thl `shouldBe` thl1 - it "does not add Server if exists" $ do - let v = "MyServer2" - hdrs = [("Server","MyServer")] - (thl, vt) <- toHeaderTable hdrs - addHeader tokenServer v vt thl `shouldBe` thl - it "does not add Server if empty" $ do - let v = "" - hdrs = [] - (thl, vt) <- toHeaderTable hdrs - addHeader tokenServer v vt thl `shouldBe` thl - it "deletes Server" $ do - let v = "" - hdrs = [("Server","MyServer")] - hdrs1 = [] - (thl, vt) <- toHeaderTable hdrs - (thl1, _) <- toHeaderTable hdrs1 - addHeader tokenServer v vt thl `shouldBe` thl1 - it "keeps Server" $ do - let v = "" - hdrs = [("Server","MyServer"),("Content-Type","Text/HTML")] - (thl, vt) <- toHeaderTable hdrs - addHeader tokenContentType v vt thl `shouldBe` thl headers :: H.ResponseHeaders headers = [ diff --git a/warp.cabal b/warp.cabal --- a/warp.cabal +++ b/warp.cabal @@ -1,5 +1,5 @@ Name: warp -Version: 3.2.28 +Version: 3.3.0 Synopsis: A fast, light-weight web server for WAI applications. License: MIT License-file: LICENSE @@ -44,8 +44,8 @@ , ghc-prim , hashable , http-date - , http-types >= 0.11 - , http2 >= 1.6 && < 1.7 + , http-types >= 0.12 + , http2 >= 2.0 && < 2.1 , iproute >= 1.3.1 , simple-sendfile >= 0.2.7 && < 0.3 , stm >= 2.3 @@ -74,15 +74,11 @@ Network.Wai.Handler.Warp.FileInfoCache Network.Wai.Handler.Warp.HashMap Network.Wai.Handler.Warp.HTTP2 - Network.Wai.Handler.Warp.HTTP2.EncodeFrame Network.Wai.Handler.Warp.HTTP2.File - Network.Wai.Handler.Warp.HTTP2.HPACK - Network.Wai.Handler.Warp.HTTP2.Manager - Network.Wai.Handler.Warp.HTTP2.Receiver + Network.Wai.Handler.Warp.HTTP2.PushPromise Network.Wai.Handler.Warp.HTTP2.Request - Network.Wai.Handler.Warp.HTTP2.Sender + Network.Wai.Handler.Warp.HTTP2.Response Network.Wai.Handler.Warp.HTTP2.Types - Network.Wai.Handler.Warp.HTTP2.Worker Network.Wai.Handler.Warp.Header Network.Wai.Handler.Warp.IO Network.Wai.Handler.Warp.Imports @@ -117,6 +113,7 @@ Default-Language: Haskell2010 Test-Suite doctest + buildable: False Type: exitcode-stdio-1.0 HS-Source-Dirs: test Ghc-Options: -threaded -Wall @@ -153,15 +150,11 @@ Network.Wai.Handler.Warp.File Network.Wai.Handler.Warp.FileInfoCache Network.Wai.Handler.Warp.HTTP2 - Network.Wai.Handler.Warp.HTTP2.EncodeFrame Network.Wai.Handler.Warp.HTTP2.File - Network.Wai.Handler.Warp.HTTP2.HPACK - Network.Wai.Handler.Warp.HTTP2.Manager - Network.Wai.Handler.Warp.HTTP2.Receiver + Network.Wai.Handler.Warp.HTTP2.PushPromise Network.Wai.Handler.Warp.HTTP2.Request - Network.Wai.Handler.Warp.HTTP2.Sender + Network.Wai.Handler.Warp.HTTP2.Response Network.Wai.Handler.Warp.HTTP2.Types - Network.Wai.Handler.Warp.HTTP2.Worker Network.Wai.Handler.Warp.HashMap Network.Wai.Handler.Warp.Header Network.Wai.Handler.Warp.IO @@ -202,8 +195,8 @@ , hspec >= 1.3 , http-client , http-date - , http-types >= 0.8.5 - , http2 >= 1.6 && < 1.7 + , http-types >= 0.12 + , http2 >= 2.0 && < 2.1 , iproute >= 1.3.1 , lifted-base >= 0.1 , network @@ -214,7 +207,6 @@ , text , time , time-manager - , transformers >= 0.2.2 , unix-compat >= 0.2 , vault , wai >= 3.2 && < 3.3 @@ -222,6 +214,7 @@ -- Build-Tool-Depends: hspec-discover:hspec-discover if impl(ghc < 8) Build-Depends: semigroups + , transformers if (os(linux) || os(freebsd) || os(darwin)) && flag(allow-sendfilefd) Cpp-Options: -DSENDFILEFD