{-# 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, MonadMask)
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
                 (foldl',toList)
import           Data.Functor.Alt
                 (Alt (..))
import           Data.Maybe
                 (maybe, maybeToList)
import           Data.Proxy
                 (Proxy (..))
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, statusIsSuccessful, urlEncode, 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 -> IO Request
makeClientRequest :: BaseUrl -> Request -> IO 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 -> IO Request)
-> ClientEnv
ClientEnv Manager
mgr BaseUrl
burl forall a. Maybe a
Nothing BaseUrl -> Request -> IO 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 :: forall api.
HasClient ClientM api =>
Proxy api -> Client ClientM api
client Proxy api
api = Proxy api
api forall (m :: * -> *) api.
HasClient m api =>
Proxy api -> Proxy m -> Client m api
`clientIn` (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 :: forall api (m :: * -> *) (n :: * -> *).
HasClient ClientM api =>
Proxy api -> (forall a. m a -> n a) -> Client m api -> Client n api
hoistClient = 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 (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
  { forall a. ClientM a -> ReaderT ClientEnv (ExceptT ClientError IO) a
unClientM :: ReaderT ClientEnv (ExceptT ClientError IO) a }
  deriving ( 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
<$ :: forall a b. a -> ClientM b -> ClientM a
$c<$ :: forall a b. a -> ClientM b -> ClientM a
fmap :: forall a b. (a -> b) -> ClientM a -> ClientM b
$cfmap :: forall a b. (a -> b) -> ClientM a -> ClientM b
Functor, Functor ClientM
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
<* :: forall a b. ClientM a -> ClientM b -> ClientM a
$c<* :: forall a b. ClientM a -> ClientM b -> ClientM a
*> :: forall a b. ClientM a -> ClientM b -> ClientM b
$c*> :: forall a b. ClientM a -> ClientM b -> ClientM b
liftA2 :: forall a b c. (a -> b -> c) -> ClientM a -> ClientM b -> ClientM c
$cliftA2 :: forall a b c. (a -> b -> c) -> ClientM a -> ClientM b -> ClientM c
<*> :: forall a b. ClientM (a -> b) -> ClientM a -> ClientM b
$c<*> :: forall a b. ClientM (a -> b) -> ClientM a -> ClientM b
pure :: forall a. a -> ClientM a
$cpure :: forall a. a -> ClientM a
Applicative, Applicative ClientM
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 :: forall a. a -> ClientM a
$creturn :: forall a. a -> ClientM a
>> :: forall a b. ClientM a -> ClientM b -> ClientM b
$c>> :: forall a b. ClientM a -> ClientM b -> ClientM b
>>= :: forall a b. ClientM a -> (a -> ClientM b) -> ClientM b
$c>>= :: forall a b. ClientM a -> (a -> ClientM b) -> ClientM b
Monad, Monad ClientM
forall a. IO a -> ClientM a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: forall a. IO a -> ClientM a
$cliftIO :: forall a. IO a -> ClientM a
MonadIO, 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
forall e a. Exception e => e -> ClientM a
forall (m :: * -> *).
Monad m -> (forall e a. Exception e => e -> m a) -> MonadThrow m
throwM :: forall e a. Exception e => e -> ClientM a
$cthrowM :: forall e a. Exception e => e -> ClientM a
MonadThrow
           , MonadThrow ClientM
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 :: forall e a.
Exception e =>
ClientM a -> (e -> ClientM a) -> ClientM a
$ccatch :: forall e a.
Exception e =>
ClientM a -> (e -> ClientM a) -> ClientM a
MonadCatch, MonadCatch ClientM
forall b.
((forall a. ClientM a -> ClientM a) -> ClientM b) -> ClientM b
forall a b c.
ClientM a
-> (a -> ExitCase b -> ClientM c)
-> (a -> ClientM b)
-> ClientM (b, c)
forall (m :: * -> *).
MonadCatch m
-> (forall b. ((forall a. m a -> m a) -> m b) -> m b)
-> (forall b. ((forall a. m a -> m a) -> m b) -> m b)
-> (forall a b c.
    m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c))
-> MonadMask m
generalBracket :: forall a b c.
ClientM a
-> (a -> ExitCase b -> ClientM c)
-> (a -> ClientM b)
-> ClientM (b, c)
$cgeneralBracket :: forall a b c.
ClientM a
-> (a -> ExitCase b -> ClientM c)
-> (a -> ClientM b)
-> ClientM (b, c)
uninterruptibleMask :: forall b.
((forall a. ClientM a -> ClientM a) -> ClientM b) -> ClientM b
$cuninterruptibleMask :: forall b.
((forall a. ClientM a -> ClientM a) -> ClientM b) -> ClientM b
mask :: forall b.
((forall a. ClientM a -> ClientM a) -> ClientM b) -> ClientM b
$cmask :: forall b.
((forall a. ClientM a -> ClientM a) -> ClientM b) -> ClientM b
MonadMask)

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

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

  liftBaseWith :: forall a. (RunInBase ClientM IO -> IO a) -> ClientM a
liftBaseWith RunInBase ClientM IO -> IO a
f = forall a. ReaderT ClientEnv (ExceptT ClientError IO) a -> ClientM a
ClientM (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 (RunInBase (ReaderT ClientEnv (ExceptT ClientError IO)) IO
g forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ClientM a -> ReaderT ClientEnv (ExceptT ClientError IO) a
unClientM)))

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

-- | Try clients in order, last error is preserved.
instance Alt ClientM where
  ClientM a
a <!> :: forall a. ClientM a -> ClientM a -> ClientM a
<!> ClientM a
b = ClientM a
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 :: forall a. ClientError -> ClientM a
throwClientError = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError

runClientM :: ClientM a -> ClientEnv -> IO (Either ClientError a)
runClientM :: forall a. ClientM a -> ClientEnv -> IO (Either ClientError a)
runClientM ClientM a
cm ClientEnv
env = forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ClientEnv
env forall a b. (a -> b) -> a -> b
$ 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 -> IO Request
createClientRequest <- forall r (m :: * -> *). MonadReader r m => m r
ask
  Request
clientRequest <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ BaseUrl -> Request -> IO Request
createClientRequest BaseUrl
burl Request
req
  Request
request <- case Maybe (TVar CookieJar)
cookieJar' of
    Maybe (TVar CookieJar)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Request
clientRequest
    Just TVar CookieJar
cj -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
      UTCTime
now <- IO UTCTime
getCurrentTime
      forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
        CookieJar
oldCookieJar <- 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
        forall a. TVar a -> a -> STM ()
writeTVar TVar CookieJar
cj CookieJar
newCookieJar
        forall (f :: * -> *) a. Applicative f => a -> f a
pure Request
newRequest

  Response ByteString
response <- 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 = forall body. Response body -> Status
Client.responseStatus Response ByteString
response
      ourResponse :: Response
ourResponse = forall a b. (a -> b) -> Response a -> ResponseF b
clientResponseToResponse forall a. a -> a
id Response ByteString
response
      goodStatus :: Bool
goodStatus = case Maybe [Status]
acceptStatus of
        Maybe [Status]
Nothing -> Status -> Bool
statusIsSuccessful Status
status
        Just [Status]
good -> Status
status forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Status]
good
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
goodStatus forall a b. (a -> b) -> a -> b
$ do
    forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ BaseUrl -> Request -> Response -> ClientError
