{-# 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 Maybe (TVar CookieJar)
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 Proxy api -> Proxy ClientM -> Client ClientM api
forall (m :: * -> *) api.
HasClient m api =>
Proxy api -> Proxy m -> Client m api
`clientIn` (Proxy ClientM
forall {k} (t :: k). Proxy t
Proxy :: Proxy ClientM)

-- | Change the monad the client functions live in, by
--   supplying a conversion function
--   (a natural transformation to be precise).
--
--   For example, assuming you have some @manager :: 'Manager'@ and
--   @baseurl :: 'BaseUrl'@ around:
--
--   > type API = Get '[JSON] Int :<|> Capture "n" Int :> Post '[JSON] Int
--   > api :: Proxy API
--   > api = Proxy
--   > getInt :: IO Int
--   > postInt :: Int -> IO Int
--   > getInt :<|> postInt = hoistClient api (flip runClientM cenv) (client api)
--   >   where cenv = mkClientEnv manager baseurl
hoistClient
  :: HasClient ClientM api
  => Proxy api
  -> (forall a. m a -> n a)
  -> Client m api
  -> Client n api
hoistClient :: forall api (m :: * -> *) (n :: * -> *).
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 :: * -> *) api (mon :: * -> *) (mon' :: * -> *).
HasClient m api =>
Proxy m
-> Proxy api
-> (forall x. mon x -> mon' x)
-> Client mon api
-> Client mon' api
forall (mon :: * -> *) (mon' :: * -> *).
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 ( (forall a b. (a -> b) -> ClientM a -> ClientM b)
-> (forall a b. a -> ClientM b -> ClientM a) -> Functor ClientM
forall a b. a -> ClientM b -> ClientM a
forall a b. (a -> b) -> ClientM a -> ClientM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$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 :: * -> *).
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 :: * -> *).
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 :: * -> *).
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 :: * -> *).
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 :: * -> *).
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 :: * -> *).
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 :: * -> *) (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 = 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 :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
(RunInBase m b -> b a) -> m a
liftBaseWith (\RunInBase (ReaderT ClientEnv (ExceptT ClientError IO)) IO
g -> RunInBase ClientM IO -> IO a
f (ReaderT ClientEnv (ExceptT ClientError IO) a
-> IO (Either ClientError a)
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 :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
StM m a -> m a
restoreM StM (ReaderT ClientEnv (ExceptT ClientError IO)) a
StM ClientM a
st)

-- | Try clients in order, last error is preserved.
instance Alt ClientM where
  ClientM a
a <!> :: 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 :: * -> *) 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 = ClientError -> ClientM a
forall a. ClientError -> ClientM a
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 = ExceptT ClientError IO a -> IO (Either ClientError a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT ClientError IO a -> IO (Either ClientError a))
-> ExceptT ClientError IO a -> IO (Either ClientError a)
forall a b. (a -> b) -> a -> b
$ (ReaderT ClientEnv (ExceptT ClientError IO) a
 -> ClientEnv -> ExceptT ClientError IO a)
-> ClientEnv
-> ReaderT ClientEnv (ExceptT ClientError IO) a
-> ExceptT ClientError IO a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT ClientEnv (ExceptT ClientError IO) a
-> ClientEnv -> ExceptT ClientError IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ClientEnv
env (ReaderT ClientEnv (ExceptT ClientError IO) a
 -> ExceptT ClientError IO a)
-> ReaderT ClientEnv (ExceptT ClientError IO) a
-> ExceptT ClientError IO a
forall a b. (a -> b) -> a -> b
$ ClientM a -> ReaderT ClientEnv (ExceptT ClientError IO) a
forall a. ClientM a -> ReaderT ClientEnv (ExceptT ClientError IO) a
unClientM ClientM a
cm

performRequest :: Maybe [Status] -> Request -> ClientM Response
performRequest :: Maybe [Status] -> Request -> ClientM Response
performRequest Maybe [Status]
acceptStatus Request
req = do
  ClientEnv Manager
m BaseUrl
burl Maybe (TVar CookieJar)
cookieJar' BaseUrl -> Request -> IO Request
createClientRequest <- ClientM ClientEnv
forall r (m :: * -> *). MonadReader r m => m r
ask
  Request
clientRequest <- IO Request -> ClientM Request
forall a. IO a -> ClientM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Request -> ClientM Request) -> IO Request -> ClientM Request
forall a b. (a -> b) -> a -> b
$ BaseUrl -> Request -> IO Request
createClientRequest BaseUrl
burl Request
req
  Request
request <- case Maybe (TVar CookieJar)
cookieJar' of
    Maybe (TVar CookieJar)
Nothing -> Request -> ClientM Request
forall a. a -> ClientM a
forall (f :: * -> *) 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 :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Request -> ClientM Request) -> IO Request -> ClientM Request
forall a b. (a -> b) -> a -> b
$ do
      UTCTime
now <- IO UTCTime
getCurrentTime
      STM Request -> IO Request
forall a. STM a -> IO a
atomically (STM Request -> IO Request) -> STM Request -> IO Request
forall a b. (a -> b) -> a -> b
$ do
        CookieJar
oldCookieJar <- TVar CookieJar -> STM CookieJar
forall a. TVar a -> STM a
readTVar TVar CookieJar
cj
        let (Request
newRequest, CookieJar
newCookieJar) =
              Request -> CookieJar -> UTCTime -> (Request, CookieJar)
Client.insertCookiesIntoRequest
                Request
clientRequest
                CookieJar
oldCookieJar
                UTCTime
now
        TVar CookieJar -> CookieJar -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar CookieJar
cj CookieJar
newCookieJar
        Request -> STM Request
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Request
newRequest

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

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

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

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

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

clientResponseToResponse :: (a -> b) -> Client.Response a -> ResponseF b
clientResponseToResponse :: 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 :: * -> *) 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 :: * -> *) 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 :: * -> *) 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 :: * -> *) a. Foldable t => t a -> [a]
toList (Seq MediaType -> [MediaType]) -> Seq MediaType -> [MediaType]
forall a b. (a -> b) -> a -> b
$ Request -> Seq MediaType
forall body path. RequestF body path -> Seq MediaType
requestAccept Request
r

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

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

                BodyReader -> IO ()
needsPopper BodyReader
popper

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

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

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

    -- 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 :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ByteString -> (ByteString, t ByteString) -> ByteString
forall {t :: * -> *}.
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 :: * -> *) 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 :: * -> *) 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 :: * -> *) a. Applicative f => a -> f a
pure (Either ClientError a -> IO (Either ClientError a))
-> (SomeException -> Either ClientError a)
-> SomeException
-> IO (Either ClientError a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClientError -> Either ClientError a
forall a b. a -> Either a b
Left (ClientError -> Either ClientError a)
-> (SomeException -> ClientError)
-> SomeException
-> Either ClientError a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> ClientError
ConnectionError (SomeException -> IO (Either ClientError a))
-> SomeException -> IO (Either ClientError a)
forall a b. (a -> b) -> a -> b
$ HttpException -> SomeException
forall e. Exception e => e -> SomeException
SomeException (HttpException
e :: Client.HttpException)