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
, 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

View file

@ -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)

View file

@ -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

View file

@ -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

View file

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