http2 5.3.11 → 5.4.3
raw patch · 16 files changed
Files
- ChangeLog.md +23/−0
- Network/HTTP2/Client.hs +12/−1
- Network/HTTP2/Client/Internal.hs +1/−0
- Network/HTTP2/Client/Run.hs +9/−2
- Network/HTTP2/H2/Config.hs +1/−0
- Network/HTTP2/H2/Context.hs +7/−2
- Network/HTTP2/H2/Receiver.hs +40/−19
- Network/HTTP2/H2/Sender.hs +49/−21
- Network/HTTP2/H2/Stream.hs +4/−9
- Network/HTTP2/H2/Types.hs +25/−0
- Network/HTTP2/Server.hs +12/−1
- Network/HTTP2/Server/Internal.hs +2/−0
- Network/HTTP2/Server/Run.hs +3/−6
- Network/HTTP2/Server/Worker.hs +23/−0
- http2.cabal +5/−5
- test/HTTP2/ServerSpec.hs +30/−1
ChangeLog.md view
@@ -1,5 +1,28 @@ # ChangeLog for http2 +## 5.4.3++* auxSendInformational: gate usage with CPP to http-semantics >= 0.4.1+ [#170](https://github.com/kazu-yamamoto/http2/pull/170)++## 5.4.2++* Support informational (1xx) responses, e.g. 103 Early Hints. Servers can send+ them via `auxSendInformational`; clients can observe them via the new+ `confOnInformational` callback in `Config`.+ [#168](https://github.com/kazu-yamamoto/http2/pull/168)++## 5.4.1++* Ensure sender notices when receiver has terminated.+ [#167](https://github.com/kazu-yamamoto/http2/pull/167)++## 5.4.0++* Providing `defaultConfig`.+* Except the item above, this version is identical to v5.3.11 which+ includes breaking changes and is thus deprecated.+ ## 5.3.11 * Implementing `auxSendPing` for client.
Network/HTTP2/Client.hs view
@@ -71,7 +71,18 @@ rstRateLimit, -- * Common configuration- Config (..),+ Config,+ defaultConfig,+ confWriteBuffer,+ confBufferSize,+ confSendAll,+ confReadN,+ confPositionReadMaker,+ confTimeoutManager,+ confMySockAddr,+ confPeerSockAddr,+ confReadNTimeout,+ confOnInformational, allocSimpleConfig, allocSimpleConfig', freeSimpleConfig,
Network/HTTP2/Client/Internal.hs view
@@ -1,6 +1,7 @@ module Network.HTTP2.Client.Internal ( Request (..), Response (..),+ Config (..), ClientConfig (..), Settings (..), Aux (..),
Network/HTTP2/Client/Run.hs view
@@ -151,8 +151,15 @@ er <- race runReceiver runClient case er of Right r -> return r- -- never reached because runReceiver throws an exception to exit.- Left () -> throwIO ConnectionIsClosed+ Left err -> throwIO err++ -- When 'runClientReceiver' terminates, it is important we give the sender+ -- a chance to terminate cleanly also (it's possible the client terminated+ -- but there are still some messages in the queue to be sent).+ --+ -- If the client terminated successfully, we ignore any other errors in the+ -- sender (indeed, any exception here might simply be that the background+ -- threads were cancelled /because/ the client terminated). runAll = snd <$> concurrently runSender runClientReceiver makeStream
Network/HTTP2/H2/Config.hs view
@@ -33,6 +33,7 @@ confMySockAddr <- getSocketName s confPeerSockAddr <- getPeerName s let confReadNTimeout = False+ let confOnInformational = \_ _ -> return () return Config{..} -- | Deallocating the resource of the simple configuration.
Network/HTTP2/H2/Context.hs view
@@ -90,8 +90,12 @@ , mySockAddr :: SockAddr , peerSockAddr :: SockAddr , threadManager :: T.ThreadManager- , receiverDone :: TVar Bool+ , receiverDone :: TVar (Maybe SomeException) , workersDone :: STM Bool+ , informationalCallback :: StreamId -> TokenHeaderTable -> IO ()+ -- ^ Client only: called when a 1xx informational response (e.g. 103 Early+ -- Hints) is received, ahead of the final response. Copied from+ -- 'confOnInformational'; no-op by default. } {- FOURMOLU_ENABLE -} @@ -138,7 +142,8 @@ let mySockAddr = confMySockAddr let peerSockAddr = confPeerSockAddr threadManager <- T.newThreadManager timmgr- receiverDone <- newTVarIO False+ receiverDone <- newTVarIO Nothing+ let informationalCallback = confOnInformational let workersDone = fromMaybe (T.isAllGone threadManager) mdone return Context{..} where
Network/HTTP2/H2/Receiver.hs view
@@ -19,6 +19,7 @@ import qualified Data.ByteString.Short as Short import qualified Data.ByteString.UTF8 as UTF8 import Data.IORef+import Data.Void import Network.Control import Network.HTTP.Semantics import qualified System.ThreadManager as T@@ -45,14 +46,18 @@ ---------------------------------------------------------------- -frameReceiver :: Context -> Config -> IO ()-frameReceiver ctx conf@Config{..} =- (switch `E.catch` handler)- `E.finally` atomically- (writeTVar (receiverDone ctx) True)+frameReceiver :: Context -> Config -> IO E.SomeException+frameReceiver ctx@Context{receiverDone} conf@Config{..} =+ E.mask $ \unmask -> do+ mErr <- E.try $ unmask switch+ case mErr of+ Left err -> do+ atomically $ writeTVar receiverDone $ Just err+ return err+ Right x -> do+ absurd x -- We only terminate due to exceptions where- handler ConnectionIsClosed = return ()- handler e = E.throwIO e+ switch :: IO Void switch = do labelMe "H2 receiver" tid <- myThreadId@@ -60,13 +65,16 @@ then loop1 else- void $- T.withHandle (threadManager ctx) (E.throwTo tid ConnectionIsTimeout) loop2+ T.withHandle (threadManager ctx) (E.throwTo tid ConnectionIsTimeout) loop2++ loop1 :: IO Void loop1 = do hd <- confReadN frameHeaderLength -- throwing an exception on timeout when (BS.null hd) $ E.throwIO ConnectionIsClosed processFrame ctx conf $ decodeFrameHeader hd loop1++ loop2 :: T.Handle -> IO Void loop2 th = do -- If 'confReadN' is timeouted, 'ConnectionIsTimeout' is thrown -- to destroy the thread trees.@@ -379,6 +387,27 @@ where dep = streamDependency p +-- | Handle a decoded response HEADERS section. On the client, a 1xx+-- informational response (e.g. 103 Early Hints) is delivered to the+-- informational callback and the stream keeps waiting for the final response;+-- otherwise the headers become the (final) response.+onResponseHeaders+ :: Context+ -> StreamId+ -> Maybe ClosedCode+ -> Bool+ -> TokenHeaderTable+ -> IO StreamState+onResponseHeaders ctx streamId hcl endOfStream tbl+ | endOfStream = return $ Open hcl (NoBody tbl)+ | role ctx == Client && isInformational = do+ informationalCallback ctx streamId tbl+ return $ Open hcl JustOpened+ | otherwise = return $ Open hcl (HasBody tbl)+ where+ isInformational =+ maybe False ("1" `BS.isPrefixOf`) $ getFieldValue tokenStatus (snd tbl)+ stream :: FrameType -> FrameHeader@@ -408,11 +437,7 @@ if endOfHeader then do tbl <- hpackDecodeHeader frag streamId ctx- return $- if endOfStream- then -- turned into HalfClosedRemote in processState- Open hcl (NoBody tbl)- else Open hcl (HasBody tbl)+ onResponseHeaders ctx streamId hcl endOfStream tbl else do let siz = BS.length frag return $ Open hcl $ Continued [frag] siz 1 endOfStream@@ -514,11 +539,7 @@ then do let hdrblk = BS.concat $ reverse rfrags' tbl <- hpackDecodeHeader hdrblk streamId ctx- return $- if endOfStream- then -- turned into HalfClosedRemote in processState- Open hcl (NoBody tbl)- else Open hcl (HasBody tbl)+ onResponseHeaders ctx streamId hcl endOfStream tbl else return $ Open hcl $ Continued rfrags' siz' n' endOfStream -- (No state transition)
Network/HTTP2/H2/Sender.hs view
@@ -16,7 +16,6 @@ import Network.ByteOrder import Network.HTTP.Semantics.Client import Network.HTTP.Semantics.IO-import System.ThreadManager import Imports import Network.HPACK (setLimitForEncoding, toTokenHeaderTable)@@ -59,38 +58,42 @@ updateAllStreamTxFlow siz strms = forM_ strms $ \strm -> increaseStreamWindowSize strm siz -checkDone :: Context -> Int -> IO Bool+checkDone :: Context -> Int -> IO (Maybe E.SomeException) checkDone Context{..} 0 = atomically $ do isEmptyC <- isEmptyTQueue controlQ isEmptyO <- isEmptyTQueue outputQ if not isEmptyC || not isEmptyO then- return False+ return Nothing else do- gone <- isAllGone threadManager- unless gone retry- done <- readTVar receiverDone- unless done retry- return True-checkDone _ _ = return False+ recv <- readTVar receiverDone+ case recv of+ Just done ->+ return $ Just done+ _otherwise ->+ retry+checkDone _ _ = return Nothing -frameSender :: Context -> Config -> IO ()+frameSender :: Context -> Config -> IO E.SomeException frameSender ctx@Context{outputQ, controlQ, encodeDynamicTable, outputBufferLimit} Config{..} = do labelMe "H2 sender"- loop 0+ loop 0 `E.catch` return where ----------------------------------------------------------------- loop :: Offset -> IO ()+ loop :: Offset -> IO E.SomeException loop off = do- done <- checkDone ctx off- unless done $ do- x <- atomically $ dequeue off- case x of- C ctl -> flushN off >> control ctl >> loop 0- O out -> outputAndSync out off >>= flushIfNecessary >>= loop- Flush -> flushN off >> loop 0+ mDone <- checkDone ctx off+ case mDone of+ Just done ->+ return done+ Nothing -> do+ x <- atomically $ dequeue off+ case x of+ C ctl -> flushN off >> control ctl >> loop 0+ O out -> outputAndSync out off >>= flushIfNecessary >>= loop+ Flush -> flushN off >> loop 0 -- Flush the connection buffer to the socket, where the first 'n' bytes of -- the buffer are filled.@@ -164,6 +167,10 @@ (off', mout') <- outputHeader strm hdr mnext tlrmkr sync off sync mout' return off'+ OInformational hdr -> do+ off' <- outputInformational strm hdr off+ sync Nothing+ return off' _ -> do sws <- getStreamWindowSize strm cws <- getConnectionWindowSize ctx -- not 0@@ -208,6 +215,21 @@ return (off, Just out') ----------------------------------------------------------------+ -- Emit an informational (1xx) HEADERS section. Unlike 'outputHeader',+ -- this never sets END_STREAM and never half-closes the stream, so the+ -- final response can still be sent afterwards.+ outputInformational+ :: Stream+ -> [Header]+ -> Offset+ -> IO Offset+ outputInformational strm hdr off0 = do+ let sid = streamNumber strm+ (ths, _) <- toTokenHeaderTable $ fixHeaders hdr+ off' <- headerContinue sid ths False {- not endOfStream -} off0+ flushIfNecessary off'++ ---------------------------------------------------------------- output :: Output -> Offset -> WindowSize -> IO (Offset, Maybe Output) output out@(Output strm (ONext curr tlrmkr) _) off0 lim = do -- Data frame payload@@ -217,7 +239,10 @@ datBufSiz = buflim - payloadOff curr datBuf (min datBufSiz lim) >>= \case Next datPayloadLen reqflush mnext -> do- NextTrailersMaker tlrmkr' <- runTrailersMaker tlrmkr datBuf datPayloadLen+ tm <- runTrailersMaker tlrmkr datBuf datPayloadLen+ let tlrmkr' = case tm of+ NextTrailersMaker t -> t+ _ -> defaultTrailersMaker fillDataHeader strm off0@@ -312,7 +337,10 @@ reqflush = do let buf = confWriteBuffer `plusPtr` off (mtrailers, flag) <- do- Trailers trailers <- tlrmkr Nothing+ tm <- tlrmkr Nothing+ let trailers = case tm of+ Trailers t -> t+ _ -> [] if null trailers then return (Nothing, setEndStream defaultFlags) else return (Just trailers, defaultFlags)
Network/HTTP2/H2/Stream.hs view
@@ -77,12 +77,15 @@ closeAllStreams :: TVar OddStreamTable -> TVar EvenStreamTable -> Maybe SomeException -> IO ()-closeAllStreams ovar evar mErr' = do+closeAllStreams ovar evar mErr = do ostrms <- clearOddStreamTable ovar mapM_ finalize ostrms estrms <- clearEvenStreamTable evar mapM_ finalize estrms where+ -- We treat /every/ exception, including 'ConectionIsClosed', as abnormal+ -- termination: we should only report a clean termination when we receive an+ -- explicit @END_STREAM@ frame. finalize strm = do st <- readStreamState strm void $ tryPutMVar (streamInput strm) err@@ -91,14 +94,6 @@ atomically $ writeTQueue q $ maybe (Right (mempty, True)) Left mErr _otherwise -> return ()-- mErr :: Maybe SomeException- mErr = case mErr' of- Just e- | Just ConnectionIsClosed <- fromException e ->- Nothing- _otherwise ->- mErr' err :: Either SomeException a err = Left $ fromMaybe (toException ConnectionIsClosed) mErr
Network/HTTP2/H2/Types.hs view
@@ -14,6 +14,7 @@ ) import qualified Control.Exception as E import Data.IORef+import Foreign.Ptr (nullPtr) import Network.Control import Network.HTTP.Semantics.Client import Network.HTTP.Semantics.IO@@ -189,6 +190,7 @@ = OHeader [Header] (Maybe DynaNext) TrailersMaker | OPush TokenHeaderList StreamId -- associated stream id from client | ONext DynaNext TrailersMaker+ | OInformational [Header] data Sync = Done | Cont Output @@ -270,7 +272,30 @@ , confPeerSockAddr :: SockAddr -- ^ This is copied into 'Aux', if exist, on server. , confReadNTimeout :: Bool+ , confOnInformational :: StreamId -> TokenHeaderTable -> IO ()+ -- ^ Client only: called when a 1xx informational response (e.g. 103 Early+ -- Hints) is received on the given stream, ahead of the final response.+ -- No-op by default.+ --+ -- @since 5.4.2 }++-- | Default config. This is just a template to modify via+-- field names. Don't use this without modifications.+defaultConfig :: Config+defaultConfig =+ Config+ { confWriteBuffer = nullPtr+ , confBufferSize = 0+ , confSendAll = \_ -> return ()+ , confReadN = \_ -> return ""+ , confPositionReadMaker = defaultPositionReadMaker+ , confTimeoutManager = T.defaultManager+ , confMySockAddr = SockAddrInet 0 0+ , confPeerSockAddr = SockAddrInet 0 0+ , confReadNTimeout = False+ , confOnInformational = \_ _ -> return ()+ } isAsyncException :: Exception e => e -> Bool isAsyncException e =
Network/HTTP2/Server.hs view
@@ -51,7 +51,18 @@ rstRateLimit, -- * Common configuration- Config (..),+ Config,+ defaultConfig,+ confWriteBuffer,+ confBufferSize,+ confSendAll,+ confReadN,+ confPositionReadMaker,+ confTimeoutManager,+ confMySockAddr,+ confPeerSockAddr,+ confReadNTimeout,+ confOnInformational, allocSimpleConfig, allocSimpleConfig', freeSimpleConfig,
Network/HTTP2/Server/Internal.hs view
@@ -1,6 +1,8 @@ module Network.HTTP2.Server.Internal ( Request (..), Response (..),+ Config (..),+ ServerConfig (..), Aux (..), -- * Low level
Network/HTTP2/Server/Run.hs view
@@ -3,9 +3,8 @@ module Network.HTTP2.Server.Run where -import Control.Concurrent.Async (concurrently_)+import Control.Concurrent.Async import Control.Concurrent.STM-import qualified Control.Exception as E import Imports import Network.Control (defaultMaxData) import Network.HTTP.Semantics.IO@@ -128,10 +127,8 @@ runReceiver = frameReceiver ctx conf runSender = frameSender ctx conf runBackgroundThreads = do- er <- E.try $ concurrently_ runReceiver runSender- case er of- Right () -> return ()- Left e -> closureServer conf ctx e+ e <- snd <$> concurrently runReceiver runSender+ closureServer conf ctx e T.stopAfter mgr runBackgroundThreads $ \res -> closeAllStreams (oddStreamTable ctx) (evenStreamTable ctx) res
Network/HTTP2/Server/Worker.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -18,6 +19,10 @@ import Network.HTTP2.Frame import Network.HTTP2.H2 +#if MIN_VERSION_http_semantics(0,4,1)+import qualified Data.ByteString.Char8 as C8+#endif+ ---------------------------------------------------------------- runServer :: Config -> Server -> Launch@@ -29,6 +34,9 @@ { auxTimeHandle = th , auxMySockAddr = mySockAddr , auxPeerSockAddr = peerSockAddr+#if MIN_VERSION_http_semantics(0,4,1)+ , auxSendInformational = sendInformational ctx strm+#endif } request = Request req' lc <- newLoopCheck strm Nothing@@ -45,6 +53,21 @@ bs <- readBody T.resume th -- this is the same as 'tickle' return bs++----------------------------------------------------------------++#if MIN_VERSION_http_semantics(0,4,1)+-- | Send an informational (1xx) response, e.g. 103 Early Hints, on the given+-- stream ahead of the final response. This is wired into 'auxSendInformational'+-- so that a server (or WAI handler via Warp) can emit early hints. It blocks+-- until the informational HEADERS have been handed to the sender, preserving+-- ordering with respect to the final response.+sendInformational :: Context -> Stream -> Status -> ResponseHeaders -> IO ()+sendInformational ctx strm st hdrs = do+ lc <- newLoopCheck strm Nothing+ let hdr = (":status", C8.pack (show (statusCode st))) : hdrs+ syncWithSender ctx strm (OInformational hdr) lc+#endif ----------------------------------------------------------------
http2.cabal view
@@ -1,6 +1,6 @@ cabal-version: >=1.10 name: http2-version: 5.3.11+version: 5.4.3 license: BSD3 license-file: LICENSE maintainer: Kazu Yamamoto <kazu@iij.ad.jp>@@ -8,7 +8,7 @@ homepage: https://github.com/kazu-yamamoto/http2 synopsis: HTTP/2 library description:- HTTP/2 library including frames, priority queues, HPACK, client and server.+ HTTP/2 library including frames, HPACK, client and server. category: Network build-type: Simple@@ -114,15 +114,15 @@ bytestring >=0.10, case-insensitive >=1.2 && <1.3, containers >=0.6,- http-semantics >= 0.3.1 && <0.4,+ http-semantics >= 0.4 && <0.5, http-types >=0.12 && <0.13, iproute >= 1.7 && < 1.8, network >=3.1, network-byte-order >=0.1.7 && <0.2, network-control >=0.1 && <0.2, stm >=2.5 && <2.6,- time-manager >=0.2 && <0.4,- unix-time >=0.4.11 && <0.5,+ time-manager >=0.3.0 && <0.4,+ unix-time >=0.4.11 && <0.6, utf8-string >=1.0 && <1.1 executable h2c-client
test/HTTP2/ServerSpec.hs view
@@ -49,6 +49,17 @@ threadDelay 10000 runClient allocSimpleConfig + it "delivers 103 Early Hints to the client's informational handler" $+ E.bracket (forkIO runServer) killThread $ \_ -> do+ threadDelay 10000+ hintsRef <- newIORef []+ runClientEarly hintsRef >>= (`shouldBe` Just ok200)+ hints <- readIORef hintsRef+ map (getFieldValue (toToken "link") . snd) hints+ `shouldBe` [ Just "</style.css>; rel=preload; as=style"+ , Just "</app.js>; rel=preload; as=script"+ ]+ it "should always send the connection preface first" $ do prefaceVar <- newEmptyMVar E.bracket (forkIO (runFakeServer prefaceVar)) killThread $ \_ -> do@@ -103,9 +114,13 @@ threadDelay 10000 server :: Server-server req _aux sendResponse = case requestMethod req of+server req aux sendResponse = case requestMethod req of Just "GET" -> case requestPath req of Just "/" -> sendResponse responseHello []+ Just "/early" -> do+ auxSendInformational aux earlyHints103 [("link", "</style.css>; rel=preload; as=style")]+ auxSendInformational aux earlyHints103 [("link", "</app.js>; rel=preload; as=script")]+ sendResponse responseHello [] Just "/stream" -> sendResponse responseInfinite [] Just "/push" -> do let pp = pushPromise "/push-pp" responsePP 0@@ -122,6 +137,9 @@ header = [("Content-Type", "text/plain")] body = byteString "Hello, world!\n" +earlyHints103 :: Status+earlyHints103 = mkStatus 103 "Early Hints"+ responsePP :: Response responsePP = responseBuilder ok200 header body where@@ -172,6 +190,17 @@ trailersMaker ctx (Just bs) = return $ NextTrailersMaker $ trailersMaker ctx' where !ctx' = CH.hashUpdate ctx bs++-- | Request @/early@ with an informational handler installed, recording each+-- 103 Early Hints section and returning the final response status.+runClientEarly :: IORef [TokenHeaderTable] -> IO (Maybe Status)+runClientEarly hintsRef = runTCPClient host port $ \s ->+ E.bracket (allocSimpleConfig s 4096) freeSimpleConfig $ \conf0 ->+ C.run cliconf (conf0{confOnInformational = onInformational }) $ \sendRequest _aux ->+ sendRequest (C.requestNoBody methodGet "/early" []) (return . C.responseStatus)+ where+ cliconf = C.defaultClientConfig{C.authority = host}+ onInformational _sid tbl = modifyIORef' hintsRef (++ [tbl]) runClient :: (Socket -> BufferSize -> IO Config) -> IO () runClient allocConfig =