From 0dd8ee75855310a6948c394402a4b86cd26a493a Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Fri, 9 Nov 2018 19:43:55 +0200 Subject: [PATCH] Add runClientM for streaming-client --- servant-client-core/servant-client-core.cabal | 1 + .../Servant/Client/Core/Internal/Request.hs | 32 +++++++++++++++++-- servant-client/servant-client.cabal | 1 + .../Client/Internal/HttpClient/Streaming.hs | 18 ++++++++++- .../src/Servant/Client/Streaming.hs | 1 + 5 files changed, 49 insertions(+), 4 deletions(-) diff --git a/servant-client-core/servant-client-core.cabal b/servant-client-core/servant-client-core.cabal index fd5a0718..4dfb5908 100644 --- a/servant-client-core/servant-client-core.cabal +++ b/servant-client-core/servant-client-core.cabal @@ -50,6 +50,7 @@ library base >= 4.9 && < 4.13 , bytestring >= 0.10.8.1 && < 0.11 , containers >= 0.5.7.1 && < 0.7 + , deepseq >= 1.4.2.0 && < 1.5 , text >= 1.2.3.0 && < 1.3 , transformers >= 0.5.2.0 && < 0.6 , template-haskell >= 2.11.1.0 && < 2.15 diff --git a/servant-client-core/src/Servant/Client/Core/Internal/Request.hs b/servant-client-core/src/Servant/Client/Core/Internal/Request.hs index a85ccaf6..bae7309e 100644 --- a/servant-client-core/src/Servant/Client/Core/Internal/Request.hs +++ b/servant-client-core/src/Servant/Client/Core/Internal/Request.hs @@ -15,6 +15,8 @@ module Servant.Client.Core.Internal.Request where import Prelude () import Prelude.Compat +import Control.DeepSeq + (NFData (..)) import Control.Monad.Catch (Exception) import qualified Data.ByteString as BS @@ -34,10 +36,10 @@ import Data.Typeable import GHC.Generics (Generic) import Network.HTTP.Media - (MediaType) + (MediaType, mainType, parameters, subType) import Network.HTTP.Types - (Header, HeaderName, HttpVersion, Method, QueryItem, Status, - http11, methodGet) + (Header, HeaderName, HttpVersion (..), Method, QueryItem, + Status (..), http11, methodGet) import Web.HttpApiData (ToHttpApiData, toEncodedUrlPiece, toHeader) @@ -59,6 +61,20 @@ data ServantError = instance Exception ServantError +instance NFData ServantError where + rnf (FailureResponse res) = rnf res + rnf (DecodeFailure err res) = rnf err `seq` rnf res + rnf (UnsupportedContentType mt' res) = + mediaTypeRnf mt' `seq` + rnf res + where + mediaTypeRnf mt = + rnf (mainType mt) `seq` + rnf (subType mt) `seq` + rnf (parameters mt) + rnf (InvalidContentTypeHeader res) = rnf res + rnf (ConnectionError err) = rnf err + data RequestF a = Request { requestPath :: a , requestQueryString :: Seq.Seq QueryItem @@ -88,6 +104,16 @@ data GenResponse a = Response , responseBody :: a } deriving (Eq, Show, Generic, Typeable, Functor, Foldable, Traversable) +instance NFData a => NFData (GenResponse a) where + rnf (Response sc hs hv body) = + rnfStatus sc `seq` + rnf hs `seq` + rnfHttpVersion hv `seq` + rnf body + where + rnfStatus (Status code msg) = rnf code `seq` rnf msg + rnfHttpVersion (HttpVersion _ _) = () -- HttpVersion fields are strict + type Response = GenResponse LBS.ByteString type StreamingResponse = GenResponse (IO BS.ByteString) diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal index ebcd645e..848d284d 100644 --- a/servant-client/servant-client.cabal +++ b/servant-client/servant-client.cabal @@ -43,6 +43,7 @@ library base >= 4.9 && < 4.13 , bytestring >= 0.10.8.1 && < 0.11 , containers >= 0.5.7.1 && < 0.7 + , deepseq >= 1.4.2.0 && < 1.5 , mtl >= 2.2.2 && < 2.3 , stm >= 2.4.5.1 && < 2.6 , text >= 1.2.3.0 && < 1.3 diff --git a/servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs b/servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs index 3a0014f7..4303ce74 100644 --- a/servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs +++ b/servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs @@ -20,8 +20,11 @@ import Prelude () import Prelude.Compat import Control.Concurrent.STM.TVar +import Control.DeepSeq + (NFData, force) import Control.Exception -import Control.Monad + (evaluate, throwIO) +import Control.Monad () import Control.Monad.Base (MonadBase (..)) import Control.Monad.Codensity @@ -120,6 +123,19 @@ withClientM cm env k = let Codensity f = runExceptT $ flip runReaderT env $ unClientM cm in f k +-- | A 'runClientM' variant for streaming client. +-- +-- It allows using this module's 'ClientM' in a direct style. +-- The 'NFData' constraint however prevents using this function with genuine +-- streaming response types ('SourceT', 'Conduit', pipes 'Proxy' or 'Machine'). +-- For those you have to use 'withClientM'. +-- +-- /Note:/ we 'force' the result, so the likehood of accidentally leaking a +-- connection is smaller. Use with care. +-- +runClientM :: NFData a => ClientM a -> ClientEnv -> IO (Either ServantError a) +runClientM cm env = withClientM cm env (evaluate . force) + performRequest :: Request -> ClientM Response performRequest req = do -- TODO: should use Client.withResponse here too diff --git a/servant-client/src/Servant/Client/Streaming.hs b/servant-client/src/Servant/Client/Streaming.hs index a443882d..d4e8721d 100644 --- a/servant-client/src/Servant/Client/Streaming.hs +++ b/servant-client/src/Servant/Client/Streaming.hs @@ -7,6 +7,7 @@ module Servant.Client.Streaming ( client , ClientM , withClientM + , runClientM , ClientEnv(..) , mkClientEnv , hoistClient