diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,16 @@ # ChangeLog for http2 +## 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/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/Context.hs b/Network/HTTP2/H2/Context.hs --- a/Network/HTTP2/H2/Context.hs +++ b/Network/HTTP2/H2/Context.hs @@ -90,7 +90,7 @@ , mySockAddr :: SockAddr , peerSockAddr :: SockAddr , threadManager :: T.ThreadManager - , receiverDone :: TVar Bool + , receiverDone :: TVar (Maybe SomeException) , workersDone :: STM Bool } {- FOURMOLU_ENABLE -} @@ -138,7 +138,7 @@ let mySockAddr = confMySockAddr let peerSockAddr = confPeerSockAddr threadManager <- T.newThreadManager timmgr - receiverDone <- newTVarIO False + receiverDone <- newTVarIO Nothing 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. 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. @@ -217,7 +220,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 +318,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/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/http2.cabal b/http2.cabal --- a/http2.cabal +++ b/http2.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: http2 -version: 5.4.0 +version: 5.4.1 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 @@ -122,7 +122,7 @@ network-control >=0.1 && <0.2, stm >=2.5 && <2.6, time-manager >=0.2.3 && <0.4, - unix-time >=0.4.11 && <0.5, + unix-time >=0.4.11 && <0.6, utf8-string >=1.0 && <1.1 executable h2c-client