servant/servant-client/src/Servant/Client/Internal/HttpClient.hs

302 lines
12 KiB
Haskell
Raw Normal View History

2017-08-28 18:36:05 +02:00
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
2017-09-12 18:38:52 +02:00
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
2017-08-28 18:36:05 +02:00
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
2018-03-23 17:36:24 +01:00
{-# LANGUAGE RankNTypes #-}
2017-08-28 18:36:05 +02:00
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
2017-09-12 18:38:52 +02:00
module Servant.Client.Internal.HttpClient where
2017-08-28 18:36:05 +02:00
2018-06-29 21:08:26 +02:00
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)
2018-06-29 21:08:26 +02:00
import Control.Monad.Base
(MonadBase (..))
import Control.Monad.Catch
(MonadCatch, MonadThrow)
import Control.Monad.Error.Class
(MonadError (..))
import Control.Monad.IO.Class
(MonadIO (..))
2017-09-08 01:11:20 +02:00
import Control.Monad.Reader
(MonadReader, ReaderT, ask, runReaderT)
2018-06-29 21:08:26 +02:00
import Control.Monad.STM
(STM, atomically)
2018-06-29 21:08:26 +02:00
import Control.Monad.Trans.Control
(MonadBaseControl (..))
2017-09-08 01:11:20 +02:00
import Control.Monad.Trans.Except
(ExceptT, runExceptT)
2019-02-05 10:51:42 +01:00
import Data.Bifunctor
(bimap)
import qualified Data.ByteString as BS
2018-06-29 21:08:26 +02:00
import Data.ByteString.Builder
(toLazyByteString)
2017-09-08 01:07:18 +02:00
import qualified Data.ByteString.Lazy as BSL
import Data.Either
(either)
2018-06-29 21:08:26 +02:00
import Data.Foldable
(foldl',toList)
2018-06-29 21:08:26 +02:00
import Data.Functor.Alt
(Alt (..))
import Data.Maybe
(maybe, maybeToList)
2018-06-29 21:08:26 +02:00
import Data.Proxy
(Proxy (..))
import Data.Sequence
(fromList)
import Data.String
(fromString)
import Data.Time.Clock
(UTCTime, getCurrentTime)
import GHC.Generics
2018-06-29 21:08:26 +02:00
import Network.HTTP.Media
(renderHeader)
import Network.HTTP.Types
(hContentType, renderQuery, statusIsSuccessful, urlEncode, Status)
2017-09-08 01:07:18 +02:00
import Servant.Client.Core
import qualified Network.HTTP.Client as Client
import qualified Servant.Types.SourceT as S
2017-08-28 18:36:05 +02:00
2017-09-13 17:05:48 +02:00
-- | 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'
2017-08-28 18:36:05 +02:00
data ClientEnv
= ClientEnv
2017-09-08 01:07:18 +02:00
{ manager :: Client.Manager
2017-08-28 18:36:05 +02:00
, baseUrl :: BaseUrl
, cookieJar :: Maybe (TVar Client.CookieJar)
, makeClientRequest :: BaseUrl -> Request -> 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.
2017-08-28 18:36:05 +02:00
}
-- | 'ClientEnv' smart constructor.
mkClientEnv :: Client.Manager -> BaseUrl -> ClientEnv
mkClientEnv mgr burl = ClientEnv mgr burl Nothing defaultMakeClientRequest
2017-09-13 17:05:48 +02:00
-- | 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
2017-09-12 18:38:52 +02:00
client :: HasClient ClientM api => Proxy api -> Client ClientM api
client api = api `clientIn` (Proxy :: Proxy ClientM)
2018-03-23 17:36:24 +01:00
-- | 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
2018-03-23 17:36:24 +01:00
hoistClient
:: HasClient ClientM api
=> Proxy api
-> (forall a. m a -> n a)
-> Client m api
-> Client n api
hoistClient = hoistClientMonad (Proxy :: Proxy ClientM)
2017-08-28 18:36:05 +02:00
-- | @ClientM@ is the monad in which client functions run. Contains the
2017-09-13 22:01:31 +02:00
-- 'Client.Manager' and 'BaseUrl' used for requests in the reader environment.
2017-09-13 17:05:48 +02:00
newtype ClientM a = ClientM
{ unClientM :: ReaderT ClientEnv (ExceptT ClientError IO) a }
2017-09-13 17:05:48 +02:00
deriving ( Functor, Applicative, Monad, MonadIO, Generic
, MonadReader ClientEnv, MonadError ClientError, MonadThrow
2017-09-13 17:05:48 +02:00
, MonadCatch)
2017-08-28 18:36:05 +02:00
instance MonadBase IO ClientM where
liftBase = ClientM . liftBase
instance MonadBaseControl IO ClientM where
type StM ClientM a = Either ClientError a
2017-08-28 18:36:05 +02:00
liftBaseWith f = ClientM (liftBaseWith (\g -> f (g . unClientM)))
2017-08-28 18:36:05 +02:00
restoreM st = ClientM (restoreM st)
-- | Try clients in order, last error is preserved.
instance Alt ClientM where
a <!> b = a `catchError` \_ -> b
2017-09-08 01:07:18 +02:00
instance RunClient ClientM where
2020-10-31 20:45:46 +01:00
runRequestAcceptStatus = performRequest
throwClientError = throwError
2017-09-08 01:07:18 +02:00
runClientM :: ClientM a -> ClientEnv -> IO (Either ClientError a)
runClientM cm env = runExceptT $ flip runReaderT env $ unClientM cm
2017-08-28 18:36:05 +02:00
2020-10-31 20:45:46 +01:00
performRequest :: Maybe [Status] -> Request -> ClientM Response
performRequest acceptStatus req = do
ClientEnv m burl cookieJar' createClientRequest <- ask
let clientRequest = createClientRequest burl req
request <- case cookieJar' of
Nothing -> pure clientRequest
Just cj -> liftIO $ do
now <- getCurrentTime
atomically $ do
oldCookieJar <- readTVar cj
let (newRequest, newCookieJar) =
Client.insertCookiesIntoRequest
clientRequest
oldCookieJar
now
writeTVar cj newCookieJar
pure newRequest
2017-08-28 18:36:05 +02:00
response <- maybe (requestWithoutCookieJar m request) (requestWithCookieJar m request) cookieJar'
let status = Client.responseStatus response
ourResponse = clientResponseToResponse id response
2020-10-31 20:45:46 +01:00
goodStatus = case acceptStatus of
Nothing -> statusIsSuccessful status
2020-10-31 20:45:46 +01:00
Just good -> status `elem` good
unless goodStatus $ do
throwError $ mkFailureResponse burl req ourResponse
return ourResponse
where
requestWithoutCookieJar :: Client.Manager -> Client.Request -> ClientM (Client.Response BSL.ByteString)
requestWithoutCookieJar m' request' = do
eResponse <- liftIO . catchConnectionError $ Client.httpLbs request' m'
either throwError return eResponse
requestWithCookieJar :: Client.Manager -> Client.Request -> TVar Client.CookieJar -> ClientM (Client.Response BSL.ByteString)
requestWithCookieJar m' request' cj = do
eResponse <- liftIO . catchConnectionError . Client.withResponseHistory request' m' $ updateWithResponseCookies cj
either throwError return eResponse
updateWithResponseCookies :: TVar Client.CookieJar -> Client.HistoriedResponse Client.BodyReader -> IO (Client.Response BSL.ByteString)
updateWithResponseCookies cj responses = do
now <- getCurrentTime
bss <- Client.brConsume $ Client.responseBody fRes
let fRes' = fRes { Client.responseBody = BSL.fromChunks bss }
allResponses = Client.hrRedirects responses <> [(fReq, fRes')]
atomically $ mapM_ (updateCookieJar now) allResponses
return fRes'
where
updateCookieJar :: UTCTime -> (Client.Request, Client.Response BSL.ByteString) -> STM ()
updateCookieJar now' (req', res') = modifyTVar' cj (fst . Client.updateCookieJar res' req' now')
fReq = Client.hrFinalRequest responses
fRes = Client.hrFinalResponse responses
2017-09-08 01:07:18 +02:00
mkFailureResponse :: BaseUrl -> Request -> ResponseF BSL.ByteString -> ClientError
2019-02-05 10:51:42 +01:00
mkFailureResponse burl request =
FailureResponse (bimap (const ()) f request)
where
f b = (burl, BSL.toStrict $ toLazyByteString b)
clientResponseToResponse :: (a -> b) -> Client.Response a -> ResponseF b
clientResponseToResponse f r = Response
{ responseStatusCode = Client.responseStatus r
, responseBody = f (Client.responseBody r)
, responseHeaders = fromList $ Client.responseHeaders r
, responseHttpVersion = Client.responseVersion r
}
2017-09-08 01:07:18 +02:00
-- | 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 -> Client.Request
defaultMakeClientRequest burl r = 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
}
2017-09-08 01:07:18 +02:00
where
-- Content-Type and Accept are specified by requestBody and requestAccept
headers = filter (\(h, _) -> h /= "Accept" && h /= "Content-Type") $
toList $requestHeaders r
acceptHdr
| null hs = Nothing
| otherwise = Just ("Accept", renderHeader hs)
where
hs = toList $ requestAccept r
convertBody bd = case bd of
RequestBodyLBS body' -> Client.RequestBodyLBS body'
RequestBodyBS body' -> Client.RequestBodyBS body'
RequestBodySource sourceIO -> Client.RequestBodyStreamChunked givesPopper
where
givesPopper :: (IO BS.ByteString -> IO ()) -> IO ()
givesPopper needsPopper = S.unSourceT sourceIO $ \step0 -> do
ref <- newMVar step0
-- Note sure we need locking, but it's feels safer.
let popper :: IO BS.ByteString
popper = modifyMVar ref nextBs
needsPopper popper
nextBs S.Stop = return (S.Stop, BS.empty)
nextBs (S.Error err) = fail err
nextBs (S.Skip s) = nextBs s
nextBs (S.Effect ms) = ms >>= nextBs
nextBs (S.Yield lbs s) = case BSL.toChunks lbs of
[] -> nextBs s
(x:xs) | BS.null x -> nextBs step'
| otherwise -> return (step', x)
where
step' = S.Yield (BSL.fromChunks xs) s
2017-09-08 01:07:18 +02:00
(body, contentTypeHdr) = case requestBody r of
Nothing -> (Client.RequestBodyBS "", Nothing)
Just (body', typ) -> (convertBody body', Just (hContentType, renderHeader typ))
2017-09-29 01:15:53 +02:00
isSecure = case baseUrlScheme burl of
Http -> False
Https -> True
2017-08-28 18:36:05 +02:00
-- Query string builder which does not do any encoding
buildQueryString = ("?" <>) . foldl' addQueryParam mempty
addQueryParam qs (k, v) =
qs <> (if BS.null qs then mempty else "&") <> urlEncode True k <> foldMap ("=" <>) v
catchConnectionError :: IO a -> IO (Either ClientError a)
2017-08-28 18:36:05 +02:00
catchConnectionError action =
catch (Right <$> action) $ \e ->
pure . Left . ConnectionError $ SomeException (e :: Client.HttpException)