diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,6 @@ +# Changelog for servant-http2-client + +## Unreleased changes + +## v0.1.0.0 +- initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Author name here (c) 2018 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,49 @@ +# servant-http2-client + +This package provides a way to generate HTTP2 client code from +[Servant](http://haskell-servant.github.io/) API descriptions. + +Please consider this package somewhat unstable. The author would appreciate +feedbacks and benchmarks in real-world deployments. + +## Usage + +The usage is pretty similar to `servant-client` but uses an HTTP2Client rather +than a Manager. See also the section below to highlight differences between +`servant-client` and `servant-http2-client`. + +HTTP2 uses a flow-control mechanism, which `http2-client` exposes but +`servant-http2-client` hides: as a client you have nothing to do and +DATA-credit is immediately sent to the server. This mechanism is easy for the +user but effectively disables flow control at the application level. Further, +this easy-to-use mechanism may have some slight overhead for sending many small +control frames. Future version of the library will expose more control points +(at an increased cost). + +You can find a full example at `./test/Spec.hs` . + +## Differences with servant-client + +The client leverages `http2-client` and hence behave slightly differently from +`servant-client`, which uses `http-client`. Most notably, HTTP/2 uses a single +TCP connection for performing concurrent requests, whereas HTTP/1.x at best +pipelines request sequentially over a same connection. + +The `servant-client` library uses a connection Manager to create new TCP +connections or try re-using existing connections. This `servant-http2-client` +makes no use of such a Manager. This difference is mostly important for +load-balancing and unstable network environments. When targeting a +load-balanced server, a `servant-http2-client` will always hit the same +TCP-endpoint whereas a `servant-client` may hit different TCP-endpoint for each +request. Also, after handling a connection error, a `servant-client` will open +a new TCP connection without any decision from the programmer. Conversely, a +broken `servant-http2-client` will be of no practical use and the programmer +must create a new H2ClientEnv. A Manager abstraction may be added to +`http2-client` later. + +The `servant-client` package offers Cookies handling, whereas +`servant-http2-client` has no such feature. Please consider opening a +pull-request for adding the support. + +Finally, it's always good to remember that HTTP2 allows concurrent queries, +that is, many API calls may fail when a single TCP connection dies out. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/servant-http2-client.cabal b/servant-http2-client.cabal new file mode 100644 --- /dev/null +++ b/servant-http2-client.cabal @@ -0,0 +1,83 @@ +-- This file has been generated from package.yaml by hpack version 0.28.2. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 1637fc4fd7ba4a0e9a44eb9e134093e35f8bcd5548e8997d635cbfb834599852 + +name: servant-http2-client +version: 0.1.0.0 +synopsis: Generate HTTP2 clients from Servant API descriptions. +description: Please see the README on GitHub at +category: Web +homepage: https://github.com/lucasdicioccio/servant-http2-client#readme +bug-reports: https://github.com/lucasdicioccio/servant-http2-client/issues +author: Lucas DiCioccio +maintainer: lucas@dicioccio.fr +copyright: 2018 Lucas DiCioccio +license: BSD3 +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 +extra-source-files: + ChangeLog.md + README.md + +source-repository head + type: git + location: https://github.com/lucasdicioccio/servant-http2-client + +library + exposed-modules: + Network.HTTP2.Client.Servant + other-modules: + Paths_servant_http2_client + hs-source-dirs: + src + 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 + default-language: Haskell2010 + +test-suite servant-http2-client-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_servant_http2_client + hs-source-dirs: + test + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + aeson + , async + , base >=4.7 && <5 + , binary + , bytestring + , case-insensitive + , containers + , data-default-class + , exceptions + , http-media + , http-types + , http2 + , http2-client + , mtl + , servant + , servant-client-core + , servant-http2-client + , text + , tls + , transformers + default-language: Haskell2010 diff --git a/src/Network/HTTP2/Client/Servant.hs b/src/Network/HTTP2/Client/Servant.hs new file mode 100644 --- /dev/null +++ b/src/Network/HTTP2/Client/Servant.hs @@ -0,0 +1,299 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE OverloadedStrings #-} + +module Network.HTTP2.Client.Servant ( + H2ClientM + , runH2ClientM + , H2ClientEnv (..) + -- * generate functions + , h2client + ) where + +import Data.IORef (newIORef, readIORef, writeIORef) +import Data.Foldable (traverse_) +import Control.Exception (throwIO) +import Control.Monad (unless, when, (>=>)) +import Control.Monad.Catch (MonadCatch, MonadThrow) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Trans.Except (ExceptT, runExceptT) +import Control.Monad.Error.Class (MonadError (..)) +import Control.Monad.Reader (MonadReader, ReaderT, ask, runReaderT) +import Data.Binary.Builder (toLazyByteString) +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as ByteString +import Data.ByteString.Lazy (fromStrict, toStrict, toChunks) +import Data.Foldable (toList) +import Data.Proxy (Proxy(..)) +import Data.Sequence (fromList) +import qualified Data.Text as Text +import GHC.Generics (Generic) +import Network.HPACK (HeaderList) +import Network.HTTP.Media.RenderHeader (renderHeader) +import Network.HTTP2 (flags, setEndStream, testEndStream, payloadLength, toErrorCodeId, ErrorCodeId(RefusedStream)) +import Network.HTTP2.Client.Helpers (upload, waitStream, fromStreamResult) +import Network.HTTP.Types.Status (Status(..)) +import Network.HTTP.Types.Version (http20) +import qualified Data.CaseInsensitive as CI +import Text.Read (readMaybe) + + +import Network.HTTP2.Client +import Servant.Client.Core + +newtype H2ClientM a = H2ClientM + { unH2ClientM :: ReaderT H2ClientEnv (ExceptT ServantError IO) a } + deriving ( Functor, Applicative, Monad, MonadIO, Generic + , MonadReader H2ClientEnv, MonadError ServantError, MonadThrow + , MonadCatch) + +runH2ClientM :: H2ClientM a -> H2ClientEnv -> IO (Either ServantError a) +runH2ClientM cm env = runExceptT $ flip runReaderT env $ unH2ClientM cm + +instance RunClient H2ClientM where + runRequest :: Request -> H2ClientM Response + runRequest = performRequest + streamingRequest :: Request -> H2ClientM StreamingResponse + streamingRequest = performStreamingRequest + throwServantError :: ServantError -> H2ClientM a + throwServantError = throwError + +data H2ClientEnv = H2ClientEnv ByteString Http2Client + +type ByteSegments = (IO ByteString -> IO ()) -> IO () + +-- | Construct a ByteSegments from a single ByteString. +onlySegment :: ByteString -> ByteSegments +onlySegment bs handle = handle (pure bs) + +-- | Construct a ByteSegments from a lazy list of ByteString. +-- +-- Since we expect the handler passed to ByteSegments to do some IO, empty +-- chunks are discarded to save on IOs. +multiSegments :: [ByteString] -> ByteSegments +multiSegments bss handle = + traverse_ (handle . pure) (filter (not . ByteString.null) bss) + +-- | Pulls data segments from ByteSegments and calls 'upload' on it. +sendSegments + :: Http2Client + -> Http2Stream + -> OutgoingFlowControl + -- ^ Connection + -> OutgoingFlowControl + -- ^ Stream + -> ByteSegments + -> IO () +sendSegments http2client stream ocfc osfc segments = + segments go + where + go getChunk = do + dat <- getChunk + upload dat id http2client ocfc stream osfc + +-- | Prepare an HTTP2 request to a given server. +makeRequest + :: ByteString + -- ^ Server's Authority. + -> Request + -- ^ The HTTP request. + -> IO (HeaderList, ByteSegments) +makeRequest authority req = do + let go ct obj = case obj of + (RequestBodyBS bs) -> pure $ + (onlySegment bs, + [ ("Content-Type", renderHeader ct) + , ("Content-Length", ByteString.pack $ show $ ByteString.length bs) + ]) + (RequestBodyLBS lbs) -> pure $ + (multiSegments $ toChunks lbs, + [ ("Content-Type", renderHeader ct) + ]) + (RequestBodyBuilder n builder) -> + let lbs = toLazyByteString builder in pure $ + (multiSegments $ toChunks lbs, + [ ("Content-Type", renderHeader ct) + , ("Content-Length", ByteString.pack $ show n) + ]) + (RequestBodyStream n act) -> pure $ + (act, + [ ("Content-Type", renderHeader ct) + , ("Content-Length", ByteString.pack $ show n) + ]) + (RequestBodyStreamChunked act) -> pure $ + (act, + [ ("Content-Type", renderHeader ct) + , ("Transfer-Encoding", "chunked") + ]) + (RequestBodyIO again) -> + again >>= go ct + + (bodyIO,bodyheaders) <- case requestBody req of + Nothing -> pure (onlySegment "", []) + (Just (r,ct)) -> go ct r + let headersPairs = baseHeaders <> reqHeaders <> bodyheaders + pure (headersPairs, bodyIO) + where + baseHeaders = + [ (":method", requestMethod req) + , (":scheme", "https") + , (":path", toStrict $ toLazyByteString $ requestPath req) + , (":authority", authority) + , ("Accept", ByteString.intercalate "," $ toList $ fmap renderHeader $ requestAccept req) + , ("User-Agent", "servant-http2-client/dev") + ] + reqHeaders = [(CI.original h, hv) | (h,hv) <- toList (requestHeaders req)] + +resetPushPromises :: PushPromiseHandler +resetPushPromises _ pps _ _ _ = _rst pps RefusedStream + +-- | Implementation of simple requests. +performRequest :: Request -> H2ClientM Response +performRequest req = do + H2ClientEnv authority http2client <- ask + let icfc = _incomingFlowControl http2client + let ocfc = _outgoingFlowControl http2client + let headersFlags = id + + (headersPairs, bodyIO) <- liftIO $ makeRequest authority req + http2rsp <- liftIO $ withHttp2Stream http2client $ \stream -> + let initStream = + headers stream headersPairs headersFlags + handler _ osfc = do + sendSegments http2client stream ocfc osfc bodyIO + sendData http2client stream setEndStream "" + streamResult <- waitStream stream icfc resetPushPromises + pure $ fromStreamResult streamResult + in (StreamDefinition initStream handler) + case http2rsp of + Left (TooMuchConcurrency _) -> + throwError $ Servant.Client.Core.ConnectionError "too many concurrent streams" + Right (Right (hdrs,body,_)) + | let Just status = lookupStatus hdrs -> do + let response = mkResponse status hdrs body + unless (status >= 200 && status < 300) $ + throwError $ FailureResponse response + pure response + | otherwise -> do + let response = mkResponse 0 hdrs body + throwError $ DecodeFailure "no :status header" response + Right (Left err) -> + throwError $ Servant.Client.Core.ConnectionError $ "connection error: " <> (Text.pack $ show $ toErrorCodeId err) + +mkResponse :: Int -> HeaderList -> ByteString -> Response +mkResponse status hdrs body = + Response (Status status "") + (fromList [ (CI.mk h, hv) | (h,hv) <- hdrs ]) + http20 + (fromStrict body) + +lookupStatus :: HeaderList -> Maybe Int +lookupStatus = lookup ":status" >=> readMaybe . ByteString.unpack + +replenishFlowControls + :: IncomingFlowControl -> IncomingFlowControl -> Int -> IO () +replenishFlowControls icfc isfc len = do + _ <- _consumeCredit isfc len + _addCredit isfc len + _ <- _updateWindow isfc + _ <- _consumeCredit icfc len + _addCredit icfc len + _ <- _updateWindow icfc + pure () + +-- | Implementation of requests with streaming replies. +performStreamingRequest :: Request -> H2ClientM StreamingResponse +performStreamingRequest req = do + H2ClientEnv authority http2client <- ask + let icfc = _incomingFlowControl http2client + let ocfc = _outgoingFlowControl http2client + let headersFlags = id + + (headersPairs, bodyIO) <- liftIO $ makeRequest authority req + 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 "" + -- Waits for headers and returns the response object to the + -- caller. + pure $ StreamingResponse (\handleGenResponse -> do + ev <- _waitEvent stream + case ev of + (StreamHeadersEvent fh hdrs) -> handleHeaders stream icfc isfc fh hdrs handleGenResponse + _ -> throwIO $ Servant.Client.Core.ConnectionError $ "unwanted event received in data stream" <> Text.pack (show ev) + ) + in (StreamDefinition initStream handler) + case ret of + Right streamingResp -> pure streamingResp + Left (TooMuchConcurrency _) -> + throwError $ Servant.Client.Core.ConnectionError "too many concurrent streams" + where + handleHeaders stream icfc isfc fh hdrs handleGenResponse + | let Just status = lookupStatus hdrs = do + isFinished <- newIORef False + when (testEndStream $ flags fh) $ + writeIORef isFinished True + let response = mkStreamResponse status hdrs isFinished stream icfc isfc + unless (status >= 200 && status < 300) $ do + wholeBody <- consumeBody stream icfc isfc + let failResponse = mkResponse status hdrs wholeBody + throwIO $ FailureResponse failResponse + handleGenResponse response + | otherwise = do + wholeBody <- consumeBody stream icfc isfc + let response = mkResponse 0 hdrs wholeBody + throwIO $ DecodeFailure "no :status header" response + + -- | Helper to consume the whole response body when the status is not a 2xx. + -- This consumption can itself fail. + consumeBody stream icfc isfc = do + (revBss,_) <- waitDataFrames stream icfc isfc [] + let bs = mconcat $ reverse revBss + pure bs + + -- | Helper to iteratively eat all data frames. + waitDataFrames stream icfc isfc xs = do + ev <- _waitEvent stream + case ev of + StreamDataEvent fh x + | testEndStream (flags fh) -> + return (x:xs, Nothing) + | otherwise -> do + replenishFlowControls icfc isfc (payloadLength fh) + waitDataFrames stream icfc isfc (x:xs) + StreamPushPromiseEvent _ ppSid ppHdrs -> do + _handlePushPromise stream ppSid ppHdrs resetPushPromises + waitDataFrames stream icfc isfc xs + StreamHeadersEvent _ hdrs -> + return (xs, Just hdrs) + _ -> throwIO $ Servant.Client.Core.ConnectionError $ "unwanted event received in data stream" <> Text.pack (show ev) + + -- | Function to get the next DATA chunk on a stream this function is + -- stateful and modifies an IORef to remember that the stream is closed on + -- the server side. + -- Do not copy-paste this utility method unless you understand that the + -- IORef must be entirely owned by this function. + nextChunk isFinished stream icfc isfc = do + done <- readIORef isFinished + if done + then pure "" + else do + ev <- _waitEvent stream + case ev of + (StreamDataEvent fh dat) -> do + replenishFlowControls icfc isfc (payloadLength fh) + when (testEndStream $ flags fh) $ + writeIORef isFinished True + pure dat + _ -> throwIO $ Servant.Client.Core.ConnectionError $ "unwanted event received in data stream" <> Text.pack (show ev) + + mkStreamResponse status hdrs isFinished stream icfc isfc = + Response (Status status "") (fromList [ (CI.mk h, hv) | (h,hv) <- hdrs ]) http20 (nextChunk isFinished stream icfc isfc) + +h2client :: HasClient H2ClientM api => Proxy api -> Client H2ClientM api +h2client api = api `clientIn` (Proxy :: Proxy H2ClientM) diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,77 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} + +module Main where + +import Control.Concurrent.Async (mapConcurrently) +import qualified Data.ByteString.Char8 as ByteString +import Data.ByteString.Lazy (fromStrict, toStrict) +import Data.Default.Class (def) +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Text.Encoding as Encoding +import Data.Proxy +import Network.HTTP2.Client +import Network.HTTP2.Client.Servant +import qualified Network.TLS as TLS +import qualified Network.TLS.Extra.Cipher as TLS +import Servant.API +import Servant.Client.Core + +data RawText +instance Accept RawText where + contentType _ = "text/plain" +instance MimeRender RawText Text where + mimeRender _ = fromStrict . Encoding.encodeUtf8 +instance MimeUnrender RawText Text where + mimeUnrender _ = pure . Encoding.decodeUtf8 . toStrict +instance MimeUnrender OctetStream Text where + mimeUnrender _ = pure . Encoding.decodeUtf8 . toStrict + +type Http2Golang = + "reqinfo" :> Get '[RawText] Text + :<|> "goroutines" :> StreamGet NewlineFraming RawText (ResultStream Text) + :<|> "ECHO" :> ReqBody '[RawText] Text :> Put '[OctetStream] Text + +myApi :: Proxy Http2Golang +myApi = Proxy + +getExample :: H2ClientM Text +getGoroutines :: H2ClientM (ResultStream Text) +capitalize :: Text -> H2ClientM Text +getExample :<|> getGoroutines :<|> capitalize = h2client myApi + +main :: IO () +main = do + frameConn <- newHttp2FrameConnection "http2.golang.org" 443 (Just tlsParams) + client <- newHttp2Client frameConn 8192 8192 [] defaultGoAwayHandler ignoreFallbackHandler + let env = H2ClientEnv "http2.golang.org" client + runH2ClientM getExample env >>= print + runH2ClientM (capitalize "shout me something back") env >>= print + mapConcurrently (\c -> runH2ClientM (capitalize $ Text.singleton c) env) ['a'..'z'] >>= print + runH2ClientM getGoroutines env >>= go + _close client + where + go :: Either ServantError (ResultStream Text) -> IO () + go (Left err) = print err + go (Right (ResultStream k)) = k $ \getResult -> + let loop = do + r <- getResult + case r of + Nothing -> return () + Just x -> print x >> loop + in loop + tlsParams = TLS.ClientParams { + TLS.clientWantSessionResume = Nothing + , TLS.clientUseMaxFragmentLength = Nothing + , TLS.clientServerIdentification = ("http2.golang.org", ByteString.pack "443") + , TLS.clientUseServerNameIndication = True + , TLS.clientShared = def + , TLS.clientHooks = def { TLS.onServerCertificate = \_ _ _ _ -> return [] + } + , TLS.clientSupported = def { TLS.supportedCiphers = TLS.ciphersuite_default } + , TLS.clientDebug = def + }