2018-11-01 18:42:30 +01:00
|
|
|
{-# LANGUAGE CPP #-}
|
|
|
|
{-# LANGUAGE DeriveGeneric #-}
|
|
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
|
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
|
|
{-# LANGUAGE RankNTypes #-}
|
|
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
|
|
module Servant.Client.Internal.HttpClient.Streaming (
|
|
|
|
module Servant.Client.Internal.HttpClient.Streaming,
|
|
|
|
ClientEnv (..),
|
|
|
|
mkClientEnv,
|
|
|
|
clientResponseToResponse,
|
2019-09-05 08:47:14 +02:00
|
|
|
defaultMakeClientRequest,
|
2018-11-01 18:42:30 +01:00
|
|
|
catchConnectionError,
|
|
|
|
) where
|
|
|
|
|
|
|
|
import Prelude ()
|
|
|
|
import Prelude.Compat
|
|
|
|
|
|
|
|
import Control.Concurrent.STM.TVar
|
2018-11-09 18:43:55 +01:00
|
|
|
import Control.DeepSeq
|
|
|
|
(NFData, force)
|
2018-11-01 18:42:30 +01:00
|
|
|
import Control.Exception
|
2018-11-09 18:43:55 +01:00
|
|
|
(evaluate, throwIO)
|
|
|
|
import Control.Monad ()
|
2018-11-01 18:42:30 +01:00
|
|
|
import Control.Monad.Base
|
|
|
|
(MonadBase (..))
|
|
|
|
import Control.Monad.Codensity
|
|
|
|
(Codensity (..))
|
|
|
|
import Control.Monad.Error.Class
|
|
|
|
(MonadError (..))
|
|
|
|
import Control.Monad.Reader
|
|
|
|
import Control.Monad.STM
|
|
|
|
(atomically)
|
|
|
|
import Control.Monad.Trans.Except
|
2019-02-06 11:12:56 +01:00
|
|
|
import qualified Data.ByteString as BS
|
2018-11-01 18:42:30 +01:00
|
|
|
import qualified Data.ByteString.Lazy as BSL
|
|
|
|
import Data.Foldable
|
|
|
|
(for_)
|
|
|
|
import Data.Functor.Alt
|
|
|
|
(Alt (..))
|
|
|
|
import Data.Proxy
|
|
|
|
(Proxy (..))
|
|
|
|
import Data.Time.Clock
|
|
|
|
(getCurrentTime)
|
|
|
|
import GHC.Generics
|
|
|
|
import Network.HTTP.Types
|
2020-10-31 20:45:46 +01:00
|
|
|
(Status, statusCode)
|
2018-11-01 18:42:30 +01:00
|
|
|
|
|
|
|
import qualified Network.HTTP.Client as Client
|
|
|
|
|
|
|
|
import Servant.Client.Core
|
|
|
|
import Servant.Client.Internal.HttpClient
|
|
|
|
(ClientEnv (..), catchConnectionError,
|
2019-02-06 11:12:56 +01:00
|
|
|
clientResponseToResponse, mkClientEnv, mkFailureResponse,
|
2019-09-05 08:47:14 +02:00
|
|
|
defaultMakeClientRequest)
|
2019-02-06 11:12:56 +01:00
|
|
|
import qualified Servant.Types.SourceT as S
|
2018-11-01 18:42:30 +01: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
|
|
|
|
client :: HasClient ClientM api => Proxy api -> Client ClientM api
|
|
|
|
client api = api `clientIn` (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 = hoistClientMonad (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
|
2019-02-18 19:17:46 +01:00
|
|
|
{ unClientM :: ReaderT ClientEnv (ExceptT ClientError (Codensity IO)) a }
|
2018-11-01 18:42:30 +01:00
|
|
|
deriving ( Functor, Applicative, Monad, MonadIO, Generic
|
2019-02-18 19:17:46 +01:00
|
|
|
, MonadReader ClientEnv, MonadError ClientError)
|
2018-11-01 18:42:30 +01:00
|
|
|
|
|
|
|
instance MonadBase IO ClientM where
|
|
|
|
liftBase = ClientM . liftIO
|
|
|
|
|
|
|
|
-- | Try clients in order, last error is preserved.
|
|
|
|
instance Alt ClientM where
|
|
|
|
a <!> b = a `catchError` \_ -> b
|
|
|
|
|
|
|
|
instance RunClient ClientM where
|
2020-10-31 20:45:46 +01:00
|
|
|
runRequestAcceptStatus = performRequest
|
2019-02-18 19:17:46 +01:00
|
|
|
throwClientError = throwError
|
2018-11-01 18:42:30 +01:00
|
|
|
|
|
|
|
instance RunStreamingClient ClientM where
|
|
|
|
withStreamingRequest = performWithStreamingRequest
|
|
|
|
|
2019-02-18 19:17:46 +01:00
|
|
|
withClientM :: ClientM a -> ClientEnv -> (Either ClientError a -> IO b) -> IO b
|
2018-11-01 18:42:30 +01:00
|
|
|
withClientM cm env k =
|
|
|
|
let Codensity f = runExceptT $ flip runReaderT env $ unClientM cm
|
|
|
|
in f k
|
|
|
|
|
2018-11-09 18:43:55 +01:00
|
|
|
-- | A 'runClientM' variant for streaming client.
|
|
|
|
--
|
|
|
|
-- It allows using this module's 'ClientM' in a direct style.
|
|
|
|
-- The 'NFData' constraint however prevents using this function with genuine
|
|
|
|
-- streaming response types ('SourceT', 'Conduit', pipes 'Proxy' or 'Machine').
|
|
|
|
-- For those you have to use 'withClientM'.
|
|
|
|
--
|
2020-06-06 06:43:51 +02:00
|
|
|
-- /Note:/ we 'force' the result, so the likelihood of accidentally leaking a
|
2018-11-09 18:43:55 +01:00
|
|
|
-- connection is smaller. Use with care.
|
|
|
|
--
|
2019-02-18 19:17:46 +01:00
|
|
|
runClientM :: NFData a => ClientM a -> ClientEnv -> IO (Either ClientError a)
|
2018-11-09 18:43:55 +01:00
|
|
|
runClientM cm env = withClientM cm env (evaluate . force)
|
|
|
|
|
2020-10-31 20:45:46 +01:00
|
|
|
performRequest :: Maybe [Status] -> Request -> ClientM Response
|
|
|
|
performRequest acceptStatus req = do
|
2018-11-01 18:42:30 +01:00
|
|
|
-- TODO: should use Client.withResponse here too
|
2019-09-05 08:47:14 +02:00
|
|
|
ClientEnv m burl cookieJar' createClientRequest <- ask
|
|
|
|
let clientRequest = createClientRequest burl req
|
2018-11-01 18:42:30 +01:00
|
|
|
request <- case cookieJar' of
|
|
|
|
Nothing -> pure clientRequest
|
|
|
|
Just cj -> liftIO $ do
|
|
|
|
now <- getCurrentTime
|
|
|
|
atomically $ do
|
|
|
|
oldCookieJar <- readTVar cj
|
|
|
|
let (newRequest, newCookieJar) =
|
|
|
|
Client.insertCookiesIntoRequest
|
2019-09-05 08:47:14 +02:00
|
|
|
clientRequest
|
2018-11-01 18:42:30 +01:00
|
|
|
oldCookieJar
|
|
|
|
now
|
|
|
|
writeTVar cj newCookieJar
|
|
|
|
pure newRequest
|
|
|
|
|
|
|
|
eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request m
|
|
|
|
case eResponse of
|
|
|
|
Left err -> throwError err
|
|
|
|
Right response -> do
|
|
|
|
for_ cookieJar' $ \cj -> liftIO $ do
|
|
|
|
now' <- getCurrentTime
|
|
|
|
atomically $ modifyTVar' cj (fst . Client.updateCookieJar response request now')
|
|
|
|
let status = Client.responseStatus response
|
|
|
|
status_code = statusCode status
|
2019-02-06 11:12:56 +01:00
|
|
|
ourResponse = clientResponseToResponse id response
|
2020-10-31 20:45:46 +01:00
|
|
|
goodStatus = case acceptStatus of
|
|
|
|
Nothing -> status_code >= 200 && status_code < 300
|
|
|
|
Just good -> status `elem` good
|
|
|
|
unless goodStatus $ do
|
2019-02-03 17:18:55 +01:00
|
|
|
throwError $ mkFailureResponse burl req ourResponse
|
2018-11-01 18:42:30 +01:00
|
|
|
return ourResponse
|
|
|
|
|
2020-10-31 20:45:46 +01:00
|
|
|
-- | TODO: support UVerb ('acceptStatus' argument, like in 'performRequest' above).
|
2018-11-01 18:42:30 +01:00
|
|
|
performWithStreamingRequest :: Request -> (StreamingResponse -> IO a) -> ClientM a
|
|
|
|
performWithStreamingRequest req k = do
|
|
|
|
m <- asks manager
|
|
|
|
burl <- asks baseUrl
|
2019-09-05 08:47:14 +02:00
|
|
|
createClientRequest <- asks makeClientRequest
|
|
|
|
let request = createClientRequest burl req
|
2018-11-01 18:42:30 +01:00
|
|
|
ClientM $ lift $ lift $ Codensity $ \k1 ->
|
|
|
|
Client.withResponse request m $ \res -> do
|
|
|
|
let status = Client.responseStatus res
|
|
|
|
status_code = statusCode status
|
|
|
|
|
|
|
|
-- we throw FailureResponse in IO :(
|
|
|
|
unless (status_code >= 200 && status_code < 300) $ do
|
|
|
|
b <- BSL.fromChunks <$> Client.brConsume (Client.responseBody res)
|
2019-02-06 11:12:56 +01:00
|
|
|
throwIO $ mkFailureResponse burl req (clientResponseToResponse (const b) res)
|
2018-11-01 18:42:30 +01:00
|
|
|
|
2019-02-06 11:12:56 +01:00
|
|
|
x <- k (clientResponseToResponse (S.fromAction BS.null) res)
|
2018-11-01 18:42:30 +01:00
|
|
|
k1 x
|