{-# LANGUAGE CPP                        #-}
{-# LANGUAGE DeriveDataTypeable         #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE TypeFamilies               #-}
module Servant.Client.Internal.HttpClient where

import           Prelude ()
import           Prelude.Compat

import           Control.Concurrent.MVar
                 (modifyMVar, newMVar)
import           Control.Concurrent.STM.TVar
import           Control.Exception
                 (SomeException (..), catch)
import           Control.Monad
                 (unless)
import           Control.Monad.Base
                 (MonadBase (..))
import           Control.Monad.Catch
                 (MonadCatch, MonadThrow)
import           Control.Monad.Error.Class
                 (MonadError (..))
import           Control.Monad.IO.Class
                 (MonadIO (..))
import           Control.Monad.Reader
                 (MonadReader, ReaderT, ask, runReaderT)
import           Control.Monad.STM
                 (STM, atomically)
import           Control.Monad.Trans.Control
                 (MonadBaseControl (..))
import           Control.Monad.Trans.Except
                 (ExceptT, runExceptT)
import           Data.Bifunctor
                 (bimap)
import qualified Data.ByteString             as BS
import           Data.ByteString.Builder
                 (toLazyByteString)
import qualified Data.ByteString.Lazy        as BSL
import           Data.Either
                 (either)
import           Data.Foldable
                 (toList)
import           Data.Functor.Alt
                 (Alt (..))
import           Data.Maybe
                 (maybe, maybeToList)
import           Data.Proxy
                 (Proxy (..))
import           Data.Semigroup
                 ((<>))
import           Data.Sequence
                 (fromList)
import           Data.String
                 (fromString)
import           Data.Time.Clock
                 (UTCTime, getCurrentTime)
import           GHC.Generics
import           Network.HTTP.Media
                 (renderHeader)
import           Network.HTTP.Types
                 (hContentType, renderQuery, statusCode, Status)
import           Servant.Client.Core

import qualified Network.HTTP.Client         as Client
import qualified Servant.Types.SourceT       as S

-- | The environment in which a request is run.
--   The 'baseUrl' and 'makeClientRequest' function are used to create a @http-client@ request.
--   Cookies are then added to that request if a 'CookieJar' is set on the environment.
--   Finally the request is executed with the 'manager'.
--   The 'makeClientRequest' function can be used to modify the request to execute and set values which
--   are not specified on a @servant@ 'Request' like 'responseTimeout' or 'redirectCount'
data ClientEnv
  = ClientEnv
  { ClientEnv -> Manager
manager :: Client.Manager
  , ClientEnv -> BaseUrl
baseUrl :: BaseUrl
  , ClientEnv -> Maybe (TVar CookieJar)
cookieJar :: Maybe (TVar Client.CookieJar)
  , ClientEnv -> BaseUrl -> Request -> Request
makeClientRequest :: BaseUrl -> Request -> Client.Request
  -- ^ this function can be used to customize the creation of @http-client@ requests from @servant@ requests. Default value: 'defaultMakeClientRequest'
  --   Note that:
  --      1. 'makeClientRequest' exists to allow overriding operational semantics e.g. 'responseTimeout' per request,
  --          If you need global modifications, you should use 'managerModifyRequest'
  --      2. the 'cookieJar', if defined, is being applied after 'makeClientRequest' is called.
  }

-- | 'ClientEnv' smart constructor.
mkClientEnv :: Client.Manager -> BaseUrl -> ClientEnv
mkClientEnv :: Manager -> BaseUrl -> ClientEnv
mkClientEnv Manager
mgr BaseUrl
burl = Manager
-> BaseUrl
-> Maybe (TVar CookieJar)
-> (BaseUrl -> Request -> Request)
-> ClientEnv
ClientEnv Manager
mgr BaseUrl
burl Maybe (TVar CookieJar)
forall a. Maybe a
Nothing BaseUrl -> Request -> Request
defaultMakeClientRequest

-- | Generates a set of client functions for an API.
--
-- Example:
--
-- > type API = Capture "no" Int :> Get '[JSON] Int
-- >        :<|> Get '[JSON] [Bool]
-- >
-- > api :: Proxy API
-- > api = Proxy
-- >
-- > getInt :: Int -> ClientM Int
-- > getBools :: ClientM [Bool]
-- > getInt :<|> getBools = client api
client :: HasClient ClientM api => Proxy api -> Client ClientM api
client :: Proxy api -> Client ClientM api
client 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)

-- | Change the monad the client functions live in, by
--   supplying a conversion function
--   (a natural transformation to be precise).
--
--   For example, assuming you have some @manager :: 'Manager'@ and
--   @baseurl :: 'BaseUrl'@ around:
--
--   > type API = Get '[JSON] Int :<|> Capture "n" Int :> Post '[JSON] Int
--   > api :: Proxy API
--   > api = Proxy
--   > getInt :: IO Int
--   > postInt :: Int -> IO Int
--   > getInt :<|> postInt = hoistClient api (flip runClientM cenv) (client api)
--   >   where cenv = mkClientEnv manager baseurl
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)

