{-# 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
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
, ClientEnv -> ClientMiddleware
middleware :: ClientMiddleware
}
type ClientApplication = Request -> ClientM Response
type ClientMiddleware = ClientApplication -> ClientApplication
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
}
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)
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)
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)
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
}
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
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
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
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)