Add runClientM for streaming-client

This commit is contained in:
Oleg Grenrus 2018-11-09 19:43:55 +02:00
parent 5f947d1c43
commit 0dd8ee7585
5 changed files with 49 additions and 4 deletions

View file

@ -50,6 +50,7 @@ library
base >= 4.9 && < 4.13 base >= 4.9 && < 4.13
, bytestring >= 0.10.8.1 && < 0.11 , bytestring >= 0.10.8.1 && < 0.11
, containers >= 0.5.7.1 && < 0.7 , containers >= 0.5.7.1 && < 0.7
, deepseq >= 1.4.2.0 && < 1.5
, text >= 1.2.3.0 && < 1.3 , text >= 1.2.3.0 && < 1.3
, transformers >= 0.5.2.0 && < 0.6 , transformers >= 0.5.2.0 && < 0.6
, template-haskell >= 2.11.1.0 && < 2.15 , template-haskell >= 2.11.1.0 && < 2.15

View file

@ -15,6 +15,8 @@ module Servant.Client.Core.Internal.Request where
import Prelude () import Prelude ()
import Prelude.Compat import Prelude.Compat
import Control.DeepSeq
(NFData (..))
import Control.Monad.Catch import Control.Monad.Catch
(Exception) (Exception)
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
@ -34,10 +36,10 @@ import Data.Typeable
import GHC.Generics import GHC.Generics
(Generic) (Generic)
import Network.HTTP.Media import Network.HTTP.Media
(MediaType) (MediaType, mainType, parameters, subType)
import Network.HTTP.Types import Network.HTTP.Types
(Header, HeaderName, HttpVersion, Method, QueryItem, Status, (Header, HeaderName, HttpVersion (..), Method, QueryItem,
http11, methodGet) Status (..), http11, methodGet)
import Web.HttpApiData import Web.HttpApiData
(ToHttpApiData, toEncodedUrlPiece, toHeader) (ToHttpApiData, toEncodedUrlPiece, toHeader)
@ -59,6 +61,20 @@ data ServantError =
instance Exception 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 data RequestF a = Request
{ requestPath :: a { requestPath :: a
, requestQueryString :: Seq.Seq QueryItem , requestQueryString :: Seq.Seq QueryItem
@ -88,6 +104,16 @@ data GenResponse a = Response
, responseBody :: a , responseBody :: a
} deriving (Eq, Show, Generic, Typeable, Functor, Foldable, Traversable) } 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 Response = GenResponse LBS.ByteString
type StreamingResponse = GenResponse (IO BS.ByteString) type StreamingResponse = GenResponse (IO BS.ByteString)

View file

@ -43,6 +43,7 @@ library
base >= 4.9 && < 4.13 base >= 4.9 && < 4.13
, bytestring >= 0.10.8.1 && < 0.11 , bytestring >= 0.10.8.1 && < 0.11
, containers >= 0.5.7.1 && < 0.7 , containers >= 0.5.7.1 && < 0.7
, deepseq >= 1.4.2.0 && < 1.5
, mtl >= 2.2.2 && < 2.3 , mtl >= 2.2.2 && < 2.3
, stm >= 2.4.5.1 && < 2.6 , stm >= 2.4.5.1 && < 2.6
, text >= 1.2.3.0 && < 1.3 , text >= 1.2.3.0 && < 1.3

View file

@ -20,8 +20,11 @@ import Prelude ()
import Prelude.Compat import Prelude.Compat
import Control.Concurrent.STM.TVar import Control.Concurrent.STM.TVar
import Control.DeepSeq
(NFData, force)
import Control.Exception import Control.Exception
import Control.Monad (evaluate, throwIO)
import Control.Monad ()
import Control.Monad.Base import Control.Monad.Base
(MonadBase (..)) (MonadBase (..))
import Control.Monad.Codensity import Control.Monad.Codensity
@ -120,6 +123,19 @@ withClientM cm env k =
let Codensity f = runExceptT $ flip runReaderT env $ unClientM cm let Codensity f = runExceptT $ flip runReaderT env $ unClientM cm
in f k 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 :: Request -> ClientM Response
performRequest req = do performRequest req = do
-- TODO: should use Client.withResponse here too -- TODO: should use Client.withResponse here too

View file

@ -7,6 +7,7 @@ module Servant.Client.Streaming
( client ( client
, ClientM , ClientM
, withClientM , withClientM
, runClientM
, ClientEnv(..) , ClientEnv(..)
, mkClientEnv , mkClientEnv
, hoistClient , hoistClient