diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,12 @@ +## 5.1.0 + +* Drop frames after reset + [#106](https://github.com/kazu-yamamoto/http2/pull/106) +* BREAKING CHANGE: Use String for Authority + [#105](https://github.com/kazu-yamamoto/http2/pull/105) +* Properly close streams + [#104](https://github.com/kazu-yamamoto/http2/pull/104) + ## 5.0.1 * Allowing bytestring 0.12. 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 @@ -14,11 +14,13 @@ import UnliftIO.Async import UnliftIO.Concurrent import UnliftIO.STM +import qualified Data.ByteString.UTF8 as UTF8 import Imports import Network.HTTP2.Client.Types import Network.HTTP2.Frame import Network.HTTP2.H2 +import Network.HTTP.Types (Header) -- | Client configuration data ClientConfig = ClientConfig @@ -172,11 +174,12 @@ -- Otherwise, it would be re-enqueue because of empty -- resulting in out-of-order. -- To implement this, 'tbqNonEmpty' is used. - let hdr1 + let hdr1, hdr2 :: [Header] + hdr1 | scheme /= "" = (":scheme", scheme) : hdr0 | otherwise = hdr0 hdr2 - | auth /= "" = (":authority", auth) : hdr1 + | auth /= "" = (":authority", UTF8.fromString auth) : hdr1 | otherwise = hdr1 req' = req{outObjHeaders = hdr2} -- FLOW CONTROL: SETTINGS_MAX_CONCURRENT_STREAMS: send: respecting peer's limit 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 @@ -32,7 +32,7 @@ data ClientInfo = ClientInfo { scheme :: ByteString - , authority :: ByteString + , authority :: Authority } toServerInfo :: RoleInfo -> ServerInfo @@ -46,7 +46,7 @@ newServerInfo :: IO RoleInfo newServerInfo = RIS . ServerInfo <$> newTQueueIO -newClientInfo :: ByteString -> ByteString -> RoleInfo +newClientInfo :: ByteString -> Authority -> RoleInfo newClientInfo scm auth = RIC $ ClientInfo scm auth ---------------------------------------------------------------- @@ -175,7 +175,20 @@ {-# INLINE setStreamState #-} setStreamState :: Context -> Stream -> StreamState -> IO () -setStreamState _ Stream{streamState} val = writeIORef streamState val +setStreamState _ Stream{streamState} newState = do + oldState <- readIORef streamState + case (oldState, newState) of + (Open _ (Body q _ _ _), Open _ (Body q' _ _ _)) | q == q' -> + -- The stream stays open with the same body; nothing to do + return () + (Open _ (Body q _ _ _), _) -> + -- The stream is either closed, or is open with a /new/ body + -- We need to close the old queue so that any reads from it won't block + atomically $ writeTQueue q $ Left $ toException ConnectionIsClosed + _otherwise -> + -- The stream wasn't open to start with; nothing to do + return () + writeIORef streamState newState opened :: Context -> Stream -> IO () opened ctx strm = setStreamState ctx strm (Open Nothing JustOpened) 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 @@ -15,6 +15,7 @@ import UnliftIO.Concurrent import qualified UnliftIO.Exception as E import UnliftIO.STM +import qualified Data.ByteString.UTF8 as UTF8 import Imports hiding (delete, insert) import Network.HPACK @@ -289,7 +290,11 @@ when (ftyp == FrameHeaders) $ setPeerStreamID ctx streamId -- FLOW CONTROL: SETTINGS_MAX_CONCURRENT_STREAMS: recv: rejecting if over my limit Just <$> openOddStreamCheck ctx streamId ftyp - | otherwise = undefined -- never reach + | otherwise = + -- We received a frame from the server on an unknown stream + -- (likely a previously created and then subsequently reset stream). + -- We just drop it. + return Nothing ---------------------------------------------------------------- @@ -365,7 +370,7 @@ (_, vt) <- hpackDecodeHeader frag streamId ctx let ClientInfo{..} = toClientInfo $ roleInfo ctx when - ( getHeaderValue tokenAuthority vt == Just authority + ( getHeaderValue tokenAuthority vt == Just (UTF8.fromString authority) && getHeaderValue tokenScheme vt == Just scheme ) $ do 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 @@ -28,7 +28,7 @@ type Scheme = ByteString -- | Authority. -type Authority = ByteString +type Authority = String -- | Path. type Path = ByteString diff --git a/Network/HTTP2/Server.hs b/Network/HTTP2/Server.hs --- a/Network/HTTP2/Server.hs +++ b/Network/HTTP2/Server.hs @@ -118,6 +118,7 @@ import Data.ByteString.Builder (Builder) import Data.IORef (readIORef) import qualified Network.HTTP.Types as H +import qualified Data.ByteString.UTF8 as UTF8 import Imports import Network.HPACK @@ -147,7 +148,7 @@ -- | Getting the authority from a request. requestAuthority :: Request -> Maybe Authority -requestAuthority (Request req) = getHeaderValue tokenAuthority vt +requestAuthority (Request req) = UTF8.toString <$> getHeaderValue tokenAuthority vt where (_, vt) = inpObjHeaders req 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.0.1 +version: 5.1.0 license: BSD3 license-file: LICENSE maintainer: Kazu Yamamoto @@ -127,7 +127,8 @@ network-control >= 0.0.2 && < 0.1, unix-time >= 0.4.11 && < 0.5, time-manager >= 0.0.1 && < 0.1, - unliftio >= 0.2 && < 0.3 + unliftio >= 0.2 && < 0.3, + utf8-string >= 1.0 && < 1.1 executable client main-is: client.hs diff --git a/test/HTTP2/ClientSpec.hs b/test/HTTP2/ClientSpec.hs --- a/test/HTTP2/ClientSpec.hs +++ b/test/HTTP2/ClientSpec.hs @@ -8,9 +8,7 @@ import Control.Concurrent import qualified Control.Exception as E import Control.Monad -import Data.ByteString (ByteString) import Data.ByteString.Builder (byteString) -import qualified Data.ByteString.Char8 as C8 import Data.Foldable (for_) import Data.Maybe import Data.Traversable (for) @@ -32,16 +30,13 @@ host :: String host = "127.0.0.1" -host' :: ByteString -host' = C8.pack host - spec :: Spec spec = do describe "client" $ do it "receives an error if scheme is missing" $ E.bracket (forkIO $ runServer defaultServer) killThread $ \_ -> do threadDelay 10000 - runClient "" host' (defaultClient []) `shouldThrow` connectionError + runClient "" host (defaultClient []) `shouldThrow` connectionError it "receives an error if authority is missing" $ E.bracket (forkIO $ runServer defaultServer) killThread $ \_ -> do @@ -51,7 +46,7 @@ it "receives an error if authority and host are different" $ E.bracket (forkIO $ runServer defaultServer) killThread $ \_ -> do threadDelay 10000 - runClient "http" host' (defaultClient [("Host", "foo")]) + runClient "http" host (defaultClient [("Host", "foo")]) `shouldThrow` connectionError it "does not deadlock (in concurrent setting)" $ diff --git a/test/HTTP2/ServerSpec.hs b/test/HTTP2/ServerSpec.hs --- a/test/HTTP2/ServerSpec.hs +++ b/test/HTTP2/ServerSpec.hs @@ -177,7 +177,7 @@ runClient allocConfig = runTCPClient host port $ runHTTP2Client where - auth = C8.pack host + auth = host cliconf = C.defaultClientConfig{C.authority = auth} runHTTP2Client s = E.bracket @@ -315,7 +315,7 @@ runAttack attack = runTCPClient host port $ runHTTP2Client where - auth = C8.pack host + auth = host cliconf = C.defaultClientConfig{C.authority = auth} runHTTP2Client s = E.bracket