664d4e3 · typeable/wai

git.iko.soy/typeable/wai

on master help sign in

Remove HTTP/2 ResponseBuilder and ResponseFile

664d4e3Andrew Pritchard11 years ago

wai/Network/Wai/HTTP2.hs+2−10

compare with master

unifiedsplit

@@ -9,7 +9,7 @@ module Network.Wai.HTTP2

9import Blaze.ByteString.Builder (Builder)

10import qualified Network.HTTP.Types as H

12−import Network.Wai.Internal (Request, FilePart)

12+import Network.Wai.Internal (Request)

14-- | Headers sent after the end of a data stream, as defined by section 4.1.2 of

15-- the HTTP\/1.1 spec (RFC 7230), and section 8.1 of the HTTP\/2 spec.

@@ -20,18 +20,10 @@ type Http2Application = Request -> (Response -> IO ()) -> IO Trailers

21type StreamingBody = (Builder -> IO ()) -> IO () -> IO ()

23−data Response

24− = ResponseFile H.Status H.ResponseHeaders FilePath (Maybe FilePart)

25− | ResponseBuilder H.Status H.ResponseHeaders Builder

26− | ResponseStream H.Status H.ResponseHeaders StreamingBody

23+data Response = ResponseStream H.Status H.ResponseHeaders StreamingBody

28responseStatus :: Response -> H.Status

25responseStatus :: Response -> H.Status

29−responseStatus (ResponseFile s _ _ _) = s

30−responseStatus (ResponseBuilder s _ _) = s

31responseStatus (ResponseStream s _ _) = s

26responseStatus (ResponseStream s _ _) = s

33responseHeaders :: Response -> H.ResponseHeaders

28responseHeaders :: Response -> H.ResponseHeaders

34−responseHeaders (ResponseFile _ h _ _) = h

35−responseHeaders (ResponseBuilder _ h _) = h

36responseHeaders (ResponseStream _ h _) = h

29responseHeaders (ResponseStream _ h _) = h

37−

warp/Network/Wai/Handler/Warp/HTTP2.hs+6−13

@@ -16,10 +16,10 @@ import Data.ByteString (ByteString)

16import Network.HTTP2

17import Network.Socket (SockAddr)

19−import Network.Wai (Application, Response)

19+import Network.Wai (Application, responseToStream)

20−import qualified Network.Wai.HTTP2 as H2 (Response(..))

20+import Network.Wai.HTTP2 (Response(..))

21import Network.Wai.HTTP2 (Http2Application)

22−import Network.Wai.Internal (ResponseReceived(..), Response(..))

22+import Network.Wai.Internal (ResponseReceived(..))

23import Network.Wai.Handler.Warp.HTTP2.EncodeFrame

24import Network.Wai.Handler.Warp.HTTP2.Manager

25import Network.Wai.Handler.Warp.HTTP2.Receiver

@@ -79,13 +79,6 @@ goaway Connection{..} etype debugmsg = connSendAll bytestream

79-- the HTTP/2-specific features.

80promoteApplication :: Application -> Http2Application

81promoteApplication app req respond = [] <$ app req respond'

82+ where

82− where respond' x = ResponseReceived <$ respond (promoteResponse x)

83+ respond' r = ResponseReceived <$ (withBody $ respond . ResponseStream s h)

83−

84+ where (s, h, withBody) = responseToStream r

84−promoteResponse :: Response -> H2.Response

85−promoteResponse (ResponseFile a b c d) = H2.ResponseFile a b c d

86−promoteResponse (ResponseBuilder a b c) = H2.ResponseBuilder a b c

87−promoteResponse (ResponseStream a b c) = H2.ResponseStream a b c

88−promoteResponse (ResponseRaw _ b) =

89− -- There is no way to take over an HTTP/2 connection, so always serve the

90− -- backup response.

91− promoteResponse b

warp/Network/Wai/Handler/Warp/HTTP2/Sender.hs+2−158

@@ -15,26 +15,14 @@ import qualified Data.ByteString.Builder.Extra as B

15import Foreign.Ptr

16import Network.HTTP2

17import Network.HTTP2.Priority

18−import Network.Wai hiding (Response)

18+import Network.Wai.HTTP2 (Trailers)

