Script 'mail_helper' called by obssrc Hello community, here is the log from the commit of package ghc-http2 for openSUSE:Factory checked in at 2025-07-02 12:08:55 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-http2 (Old) and /work/SRC/openSUSE:Factory/.ghc-http2.new.7067 (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-http2" Wed Jul 2 12:08:55 2025 rev:15 rq:1289423 version:5.3.10 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-http2/ghc-http2.changes 2024-12-20 23:11:13.701976274 +0100 +++ /work/SRC/openSUSE:Factory/.ghc-http2.new.7067/ghc-http2.changes 2025-07-02 12:09:46.247403505 +0200 @@ -1,0 +2,9 @@ +Thu Jun 26 05:31:35 UTC 2025 - Peter Simons <[email protected]> + +- Update http2 to version 5.3.10. + ## 5.3.10 + + * Introducing closure. + [#157](https://github.com/kazu-yamamoto/http2/pull/157) + +------------------------------------------------------------------- Old: ---- http2-5.3.9.tar.gz New: ---- http2-5.3.10.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-http2.spec ++++++ --- /var/tmp/diff_new_pack.DyJDam/_old 2025-07-02 12:09:48.347492694 +0200 +++ /var/tmp/diff_new_pack.DyJDam/_new 2025-07-02 12:09:48.351492864 +0200 @@ -1,7 +1,7 @@ # # spec file for package ghc-http2 # -# Copyright (c) 2024 SUSE LLC +# Copyright (c) 2025 SUSE LLC # # All modifications and additions to the file contributed by third parties # remain the property of their copyright owners, unless otherwise agreed @@ -20,7 +20,7 @@ %global pkgver %{pkg_name}-%{version} %bcond_with tests Name: ghc-%{pkg_name} -Version: 5.3.9 +Version: 5.3.10 Release: 0 Summary: HTTP/2 library License: BSD-3-Clause ++++++ http2-5.3.9.tar.gz -> http2-5.3.10.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/http2-5.3.9/ChangeLog.md new/http2-5.3.10/ChangeLog.md --- old/http2-5.3.9/ChangeLog.md 2001-09-09 03:46:40.000000000 +0200 +++ new/http2-5.3.10/ChangeLog.md 2001-09-09 03:46:40.000000000 +0200 @@ -1,5 +1,10 @@ # ChangeLog for http2 +## 5.3.10 + +* Introducing closure. + [#157](https://github.com/kazu-yamamoto/http2/pull/157) + ## 5.3.9 * Using `ThreadManager` of `time-manager`. diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/http2-5.3.9/Network/HPACK/HeaderBlock/Encode.hs new/http2-5.3.10/Network/HPACK/HeaderBlock/Encode.hs --- old/http2-5.3.9/Network/HPACK/HeaderBlock/Encode.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/http2-5.3.10/Network/HPACK/HeaderBlock/Encode.hs 2001-09-09 03:46:40.000000000 +0200 @@ -1,4 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Network.HPACK.HeaderBlock.Encode ( diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/http2-5.3.9/Network/HPACK/HeaderBlock/Integer.hs new/http2-5.3.10/Network/HPACK/HeaderBlock/Integer.hs --- old/http2-5.3.9/Network/HPACK/HeaderBlock/Integer.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/http2-5.3.10/Network/HPACK/HeaderBlock/Integer.hs 2001-09-09 03:46:40.000000000 +0200 @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Network.HPACK.HeaderBlock.Integer ( encodeI, encodeInteger, diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/http2-5.3.9/Network/HPACK/Huffman/Tree.hs new/http2-5.3.10/Network/HPACK/Huffman/Tree.hs --- old/http2-5.3.9/Network/HPACK/Huffman/Tree.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/http2-5.3.10/Network/HPACK/Huffman/Tree.hs 2001-09-09 03:46:40.000000000 +0200 @@ -72,9 +72,13 @@ (cnt2, r) = build cnt1 ts in (cnt2, Bin Nothing cnt0 l r) where - (fs', ts') = partition ((==) F . head . snd) xs - fs = map (second tail) fs' - ts = map (second tail) ts' + (fs', ts') = partition (isHeadF . snd) xs + fs = map (second (drop 1)) fs' + ts = map (second (drop 1)) ts' + +isHeadF :: Bits -> Bool +isHeadF [] = error "isHeadF" +isHeadF (b : _) = b == F -- | Marking the EOS path mark :: Int -> Bits -> HTree -> HTree diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/http2-5.3.9/Network/HPACK/Table/Dynamic.hs new/http2-5.3.10/Network/HPACK/Table/Dynamic.hs --- old/http2-5.3.9/Network/HPACK/Table/Dynamic.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/http2-5.3.10/Network/HPACK/Table/Dynamic.hs 2001-09-09 03:46:40.000000000 +0200 @@ -312,11 +312,12 @@ ---------------------------------------------------------------- -- | Inserting 'Entry' to 'DynamicTable'. --- New 'DynamicTable', the largest new 'Index' --- and a set of dropped OLD 'Index' --- are returned. insertEntry :: Entry -> DynamicTable -> IO () insertEntry e dyntbl@DynamicTable{..} = do + -- Theoretically speaking, dropping entries by adjustTableSize + -- should be first. However, non-used slots always exist since the + -- size of dynamic table calculated via the minimum entry size (32 + -- bytes). To simply adjustTableSize, insertFront is called first. insertFront e dyntbl es <- adjustTableSize dyntbl case codeInfo of @@ -359,6 +360,7 @@ ---------------------------------------------------------------- +-- Used in copyEntries. insertEnd :: Entry -> DynamicTable -> IO () insertEnd e DynamicTable{..} = do maxN <- readIORef maxNumOfEntries diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/http2-5.3.9/Network/HPACK/Types.hs new/http2-5.3.10/Network/HPACK/Types.hs --- old/http2-5.3.9/Network/HPACK/Types.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/http2-5.3.10/Network/HPACK/Types.hs 2001-09-09 03:46:40.000000000 +0200 @@ -23,7 +23,6 @@ ) where import Control.Exception as E -import Data.Typeable import Network.ByteOrder (Buffer, BufferOverrun (..), BufferSize) import Imports @@ -88,6 +87,6 @@ | HeaderBlockTruncated | IllegalHeaderName | TooLargeHeader - deriving (Eq, Show, Typeable) + deriving (Eq, Show) instance Exception DecodeError diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/http2-5.3.9/Network/HTTP2/Client/Run.hs new/http2-5.3.10/Network/HTTP2/Client/Run.hs --- old/http2-5.3.9/Network/HTTP2/Client/Run.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/http2-5.3.10/Network/HTTP2/Client/Run.hs 2001-09-09 03:46:40.000000000 +0200 @@ -1,4 +1,3 @@ -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} @@ -93,19 +92,7 @@ x <- processResponse rsp adjustRxWindow ctx strm return x - runClient ctx = wrapClient ctx $ client (clientCore ctx) $ aux ctx - -wrapClient :: Context -> IO a -> IO a -wrapClient ctx client = do - x <- client - T.waitUntilAllGone $ threadManager ctx - let frame = goawayFrame 0 NoError "graceful closing" - enqueueControl (controlQ ctx) $ CFrames Nothing [frame] - enqueueControl (controlQ ctx) $ CFinish GoAwayIsSent - atomically $ do - done <- readTVar $ senderDone ctx - check done - return x + runClient ctx = client (clientCore ctx) $ aux ctx -- | Launching a receiver and a sender. runIO :: ClientConfig -> Config -> (ClientIO -> IO (IO a)) -> IO a @@ -120,9 +107,8 @@ return (streamNumber strm, strm) get = getResponse create = openOddStreamWait ctx - runClient <- do - act <- action $ ClientIO confMySockAddr confPeerSockAddr putR get putB create - return $ wrapClient ctx act + runClient <- + action $ ClientIO confMySockAddr confPeerSockAddr putR get putB create runH2 conf ctx runClient getResponse :: Stream -> IO Response @@ -148,7 +134,7 @@ runH2 :: Config -> Context -> IO a -> IO a runH2 conf ctx runClient = do - T.stopAfter mgr runAll $ \res -> + T.stopAfter mgr (try runAll >>= closureClient conf) $ \res -> closeAllStreams (oddStreamTable ctx) (evenStreamTable ctx) res where mgr = threadManager ctx @@ -157,20 +143,11 @@ runBackgroundThreads = do labelMe "H2 runBackgroundThreads" concurrently_ runReceiver runSender - - -- Run the background threads and client concurrently. If the client - -- finishes first, cancel the background threads. If the background - -- threads finish first, wait for the client. runAll = do - withAsync runBackgroundThreads $ \runningBackgroundThreads -> - withAsync runClient $ \runningClient -> do - result <- waitEither runningBackgroundThreads runningClient - case result of - Right clientResult -> do - cancel runningBackgroundThreads - return clientResult - Left () -> do - wait runningClient + er <- race runBackgroundThreads runClient + case er of + Left () -> undefined + Right r -> return r makeStream :: Context diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/http2-5.3.9/Network/HTTP2/Frame/Decode.hs new/http2-5.3.10/Network/HTTP2/Frame/Decode.hs --- old/http2-5.3.9/Network/HTTP2/Frame/Decode.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/http2-5.3.10/Network/HTTP2/Frame/Decode.hs 2001-09-09 03:46:40.000000000 +0200 @@ -1,4 +1,3 @@ -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/http2-5.3.9/Network/HTTP2/Frame/Types.hs new/http2-5.3.10/Network/HTTP2/Frame/Types.hs --- old/http2-5.3.9/Network/HTTP2/Frame/Types.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/http2-5.3.10/Network/HTTP2/Frame/Types.hs 2001-09-09 03:46:40.000000000 +0200 @@ -1,4 +1,3 @@ -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} @@ -541,6 +540,6 @@ type SettingsKeyId = SettingsKey type FrameTypeId = FrameType {- FOURMOLU_ENABLE -} -{- DEPRECATED ErrorCodeId "Use ErrorCode instead" -} -{- DEPRECATED SettingsKeyId "Use SettingsKey instead" -} -{- DEPRECATED FrameTypeId "Use FrameType instead" -} +{-# DEPRECATED ErrorCodeId "Use ErrorCode instead" #-} +{-# DEPRECATED SettingsKeyId "Use SettingsKey instead" #-} +{-# DEPRECATED FrameTypeId "Use FrameType instead" #-} diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/http2-5.3.9/Network/HTTP2/H2/Config.hs new/http2-5.3.10/Network/HTTP2/H2/Config.hs --- old/http2-5.3.9/Network/HTTP2/H2/Config.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/http2-5.3.10/Network/HTTP2/H2/Config.hs 2001-09-09 03:46:40.000000000 +0200 @@ -1,3 +1,5 @@ +{-# LANGUAGE RecordWildCards #-} + module Network.HTTP2.H2.Config where import Data.IORef @@ -22,23 +24,15 @@ -- timeout manager. allocSimpleConfig' :: Socket -> BufferSize -> Int -> IO Config allocSimpleConfig' s bufsiz usec = do - buf <- mallocBytes bufsiz - ref <- newIORef Nothing - timmgr <- T.initialize usec - mysa <- getSocketName s - peersa <- getPeerName s - let config = - Config - { confWriteBuffer = buf - , confBufferSize = bufsiz - , confSendAll = sendAll s - , confReadN = defaultReadN s ref - , confPositionReadMaker = defaultPositionReadMaker - , confTimeoutManager = timmgr - , confMySockAddr = mysa - , confPeerSockAddr = peersa - } - return config + confWriteBuffer <- mallocBytes bufsiz + let confBufferSize = bufsiz + let confSendAll = sendAll s + confReadN <- defaultReadN s <$> newIORef Nothing + let confPositionReadMaker = defaultPositionReadMaker + confTimeoutManager <- T.initialize usec + confMySockAddr <- getSocketName s + confPeerSockAddr <- getPeerName s + return Config{..} -- | Deallocating the resource of the simple configuration. freeSimpleConfig :: Config -> IO () diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/http2-5.3.9/Network/HTTP2/H2/Context.hs new/http2-5.3.10/Network/HTTP2/H2/Context.hs --- old/http2-5.3.9/Network/HTTP2/H2/Context.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/http2-5.3.10/Network/HTTP2/H2/Context.hs 2001-09-09 03:46:40.000000000 +0200 @@ -28,7 +28,7 @@ type Launch = Context -> Stream -> InpObj -> IO () -data ServerInfo = ServerInfo +newtype ServerInfo = ServerInfo { launch :: Launch } @@ -53,46 +53,48 @@ ---------------------------------------------------------------- +{- FOURMOLU_DISABLE -} -- | The context for HTTP/2 connection. data Context = Context - { role :: Role - , roleInfo :: RoleInfo + { role :: Role + , roleInfo :: RoleInfo , -- Settings - mySettings :: Settings - , myFirstSettings :: IORef Bool - , peerSettings :: IORef Settings - , oddStreamTable :: TVar OddStreamTable - , evenStreamTable :: TVar EvenStreamTable - , continued :: IORef (Maybe StreamId) + mySettings :: Settings + , myFirstSettings :: IORef Bool + , peerSettings :: IORef Settings + , oddStreamTable :: TVar OddStreamTable + , evenStreamTable :: TVar EvenStreamTable + , continued :: IORef (Maybe StreamId) -- ^ RFC 9113 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. - , myStreamId :: TVar StreamId - , peerStreamId :: IORef StreamId - , outputBufferLimit :: IORef Int - , outputQ :: TQueue Output + , myStreamId :: TVar StreamId + , peerStreamId :: IORef StreamId + , outputBufferLimit :: IORef Int + , outputQ :: TQueue Output -- ^ Invariant: Each stream will only ever have at most one 'Output' -- object in this queue at any moment. - , outputQStreamID :: TVar StreamId - , controlQ :: TQueue Control + , outputQStreamID :: TVar StreamId + , controlQ :: TQueue Control , encodeDynamicTable :: DynamicTable , decodeDynamicTable :: DynamicTable , -- the connection window for sending data - txFlow :: TVar TxFlow - , rxFlow :: IORef RxFlow - , pingRate :: Rate - , settingsRate :: Rate - , emptyFrameRate :: Rate - , rstRate :: Rate - , mySockAddr :: SockAddr - , peerSockAddr :: SockAddr - , threadManager :: T.ThreadManager - , senderDone :: TVar Bool + txFlow :: TVar TxFlow + , rxFlow :: IORef RxFlow + , pingRate :: Rate + , settingsRate :: Rate + , emptyFrameRate :: Rate + , rstRate :: Rate + , mySockAddr :: SockAddr + , peerSockAddr :: SockAddr + , threadManager :: T.ThreadManager } +{- FOURMOLU_ENABLE -} ---------------------------------------------------------------- +{- FOURMOLU_DISABLE -} newContext :: RoleInfo -> Config @@ -101,47 +103,49 @@ -> Settings -> T.Manager -> IO Context -newContext rinfo Config{..} cacheSiz connRxWS settings timmgr = +newContext roleInfo Config{..} cacheSiz connRxWS mySettings timmgr = do -- My: Use this even if ack has not been received yet. - Context rl rinfo settings - <$> newIORef False - -- Peer: The spec defines max concurrency is infinite unless - -- SETTINGS_MAX_CONCURRENT_STREAMS is exchanged. - -- But it is vulnerable, so we set the limitations. - <*> newIORef baseSettings{maxConcurrentStreams = Just defaultMaxStreams} - <*> newTVarIO emptyOddStreamTable - <*> newTVarIO (emptyEvenStreamTable cacheSiz) - <*> newIORef Nothing - <*> newTVarIO sid0 - <*> newIORef 0 - <*> newIORef buflim - <*> newTQueueIO - <*> newTVarIO sid0 - <*> newTQueueIO - -- My SETTINGS_HEADER_TABLE_SIZE - <*> newDynamicTableForEncoding defaultDynamicTableSize - <*> newDynamicTableForDecoding (headerTableSize settings) 4096 - <*> newTVarIO (newTxFlow defaultWindowSize) -- 64K - <*> newIORef (newRxFlow connRxWS) - <*> newRate - <*> newRate - <*> newRate - <*> newRate - <*> return confMySockAddr - <*> return confPeerSockAddr - <*> T.newThreadManager timmgr - <*> newTVarIO False + myFirstSettings <- newIORef False + -- Peer: The spec defines max concurrency is infinite unless + -- SETTINGS_MAX_CONCURRENT_STREAMS is exchanged. + -- But it is vulnerable, so we set the limitations. + peerSettings <- + newIORef baseSettings{maxConcurrentStreams = Just defaultMaxStreams} + oddStreamTable <- newTVarIO emptyOddStreamTable + evenStreamTable <- newTVarIO (emptyEvenStreamTable cacheSiz) + continued <- newIORef Nothing + myStreamId <- newTVarIO sid0 + peerStreamId <- newIORef 0 + outputBufferLimit <- newIORef buflim + outputQ <- newTQueueIO + outputQStreamID <- newTVarIO sid0 + controlQ <- newTQueueIO + -- My SETTINGS_HEADER_TABLE_SIZE + encodeDynamicTable <- newDynamicTableForEncoding defaultDynamicTableSize + decodeDynamicTable <- + newDynamicTableForDecoding (headerTableSize mySettings) 4096 + txFlow <- newTVarIO (newTxFlow defaultWindowSize) -- 64K + rxFlow <- newIORef (newRxFlow connRxWS) + pingRate <- newRate + settingsRate <- newRate + emptyFrameRate <- newRate + rstRate <- newRate + let mySockAddr = confMySockAddr + let peerSockAddr = confPeerSockAddr + threadManager <- T.newThreadManager timmgr + return Context{..} where - rl = case rinfo of + role = case roleInfo of RIC{} -> Client _ -> Server sid0 - | rl == Client = 1 + | role == Client = 1 | otherwise = 2 dlim = defaultPayloadLength + frameHeaderLength buflim | confBufferSize >= dlim = dlim | otherwise = confBufferSize +{- FOURMOLU_ENABLE -} ---------------------------------------------------------------- diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/http2-5.3.9/Network/HTTP2/H2/Queue.hs new/http2-5.3.10/Network/HTTP2/H2/Queue.hs --- old/http2-5.3.9/Network/HTTP2/H2/Queue.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/http2-5.3.10/Network/HTTP2/H2/Queue.hs 2001-09-09 03:46:40.000000000 +0200 @@ -1,5 +1,3 @@ -{-# LANGUAGE RecordWildCards #-} - module Network.HTTP2.H2.Queue where import Control.Concurrent.STM diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/http2-5.3.9/Network/HTTP2/H2/Receiver.hs new/http2-5.3.10/Network/HTTP2/H2/Receiver.hs --- old/http2-5.3.9/Network/HTTP2/H2/Receiver.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/http2-5.3.10/Network/HTTP2/H2/Receiver.hs 2001-09-09 03:46:40.000000000 +0200 @@ -6,6 +6,8 @@ module Network.HTTP2.H2.Receiver ( frameReceiver, + closureClient, + closureServer, ) where import Control.Concurrent @@ -18,7 +20,6 @@ import Data.IORef import Network.Control import Network.HTTP.Semantics -import qualified System.ThreadManager as T import Imports hiding (delete, insert) import Network.HTTP2.Frame @@ -43,49 +44,17 @@ ---------------------------------------------------------------- frameReceiver :: Context -> Config -> IO () -frameReceiver ctx@Context{..} conf@Config{..} = do +frameReceiver ctx conf@Config{..} = do labelMe "H2 receiver" - loop `E.catch` sendGoaway + loop where loop = do -- If 'confReadN' is timeouted, an exception is thrown -- to destroy the thread trees. hd <- confReadN frameHeaderLength - if BS.null hd - then enqueueControl controlQ $ CFinish ConnectionIsTimeout - else do - processFrame ctx conf $ decodeFrameHeader hd - loop - - sendGoaway se - | isAsyncException se = E.throwIO se - | Just GoAwayIsSent <- E.fromException se = do - T.waitUntilAllGone threadManager - enqueueControl controlQ $ CFinish GoAwayIsSent - | Just ConnectionIsClosed <- E.fromException se = do - T.waitUntilAllGone threadManager - enqueueControl controlQ $ CFinish ConnectionIsClosed - | Just e@(ConnectionErrorIsReceived _ _ _) <- E.fromException se = - enqueueControl controlQ $ CFinish e - | Just e@(ConnectionErrorIsSent err sid msg) <- E.fromException se = do - let frame = goawayFrame sid err $ Short.fromShort msg - enqueueControl controlQ $ CFrames Nothing [frame] - enqueueControl controlQ $ CFinish e - | Just e@(StreamErrorIsSent err sid msg) <- E.fromException se = do - let frame = resetFrame err sid - enqueueControl controlQ $ CFrames Nothing [frame] - let frame' = goawayFrame sid err $ Short.fromShort msg - enqueueControl controlQ $ CFrames Nothing [frame'] - enqueueControl controlQ $ CFinish e - | Just e@(StreamErrorIsReceived err sid) <- E.fromException se = do - let frame = goawayFrame sid err "treat a stream error as a connection error" - enqueueControl controlQ $ CFrames Nothing [frame] - enqueueControl controlQ $ CFinish e - -- this never happens - | Just e@(BadThingHappen _) <- E.fromException se = - enqueueControl controlQ $ CFinish e - | otherwise = - enqueueControl controlQ $ CFinish $ BadThingHappen se + when (BS.null hd) $ E.throwIO ConnectionIsTimeout + processFrame ctx conf $ decodeFrameHeader hd + loop ---------------------------------------------------------------- @@ -278,7 +247,7 @@ let errmsg = Short.toShort ( "this frame is not allowed in an idle stream: " - `BS.append` (C8.pack (show ftyp)) + `BS.append` C8.pack (show ftyp) ) E.throwIO $ ConnectionErrorIsSent ProtocolError streamId errmsg when (ftyp == FrameHeaders) $ setPeerStreamID ctx streamId @@ -650,3 +619,39 @@ let len = BS.length bs inform len return (bs, isEOF) + +---------------------------------------------------------------- + +closureClient :: Config -> Either E.SomeException a -> IO a +closureClient Config{..} (Right x) = do + let frame = goawayFrame 0 NoError "" + confSendAll frame `E.catch` ignore + return x + where + ignore (E.SomeException e) + | isAsyncException e = E.throwIO e + | otherwise = return () +closureClient conf (Left se) = closureServer conf se + +closureServer :: Config -> E.SomeException -> IO a +closureServer Config{..} se + | isAsyncException se = E.throwIO se + | Just ConnectionIsClosed <- E.fromException se = do + E.throwIO ConnectionIsClosed + | Just e@(ConnectionErrorIsReceived{}) <- E.fromException se = + E.throwIO e + | Just e@(ConnectionErrorIsSent err sid msg) <- E.fromException se = do + let frame = goawayFrame sid err $ Short.fromShort msg + confSendAll frame + E.throwIO e + | Just e@(StreamErrorIsSent err sid msg) <- E.fromException se = do + let frame = resetFrame err sid + let frame' = goawayFrame sid err $ Short.fromShort msg + confSendAll $ frame <> frame' + E.throwIO e + | Just e@(StreamErrorIsReceived err sid) <- E.fromException se = do + let frame = goawayFrame sid err "treat a stream error as a connection error" + confSendAll frame + E.throwIO e + | Just (_ :: HTTP2Error) <- E.fromException se = E.throwIO se + | otherwise = E.throwIO $ BadThingHappen se diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/http2-5.3.9/Network/HTTP2/H2/Sender.hs new/http2-5.3.10/Network/HTTP2/H2/Sender.hs --- old/http2-5.3.9/Network/HTTP2/H2/Sender.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/http2-5.3.10/Network/HTTP2/H2/Sender.hs 2001-09-09 03:46:40.000000000 +0200 @@ -36,14 +36,6 @@ | O Output | Flush -wrapException :: E.SomeException -> IO () -wrapException se - | isAsyncException se = E.throwIO se - | Just GoAwayIsSent <- E.fromException se = return () - | Just ConnectionIsClosed <- E.fromException se = return () - | Just (e :: HTTP2Error) <- E.fromException se = E.throwIO e - | otherwise = E.throwIO $ BadThingHappen se - -- Peer SETTINGS_INITIAL_WINDOW_SIZE -- Adjusting initial window size for streams updatePeerSettings :: Context -> SettingsList -> IO () @@ -67,10 +59,10 @@ frameSender :: Context -> Config -> IO () frameSender - ctx@Context{outputQ, controlQ, encodeDynamicTable, outputBufferLimit, senderDone} + ctx@Context{outputQ, controlQ, encodeDynamicTable, outputBufferLimit} Config{..} = do labelMe "H2 sender" - (loop 0 `E.finally` setSenderDone) `E.catch` wrapException + loop 0 where ---------------------------------------------------------------- loop :: Offset -> IO () @@ -115,7 +107,6 @@ -- called with off == 0 control :: Control -> IO () - control (CFinish e) = E.throwIO e control (CFrames ms xs) = do buf <- copyAll xs confWriteBuffer let off = buf `minusPtr` confWriteBuffer @@ -163,10 +154,12 @@ return off' resetStream :: Stream -> ErrorCode -> E.SomeException -> IO () - resetStream strm err e = do - closed ctx strm (ResetByMe e) - let rst = resetFrame err $ streamNumber strm - enqueueControl controlQ $ CFrames Nothing [rst] + resetStream strm err e + | isAsyncException e = E.throwIO e + | otherwise = do + closed ctx strm (ResetByMe e) + let rst = resetFrame err $ streamNumber strm + enqueueControl controlQ $ CFrames Nothing [rst] ---------------------------------------------------------------- outputHeader @@ -260,7 +253,7 @@ where eos = if endOfStream then setEndStream else id getFlag [] = eos $ setEndHeader defaultFlags - getFlag _ = eos $ defaultFlags + getFlag _ = eos defaultFlags continue :: Offset -> TokenHeaderList -> FrameType -> IO Offset continue off [] _ = return off @@ -388,5 +381,3 @@ , flags = flag , streamId = sid } - - setSenderDone = atomically $ writeTVar senderDone True diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/http2-5.3.9/Network/HTTP2/H2/Settings.hs new/http2-5.3.10/Network/HTTP2/H2/Settings.hs --- old/http2-5.3.9/Network/HTTP2/H2/Settings.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/http2-5.3.10/Network/HTTP2/H2/Settings.hs 2001-09-09 03:46:40.000000000 +0200 @@ -1,6 +1,3 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RecordWildCards #-} - module Network.HTTP2.H2.Settings where import Network.Control diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/http2-5.3.9/Network/HTTP2/H2/Stream.hs new/http2-5.3.10/Network/HTTP2/H2/Stream.hs --- old/http2-5.3.9/Network/HTTP2/H2/Stream.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/http2-5.3.10/Network/HTTP2/H2/Stream.hs 2001-09-09 03:46:40.000000000 +0200 @@ -2,7 +2,6 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} module Network.HTTP2.H2.Stream where @@ -102,10 +101,7 @@ mErr' err :: Either SomeException a - err = - Left $ - fromMaybe (toException ConnectionIsClosed) $ - mErr + err = Left $ fromMaybe (toException ConnectionIsClosed) mErr ---------------------------------------------------------------- diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/http2-5.3.9/Network/HTTP2/H2/StreamTable.hs new/http2-5.3.10/Network/HTTP2/H2/StreamTable.hs --- old/http2-5.3.9/Network/HTTP2/H2/StreamTable.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/http2-5.3.10/Network/HTTP2/H2/StreamTable.hs 2001-09-09 03:46:40.000000000 +0200 @@ -58,6 +58,7 @@ , -- Cache must contain Stream instead of StreamId because -- a Stream is deleted when end-of-stream is received. -- After that, cache is looked up. + -- LRUCache is not used as LRU but as fixed-size map. evenCache :: LRUCache (Method, ByteString) Stream } diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/http2-5.3.9/Network/HTTP2/H2/Types.hs new/http2-5.3.10/Network/HTTP2/H2/Types.hs --- old/http2-5.3.9/Network/HTTP2/H2/Types.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/http2-5.3.10/Network/HTTP2/H2/Types.hs 2001-09-09 03:46:40.000000000 +0200 @@ -14,7 +14,6 @@ ) import qualified Control.Exception as E import Data.IORef -import Data.Typeable import Network.Control import Network.HTTP.Semantics.Client import Network.HTTP.Semantics.IO @@ -195,9 +194,7 @@ ---------------------------------------------------------------- -data Control - = CFinish HTTP2Error - | CFrames (Maybe SettingsList) [ByteString] +data Control = CFrames (Maybe SettingsList) [ByteString] ---------------------------------------------------------------- @@ -217,8 +214,7 @@ | StreamErrorIsReceived ErrorCode StreamId | StreamErrorIsSent ErrorCode StreamId ReasonPhrase | BadThingHappen E.SomeException - | GoAwayIsSent - deriving (Show, Typeable) + deriving (Show) instance E.Exception HTTP2Error diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/http2-5.3.9/Network/HTTP2/Server/Run.hs new/http2-5.3.10/Network/HTTP2/Server/Run.hs --- old/http2-5.3.9/Network/HTTP2/Server/Run.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/http2-5.3.10/Network/HTTP2/Server/Run.hs 2001-09-09 03:46:40.000000000 +0200 @@ -1,4 +1,3 @@ -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -6,6 +5,7 @@ import Control.Concurrent.Async (concurrently_) import Control.Concurrent.STM +import qualified Control.Exception as E import Imports import Network.Control (defaultMaxData) import Network.HTTP.Semantics.IO @@ -123,8 +123,12 @@ let mgr = threadManager ctx runReceiver = frameReceiver ctx conf runSender = frameSender ctx conf - runBackgroundThreads = concurrently_ runReceiver runSender - T.stopAfter mgr runBackgroundThreads $ \res -> + runBackgroundThreads = do + er <- E.try $ concurrently_ runReceiver runSender + case er of + Right () -> return () + Left e -> closureServer conf e + T.stopAfter mgr (runBackgroundThreads) $ \res -> closeAllStreams (oddStreamTable ctx) (evenStreamTable ctx) res -- connClose must not be called here since Run:fork calls it diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/http2-5.3.9/Network/HTTP2/Server/Worker.hs new/http2-5.3.10/Network/HTTP2/Server/Worker.hs --- old/http2-5.3.9/Network/HTTP2/Server/Worker.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/http2-5.3.10/Network/HTTP2/Server/Worker.hs 2001-09-09 03:46:40.000000000 +0200 @@ -1,5 +1,4 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternGuards #-} {-# LANGUAGE RecordWildCards #-} module Network.HTTP2.Server.Worker ( diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/http2-5.3.9/Network/HTTP2/Server.hs new/http2-5.3.10/Network/HTTP2/Server.hs --- old/http2-5.3.9/Network/HTTP2/Server.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/http2-5.3.10/Network/HTTP2/Server.hs 2001-09-09 03:46:40.000000000 +0200 @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - -- | HTTP\/2 server library. -- -- Example: diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/http2-5.3.9/http2.cabal new/http2-5.3.10/http2.cabal --- old/http2-5.3.9/http2.cabal 2001-09-09 03:46:40.000000000 +0200 +++ new/http2-5.3.10/http2.cabal 2001-09-09 03:46:40.000000000 +0200 @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: http2 -version: 5.3.9 +version: 5.3.10 license: BSD3 license-file: LICENSE maintainer: Kazu Yamamoto <[email protected]> diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/http2-5.3.9/test/HTTP2/ClientSpec.hs new/http2-5.3.10/test/HTTP2/ClientSpec.hs --- old/http2-5.3.9/test/HTTP2/ClientSpec.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/http2-5.3.10/test/HTTP2/ClientSpec.hs 2001-09-09 03:46:40.000000000 +0200 @@ -1,4 +1,3 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} @@ -68,7 +67,7 @@ let maxConc = fromJust $ maxConcurrentStreams defaultSettings resultVars <- runClient "http" "localhost" $ \sendReq aux -> do - for [1 .. (maxConc + 1) :: Int] $ \_ -> do + replicateM ((maxConc + 1) :: Int) $ do resultVar <- newEmptyMVar concurrentClient resultVar sendReq aux pure resultVar @@ -111,7 +110,7 @@ body = byteString "Hello, world!\n" runClient :: Scheme -> Authority -> Client a -> IO a -runClient sc au client = runTCPClient host port $ runHTTP2Client +runClient sc au client = runTCPClient host port runHTTP2Client where cliconf = defaultClientConfig{scheme = sc, authority = au} runHTTP2Client s = diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/http2-5.3.9/test/HTTP2/ServerSpec.hs new/http2-5.3.10/test/HTTP2/ServerSpec.hs --- old/http2-5.3.9/test/HTTP2/ServerSpec.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/http2-5.3.10/test/HTTP2/ServerSpec.hs 2001-09-09 03:46:40.000000000 +0200 @@ -6,8 +6,6 @@ module HTTP2.ServerSpec (spec) where import Control.Concurrent --- cryptonite - import Control.Concurrent.Async import qualified Control.Exception as E import Control.Monad @@ -49,7 +47,7 @@ it "handles normal cases" $ E.bracket (forkIO runServer) killThread $ \_ -> do threadDelay 10000 - (runClient allocSimpleConfig) + runClient allocSimpleConfig it "should always send the connection preface first" $ do prefaceVar <- newEmptyMVar @@ -177,7 +175,7 @@ runClient :: (Socket -> BufferSize -> IO Config) -> IO () runClient allocConfig = - runTCPClient host port $ runHTTP2Client + runTCPClient host port runHTTP2Client where auth = host cliconf = C.defaultClientConfig{C.authority = auth} @@ -189,7 +187,8 @@ client :: C.Client () client sendRequest aux = - foldr1 concurrently_ $ + foldr1 + concurrently_ [ client0 sendRequest aux , client1 sendRequest aux , client2 sendRequest aux @@ -311,11 +310,13 @@ go (100 :: Int) firstTrailerValue :: TokenHeaderTable -> FieldValue -firstTrailerValue = snd . Prelude.head . fst +firstTrailerValue tbl = case fst tbl of + [] -> error "firstTrailerValue" + x : _ -> snd x runAttack :: (C.ClientIO -> IO ()) -> IO () runAttack attack = - runTCPClient host port $ runHTTP2Client + runTCPClient host port runHTTP2Client where auth = host cliconf = C.defaultClientConfig{C.authority = auth} diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/http2-5.3.9/test-frame/FrameSpec.hs new/http2-5.3.10/test-frame/FrameSpec.hs --- old/http2-5.3.9/test-frame/FrameSpec.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/http2-5.3.10/test-frame/FrameSpec.hs 2001-09-09 03:46:40.000000000 +0200 @@ -10,7 +10,7 @@ import qualified Data.ByteString.Base16 as B16 import qualified Data.ByteString.Lazy as BL import Network.HTTP2.Frame -import System.FilePath.Glob (compile, globDir) +import System.FilePath.Glob (compile, globDir1) import Test.Hspec import JSON @@ -19,7 +19,7 @@ testDir = "test-frame/http2-frame-test-case" getTestFiles :: FilePath -> IO [FilePath] -getTestFiles dir = head <$> globDir [compile "*/*.json"] dir +getTestFiles dir = globDir1 (compile "*/*.json") dir check :: FilePath -> IO () check file = do diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/http2-5.3.9/test-frame/frame-encode.hs new/http2-5.3.10/test-frame/frame-encode.hs --- old/http2-5.3.9/test-frame/frame-encode.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/http2-5.3.10/test-frame/frame-encode.hs 2001-09-09 03:46:40.000000000 +0200 @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Main where import Data.Aeson diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/http2-5.3.9/test-hpack/JSON.hs new/http2-5.3.10/test-hpack/JSON.hs --- old/http2-5.3.9/test-hpack/JSON.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/http2-5.3.10/test-hpack/JSON.hs 2001-09-09 03:46:40.000000000 +0200 @@ -100,7 +100,9 @@ toKey = toValue parseJSON (Object o) = pure (mk $ textToByteString $ Key.toText k, toValue v) -- new where - (k, v) = head $ H.toList o + (k, v) = case H.toList o of + [] -> error "parseJSON" + x : _ -> x parseJSON _ = mzero instance {-# OVERLAPPING #-} ToJSON Header where diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/http2-5.3.9/test2/ServerSpec.hs new/http2-5.3.10/test2/ServerSpec.hs --- old/http2-5.3.9/test2/ServerSpec.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/http2-5.3.10/test2/ServerSpec.hs 2001-09-09 03:46:40.000000000 +0200 @@ -1,4 +1,3 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} module ServerSpec (spec) where diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/http2-5.3.9/util/h2c-client.hs new/http2-5.3.10/util/h2c-client.hs --- old/http2-5.3.9/util/h2c-client.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/http2-5.3.10/util/h2c-client.hs 2001-09-09 03:46:40.000000000 +0200 @@ -1,5 +1,4 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} module Main where diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/http2-5.3.9/util/h2c-server.hs new/http2-5.3.10/util/h2c-server.hs --- old/http2-5.3.9/util/h2c-server.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/http2-5.3.10/util/h2c-server.hs 2001-09-09 03:46:40.000000000 +0200 @@ -1,6 +1,4 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} module Main (main) where @@ -37,7 +35,7 @@ (o, n, []) -> return (foldl (flip id) defaultOptions o, n) (_, _, errs) -> showUsageAndExit $ concat errs -data Options = Options +newtype Options = Options { optMonitor :: Bool } deriving (Show)
