diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -2,5 +2,8 @@ ## Unreleased changes +## v0.1.0.1 +- compact transfers for requests with no body or when chunking has empty bytestrings (see https://github.com/lucasdicioccio/servant-http2-client/issues/1 and https://github.com/yesodweb/wai/issues/717) + ## v0.1.0.0 - initial release diff --git a/servant-http2-client.cabal b/servant-http2-client.cabal --- a/servant-http2-client.cabal +++ b/servant-http2-client.cabal @@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 1637fc4fd7ba4a0e9a44eb9e134093e35f8bcd5548e8997d635cbfb834599852 +-- hash: e352f7dda8407f7f694c6418b746407bfd6e634a996cd13a2dba4fdf7164dcc0 name: servant-http2-client -version: 0.1.0.0 +version: 0.1.0.1 synopsis: Generate HTTP2 clients from Servant API descriptions. description: Please see the README on GitHub at category: Web @@ -36,19 +36,19 @@ ghc-options: -Wall build-depends: base >=4.7 && <5 - , binary - , bytestring - , case-insensitive - , containers - , exceptions - , http-media - , http-types - , http2 - , http2-client - , mtl - , servant-client-core - , text - , transformers + , binary >=0.8.5.1 && <0.9 + , bytestring >=0.10.8.2 && <0.11 + , case-insensitive >=1.2.0.11 && <1.3 + , containers >=0.5.11.0 && <0.6 + , exceptions >=0.10.0 && <0.11 + , http-media >=0.7.1.3 && <0.8 + , http-types >=0.12.2 && <0.13 + , http2 >=1.6.3 && <1.7 + , http2-client >=0.8.0.1 && <0.9 + , mtl >=2.2.2 && <2.3 + , servant-client-core >=0.14.1 && <0.15 + , text >=1.2.3.1 && <1.3 + , transformers >=0.5.5.0 && <0.6 default-language: Haskell2010 test-suite servant-http2-client-test @@ -63,21 +63,21 @@ aeson , async , base >=4.7 && <5 - , binary - , bytestring - , case-insensitive - , containers + , binary >=0.8.5.1 && <0.9 + , bytestring >=0.10.8.2 && <0.11 + , case-insensitive >=1.2.0.11 && <1.3 + , containers >=0.5.11.0 && <0.6 , data-default-class - , exceptions - , http-media - , http-types - , http2 - , http2-client - , mtl + , exceptions >=0.10.0 && <0.11 + , http-media >=0.7.1.3 && <0.8 + , http-types >=0.12.2 && <0.13 + , http2 >=1.6.3 && <1.7 + , http2-client >=0.8.0.1 && <0.9 + , mtl >=2.2.2 && <2.3 , servant , servant-client-core , servant-http2-client - , text + , text >=1.2.3.1 && <1.3 , tls - , transformers + , transformers >=0.5.5.0 && <0.6 default-language: Haskell2010 diff --git a/src/Network/HTTP2/Client/Servant.hs b/src/Network/HTTP2/Client/Servant.hs --- a/src/Network/HTTP2/Client/Servant.hs +++ b/src/Network/HTTP2/Client/Servant.hs @@ -13,6 +13,7 @@ ) where import Data.IORef (newIORef, readIORef, writeIORef) +import Data.Maybe (isJust) import Data.Foldable (traverse_) import Control.Exception (throwIO) import Control.Monad (unless, when, (>=>)) @@ -77,7 +78,8 @@ traverse_ (handle . pure) (filter (not . ByteString.null) bss) -- | Pulls data segments from ByteSegments and calls 'upload' on it. -sendSegments +-- Ignores empty segments. +sendNonEmptySegments :: Http2Client -> Http2Stream -> OutgoingFlowControl @@ -86,12 +88,12 @@ -- ^ Stream -> ByteSegments -> IO () -sendSegments http2client stream ocfc osfc segments = +sendNonEmptySegments http2client stream ocfc osfc segments = segments go where go getChunk = do dat <- getChunk - upload dat id http2client ocfc stream osfc + when (not $ ByteString.null dat) $ upload dat id http2client ocfc stream osfc -- | Prepare an HTTP2 request to a given server. makeRequest @@ -99,31 +101,31 @@ -- ^ Server's Authority. -> Request -- ^ The HTTP request. - -> IO (HeaderList, ByteSegments) + -> IO (HeaderList, Maybe ByteSegments) makeRequest authority req = do let go ct obj = case obj of (RequestBodyBS bs) -> pure $ - (onlySegment bs, + (Just $ onlySegment bs, [ ("Content-Type", renderHeader ct) , ("Content-Length", ByteString.pack $ show $ ByteString.length bs) ]) (RequestBodyLBS lbs) -> pure $ - (multiSegments $ toChunks lbs, + (Just $ multiSegments $ toChunks lbs, [ ("Content-Type", renderHeader ct) ]) (RequestBodyBuilder n builder) -> let lbs = toLazyByteString builder in pure $ - (multiSegments $ toChunks lbs, + (Just $ multiSegments $ toChunks lbs, [ ("Content-Type", renderHeader ct) , ("Content-Length", ByteString.pack $ show n) ]) (RequestBodyStream n act) -> pure $ - (act, + (Just act, [ ("Content-Type", renderHeader ct) , ("Content-Length", ByteString.pack $ show n) ]) (RequestBodyStreamChunked act) -> pure $ - (act, + (Just act, [ ("Content-Type", renderHeader ct) , ("Transfer-Encoding", "chunked") ]) @@ -131,7 +133,7 @@ again >>= go ct (bodyIO,bodyheaders) <- case requestBody req of - Nothing -> pure (onlySegment "", []) + Nothing -> pure (Nothing, []) (Just (r,ct)) -> go ct r let headersPairs = baseHeaders <> reqHeaders <> bodyheaders pure (headersPairs, bodyIO) @@ -155,15 +157,16 @@ H2ClientEnv authority http2client <- ask let icfc = _incomingFlowControl http2client let ocfc = _outgoingFlowControl http2client - let headersFlags = id - (headersPairs, bodyIO) <- liftIO $ makeRequest authority req + (headersPairs, mBodyIO) <- liftIO $ makeRequest authority req + let headersFlags = if isJust mBodyIO then id else setEndStream http2rsp <- liftIO $ withHttp2Stream http2client $ \stream -> let initStream = headers stream headersPairs headersFlags handler _ osfc = do - sendSegments http2client stream ocfc osfc bodyIO - sendData http2client stream setEndStream "" + flip traverse_ mBodyIO (\bodyIO -> do + sendNonEmptySegments http2client stream ocfc osfc bodyIO + sendData http2client stream setEndStream "") streamResult <- waitStream stream icfc resetPushPromises pure $ fromStreamResult streamResult in (StreamDefinition initStream handler) @@ -198,8 +201,8 @@ _ <- _consumeCredit isfc len _addCredit isfc len _ <- _updateWindow isfc - _ <- _consumeCredit icfc len - _addCredit icfc len + -- connection-level flow control already accounted for in the + -- 'creditDataFramesStep' of 'dispatchLoop' in http2-client _ <- _updateWindow icfc pure () @@ -209,16 +212,16 @@ H2ClientEnv authority http2client <- ask let icfc = _incomingFlowControl http2client let ocfc = _outgoingFlowControl http2client - let headersFlags = id - - (headersPairs, bodyIO) <- liftIO $ makeRequest authority req + (headersPairs, mBodyIO) <- liftIO $ makeRequest authority req + let headersFlags = if isJust mBodyIO then id else setEndStream ret <- liftIO $ withHttp2Stream http2client $ \stream -> let initStream = headers stream headersPairs headersFlags handler isfc osfc = do -- Send the request - sendSegments http2client stream ocfc osfc bodyIO - sendData http2client stream setEndStream "" + flip traverse_ mBodyIO (\bodyIO -> do + sendNonEmptySegments http2client stream ocfc osfc bodyIO + sendData http2client stream setEndStream "") -- Waits for headers and returns the response object to the -- caller. pure $ StreamingResponse (\handleGenResponse -> do