    {-# 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
    forall (f :: Type -> Type).
    Applicative f =>
    BaseUrl -> Request -> f 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 ByteString -> Status
    forall body. Response body -> Status
    Client.responseStatus Response ByteString
    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 = 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 ByteString)
    requestWithoutCookieJar Manager
    m' Request
    request' = do
            eResponse <- IO (Either ClientError (Response ByteString))
    -> ClientM (Either ClientError (Response ByteString))
    forall a. IO a -> ClientM a
    forall (m :: Type -> Type) 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'
            either throwError return 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
            eResponse <- IO (Either ClientError (Response ByteString))
    -> ClientM (Either ClientError (Response ByteString))
    forall a. IO a -> ClientM a
    forall (m :: Type -> Type) 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
            either throwError return 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
            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 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')]
            atomically $ mapM_ (updateCookieJar now) allResponses
            return 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 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, 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 :: 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'
    --
    -- Note that @Applicative@ dependency is not really needed for this function
    -- implementation. But in the past the return type was wrapped into @IO@
    -- without a necessity breaking the API backward-compatibility. In order to not
    -- break the API again it was changed to @Applicative@ so that you can just use
    -- something like @Data.Functor.Identity@ without a need to involve @IO@ but
    -- still keeping it compatible with the code written when it was typed as @IO@.
    defaultMakeClientRequest :: Applicative f => BaseUrl -> Request -> f Client.Request
    defaultMakeClientRequest :: forall (f :: Type -> Type).
    Applicative f =>
    BaseUrl -> Request -> f Request
    defaultMakeClientRequest BaseUrl
    burl Request
    r = Request -> f Request
    forall a. a -> f a
    forall (f :: Type -> Type) a. Applicative f => a -> f a
    pure 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 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 :: Type -> Type) 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
                    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 = 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 :: Type -> Type}.
    MonadFail m =>
    StepT m ByteString -> m (StepT m ByteString, ByteString)
    nextBs

                    needsPopper 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 a. a -> m a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return (StepT m ByteString
    forall (m :: Type -> Type) a. StepT m a
    S.Stop, ByteString
    BS.empty)
                nextBs (S.Error String
    err)   = String -> m (StepT m ByteString, ByteString)
    forall a. String -> m a
    forall (m :: Type -> Type) 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 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 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 a. a -> m a
    forall (m :: Type -> Type) 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 :: Type -> Type) 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

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