{-# LANGUAGE CPP                        #-}
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 qualified Data.List as List
import           Data.Foldable
                 (toList)
import           Data.Functor.Alt
                 (Alt (..))
import           Data.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, 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 -> ClientMiddleware
middleware :: ClientMiddleware 
  }

type ClientApplication = Request -> ClientM Response

type ClientMiddleware = ClientApplication -> ClientApplication

-- | 'ClientEnv' smart constructor.
mkClientEnv :: Client.Manager -> BaseUrl -> ClientEnv
mkClientEnv :: Manager -> BaseUrl -> ClientEnv
mkClientEnv Manager
manager BaseUrl
baseUrl = ClientEnv 
  { Manager
manager :: Manager
manager :: Manager
manager
  , BaseUrl
baseUrl :: BaseUrl
baseUrl :: BaseUrl
baseUrl
  , cookieJar :: Maybe (TVar CookieJar)
cookieJar = Maybe (TVar CookieJar)
forall a. Maybe a
Nothing
  , makeClientRequest :: BaseUrl -> Request -> IO Request
makeClientRequest = BaseUrl -> Request -> IO Request
defaultMakeClientRequest
  , middleware :: ClientMiddleware
middleware = ClientMiddleware
forall a. a -> a
id
  }

-- | 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 Proxy api -> Proxy ClientM -> Client ClientM api
forall (m :: Type -> Type) 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 :: forall api (m :: Type -> Type) (n :: Type -> Type).
HasClient ClientM api =>
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 :: Type -> Type) api (mon :: Type -> Type)
       (mon' :: Type -> Type).
HasClient m api =>
Proxy m
-> Proxy api
-> (forall x. mon x -> mon' x)
-> Client mon api
-> Client mon' api
forall (mon :: Type -> Type) (mon' :: Type -> Type).
Proxy ClientM
-> 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
  { forall a. ClientM a -> ReaderT ClientEnv (ExceptT ClientError IO) a
unClientM :: ReaderT ClientEnv (ExceptT ClientError IO) a }
  deriving newtype ( (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 :: Type -> Type).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> ClientM a -> ClientM b
fmap :: forall a b. (a -> b) -> ClientM a -> ClientM b
$c<$ :: forall a b. a -> ClientM b -> ClientM a
<$ :: forall a b. a -> ClientM b -> ClientM a
Functor, Functor ClientM
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
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 :: Type -> Type).
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
$cpure :: forall a. a -> ClientM a
pure :: forall a. a -> ClientM a
$c<*> :: forall a b. ClientM (a -> b) -> ClientM a -> ClientM b
<*> :: forall a b. ClientM (a -> b) -> ClientM a -> ClientM b
$cliftA2 :: forall a b c. (a -> b -> c) -> ClientM a -> ClientM b -> ClientM c
liftA2 :: forall a b c. (a -> b -> c) -> ClientM a -> ClientM b -> ClientM c
$c*> :: forall a b. ClientM a -> ClientM b -> ClientM b
*> :: forall a b. ClientM a -> ClientM b -> ClientM b
$c<* :: forall a b. ClientM a -> ClientM b -> ClientM a
<* :: forall a b. ClientM a -> ClientM b -> ClientM a
Applicative, Applicative ClientM
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
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 :: Type -> Type).
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
$c>>= :: forall a b. ClientM a -> (a -> ClientM b) -> ClientM b
>>= :: forall a b. ClientM a -> (a -> ClientM b) -> ClientM b
$c>> :: forall a b. ClientM a -> ClientM b -> ClientM b
>> :: forall a b. ClientM a -> ClientM b -> ClientM b
$creturn :: forall a. a -> ClientM a
return :: forall a. a -> ClientM a
Monad, Monad ClientM
Monad ClientM => (forall a. IO a -> ClientM a) -> MonadIO ClientM
forall a. IO a -> ClientM a
forall (m :: Type -> Type).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall a. IO a -> ClientM a
liftIO :: forall a. IO a -> ClientM a
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
$cfrom :: forall a x. ClientM a -> Rep (ClientM a) x
from :: forall x. ClientM a -> Rep (ClientM a) x
$cto :: forall a x. Rep (ClientM a) x -> ClientM a
to :: forall x. Rep (ClientM a) x -> ClientM a
Generic
           , MonadReader ClientEnv, MonadError ClientError, Monad ClientM
Monad ClientM =>
(forall e a. (HasCallStack, Exception e) => e -> ClientM a)
-> MonadThrow ClientM
forall e a. (HasCallStack, Exception e) => e -> ClientM a
forall (m :: Type -> Type).
Monad m =>
(forall e a. (HasCallStack, Exception e) => e -> m a)
-> MonadThrow m
$cthrowM :: forall e a. (HasCallStack, Exception e) => e -> ClientM a
throwM :: forall e a. (HasCallStack, Exception e) => e -> ClientM a
MonadThrow
           , MonadThrow ClientM
MonadThrow ClientM =>
(forall e a.
 (HasCallStack, Exception e) =>
 ClientM a -> (e -> ClientM a) -> ClientM a)
-> MonadCatch ClientM
forall e a.
(HasCallStack, Exception e) =>
ClientM a -> (e -> ClientM a) -> ClientM a
forall (m :: Type -> Type).
MonadThrow m =>
(forall e a.
 (HasCallStack, Exception e) =>
 m a -> (e -> m a) -> m a)
-> MonadCatch m
$ccatch :: forall e a.
(HasCallStack, Exception e) =>
ClientM a -> (e -> ClientM a) -> ClientM a
catch :: forall e a.
(HasCallStack, Exception e) =>
ClientM a -> (e -> ClientM a) -> ClientM a
MonadCatch, MonadCatch ClientM
MonadCatch ClientM =>
(forall b.
 HasCallStack =>
 ((forall a. ClientM a -> ClientM a) -> ClientM b) -> ClientM b)
-> (forall b.
    HasCallStack =>
    ((forall a. ClientM a -> ClientM a) -> ClientM b) -> ClientM b)
-> (forall a b c.
    HasCallStack =>
    ClientM a
    -> (a -> ExitCase b -> ClientM c)
    -> (a -> ClientM b)
    -> ClientM (b, c))
-> MonadMask ClientM
forall b.
HasCallStack =>
((forall a. ClientM a -> ClientM a) -> ClientM b) -> ClientM b
forall a b c.
HasCallStack =>
ClientM a
-> (a -> ExitCase b -> ClientM c)
-> (a -> ClientM b)
-> ClientM (b, c)
forall (m :: Type -> Type).
MonadCatch m =>
(forall b. HasCallStack => ((forall a. m a -> m a) -> m b) -> m b)
-> (forall b.
    HasCallStack =>
    ((forall a. m a -> m a) -> m b) -> m b)
-> (forall a b c.
    HasCallStack =>
    m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c))
-> MonadMask m
$cmask :: forall b.
HasCallStack =>
((forall a. ClientM a -> ClientM a) -> ClientM b) -> ClientM b
mask :: forall b.
HasCallStack =>
((forall a. ClientM a -> ClientM a) -> ClientM b) -> ClientM b
$cuninterruptibleMask :: forall b.
HasCallStack =>
((forall a. ClientM a -> ClientM a) -> ClientM b) -> ClientM b
uninterruptibleMask :: forall b.
HasCallStack =>
((forall a. ClientM a -> ClientM a) -> ClientM b) -> ClientM b
$cgeneralBracket :: forall a b c.
HasCallStack =>
ClientM a
-> (a -> ExitCase b -> ClientM c)
-> (a -> ClientM b)
-> ClientM (b, c)
generalBracket :: forall a b c.
HasCallStack =>
ClientM a
-> (a -> ExitCase b -> ClientM c)
-> (a -> ClientM b)
-> ClientM (b, c)
MonadMask)

