diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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. diff --git a/Network/HTTP2/Client.hs b/Network/HTTP2/Client.hs --- a/Network/HTTP2/Client.hs +++ b/Network/HTTP2/Client.hs @@ -71,7 +71,18 @@ rstRateLimit, -- * Common configuration - Config (..), + Config, + defaultConfig, + confWriteBuffer, + confBufferSize, + confSendAll, + confReadN, + confPositionReadMaker, + confTimeoutManager, + confMySockAddr, + confPeerSockAddr, + confReadNTimeout, + confOnInformational, allocSimpleConfig, allocSimpleConfig', freeSimpleConfig, diff --git a/Network/HTTP2/Client/Internal.hs b/Network/HTTP2/Client/Internal.hs --- a/Network/HTTP2/Client/Internal.hs +++ b/Network/HTTP2/Client/Internal.hs @@ -1,6 +1,7 @@ module Network.HTTP2.Client.Internal ( Request (..), Response (..), + Config (..), ClientConfig (..), Settings (..), Aux (..), diff --git a/Network/HTTP2/Client/Run.hs b/Network/HTTP2/Client/Run.hs --- a/Network/HTTP2/Client/Run.hs +++ b/Network/HTTP2/Client/Run.hs @@ -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 diff --git a/Network/HTTP2/H2/Config.hs b/Network/HTTP2/H2/Config.hs --- a/Network/HTTP2/H2/Config.hs +++ b/Network/HTTP2/H2/Config.hs @@ -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. diff --git a/Network/HTTP2/H2/Context.hs b/Network/HTTP2/H2/Context.hs --- a/Network/HTTP2/H2/Context.hs +++ b/Network/HTTP2/H2/Context.hs @@ -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 diff --git a/Network/HTTP2/H2/Receiver.hs b/Network/HTTP2/H2/Receiver.hs --- a/Network/HTTP2/H2/Receiver.hs +++ b/Network/HTTP2/H2/Receiver.hs @@ -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) diff --git a/Network/HTTP2/H2/Sender.hs b/Network/HTTP2/H2/Sender.hs --- a/Network/HTTP2/H2/Sender.hs +++ b/Network/HTTP2/H2/Sender.hs @@ -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) diff --git a/Network/HTTP2/H2/Stream.hs b/Network/HTTP2/H2/Stream.hs --- a/Network/HTTP2/H2/Stream.hs +++ b/Network/HTTP2/H2/Stream.hs @@ -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 diff --git a/Network/HTTP2/H2/Types.hs b/Network/HTTP2/H2/Types.hs --- a/Network/HTTP2/H2/Types.hs +++ b/Network/HTTP2/H2/Types.hs @@ -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 = diff --git a/Network/HTTP2/Server.hs b/Network/HTTP2/Server.hs --- a/Network/HTTP2/Server.hs +++ b/Network/HTTP2/Server.hs @@ -51,7 +51,18 @@ rstRateLimit, -- * Common configuration - Config (..), + Config, + defaultConfig, + confWriteBuffer, + confBufferSize, + confSendAll, + confReadN, + confPositionReadMaker, + confTimeoutManager, + confMySockAddr, + confPeerSockAddr, + confReadNTimeout, + confOnInformational, allocSimpleConfig, allocSimpleConfig', freeSimpleConfig, diff --git a/Network/HTTP2/Server/Internal.hs b/Network/HTTP2/Server/Internal.hs --- a/Network/HTTP2/Server/Internal.hs +++ b/Network/HTTP2/Server/Internal.hs @@ -1,6 +1,8 @@ module Network.HTTP2.Server.Internal ( Request (..), Response (..), + Config (..), + ServerConfig (..), Aux (..), -- * Low level diff --git a/Network/HTTP2/Server/Run.hs b/Network/HTTP2/Server/Run.hs --- a/Network/HTTP2/Server/Run.hs +++ b/Network/HTTP2/Server/Run.hs @@ -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 diff --git a/Network/HTTP2/Server/Worker.hs b/Network/HTTP2/Server/Worker.hs --- a/Network/HTTP2/Server/Worker.hs +++ b/Network/HTTP2/Server/Worker.hs @@ -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 ---------------------------------------------------------------- diff --git a/http2.cabal b/http2.cabal --- a/http2.cabal +++ b/http2.cabal @@ -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 @@ -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 diff --git a/test/HTTP2/ServerSpec.hs b/test/HTTP2/ServerSpec.hs --- a/test/HTTP2/ServerSpec.hs +++ b/test/HTTP2/ServerSpec.hs @@ -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 "; rel=preload; as=style" + , Just "; 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", "; rel=preload; as=style")] + auxSendInformational aux earlyHints103 [("link", "; 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 =