{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
module Servant.Client.Internal.HttpClient.Streaming (
module Servant.Client.Internal.HttpClient.Streaming,
ClientEnv (..),
mkClientEnv,
clientResponseToResponse,
requestToClientRequest,
catchConnectionError,
) where
import Prelude ()
import Prelude.Compat
import Control.Concurrent.STM.TVar
import Control.DeepSeq
(NFData, force)
import Control.Exception
(evaluate, throwIO)
import Control.Monad ()
import Control.Monad.Base
(MonadBase (..))
import Control.Monad.Codensity
(Codensity (..))
import Control.Monad.Error.Class
(MonadError (..))
import Control.Monad.Reader
import Control.Monad.STM
(atomically)
import Control.Monad.Trans.Except
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import Data.Foldable
(for_)
import Data.Functor.Alt
(Alt (..))
import Data.Proxy
(Proxy (..))
import Data.Time.Clock
(getCurrentTime)
import GHC.Generics
import Network.HTTP.Types
(statusCode)
import qualified Network.HTTP.Client as Client
import Servant.Client.Core
import Servant.Client.Internal.HttpClient
(ClientEnv (..), catchConnectionError,
clientResponseToResponse, mkClientEnv, mkFailureResponse,
requestToClientRequest)
import qualified Servant.Types.SourceT as S
client :: HasClient ClientM api => Proxy api -> Client ClientM api
client :: Proxy api -> Client ClientM api
client api :: Proxy api
api = Proxy api
api Proxy api -> Proxy ClientM -> Client ClientM api
forall (m :: * -> *) api.
HasClient m api =>
Proxy api -> Proxy m -> Client m api
`clientIn` (Proxy ClientM
forall k (t :: k). Proxy t
Proxy :: Proxy ClientM)
hoistClient
:: HasClient ClientM api
=> Proxy api
-> (forall a. m a -> n a)
-> Client m api
-> Client n api
hoistClient :: Proxy api -> (forall a. m a -> n a) -> Client m api -> Client n api
hoistClient = Proxy ClientM
-> Proxy api
-> (forall a. m a -> n a)
-> Client m api
-> Client n api
forall (m :: * -> *) api (mon :: * -> *) (mon' :: * -> *).
HasClient m api =>
Proxy m
-> Proxy api
-> (forall x. mon x -> mon' x)
-> Client mon api
-> Client mon' api
hoistClientMonad (Proxy ClientM
forall k (t :: k). Proxy t
Proxy :: Proxy ClientM)
newtype ClientM a = ClientM
{ ClientM a
-> ReaderT ClientEnv (ExceptT ClientError (Codensity IO)) a
unClientM :: ReaderT ClientEnv (ExceptT ClientError (Codensity IO)) a }
deriving ( a -> ClientM b -> ClientM a
(a -> b) -> ClientM a -> ClientM b
(forall a b. (a -> b) -> ClientM a -> ClientM b)
-> (forall a b. a -> ClientM b -> ClientM a) -> Functor ClientM
forall a b. a -> ClientM b -> ClientM a
forall a b. (a -> b) -> ClientM a -> ClientM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> ClientM b -> ClientM a
$c<$ :: forall a b. a -> ClientM b -> ClientM a
fmap :: (a -> b) -> ClientM a -> ClientM b
$cfmap :: forall a b. (a -> b) -> ClientM a -> ClientM b
Functor, Functor ClientM
a -> ClientM a
Functor ClientM =>
(forall a. a -> ClientM a)
-> (forall a b. ClientM (a -> b) -> ClientM a -> ClientM b)
-> (forall a b c.
(a -> b -> c) -> ClientM a -> ClientM b -> ClientM c)
-> (forall a b. ClientM a -> ClientM b -> ClientM b)
-> (forall a b. ClientM a -> ClientM b -> ClientM a)
-> Applicative ClientM
ClientM a -> ClientM b -> ClientM b
ClientM a -> ClientM b -> ClientM a
ClientM (a -> b) -> ClientM a -> ClientM b
(a -> b -> c) -> ClientM a -> ClientM b -> ClientM c
forall a. a -> ClientM a
forall a b. ClientM a -> ClientM b -> ClientM a
forall a b. ClientM a -> ClientM b -> ClientM b
forall a b. ClientM (a -> b) -> ClientM a -> ClientM b
forall a b c. (a -> b -> c) -> ClientM a -> ClientM b -> ClientM c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: ClientM a -> ClientM b -> ClientM a
$c<* :: forall a b. ClientM a -> ClientM b -> ClientM a
*> :: ClientM a -> ClientM b -> ClientM b
$c*> :: forall a b. ClientM a -> ClientM b -> ClientM b
liftA2 :: (a -> b -> c) -> ClientM a -> ClientM b -> ClientM c
$cliftA2 :: forall a b c. (a -> b -> c) -> ClientM a -> ClientM b -> ClientM c
<*> :: ClientM (a -> b) -> ClientM a -> ClientM b
$c<*> :: forall a b. ClientM (a -> b) -> ClientM a -> ClientM b
pure :: a -> ClientM a
$cpure :: forall a. a -> ClientM a
$cp1Applicative :: Functor ClientM
Applicative, Applicative ClientM
a -> ClientM a
Applicative ClientM =>
(forall a b. ClientM a -> (a -> ClientM b) -> ClientM b)
-> (forall a b. ClientM a -> ClientM b -> ClientM b)
-> (forall a. a -> ClientM a)
-> Monad ClientM
ClientM a -> (a -> ClientM b) -> ClientM b
ClientM a -> ClientM b -> ClientM b
forall a. a -> ClientM a
forall a b. ClientM a -> ClientM b -> ClientM b
forall a b. ClientM a -> (a -> ClientM b) -> ClientM b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> ClientM a
$creturn :: forall a. a -> ClientM a
>> :: ClientM a -> ClientM b -> ClientM b
$c>> :: forall a b. ClientM a -> ClientM b -> ClientM b
>>= :: ClientM a -> (a -> ClientM b) -> ClientM b
$c>>= :: forall a b. ClientM a -> (a -> ClientM b) -> ClientM b
$cp1Monad :: Applicative ClientM
Monad, Monad ClientM
Monad ClientM => (forall a. IO a -> ClientM a) -> MonadIO ClientM
IO a -> ClientM a
forall a. IO a -> ClientM a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
liftIO :: IO a -> ClientM a
$cliftIO :: forall a. IO a -> ClientM a
$cp1MonadIO :: Monad ClientM
MonadIO, (forall x. ClientM a -> Rep (ClientM a) x)
-> (forall x. Rep (ClientM a) x -> ClientM a)
-> Generic (ClientM a)
forall x. Rep (ClientM a) x -> ClientM a
forall x. ClientM a -> Rep (ClientM a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (ClientM a) x -> ClientM a
forall a x. ClientM a -> Rep (ClientM a) x
$cto :: forall a x. Rep (ClientM a) x -> ClientM a
$cfrom :: forall a x. ClientM a -> Rep (ClientM a) x
Generic
, MonadReader ClientEnv, MonadError ClientError)
instance MonadBase IO ClientM where
liftBase :: IO α -> ClientM α
liftBase = ReaderT ClientEnv (ExceptT ClientError (Codensity IO)) α
-> ClientM α
forall a.
ReaderT ClientEnv (ExceptT ClientError (Codensity IO)) a
-> ClientM a
ClientM (ReaderT ClientEnv (ExceptT ClientError (Codensity IO)) α
-> ClientM α)
-> (IO α
-> ReaderT ClientEnv (ExceptT ClientError (Codensity IO)) α)
-> IO α
-> ClientM α
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO α -> ReaderT ClientEnv (ExceptT ClientError (Codensity IO)) α
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
instance Alt ClientM where
a :: ClientM a
a <!> :: ClientM a -> ClientM a -> ClientM a
<!> b :: ClientM a
b = ClientM a
a ClientM a -> (ClientError -> ClientM a) -> ClientM a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` \_ -> ClientM a
b
instance RunClient ClientM where
runRequest :: Request -> ClientM Response
runRequest = Request -> ClientM Response
performRequest
throwClientError :: ClientError -> ClientM a
throwClientError = ClientError -> ClientM a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
instance RunStreamingClient ClientM where
withStreamingRequest :: Request -> (StreamingResponse -> IO a) -> ClientM a
withStreamingRequest = Request -> (StreamingResponse -> IO a) -> ClientM a
forall a. Request -> (StreamingResponse -> IO a) -> ClientM a
performWithStreamingRequest
withClientM :: ClientM a -> ClientEnv -> (Either ClientError a -> IO b) -> IO b
withClientM :: ClientM a -> ClientEnv -> (Either ClientError a -> IO b) -> IO b
withClientM cm :: ClientM a
cm env :: ClientEnv
env k :: Either ClientError a -> IO b
k =
let Codensity f :: forall b. (Either ClientError a -> IO b) -> IO b
f = ExceptT ClientError (Codensity IO) a
-> Codensity IO (Either ClientError a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT ClientError (Codensity IO) a
-> Codensity IO (Either ClientError a))
-> ExceptT ClientError (Codensity IO) a
-> Codensity IO (Either ClientError a)
forall a b. (a -> b) -> a -> b
$ (ReaderT ClientEnv (ExceptT ClientError (Codensity IO)) a
-> ClientEnv -> ExceptT ClientError (Codensity IO) a)
-> ClientEnv
-> ReaderT ClientEnv (ExceptT ClientError (Codensity IO)) a
-> ExceptT ClientError (Codensity IO) a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT ClientEnv (ExceptT ClientError (Codensity IO)) a
-> ClientEnv -> ExceptT ClientError (Codensity IO) a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ClientEnv
env (ReaderT ClientEnv (ExceptT ClientError (Codensity IO)) a
-> ExceptT ClientError (Codensity IO) a)
-> ReaderT ClientEnv (ExceptT ClientError (Codensity IO)) a
-> ExceptT ClientError (Codensity IO) a
forall a b. (a -> b) -> a -> b
$ ClientM a
-> ReaderT ClientEnv (ExceptT ClientError (Codensity IO)) a
forall a.
ClientM a
-> ReaderT ClientEnv (ExceptT ClientError (Codensity IO)) a
unClientM ClientM a
cm
in (Either ClientError a -> IO b) -> IO b
forall b. (Either ClientError a -> IO b) -> IO b
f Either ClientError a -> IO b
k
runClientM :: NFData a => ClientM a -> ClientEnv -> IO (Either ClientError a)
runClientM :: ClientM a -> ClientEnv -> IO (Either ClientError a)
runClientM cm :: ClientM a
cm env :: ClientEnv
env = ClientM a
-> ClientEnv
-> (Either ClientError a -> IO (Either ClientError a))
-> IO (Either ClientError a)
forall a b.
ClientM a -> ClientEnv -> (Either ClientError a -> IO b) -> IO b
withClientM ClientM a
cm ClientEnv
env (Either ClientError a -> IO (Either ClientError a)
forall a. a -> IO a
evaluate (Either ClientError a -> IO (Either ClientError a))
-> (Either ClientError a -> Either ClientError a)
-> Either ClientError a
-> IO (Either ClientError a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either ClientError a -> Either ClientError a
forall a. NFData a => a -> a
force)
performRequest :: Request -> ClientM Response
performRequest :: Request -> ClientM Response
performRequest req :: Request
req = do
ClientEnv m :: Manager
m burl :: BaseUrl
burl cookieJar' :: Maybe (TVar CookieJar)
cookieJar' <- ClientM ClientEnv
forall r (m :: * -> *). MonadReader r m => m r
ask
let clientRequest :: Request
clientRequest = BaseUrl -> Request -> Request
requestToClientRequest BaseUrl
burl Request
req
Request
request <- case Maybe (TVar CookieJar)
cookieJar' of
Nothing -> Request -> ClientM Request
forall (f :: * -> *) a. Applicative f => a -> f a
pure Request
clientRequest
Just cj :: TVar CookieJar
cj -> IO Request -> ClientM Request
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Request -> ClientM Request) -> IO Request -> ClientM Request
forall a b. (a -> b) -> a -> b
$ do
UTCTime
now <- IO UTCTime
getCurrentTime
STM Request -> IO Request
forall a. STM a -> IO a
atomically (STM Request -> IO Request) -> STM Request -> IO Request
forall a b. (a -> b) -> a -> b
$ do
CookieJar
oldCookieJar <- TVar CookieJar -> STM CookieJar
forall a. TVar a -> STM a
readTVar TVar CookieJar
cj
let (newRequest :: Request
newRequest, newCookieJar :: CookieJar
newCookieJar) =
Request -> CookieJar -> UTCTime -> (Request, CookieJar)
Client.insertCookiesIntoRequest
(BaseUrl -> Request -> Request
requestToClientRequest BaseUrl
burl Request
req)
CookieJar
oldCookieJar
UTCTime
now
TVar CookieJar -> CookieJar -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar CookieJar
cj CookieJar
newCookieJar
Request -> STM Request
forall (f :: * -> *) a. Applicative f => a -> f a
pure Request
newRequest
Either ClientError (Response ByteString)
eResponse <- IO (Either ClientError (Response ByteString))
-> ClientM (Either ClientError (Response ByteString))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either ClientError (Response ByteString))
-> ClientM (Either ClientError (Response ByteString)))
-> IO (Either ClientError (Response ByteString))
-> ClientM (Either ClientError (Response ByteString))
forall a b. (a -> b) -> a -> b
$ IO (Response ByteString)
-> IO (Either ClientError (Response ByteString))
forall a. IO a -> IO (Either ClientError a)
catchConnectionError (IO (Response ByteString)
-> IO (Either ClientError (Response ByteString)))
-> IO (Response ByteString)
-> IO (Either ClientError (Response ByteString))
forall a b. (a -> b) -> a -> b
$ Request -> Manager -> IO (Response ByteString)
Client.httpLbs Request
request Manager
m
case Either ClientError (Response ByteString)
eResponse of
Left err :: ClientError
err -> ClientError -> ClientM Response
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ClientError
err
Right response :: Response ByteString
response -> do
Maybe (TVar CookieJar)
-> (TVar CookieJar -> ClientM ()) -> ClientM ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe (TVar CookieJar)
cookieJar' ((TVar CookieJar -> ClientM ()) -> ClientM ())
-> (TVar CookieJar -> ClientM ()) -> ClientM ()
forall a b. (a -> b) -> a -> b
$ \cj :: TVar CookieJar
cj -> IO () -> ClientM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ClientM ()) -> IO () -> ClientM ()
forall a b. (a -> b) -> a -> b
$ do
UTCTime
now' <- IO UTCTime
getCurrentTime
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar CookieJar -> (CookieJar -> CookieJar) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar CookieJar
cj ((CookieJar, Response ByteString) -> CookieJar
forall a b. (a, b) -> a
fst ((CookieJar, Response ByteString) -> CookieJar)
-> (CookieJar -> (CookieJar, Response ByteString))
-> CookieJar
-> CookieJar
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response ByteString
-> Request
-> UTCTime
-> CookieJar
-> (CookieJar, Response ByteString)
forall a.
Response a
-> Request -> UTCTime -> CookieJar -> (CookieJar, Response a)
Client.updateCookieJar Response ByteString
response Request
request UTCTime
now')
let status :: Status
status = Response ByteString -> Status
forall body. Response body -> Status
Client.responseStatus Response ByteString
response
status_code :: Int
status_code = Status -> Int
statusCode Status
status
ourResponse :: Response
ourResponse = (ByteString -> ByteString) -> Response ByteString -> Response
forall a b. (a -> b) -> Response a -> ResponseF b
clientResponseToResponse ByteString -> ByteString
forall a. a -> a
id Response ByteString
response
Bool -> ClientM () -> ClientM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
status_code Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 200 Bool -> Bool -> Bool
&& Int
status_code Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 300) (ClientM () -> ClientM ()) -> ClientM () -> ClientM ()
forall a b. (a -> b) -> a -> b
$
ClientError -> ClientM ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ClientError -> ClientM ()) -> ClientError -> ClientM ()
forall a b. (a -> b) -> a -> b
$ BaseUrl -> Request -> Response -> ClientError
mkFailureResponse BaseUrl
burl Request
req Response
ourResponse
Response -> ClientM Response
forall (m :: * -> *) a. Monad m => a -> m a
return Response
ourResponse
performWithStreamingRequest :: Request -> (StreamingResponse -> IO a) -> ClientM a
performWithStreamingRequest :: Request -> (StreamingResponse -> IO a) -> ClientM a
performWithStreamingRequest req :: Request
req k :: StreamingResponse -> IO a
k = do
Manager
m <- (ClientEnv -> Manager) -> ClientM Manager
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ClientEnv -> Manager
manager
BaseUrl
burl <- (ClientEnv -> BaseUrl) -> ClientM BaseUrl
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ClientEnv -> BaseUrl
baseUrl
let request :: Request
request = BaseUrl -> Request -> Request
requestToClientRequest BaseUrl
burl Request
req
ReaderT ClientEnv (ExceptT ClientError (Codensity IO)) a
-> ClientM a
forall a.
ReaderT ClientEnv (ExceptT ClientError (Codensity IO)) a
-> ClientM a
ClientM (ReaderT ClientEnv (ExceptT ClientError (Codensity IO)) a
-> ClientM a)
-> ReaderT ClientEnv (ExceptT ClientError (Codensity IO)) a
-> ClientM a
forall a b. (a -> b) -> a -> b
$ ExceptT ClientError (Codensity IO) a
-> ReaderT ClientEnv (ExceptT ClientError (Codensity IO)) a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT ClientError (Codensity IO) a
-> ReaderT ClientEnv (ExceptT ClientError (Codensity IO)) a)
-> ExceptT ClientError (Codensity IO) a
-> ReaderT ClientEnv (ExceptT ClientError (Codensity IO)) a
forall a b. (a -> b) -> a -> b
$ Codensity IO a -> ExceptT ClientError (Codensity IO) a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Codensity IO a -> ExceptT ClientError (Codensity IO) a)
-> Codensity IO a -> ExceptT ClientError (Codensity IO) a
forall a b. (a -> b) -> a -> b
$ (forall b. (a -> IO b) -> IO b) -> Codensity IO a
forall k (m :: k -> *) a.
(forall (b :: k). (a -> m b) -> m b) -> Codensity m a
Codensity ((forall b. (a -> IO b) -> IO b) -> Codensity IO a)
-> (forall b. (a -> IO b) -> IO b) -> Codensity IO a
forall a b. (a -> b) -> a -> b
$ \k1 :: a -> IO b
k1 ->
Request -> Manager -> (Response BodyReader -> IO b) -> IO b
forall a.
Request -> Manager -> (Response BodyReader -> IO a) -> IO a
Client.withResponse Request
request Manager
m ((Response BodyReader -> IO b) -> IO b)
-> (Response BodyReader -> IO b) -> IO b
forall a b. (a -> b) -> a -> b
$ \res :: Response BodyReader
res -> do
let status :: Status
status = Response BodyReader -> Status
forall body. Response body -> Status
Client.responseStatus Response BodyReader
res
status_code :: Int
status_code = Status -> Int
statusCode Status
status
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
status_code Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 200 Bool -> Bool -> Bool
&& Int
status_code Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 300) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
ByteString
b <- [ByteString] -> ByteString
BSL.fromChunks ([ByteString] -> ByteString) -> IO [ByteString] -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BodyReader -> IO [ByteString]
Client.brConsume (Response BodyReader -> BodyReader
forall body. Response body -> body
Client.responseBody Response BodyReader
res)
ClientError -> IO ()
forall e a. Exception e => e -> IO a
throwIO (ClientError -> IO ()) -> ClientError -> IO ()
forall a b. (a -> b) -> a -> b
$ BaseUrl -> Request -> Response -> ClientError
mkFailureResponse BaseUrl
burl Request
req ((BodyReader -> ByteString) -> Response BodyReader -> Response
forall a b. (a -> b) -> Response a -> ResponseF b
clientResponseToResponse (ByteString -> BodyReader -> ByteString
forall a b. a -> b -> a
const ByteString
b) Response BodyReader
res)
a
x <- StreamingResponse -> IO a
k ((BodyReader -> SourceT IO ByteString)
-> Response BodyReader -> StreamingResponse
forall a b. (a -> b) -> Response a -> ResponseF b
clientResponseToResponse ((ByteString -> Bool) -> BodyReader -> SourceT IO ByteString
forall (m :: * -> *) a.
Functor m =>
(a -> Bool) -> m a -> SourceT m a
S.fromAction ByteString -> Bool
BS.null) Response BodyReader
res)
a -> IO b
k1 a
x