19−import Network.Wai.HTTP2 (Trailers, Response(..))

20import Network.Wai.Handler.Warp.Buffer

19import Network.Wai.Handler.Warp.Buffer

21import Network.Wai.Handler.Warp.HTTP2.EncodeFrame

20import Network.Wai.Handler.Warp.HTTP2.EncodeFrame

22import Network.Wai.Handler.Warp.HTTP2.HPACK

21import Network.Wai.Handler.Warp.HTTP2.HPACK

23import Network.Wai.Handler.Warp.HTTP2.Types

22import Network.Wai.Handler.Warp.HTTP2.Types

24import Network.Wai.Handler.Warp.IORef

23import Network.Wai.Handler.Warp.IORef

25import qualified Network.Wai.Handler.Warp.Settings as S

24import qualified Network.Wai.Handler.Warp.Settings as S

26−import qualified Network.Wai.Handler.Warp.Timeout as T

27import Network.Wai.Handler.Warp.Types

25import Network.Wai.Handler.Warp.Types

28−import qualified System.PosixCompat.Files as P

29−

30−#ifdef WINDOWS

31−import qualified System.IO as IO

32−#else

33−import Network.Wai.Handler.Warp.FdCache

34−import Network.Wai.Handler.Warp.SendFile (positionRead)

35−import System.Posix.IO (openFd, OpenFileFlags(..), defaultFileFlags, OpenMode(ReadOnly), closeFd)

36−import System.Posix.Types

37−#endif

39----------------------------------------------------------------

27----------------------------------------------------------------

@@ -98,27 +86,10 @@ frameSender ctx@Context{outputQ,connectionWindow}

98 lim <- getWindowSize connectionWindow (streamWindow strm)

86 lim <- getWindowSize connectionWindow (streamWindow strm)

99 -- Header frame and Continuation frame

87 -- Header frame and Continuation frame

100 let sid = streamNumber strm

88 let sid = streamNumber strm

101− endOfStream = case aux of

102− Persist{} -> False

103− Oneshot hb -> not hb

104 builder <- hpackEncodeHeader ctx ii settings rsp

89 builder <- hpackEncodeHeader ctx ii settings rsp

105− len <- headerContinue sid builder endOfStream

90+ len <- headerContinue sid builder False

106 let total = len + frameHeaderLength

91 let total = len + frameHeaderLength

107 case aux of

92 case aux of

108− Oneshot True -> do -- hasBody

109− -- Data frame payload

110− (off, _) <- sendHeadersIfNecessary total

111− let payloadOff = off + frameHeaderLength

112− Next datPayloadLen mnext <-

113− fillResponseBodyGetNext conn ii payloadOff lim rsp

114− fillDataHeaderSend strm total datPayloadLen mnext

115− maybeEnqueueNext strm mnext

116− Oneshot False -> do

117− -- "closed" must be before "connSendAll". If not,

118− -- the context would be switched to the receiver,

119− -- resulting the inconsistency of concurrency.

120− closed ctx strm Finished

121− flushN total

122 Persist sq tvar -> do

93 Persist sq tvar -> do

123 (off, needSend) <- sendHeadersIfNecessary total

94 (off, needSend) <- sendHeadersIfNecessary total

124 let payloadOff = off + frameHeaderLength

95 let payloadOff = off + frameHeaderLength

@@ -238,62 +209,6 @@ frameSender ctx@Context{outputQ,connectionWindow}

238

209

239----------------------------------------------------------------

210----------------------------------------------------------------

240

211

241−{-

242−ResponseFile Status ResponseHeaders FilePath (Maybe FilePart)

243−ResponseBuilder Status ResponseHeaders Builder

244−ResponseStream Status ResponseHeaders StreamingBody

245−ResponseRaw (IO ByteString -> (ByteString -> IO ()) -> IO ()) Response

246−-}

247−

248−fillResponseBodyGetNext :: Connection -> InternalInfo -> Int -> WindowSize -> Response -> IO Next

249−fillResponseBodyGetNext Connection{connWriteBuffer,connBufferSize}

250− _ off lim (ResponseBuilder _ _ bb) = do

251− let datBuf = connWriteBuffer `plusPtr` off

252− room = min (connBufferSize - off) lim