instance MonadBase IO ClientM where
  liftBase :: forall a. IO a -> ClientM a
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 α. IO α -> ReaderT ClientEnv (ExceptT ClientError IO) α
forall (b :: Type -> Type) (m :: Type -> Type) α.
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 = 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 a.
(RunInBase (ReaderT ClientEnv (ExceptT ClientError IO)) IO -> IO a)
-> ReaderT ClientEnv (ExceptT ClientError IO) a
forall (b :: Type -> Type) (m :: Type -> Type) 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)
ReaderT ClientEnv (ExceptT ClientError IO) a
-> IO (StM (ReaderT ClientEnv (ExceptT ClientError IO)) 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 :: forall a. 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 a.
StM (ReaderT ClientEnv (ExceptT ClientError IO)) a
-> ReaderT ClientEnv (ExceptT ClientError IO) a
forall (b :: Type -> Type) (m :: Type -> Type) 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 <!> :: forall a. ClientM a -> ClientM a -> ClientM a
<!> ClientM a
b = ClientM a
a ClientM a -> (ClientError -> ClientM a) -> ClientM a
forall a. ClientM a -> (ClientError -> ClientM a) -> ClientM a
forall e (m :: Type -> Type) 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]
statuses Request
req = do
    ClientEnv {middleware} <- ClientM ClientEnv