-- | @ClientM@ is the monad in which client functions run. Contains the
-- 'Client.Manager' and 'BaseUrl' used for requests in the reader environment.
newtype ClientM a = ClientM
  { ClientM a -> ReaderT ClientEnv (ExceptT ClientError IO) a
unClientM :: ReaderT ClientEnv (ExceptT ClientError 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, Monad ClientM
e -> ClientM a
Monad ClientM
-> (forall e a. Exception e => e -> ClientM a)
-> MonadThrow ClientM
forall e a. Exception e => e -> ClientM a
forall (m :: * -> *).
Monad m -> (forall e a. Exception e => e -> m a) -> MonadThrow m
throwM :: e -> ClientM a
$cthrowM :: forall e a. Exception e => e -> ClientM a
$cp1MonadThrow :: Monad ClientM
MonadThrow
           , MonadThrow ClientM
MonadThrow ClientM
-> (forall e a.
    Exception e =>
    ClientM a -> (e -> ClientM a) -> ClientM a)
-> MonadCatch ClientM
ClientM a -> (e -> ClientM a) -> ClientM a
forall e a.
Exception e =>
ClientM a -> (e -> ClientM a) -> ClientM a
forall (m :: * -> *).
MonadThrow m
-> (forall e a. Exception e => m a -> (e -> m a) -> m a)
-> MonadCatch m
catch :: ClientM a -> (e -> ClientM a) -> ClientM a
$ccatch :: forall e a.
Exception e =>
ClientM a -> (e -> ClientM a) -> ClientM a
$cp1MonadCatch :: MonadThrow ClientM
MonadCatch)

instance MonadBase IO ClientM where
  liftBase :: IO α -> ClientM α
liftBase = ReaderT ClientEnv (ExceptT ClientError IO) α -> ClientM α
forall a. ReaderT ClientEnv (ExceptT ClientError IO) a -> ClientM a
ClientM (ReaderT ClientEnv (ExceptT ClientError IO) α -> ClientM α)
-> (IO α -> ReaderT ClientEnv (ExceptT ClientError IO) α)
-> IO α
-> ClientM α
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO α -> ReaderT ClientEnv (ExceptT ClientError IO) α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase

instance MonadBaseControl IO ClientM where
  type StM ClientM a = Either ClientError a

  liftBaseWith :: (RunInBase ClientM IO -> IO a) -> ClientM a
liftBaseWith RunInBase ClientM IO -> IO a
f = ReaderT ClientEnv (ExceptT ClientError IO) a -> ClientM a
forall a. ReaderT ClientEnv (ExceptT ClientError IO) a -> ClientM a
ClientM ((RunInBase (ReaderT ClientEnv (ExceptT ClientError IO)) IO -> IO a)
-> ReaderT ClientEnv (ExceptT ClientError IO) a
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
(RunInBase m b -> b a) -> m a
liftBaseWith (\RunInBase (ReaderT ClientEnv (ExceptT ClientError IO)) IO
g -> RunInBase ClientM IO -> IO a
f (ReaderT ClientEnv (ExceptT ClientError IO) a
-> IO (Either ClientError a)
RunInBase (ReaderT ClientEnv (ExceptT ClientError IO)) IO
g (ReaderT ClientEnv (ExceptT ClientError IO) a
 -> IO (Either ClientError a))
-> (ClientM a -> ReaderT ClientEnv (ExceptT ClientError IO) a)
-> ClientM a
-> IO (Either ClientError a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClientM a -> ReaderT ClientEnv (ExceptT ClientError IO) a
forall a. ClientM a -> ReaderT ClientEnv (ExceptT ClientError IO) a
unClientM)))

  restoreM :: StM ClientM a -> ClientM a
restoreM StM ClientM a
st = ReaderT ClientEnv (ExceptT ClientError IO) a -> ClientM a
forall a. ReaderT ClientEnv (ExceptT ClientError IO) a -> ClientM a
ClientM (StM (ReaderT ClientEnv (ExceptT ClientError IO)) a
-> ReaderT ClientEnv (ExceptT ClientError IO) a
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
StM m a -> m a
restoreM StM (ReaderT ClientEnv (ExceptT ClientError IO)) a
StM ClientM a
st)

-- | Try clients in order, last error is preserved.
instance Alt ClientM where
  ClientM a
a <!> :: ClientM a -> ClientM a -> ClientM a
<!> 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` \ClientError
_ -> ClientM a
b

instance RunClient ClientM where
  runRequestAcceptStatus :: Maybe [Status] -> Request -> ClientM Response
runRequestAcceptStatus = Maybe [Status] -> Request -> ClientM Response
performRequest
  throwClientError :: ClientError -> ClientM a
throwClientError = ClientError -> ClientM a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError

runClientM :: ClientM a -> ClientEnv -> IO (Either ClientError a)
runClientM :: ClientM a -> ClientEnv -> IO (Either ClientError a)
runClientM ClientM a
cm ClientEnv
env = ExceptT ClientError IO a -> IO (Either ClientError a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT ClientError IO a -> IO (Either ClientError a))
-> ExceptT ClientError IO a -> IO (Either ClientError a)
forall a b. (a -> b) -> a -> b
$ (ReaderT ClientEnv (ExceptT ClientError IO) a
 -> ClientEnv -> ExceptT ClientError IO a)
-> ClientEnv
-> ReaderT ClientEnv (ExceptT ClientError IO) a
-> ExceptT ClientError IO a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT ClientEnv (ExceptT ClientError IO) a
-> ClientEnv -> ExceptT ClientError IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ClientEnv
env (ReaderT ClientEnv (ExceptT ClientError IO) a
 -> ExceptT ClientError IO a)
-> ReaderT ClientEnv (ExceptT ClientError IO) a
-> ExceptT ClientError IO a
forall a b. (a -> b) -> a -> b
$ ClientM a -> ReaderT ClientEnv (ExceptT ClientError IO) a
forall a. ClientM a -> ReaderT ClientEnv (ExceptT ClientError IO) a
unClientM ClientM a
cm

performRequest :: Maybe [Status] -> Request -> ClientM Response
performRequest :: Maybe [Status] -> Request -> ClientM Response
performRequest Maybe [Status]
acceptStatus Request
req = do
  ClientEnv Manager
m BaseUrl
burl Maybe (TVar CookieJar)
cookieJar' BaseUrl -> Request -> Request
createClientRequest <- ClientM ClientEnv
forall r (m :: * -> *). MonadReader r m => m r
ask
  let clientRequest :: Request
clientRequest = BaseUrl -> Request -> Request
createClientRequest BaseUrl
burl Request
req
  Request
request <- case Maybe (TVar CookieJar)
cookieJar' of
    Maybe (TVar CookieJar)
Nothing -> Request -> ClientM Request
forall (f :: * -> *) a. Applicative f => a -> f a
pure Request
clientRequest
    Just 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 (Request
newRequest, CookieJar
newCookieJar) =
              Request -> CookieJar -> UTCTime -> (Request, CookieJar)
Client.insertCookiesIntoRequest
                Request
clientRequest
                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

  Response ByteString
response <- ClientM (Response ByteString)
-> (TVar CookieJar -> ClientM (Response ByteString))
-> Maybe (TVar CookieJar)
-> ClientM (Response ByteString)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Manager -> Request -> ClientM (Response ByteString)
requestWithoutCookieJar Manager
m Request
request) (Manager
-> Request -> TVar CookieJar -> ClientM (Response ByteString)
requestWithCookieJar Manager
m Request
request) Maybe (TVar CookieJar)
cookieJar'
  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
      goodStatus :: Bool
goodStatus = case Maybe [Status]
acceptStatus of
        Maybe [Status]
Nothing -> Int
status_code Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
200 Bool -> Bool -> Bool
&& Int
status_code Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
300
        Just [Status]
good -> Status
status Status -> [Status] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Status]
good
  Bool -> ClientM () -> ClientM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
goodStatus (ClientM () -> ClientM ()) -> ClientM () -> ClientM ()
forall a b. (a -> b) -> a -> b
$ do
    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
  where
    requestWithoutCookieJar :: Client.Manager -> Client.Request -> ClientM (Client.Response BSL.ByteString)
    requestWithoutCookieJar :: Manager -> Request -> ClientM (Response ByteString)
requestWithoutCookieJar Manager
m' Request
request' = do
        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 (Response ByteString)
    -> IO (Either ClientError (Response ByteString)))
-> IO (Response ByteString)
-> ClientM (Either ClientError (Response ByteString))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Response ByteString)
-> IO (Either ClientError (Response ByteString))
forall a. IO a -> IO (Either ClientError a)
catchConnectionError (IO (Response ByteString)
 -> ClientM (Either ClientError (Response ByteString)))
-> IO (Response ByteString)
-> ClientM (Either ClientError (Response ByteString))
forall a b. (a -> b) -> a -> b
$ Request -> Manager -> IO (Response ByteString)
Client.httpLbs Request
request' Manager
m'
        (ClientError -> ClientM (Response ByteString))
-> (Response ByteString -> ClientM (Response ByteString))
-> Either ClientError (Response ByteString)
-> ClientM (Response ByteString)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ClientError -> ClientM (Response ByteString)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Response ByteString -> ClientM (Response ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return Either ClientError (Response ByteString)
eResponse

    requestWithCookieJar :: Client.Manager -> Client.Request -> TVar Client.CookieJar -> ClientM (Client.Response BSL.ByteString)
    requestWithCookieJar :: Manager
-> Request -> TVar CookieJar -> ClientM (Response ByteString)
requestWithCookieJar Manager
m' Request
request' TVar CookieJar
cj = do
        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)))
-> ((HistoriedResponse BodyReader -> IO (Response ByteString))
    -> IO (Either ClientError (Response ByteString)))
-> (HistoriedResponse BodyReader -> IO (Response ByteString))
-> ClientM (Either ClientError (Response ByteString))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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)))
-> ((HistoriedResponse BodyReader -> IO (Response ByteString))
    -> IO (Response ByteString))
-> (HistoriedResponse BodyReader -> IO (Response ByteString))
-> IO (Either ClientError (Response ByteString))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request
-> Manager
-> (HistoriedResponse BodyReader -> IO (Response ByteString))
-> IO (Response ByteString)
forall a.
Request
-> Manager -> (HistoriedResponse BodyReader -> IO a) -> IO a
Client.withResponseHistory Request
request' Manager
m' ((HistoriedResponse BodyReader -> IO (Response ByteString))
 -> ClientM (Either ClientError (Response ByteString)))
-> (HistoriedResponse BodyReader -> IO (Response ByteString))
-> ClientM (Either ClientError (Response ByteString))
forall a b. (a -> b) -> a -> b
$ TVar CookieJar
-> HistoriedResponse BodyReader -> IO (Response ByteString)
updateWithResponseCookies TVar CookieJar
cj
        (ClientError -> ClientM (Response ByteString))
-> (Response ByteString -> ClientM (Response ByteString))
-> Either ClientError (Response ByteString)
-> ClientM (Response ByteString)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ClientError -> ClientM (Response ByteString)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Response ByteString -> ClientM (Response ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return Either ClientError (Response ByteString)
eResponse

    updateWithResponseCookies :: TVar Client.CookieJar -> Client.HistoriedResponse Client.BodyReader -> IO (Client.Response BSL.ByteString)
    updateWithResponseCookies :: TVar CookieJar
-> HistoriedResponse BodyReader -> IO (Response ByteString)
updateWithResponseCookies TVar CookieJar
cj HistoriedResponse BodyReader
responses = do
        UTCTime
now <- IO UTCTime
getCurrentTime
        [ByteString]
bss <- BodyReader -> IO [ByteString]
Client.brConsume (BodyReader -> IO [ByteString]) -> BodyReader -> IO [ByteString]
forall a b. (a -> b) -> a -> b
$ Response BodyReader -> BodyReader
forall body. Response body -> body
Client.responseBody Response BodyReader
fRes
        let fRes' :: Response ByteString
fRes'        = Response BodyReader
fRes { responseBody :: ByteString
Client.responseBody = [ByteString] -> ByteString
BSL.fromChunks [ByteString]
bss }
            allResponses :: [(Request, Response ByteString)]
allResponses = HistoriedResponse BodyReader -> [(Request, Response ByteString)]
forall body.
HistoriedResponse body -> [(Request, Response ByteString)]
Client.hrRedirects HistoriedResponse BodyReader
responses [(Request, Response ByteString)]
-> [(Request, Response ByteString)]
-> [(Request, Response ByteString)]
forall a. Semigroup a => a -> a -> a
<> [(Request
fReq, Response ByteString
fRes')]
        STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ ((Request, Response ByteString) -> STM ())
-> [(Request, Response ByteString)] -> STM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (UTCTime -> (Request, Response ByteString) -> STM ()
updateCookieJar UTCTime
now) [(Request, Response ByteString)]
allResponses
        Response ByteString -> IO (Response ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return Response ByteString
fRes'
      where
          updateCookieJar :: UTCTime -> (Client.Request, Client.Response BSL.ByteString) -> STM ()
          updateCookieJar :: UTCTime -> (Request, Response ByteString) -> STM ()
updateCookieJar UTCTime
now' (Request
req', Response ByteString
res') = 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
res' Request
req' UTCTime
now')

          fReq :: Request
fReq = HistoriedResponse BodyReader -> Request
forall body. HistoriedResponse body -> Request
Client.hrFinalRequest HistoriedResponse BodyReader
responses
          fRes :: Response BodyReader
fRes = HistoriedResponse BodyReader -> Response BodyReader
forall body. HistoriedResponse body -> Response body
Client.hrFinalResponse HistoriedResponse BodyReader
responses

mkFailureResponse :: BaseUrl -> Request -> ResponseF BSL.ByteString -> ClientError
mkFailureResponse :: BaseUrl -> Request -> Response -> ClientError
mkFailureResponse BaseUrl
burl Request
request =
    RequestF () (BaseUrl, ByteString) -> Response -> ClientError
FailureResponse ((RequestBody -> ())
-> (Builder -> (BaseUrl, ByteString))
-> Request
-> RequestF () (BaseUrl, ByteString)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (() -> RequestBody -> ()
forall a b. a -> b -> a
const ()) Builder -> (BaseUrl, ByteString)
f Request
request)
  where
    f :: Builder -> (BaseUrl, ByteString)
f Builder
b = (BaseUrl
burl, ByteString -> ByteString
BSL.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
toLazyByteString Builder
b)

clientResponseToResponse :: (a -> b) -> Client.Response a -> ResponseF b
clientResponseToResponse :: (a -> b) -> Response a -> ResponseF b
clientResponseToResponse a -> b
f Response a
r = Response :: forall a. Status -> Seq Header -> HttpVersion -> a -> ResponseF a
Response
    { responseStatusCode :: Status
responseStatusCode  = Response a -> Status
forall body. Response body -> Status
Client.responseStatus Response a
r
    , responseBody :: b
responseBody        = a -> b
f (Response a -> a
forall body. Response body -> body
Client.responseBody Response a
r)
    , responseHeaders :: Seq Header
responseHeaders     = [Header] -> Seq Header
forall a. [a] -> Seq a
fromList ([Header] -> Seq Header) -> [Header] -> Seq Header
forall a b. (a -> b) -> a -> b
$ Response a -> [Header]
forall body. Response body -> [Header]
Client.responseHeaders Response a
r
    , responseHttpVersion :: HttpVersion
responseHttpVersion = Response a -> HttpVersion
forall body. Response body -> HttpVersion
Client.responseVersion Response a
r
    }

-- | Create a @http-client@ 'Client.Request' from a @servant@ 'Request'
--    The 'Client.host', 'Client.path' and 'Client.port' fields are extracted from the 'BaseUrl'
--    otherwise the body, headers and query string are derived from the @servant@ 'Request'
defaultMakeClientRequest :: BaseUrl -> Request -> Client.Request
defaultMakeClientRequest :: BaseUrl -> Request -> Request
defaultMakeClientRequest BaseUrl
burl Request
r = Request
Client.defaultRequest
    { method :: ByteString
Client.method = Request -> ByteString
forall body path. RequestF body path -> ByteString
requestMethod Request
r
    , host :: ByteString
Client.host = String -> ByteString
forall a. IsString a => String -> a
fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ BaseUrl -> String
baseUrlHost BaseUrl
burl
    , port :: Int
Client.port = BaseUrl -> Int
baseUrlPort BaseUrl
burl
    , path :: ByteString
Client.path = ByteString -> ByteString
BSL.toStrict
                  (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ String -> ByteString
forall a. IsString a => String -> a
fromString (BaseUrl -> String
baseUrlPath BaseUrl
burl)
                 ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Builder -> ByteString
toLazyByteString (Request -> Builder
forall body path. RequestF body path -> path
requestPath Request
r)
    , queryString :: ByteString
Client.queryString = Bool -> Query -> ByteString
renderQuery Bool
True (Query -> ByteString)
-> (Seq QueryItem -> Query) -> Seq QueryItem -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq QueryItem -> Query
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Seq QueryItem -> ByteString) -> Seq QueryItem -> ByteString
forall a b. (a -> b) -> a -> b
$ Request -> Seq QueryItem
forall body path. RequestF body path -> Seq QueryItem
requestQueryString Request
r
    , requestHeaders :: [Header]
Client.requestHeaders =
      Maybe Header -> [Header]
forall a. Maybe a -> [a]
maybeToList Maybe Header
acceptHdr [Header] -> [Header] -> [Header]
forall a. [a] -> [a] -> [a]
++ Maybe Header -> [Header]
forall a. Maybe a -> [a]
maybeToList Maybe Header
contentTypeHdr [Header] -> [Header] -> [Header]
forall a. [a] -> [a] -> [a]
++ [Header]
headers
    , requestBody :: RequestBody
Client.requestBody = RequestBody
body
    , secure :: Bool
Client.secure = Bool
isSecure
    }
  where
    -- Content-Type and Accept are specified by requestBody and requestAccept
    headers :: [Header]
headers = (Header -> Bool) -> [Header] -> [Header]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(HeaderName
h, ByteString
_) -> HeaderName
h HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
/= HeaderName
"Accept" Bool -> Bool -> Bool
&& HeaderName
h HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
/= HeaderName
"Content-Type") ([Header] -> [Header]) -> [Header] -> [Header]
forall a b. (a -> b) -> a -> b
$
        Seq Header -> [Header]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Seq Header -> [Header]) -> Seq Header -> [Header]
forall a b. (a -> b) -> a -> b
$Request -> Seq Header
forall body path. RequestF body path -> Seq Header
requestHeaders Request
r

    acceptHdr :: Maybe Header
acceptHdr
        | [MediaType] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [MediaType]
hs   = Maybe Header
forall a. Maybe a
Nothing
        | Bool
otherwise = Header -> Maybe Header
forall a. a -> Maybe a
Just (HeaderName
"Accept", [MediaType] -> ByteString
forall h. RenderHeader h => h -> ByteString
renderHeader [MediaType]
hs)
      where
        hs :: [MediaType]
hs = Seq MediaType -> [MediaType]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Seq MediaType -> [MediaType]) -> Seq MediaType -> [MediaType]
forall a b. (a -> b) -> a -> b
$ Request -> Seq MediaType
forall body path. RequestF body path -> Seq MediaType
requestAccept Request
r

    convertBody :: RequestBody -> RequestBody
convertBody RequestBody
bd = case RequestBody
bd of
        RequestBodyLBS ByteString
body'       -> ByteString -> RequestBody
Client.RequestBodyLBS ByteString
body'
        RequestBodyBS ByteString
body'        -> ByteString -> RequestBody
Client.RequestBodyBS ByteString
body'
        RequestBodySource SourceIO ByteString
sourceIO -> GivesPopper () -> RequestBody
Client.RequestBodyStreamChunked GivesPopper ()
givesPopper
          where
            givesPopper :: (IO BS.ByteString -> IO ()) -> IO ()
            givesPopper :: GivesPopper ()
givesPopper BodyReader -> IO ()
needsPopper = SourceIO ByteString
-> forall b. (StepT IO ByteString -> IO b) -> IO b
forall (m :: * -> *) a.
SourceT m a -> forall b. (StepT m a -> m b) -> m b
S.unSourceT SourceIO ByteString
sourceIO ((StepT IO ByteString -> IO ()) -> IO ())
-> (StepT IO ByteString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \StepT IO ByteString
step0 -> do
                MVar (StepT IO ByteString)
ref <- StepT IO ByteString -> IO (MVar (StepT IO ByteString))
forall a. a -> IO (MVar a)
newMVar StepT IO ByteString
step0

                -- Note sure we need locking, but it's feels safer.
                let popper :: IO BS.ByteString
                    popper :: BodyReader
popper = MVar (StepT IO ByteString)
-> (StepT IO ByteString -> IO (StepT IO ByteString, ByteString))
-> BodyReader
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar (StepT IO ByteString)
ref StepT IO ByteString -> IO (StepT IO ByteString, ByteString)
forall (m :: * -> *).
MonadFail m =>
StepT m ByteString -> m (StepT m ByteString, ByteString)
nextBs

                BodyReader -> IO ()
needsPopper BodyReader
popper

            nextBs :: StepT m ByteString -> m (StepT m ByteString, ByteString)
nextBs StepT m ByteString
S.Stop          = (StepT m ByteString, ByteString)
-> m (StepT m ByteString, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (StepT m ByteString
forall (m :: * -> *) a. StepT m a
S.Stop, ByteString
BS.empty)
            nextBs (S.Error String
err)   = String -> m (StepT m ByteString, ByteString)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err
            nextBs (S.Skip StepT m ByteString
s)      = StepT m ByteString -> m (StepT m ByteString, ByteString)
nextBs StepT m ByteString
s
            nextBs (S.Effect m (StepT m ByteString)
ms)   = m (StepT m ByteString)
ms m (StepT m ByteString)
-> (StepT m ByteString -> m (StepT m ByteString, ByteString))
-> m (StepT m ByteString, ByteString)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= StepT m ByteString -> m (StepT m ByteString, ByteString)
nextBs
            nextBs (S.Yield ByteString
lbs StepT m ByteString
s) = case ByteString -> [ByteString]
BSL.toChunks ByteString
lbs of
                []     -> StepT m ByteString -> m (StepT m ByteString, ByteString)
nextBs StepT m ByteString
s
                (ByteString
x:[ByteString]
xs) | ByteString -> Bool
BS.null ByteString
x -> StepT m ByteString -> m (StepT m ByteString, ByteString)
nextBs StepT m ByteString
step'
                       | Bool
otherwise -> (StepT m ByteString, ByteString)
-> m (StepT m ByteString, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (StepT m ByteString
step', ByteString
x)
                    where
                      step' :: StepT m ByteString
step' = ByteString -> StepT m ByteString -> StepT m ByteString
forall (m :: * -> *) a. a -> StepT m a -> StepT m a
S.Yield ([ByteString] -> ByteString
BSL.fromChunks [ByteString]
xs) StepT m ByteString
s

    (RequestBody
body, Maybe Header
contentTypeHdr) = case Request -> Maybe (RequestBody, MediaType)
forall body path. RequestF body path -> Maybe (body, MediaType)
requestBody Request
r of
        Maybe (RequestBody, MediaType)
Nothing           -> (ByteString -> RequestBody
Client.RequestBodyBS ByteString
"", Maybe Header
forall a. Maybe a
Nothing)
        Just (RequestBody
body', MediaType
typ) -> (RequestBody -> RequestBody
convertBody RequestBody
body', Header -> Maybe Header
forall a. a -> Maybe a
Just (HeaderName
hContentType, MediaType -> ByteString
forall h. RenderHeader h => h -> ByteString
renderHeader MediaType
typ))

    isSecure :: Bool
isSecure = case BaseUrl -> Scheme
baseUrlScheme BaseUrl
burl of
        Scheme
Http -> Bool
False
        Scheme
Https -> Bool
True

catchConnectionError :: IO a -> IO (Either ClientError a)
catchConnectionError :: IO a -> IO (Either ClientError a)
catchConnectionError IO a
action =
  IO (Either ClientError a)
-> (HttpException -> IO (Either ClientError a))
-> IO (Either ClientError a)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (a -> Either ClientError a
forall a b. b -> Either a b
Right (a -> Either ClientError a) -> IO a -> IO (Either ClientError a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO a
action) ((HttpException -> IO (Either ClientError a))
 -> IO (Either ClientError a))
-> (HttpException -> IO (Either ClientError a))
-> IO (Either ClientError a)
forall a b. (a -> b) -> a -> b
$ \HttpException
e ->
    Either ClientError a -> IO (Either ClientError a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ClientError a -> IO (Either ClientError a))
-> (SomeException -> Either ClientError a)
-> SomeException
-> IO (Either ClientError a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClientError -> Either ClientError a
forall a b. a -> Either a b
Left (ClientError -> Either ClientError a)
-> (SomeException -> ClientError)
-> SomeException
-> Either ClientError a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> ClientError
ConnectionError (SomeException -> IO (Either ClientError a))
-> SomeException -> IO (Either ClientError a)
forall a b. (a -> b) -> a -> b
$ HttpException -> SomeException
forall e. Exception e => e -> SomeException
SomeException (HttpException
e :: Client.HttpException)