253− (len, signal) <- B.runBuilder bb datBuf room

254− return $ nextForBuilder connWriteBuffer connBufferSize len signal

255−

256−#ifdef WINDOWS

257−fillResponseBodyGetNext Connection{connWriteBuffer,connBufferSize}

258− _ off lim (ResponseFile _ _ path mpart) = do

259− let datBuf = connWriteBuffer `plusPtr` off

260− room = min (connBufferSize - off) lim

261− (start, bytes) <- fileStartEnd path mpart

262− -- fixme: how to close Handle? GC does it at this moment.

263− h <- IO.openBinaryFile path IO.ReadMode

264− IO.hSeek h IO.AbsoluteSeek start

265− len <- IO.hGetBufSome h datBuf (mini room bytes)

266− let bytes' = bytes - fromIntegral len

267− return $ nextForFile len connWriteBuffer connBufferSize h bytes' (return ())

268−#else

269−fillResponseBodyGetNext Connection{connWriteBuffer,connBufferSize}

270− ii off lim (ResponseFile _ _ path mpart) = do

271− (fd, refresh) <- case fdCacher ii of

272− Just fdcache -> getFd fdcache path

273− Nothing -> do

274− fd' <- openFd path ReadOnly Nothing defaultFileFlags{nonBlock=True}