forall r (m :: Type -> Type). MonadReader r m => m r
ask
    let oldApp = Maybe [Status] -> Request -> ClientM Response
performRequest Maybe [Status]
statuses
    middleware oldApp req
  throwClientError :: forall a. ClientError -> ClientM a
throwClientError = ClientError -> ClientM a
forall a. ClientError -> ClientM a
forall e (m :: Type -> Type) 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 = ExceptT ClientError IO a -> IO (Either ClientError a)
forall e (m :: Type -> Type) 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 :: Type -> Type) 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 m burl cookieJar' createClientRequest _ <- ClientM ClientEnv
forall r (m :: Type -> Type). MonadReader r m => m r
ask
  clientRequest <- liftIO $ createClientRequest burl req
  request <- case cookieJar' of
    Maybe (TVar CookieJar)
Nothing -> Request -> ClientM Request
forall a. a -> ClientM a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Request
clientRequest
    Just TVar CookieJar
cj -> IO Request -> ClientM Request
forall a. IO a -> ClientM a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO Request -> ClientM Request) -> IO Request -> ClientM Request
forall a b. (a -> b) -> a -> b
$ do
      now <- IO UTCTime
getCurrentTime
      atomically $ do
        oldCookieJar <- readTVar cj
        let (newRequest, newCookieJar) =
              Client.insertCookiesIntoRequest
                clientRequest
                oldCookieJar
                now
        writeTVar cj newCookieJar
        pure newRequest

  response <- maybe (requestWithoutCookieJar m request) (requestWithCookieJar m request) cookieJar'
  let status = Response LazyByteString -> Status
forall body. Response body -> Status
Client.responseStatus Response LazyByteString
response
      ourResponse = (LazyByteString -> LazyByteString)
-> Response LazyByteString -> Response
forall a b. (a -> b) -> Response a -> ResponseF b
clientResponseToResponse LazyByteString -> LazyByteString
forall a. a -> a
id Response LazyByteString
response
      goodStatus = case Maybe [Status]
acceptStatus of
        Maybe [Status]
Nothing -> Status -> Bool
statusIsSuccessful Status
status
        Just [Status]