mkFailureResponse BaseUrl
burl Request
req Response
ourResponse
  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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IO a -> IO (Either ClientError a)
catchConnectionError forall a b. (a -> b) -> a -> b
$ Request -> Manager -> IO (Response ByteString)
Client.httpLbs Request
request' Manager
m'
        forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IO a -> IO (Either ClientError a)
catchConnectionError forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
Request
-> Manager -> (HistoriedResponse BodyReader -> IO a) -> IO a
Client.withResponseHistory Request
request' Manager
m' forall a b. (a -> b) -> a -> b
$ TVar CookieJar
-> HistoriedResponse BodyReader -> IO (Response ByteString)
updateWithResponseCookies TVar CookieJar
cj
        forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError 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 forall a b. (a -> b) -> a -> b
$ 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 = forall body.
HistoriedResponse body -> [(Request, Response ByteString)]
Client.hrRedirects HistoriedResponse BodyReader
responses forall a. Semigroup a => a -> a -> a
<> [(Request
fReq, Response ByteString
fRes')]
        forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ 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
        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') = forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar CookieJar
cj (forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
Response a
-> Request -> UTCTime -> CookieJar -> (CookieJar, Response a)
Client.updateCookieJar Response ByteString
res' Request
req' UTCTime
now')

          fReq :: Request
fReq = forall body. HistoriedResponse body -> Request
Client.hrFinalRequest HistoriedResponse BodyReader
responses
          fRes :: Response BodyReader
fRes = 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 (forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (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 forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
toLazyByteString Builder
b)

clientResponseToResponse :: (a -> b) -> Client.Response a -> ResponseF b
clientResponseToResponse :: forall a b. (a -> b) -> Response a -> ResponseF b
clientResponseToResponse a -> b
f Response a
r = Response
    { responseStatusCode :: Status
responseStatusCode  = forall body. Response body -> Status
Client.responseStatus Response a
r
    , responseBody :: b
responseBody        = a -> b
f (forall body. Response body -> body
Client.responseBody Response a
r)
    , responseHeaders :: Seq Header
responseHeaders     = forall a. [a] -> Seq a
fromList forall a b. (a -> b) -> a -> b
$ forall body. Response body -> ResponseHeaders
Client.responseHeaders Response a
r
    , responseHttpVersion :: HttpVersion
responseHttpVersion = 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 -> IO Client.Request
defaultMakeClientRequest :: BaseUrl -> Request -> IO Request
defaultMakeClientRequest BaseUrl
burl Request
r = forall (m :: * -> *) a. Monad m => a -> m a
return Request
Client.defaultRequest
    { method :: ByteString
Client.method = forall body path. RequestF body path -> ByteString
requestMethod Request
r
    , host :: ByteString
Client.host = forall a. IsString a => String -> a
fromString 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
                  forall a b. (a -> b) -> a -> b
$ forall a. IsString a => String -> a
fromString (BaseUrl -> String
baseUrlPath BaseUrl
burl)
                 forall a. Semigroup a => a -> a -> a
<> Builder -> ByteString
toLazyByteString (forall body path. RequestF body path -> path
requestPath Request
r)
    , queryString :: ByteString
Client.queryString = forall {t :: * -> *}.
Foldable t =>
[(ByteString, t ByteString)] -> ByteString
buildQueryString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall a b. (a -> b) -> a -> b
$ forall body path. RequestF body path -> Seq QueryItem
requestQueryString Request
r
    , requestHeaders :: ResponseHeaders
Client.requestHeaders =
      forall a. Maybe a -> [a]
maybeToList Maybe Header
acceptHdr forall a. [a] -> [a] -> [a]
++ forall a. Maybe a -> [a]
maybeToList Maybe Header
contentTypeHdr forall a. [a] -> [a] -> [a]
++ ResponseHeaders
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 :: ResponseHeaders
headers = forall a. (a -> Bool) -> [a] -> [a]
filter (\(HeaderName
h, ByteString
_) -> HeaderName
h forall a. Eq a => a -> a -> Bool
/= HeaderName
"Accept" Bool -> Bool -> Bool
&& HeaderName
h forall a. Eq a => a -> a -> Bool
/= HeaderName
"Content-Type") forall a b. (a -> b) -> a -> b
$
        forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall a b. (a -> b) -> a -> b
$ forall body path. RequestF body path -> Seq Header
requestHeaders Request
r

    acceptHdr :: Maybe Header
acceptHdr
        | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [MediaType]
hs   = forall a. Maybe a
Nothing
        | Bool
otherwise = forall a. a -> Maybe a
Just (HeaderName
"Accept", forall h. RenderHeader h => h -> ByteString
renderHeader [MediaType]
hs)
      where
        hs :: [MediaType]
hs = forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall a b. (a -> b) -> a -> b
$ 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 = forall (m :: * -> *) a.
SourceT m a -> forall b. (StepT m a -> m b) -> m b
S.unSourceT SourceIO ByteString
sourceIO forall a b. (a -> b) -> a -> b
$ \StepT IO ByteString
step0 -> do
                MVar (StepT IO ByteString)
ref <- 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 = forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar (StepT IO ByteString)
ref 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          = forall (m :: * -> *) a. Monad m => a -> m a
return (forall (m :: * -> *) a. StepT m a
S.Stop, ByteString
BS.empty)
            nextBs (S.Error String
err)   = 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 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return (StepT m ByteString
step', ByteString
x)
                    where
                      step' :: StepT m ByteString
step' = 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 forall body path. RequestF body path -> Maybe (body, MediaType)
requestBody Request
r of
        Maybe (RequestBody, MediaType)
Nothing           -> (ByteString -> RequestBody
Client.RequestBodyBS ByteString
"", forall a. Maybe a
Nothing)
        Just (RequestBody
body', MediaType
typ) -> (RequestBody -> RequestBody
convertBody RequestBody
body', forall a. a -> Maybe a
Just (HeaderName
hContentType, 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

    -- Query string builder which does not do any encoding
    buildQueryString :: [(ByteString, t ByteString)] -> ByteString
buildQueryString [] = forall a. Monoid a => a
mempty
    buildQueryString [(ByteString, t ByteString)]
qps = ByteString
"?" forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall {t :: * -> *}.
Foldable t =>
ByteString -> (ByteString, t ByteString) -> ByteString
addQueryParam forall a. Monoid a => a
mempty [(ByteString, t ByteString)]
qps

    addQueryParam :: ByteString -> (ByteString, t ByteString) -> ByteString
addQueryParam ByteString
qs (ByteString
k, t ByteString
v) =
          ByteString
qs forall a. Semigroup a => a -> a -> a
<> (if ByteString -> Bool
BS.null ByteString
qs then forall a. Monoid a => a
mempty else ByteString
"&") forall a. Semigroup a => a -> a -> a
<> Bool -> ByteString -> ByteString
urlEncode Bool
True ByteString
k forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (ByteString
"=" forall a. Semigroup a => a -> a -> a
<>) t ByteString
v


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