servant-http2-client (empty) → 0.1.0.0
raw patch · 7 files changed
+546/−0 lines, 7 filesdep +aesondep +asyncdep +basesetup-changed
Dependencies added: aeson, async, base, 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
Files
- ChangeLog.md +6/−0
- LICENSE +30/−0
- README.md +49/−0
- Setup.hs +2/−0
- servant-http2-client.cabal +83/−0
- src/Network/HTTP2/Client/Servant.hs +299/−0
- test/Spec.hs +77/−0
+ ChangeLog.md view
@@ -0,0 +1,6 @@+# Changelog for servant-http2-client++## Unreleased changes++## v0.1.0.0+- initial release
+ LICENSE view
@@ -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.
+ README.md view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ servant-http2-client.cabal view
@@ -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 <https://github.com/lucasdicioccio/servant-http2-client#readme>+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
+ src/Network/HTTP2/Client/Servant.hs view
@@ -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)
+ test/Spec.hs view
@@ -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+ }