275− th <- T.register (timeoutManager ii) (closeFd fd')

276− return (fd', T.tickle th)

277− let datBuf = connWriteBuffer `plusPtr` off

278− room = min (connBufferSize - off) lim

279− (start, bytes) <- fileStartEnd path mpart

280− len <- positionRead fd datBuf (mini room bytes) start

281− refresh

282− let len' = fromIntegral len

283− return $ nextForFile len connWriteBuffer connBufferSize fd (start + len') (bytes - len') refresh

284−#endif

285−

286−fillResponseBodyGetNext _ _ _ _ _ = error "fillResponseBodyGetNext"

287−

288−fileStartEnd :: FilePath -> Maybe FilePart -> IO (Integer, Integer)

289−fileStartEnd path Nothing = do

290− end <- fromIntegral . P.fileSize <$> P.getFileStatus path

291− return (0, end)

292−fileStartEnd _ (Just part) =

293− return (filePartOffset part, filePartByteCount part)

294−

295−----------------------------------------------------------------

296−

297fillStreamBodyGetNext :: Connection -> Int -> WindowSize -> TBQueue Sequence -> TVar Sync -> Stream -> IO Next

212fillStreamBodyGetNext :: Connection -> Int -> WindowSize -> TBQueue Sequence -> TVar Sync -> Stream -> IO Next

298fillStreamBodyGetNext Connection{connWriteBuffer,connBufferSize}

213fillStreamBodyGetNext Connection{connWriteBuffer,connBufferSize}

299 off lim sq tvar strm = do

214 off lim sq tvar strm = do

@@ -304,38 +219,6 @@ fillStreamBodyGetNext Connection{connWriteBuffer,connBufferSize}

304

219

305----------------------------------------------------------------

220----------------------------------------------------------------

306

221

307−fillBufBuilder :: Buffer -> BufSize -> Leftover -> DynaNext

308−fillBufBuilder buf0 siz0 leftover lim = do

309− let payloadBuf = buf0 `plusPtr` frameHeaderLength

310− room = min (siz0 - frameHeaderLength) lim

311− case leftover of

312− LZero -> error "fillBufBuilder: LZero"

313− LOne writer -> do

314− (len, signal) <- writer payloadBuf room

315− getNext len signal

316− LTwo bs writer

317− | BS.length bs <= room -> do

318− buf1 <- copy payloadBuf bs

319− let len1 = BS.length bs

320− (len2, signal) <- writer buf1 (room - len1)

321− getNext (len1 + len2) signal

322− | otherwise -> do

323− let (bs1,bs2) = BS.splitAt room bs

324− void $ copy payloadBuf bs1

325− getNext room (B.Chunk bs2 writer)

326− where

327− getNext l s = return $ nextForBuilder buf0 siz0 l s

328−

329−nextForBuilder :: Buffer -> BufSize -> BytesFilled -> B.Next -> Next

330−nextForBuilder _ _ len B.Done

331− = Next len CFinish

332−nextForBuilder buf siz len (B.More _ writer)

333− = Next len (CNext (fillBufBuilder buf siz (LOne writer)))

334−nextForBuilder buf siz len (B.Chunk bs writer)

335− = Next len (CNext (fillBufBuilder buf siz (LTwo bs writer)))

336−

337−----------------------------------------------------------------

338−

339runStreamBuilder :: Buffer -> BufSize -> TBQueue Sequence

222runStreamBuilder :: Buffer -> BufSize -> TBQueue Sequence

340 -> IO (Leftover, Maybe Trailers, BytesFilled)

223 -> IO (Leftover, Maybe Trailers, BytesFilled)

341runStreamBuilder buf0 room0 sq = loop buf0 room0 0

224runStreamBuilder buf0 room0 sq = loop buf0 room0 0

@@ -400,42 +283,3 @@ nextForStream buf siz sq tvar strm LZero Nothing len = do

400 return $ Next len CNone

283 return $ Next len CNone

401nextForStream buf siz sq tvar strm leftover Nothing len =

284nextForStream buf siz sq tvar strm leftover Nothing len =

402 return $ Next len (CNext (fillBufStream buf siz leftover sq tvar strm))

285 return $ Next len (CNext (fillBufStream buf siz leftover sq tvar strm))

403−

404−----------------------------------------------------------------

405−

406−#ifdef WINDOWS

407−fillBufFile :: Buffer -> BufSize -> IO.Handle -> Integer -> IO () -> DynaNext

408−fillBufFile buf siz h bytes refresh lim = do

409− let payloadBuf = buf `plusPtr` frameHeaderLength

410− room = min (siz - frameHeaderLength) lim

411− len <- IO.hGetBufSome h payloadBuf room

412− refresh

413− let bytes' = bytes - fromIntegral len

414− return $ nextForFile len buf siz h bytes' refresh

415−

416−nextForFile :: BytesFilled -> Buffer -> BufSize -> IO.Handle -> Integer -> IO () -> Next

417−nextForFile 0 _ _ _ _ _ = Next 0 CFinish

418−nextForFile len _ _ _ 0 _ = Next len CFinish

419−nextForFile len buf siz h bytes refresh =

420− Next len (CNext (fillBufFile buf siz h bytes refresh))

421−#else

422−fillBufFile :: Buffer -> BufSize -> Fd -> Integer -> Integer -> IO () -> DynaNext

423−fillBufFile buf siz fd start bytes refresh lim = do

424− let payloadBuf = buf `plusPtr` frameHeaderLength

425− room = min (siz - frameHeaderLength) lim

426− len <- positionRead fd payloadBuf (mini room bytes) start

427− let len' = fromIntegral len

428− refresh

429− return $ nextForFile len buf siz fd (start + len') (bytes - len') refresh

430−

431−nextForFile :: BytesFilled -> Buffer -> BufSize -> Fd -> Integer -> Integer -> IO () -> Next

432−nextForFile 0 _ _ _ _ _ _ = Next 0 CFinish

433−nextForFile len _ _ _ _ 0 _ = Next len CFinish

434−nextForFile len buf siz fd start bytes refresh =

435− Next len (CNext (fillBufFile buf siz fd start bytes refresh))

436−#endif

437−

438−mini :: Int -> Integer -> Int

439−mini i n

440− | fromIntegral i < n = i

441− | otherwise = fromIntegral n

warp/Network/Wai/Handler/Warp/HTTP2/Types.hs+1−2

@@ -89,8 +89,7 @@ data Sync = SyncNone

89 | SyncFinish Trailers

90 | SyncNext Output

92−data Aux = Oneshot Bool

93− | Persist (TBQueue Sequence) (TVar Sync)

92+data Aux = Persist (TBQueue Sequence) (TVar Sync)

95----------------------------------------------------------------

94----------------------------------------------------------------

warp/Network/Wai/Handler/Warp/HTTP2/Worker.hs+6−12

@@ -18,16 +18,14 @@ import Control.Exception (Exception, SomeException(..), AsyncException(..))

18import qualified Control.Exception as E

19import Control.Monad (void, when)

20import Data.Typeable

21−import qualified Network.HTTP.Types as H

22import Network.HTTP2

21import Network.HTTP2

23import Network.HTTP2.Priority

22import Network.HTTP2.Priority

24−import Network.Wai.HTTP2 (Http2Application, Response(..), responseStatus)

23+import Network.Wai.HTTP2 (Http2Application, Response(..))

25import Network.Wai hiding (Response, responseStatus)

24import Network.Wai hiding (Response, responseStatus)

26import Network.Wai.Handler.Warp.HTTP2.EncodeFrame

25import Network.Wai.Handler.Warp.HTTP2.EncodeFrame

27import Network.Wai.Handler.Warp.HTTP2.Manager

26import Network.Wai.Handler.Warp.HTTP2.Manager

28import Network.Wai.Handler.Warp.HTTP2.Types

27import Network.Wai.Handler.Warp.HTTP2.Types

29import Network.Wai.Handler.Warp.IORef

28import Network.Wai.Handler.Warp.IORef

30−import qualified Network.Wai.Handler.Warp.Response as R

31import qualified Network.Wai.Handler.Warp.Settings as S

29import qualified Network.Wai.Handler.Warp.Settings as S

32import qualified Network.Wai.Handler.Warp.Timeout as T

30import qualified Network.Wai.Handler.Warp.Timeout as T

@@ -36,16 +34,18 @@ import qualified Network.Wai.Handler.Warp.Timeout as T

36-- | The wai definition is @type Http2Application = Request -> (Response -> IO ()) -> IO Trailers@.

34-- | The wai definition is @type Http2Application = Request -> (Response -> IO ()) -> IO Trailers@.

37-- This type implements the second argument @Response -> IO ()@

35-- This type implements the second argument @Response -> IO ()@

38-- with extra arguments.

36-- with extra arguments.

39−type Responder = ThreadContinue -> T.Handle -> Stream -> Request ->

37+type Responder = ThreadContinue -> T.Handle -> Stream ->

40 TBQueue Sequence -> Response -> IO ()

38 TBQueue Sequence -> Response -> IO ()

42-- | This function is passed to workers.

40-- | This function is passed to workers.

43-- They also pass 'Response's from 'Http2Application's to this function.

41-- They also pass 'Response's from 'Http2Application's to this function.

44-- This function enqueues commands for the HTTP/2 sender.

42-- This function enqueues commands for the HTTP/2 sender.

45response :: Context -> Manager -> Responder

43response :: Context -> Manager -> Responder

46−response Context{outputQ} mgr tconf th strm req sq rsp = do

44+response Context{outputQ} mgr tconf th strm sq rsp = do

47 case rsp of

45 case rsp of

48 ResponseStream _ _ strmbdy -> do

46 ResponseStream _ _ strmbdy -> do

47+ -- TODO(awpr)r HEAD requests will still stream.

48+ --

49 -- We must not exit this WAI application.

50 -- If the application exits, streaming would be also closed.

51 -- So, this work occupies this thread.

@@ -67,12 +67,6 @@ response Context{outputQ} mgr tconf th strm req sq rsp = do

67 T.tickle th

68 flush = atomically $ writeTBQueue sq SFlush

69 strmbdy push flush

70− _ -> do

71− setThreadContinue tconf True

72− let hasBody = requestMethod req /= H.methodHead

73− && R.hasBody (responseStatus rsp)

74− out = OResponse strm rsp (Oneshot hasBody)

75− enqueueOrSpawnTemporaryWaiter strm outputQ out

77data Break = Break deriving (Show, Typeable)

71data Break = Break deriving (Show, Typeable)

@@ -98,7 +92,7 @@ worker ctx@Context{inputQ,outputQ} set tm app responder = do

98 setStreamInfo sinfo strm req

92 setStreamInfo sinfo strm req

99 T.resume th

93 T.resume th

100 T.tickle th

94 T.tickle th

101− app req $ responder tcont th strm req sq

95+ app req $ responder tcont th strm sq

102 cont1 <- case ex of

96 cont1 <- case ex of

103 Right trailers -> do

97 Right trailers -> do

104 atomically $ writeTBQueue sq $ SFinish trailers

98 atomically $ writeTBQueue sq $ SFinish trailers