good -> Status
status Status -> [Status] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` [Status]
good
  unless goodStatus $ do
    throwError $ mkFailureResponse burl req ourResponse
  return ourResponse
  where
    requestWithoutCookieJar :: Client.Manager -> Client.Request -> ClientM (Client.Response BSL.ByteString)
    requestWithoutCookieJar :: Manager -> Request -> ClientM (Response LazyByteString)
requestWithoutCookieJar Manager
m' Request
request' = do
        eResponse <- IO (Either ClientError (Response LazyByteString))
-> ClientM (Either ClientError (Response LazyByteString))
forall a. IO a -> ClientM a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (Either ClientError (Response LazyByteString))
 -> ClientM (Either ClientError (Response LazyByteString)))
-> (IO (Response LazyByteString)
    -> IO (Either ClientError (Response LazyByteString)))
-> IO (Response LazyByteString)
-> ClientM (Either ClientError (Response LazyByteString))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Response LazyByteString)
-> IO (Either ClientError (Response LazyByteString))
forall a. IO a -> IO (Either ClientError a)
catchConnectionError (IO (Response LazyByteString)
 -> ClientM (Either ClientError (Response LazyByteString)))
-> IO (Response LazyByteString)
-> ClientM (Either ClientError (Response LazyByteString))
forall a b. (a -> b) -> a -> b
$ Request -> Manager -> IO (Response LazyByteString)
Client.httpLbs Request
request' Manager
m'
        either throwError return eResponse

    requestWithCookieJar :: Client.Manager -> Client.Request -> TVar Client.CookieJar -> ClientM (Client.Response BSL.ByteString)
    requestWithCookieJar :: Manager
-> Request -> TVar CookieJar -> ClientM (Response LazyByteString)
requestWithCookieJar Manager
m' Request
request' TVar CookieJar
cj = do
        eResponse <- IO (Either ClientError (Response LazyByteString))
-> ClientM (Either ClientError (Response LazyByteString))
forall a. IO a -> ClientM a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (Either ClientError (Response LazyByteString))
 -> ClientM (Either ClientError (Response LazyByteString)))
-> ((HistoriedResponse BodyReader -> IO (Response LazyByteString))
    -> IO (Either ClientError (Response LazyByteString)))
-> (HistoriedResponse BodyReader -> IO (Response LazyByteString))
-> ClientM (Either ClientError (Response LazyByteString))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Response LazyByteString)
-> IO (Either ClientError (Response LazyByteString))
forall a. IO a -> IO (Either ClientError a)
catchConnectionError (IO (Response LazyByteString)
 -> IO (Either ClientError (Response LazyByteString)))
-> ((HistoriedResponse BodyReader -> IO (Response LazyByteString))
    -> IO (Response LazyByteString))
-> (HistoriedResponse BodyReader -> IO (Response LazyByteString))
-> IO (Either ClientError (Response LazyByteString))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request
-> Manager
-> (HistoriedResponse BodyReader -> IO (Response LazyByteString))
-> IO (Response LazyByteString)
forall a.
Request
-> Manager -> (HistoriedResponse BodyReader -> IO a) -> IO a
Client.withResponseHistory Request
request' Manager
m' ((HistoriedResponse BodyReader -> IO (Response LazyByteString))
 -> ClientM (Either ClientError (Response LazyByteString)))
-> (HistoriedResponse BodyReader -> IO (Response LazyByteString))
-> ClientM (Either ClientError (Response LazyByteString))
forall a b. (a -> b) -> a -> b
$ TVar CookieJar
-> HistoriedResponse BodyReader -> IO (Response LazyByteString)
updateWithResponseCookies TVar CookieJar
cj
        either throwError return eResponse

    updateWithResponseCookies :: TVar Client.CookieJar -> Client.HistoriedResponse Client.BodyReader -> IO (Client.Response BSL.ByteString)
    updateWithResponseCookies :: TVar CookieJar
-> HistoriedResponse BodyReader -> IO (Response LazyByteString)
updateWithResponseCookies TVar CookieJar
cj HistoriedResponse BodyReader
responses = do
        now <- IO UTCTime
getCurrentTime
        bss <- Client.brConsume $ Client.responseBody fRes
        let fRes'        = Response BodyReader
fRes { Client.responseBody = BSL.fromChunks bss }
            allResponses = HistoriedResponse BodyReader
-> [(Request, Response LazyByteString)]
forall body.
HistoriedResponse body -> [(Request, Response LazyByteString)]
Client.hrRedirects HistoriedResponse BodyReader
responses [(Request, Response LazyByteString)]
-> [(Request, Response LazyByteString)]
-> [(Request, Response LazyByteString)]
forall a. Semigroup a => a -> a -> a
<> [(Request
fReq, Response LazyByteString
fRes')]
        atomically $ mapM_ (updateCookieJar now) allResponses
        return fRes'
      where
          updateCookieJar :: UTCTime -> (Client.Request, Client.Response BSL.ByteString) -> STM ()
          updateCookieJar :: UTCTime -> (Request, Response LazyByteString) -> STM ()
updateCookieJar UTCTime
now' (Request
req', Response LazyByteString
res') = TVar CookieJar -> (CookieJar -> CookieJar) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar CookieJar
cj ((CookieJar, Response LazyByteString) -> CookieJar
forall a b. (a, b) -> a
fst ((CookieJar, Response LazyByteString) -> CookieJar)
-> (CookieJar -> (CookieJar, Response LazyByteString))
-> CookieJar
-> CookieJar
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response LazyByteString
-> Request
-> UTCTime
-> CookieJar
-> (CookieJar, Response LazyByteString)
forall a.
Response a
-> Request -> UTCTime -> CookieJar -> (CookieJar, Response a)
Client.updateCookieJar Response LazyByteString
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 a b c d.
(a -> b) -> (c -> d) -> RequestF a c -> RequestF b d
forall (p :: Type -> Type -> Type) 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, LazyByteString -> ByteString
BSL.toStrict (LazyByteString -> ByteString) -> LazyByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Builder -> LazyByteString
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  = 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 -> IO Client.Request
defaultMakeClientRequest :: BaseUrl -> Request -> IO Request
defaultMakeClientRequest BaseUrl
burl Request
r = Request -> IO Request
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Request
Client.defaultRequest
    { Client.method = requestMethod r
    , Client.host = fromString $ baseUrlHost burl
    , Client.port = baseUrlPort burl
    , Client.path = BSL.toStrict
                  $ fromString (baseUrlPath burl)
                 <> toLazyByteString (requestPath r)
    , Client.queryString = buildQueryString . toList $ requestQueryString r
    , Client.requestHeaders =
      maybeToList acceptHdr ++ maybeToList contentTypeHdr ++ headers
    , Client.requestBody = body
    , Client.secure = 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 a. Seq a -> [a]
forall (t :: Type -> Type) 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 a. [a] -> Bool
forall (t :: Type -> Type) 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 a. Seq a -> [a]
forall (t :: Type -> Type) 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 LazyByteString
body'       -> LazyByteString -> RequestBody
Client.RequestBodyLBS LazyByteString
body'
        RequestBodyBS ByteString
body'        -> ByteString -> RequestBody
Client.RequestBodyBS ByteString
body'
        RequestBodySource SourceIO LazyByteString
sourceIO -> GivesPopper () -> RequestBody
Client.RequestBodyStreamChunked GivesPopper ()
givesPopper
          where
            givesPopper :: (IO BS.ByteString -> IO ()) -> IO ()
            givesPopper :: GivesPopper ()
givesPopper BodyReader -> IO ()
needsPopper = SourceIO LazyByteString
-> forall b. (StepT IO LazyByteString -> IO b) -> IO b
forall (m :: Type -> Type) a.
SourceT m a -> forall b. (StepT m a -> m b) -> m b
S.unSourceT SourceIO LazyByteString
sourceIO ((StepT IO LazyByteString -> IO ()) -> IO ())
-> (StepT IO LazyByteString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \StepT IO LazyByteString
step0 -> do
                ref <- StepT IO LazyByteString -> IO (MVar (StepT IO LazyByteString))
forall a. a -> IO (MVar a)
newMVar StepT IO LazyByteString
step0

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

                needsPopper popper

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

    -- Query string builder which does not do any encoding
    buildQueryString :: [(ByteString, t ByteString)] -> ByteString
buildQueryString [] = ByteString
forall a. Monoid a => a
mempty
    buildQueryString [(ByteString, t ByteString)]
qps = ByteString
"?" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> (ByteString -> (ByteString, t ByteString) -> ByteString)
-> ByteString -> [(ByteString, t ByteString)] -> ByteString
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' ByteString -> (ByteString, t ByteString) -> ByteString
forall {t :: Type -> Type}.
Foldable t =>
ByteString -> (ByteString, t ByteString) -> ByteString
addQueryParam ByteString
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 ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> (if ByteString -> Bool
BS.null ByteString
qs then ByteString
forall a. Monoid a => a
mempty else ByteString
"&") ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Bool -> ByteString -> ByteString
urlEncode Bool
True ByteString
k ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> (ByteString -> ByteString) -> t ByteString -> ByteString
forall m a. Monoid m => (a -> m) -> t a -> m
forall (t :: Type -> Type) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (ByteString
"=" ByteString -> ByteString -> 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 =
  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 :: Type -> Type) 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 a. a -> IO a
forall (f :: Type -> Type) 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, HasExceptionContext) => e -> SomeException
SomeException (HttpException
e :: Client.HttpException)