warp 3.2.28 → 3.3.0
raw patch · 16 files changed
+307/−2119 lines, 16 filesdep ~basedep ~http-typesdep ~http2
Dependency ranges changed: base, http-types, http2, transformers
Files
- ChangeLog.md +7/−0
- Network/Wai/Handler/Warp/HTTP2.hs +61/−54
- Network/Wai/Handler/Warp/HTTP2/EncodeFrame.hs +0/−34
- Network/Wai/Handler/Warp/HTTP2/File.hs +19/−150
- Network/Wai/Handler/Warp/HTTP2/HPACK.hs +0/−130
- Network/Wai/Handler/Warp/HTTP2/Manager.hs +0/−95
- Network/Wai/Handler/Warp/HTTP2/PushPromise.hs +36/−0
- Network/Wai/Handler/Warp/HTTP2/Receiver.hs +0/−418
- Network/Wai/Handler/Warp/HTTP2/Request.hs +15/−12
- Network/Wai/Handler/Warp/HTTP2/Response.hs +126/−0
- Network/Wai/Handler/Warp/HTTP2/Sender.hs +0/−536
- Network/Wai/Handler/Warp/HTTP2/Types.hs +12/−305
- Network/Wai/Handler/Warp/HTTP2/Worker.hs +0/−331
- Network/Wai/Handler/Warp/Run.hs +20/−3
- test/ResponseHeaderSpec.hs +0/−33
- warp.cabal +11/−18
ChangeLog.md view
@@ -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.
Network/Wai/Handler/Warp/HTTP2.hs view
@@ -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
− Network/Wai/Handler/Warp/HTTP2/EncodeFrame.hs
@@ -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
Network/Wai/Handler/Warp/HTTP2/File.hs view
@@ -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
− Network/Wai/Handler/Warp/HTTP2/HPACK.hs
@@ -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
− Network/Wai/Handler/Warp/HTTP2/Manager.hs
@@ -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
+ Network/Wai/Handler/Warp/HTTP2/PushPromise.hs view
@@ -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
− Network/Wai/Handler/Warp/HTTP2/Receiver.hs
@@ -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
Network/Wai/Handler/Warp/HTTP2/Request.hs view
@@ -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))
+ Network/Wai/Handler/Warp/HTTP2/Response.hs view
@@ -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
− Network/Wai/Handler/Warp/HTTP2/Sender.hs
@@ -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
Network/Wai/Handler/Warp/HTTP2/Types.hs view
@@ -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 {
− Network/Wai/Handler/Warp/HTTP2/Worker.hs
@@ -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
Network/Wai/Handler/Warp/Run.hs view
@@ -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 =
test/ResponseHeaderSpec.hs view
@@ -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 = [
warp.cabal view
@@ -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