@@ -0,0 +1,172 @@
2+{-# LANGUAGE DeriveGeneric #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6+{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE RankNTypes #-}
8+{-# LANGUAGE ScopedTypeVariables #-}
9+{-# LANGUAGE TypeFamilies #-}
10+module Servant.Client.Internal.HttpClient.Streaming (
11+ module Servant.Client.Internal.HttpClient.Streaming,
14+ clientResponseToResponse,
15+ requestToClientRequest,
16+ catchConnectionError,
22+import Control.Concurrent.STM.TVar
23+import Control.Exception
25+import Control.Monad.Base
27+import Control.Monad.Codensity
29+import Control.Monad.Error.Class
31+import Control.Monad.Reader
32+import Control.Monad.STM
34+import Control.Monad.Trans.Except
35+import qualified Data.ByteString.Lazy as BSL
38+import Data.Functor.Alt
42+import Data.Time.Clock
45+import Network.HTTP.Types
48+import qualified Network.HTTP.Client as Client
50+import Servant.Client.Core
51+import Servant.Client.Internal.HttpClient
52+ (ClientEnv (..), catchConnectionError,
53+ clientResponseToResponse, mkClientEnv, requestToClientRequest)
56+-- | Generates a set of client functions for an API.
60+-- > type API = Capture "no" Int :> Get '[JSON] Int
61+-- > :<|> Get '[JSON] [Bool]
66+-- > getInt :: Int -> ClientM Int
67+-- > getBools :: ClientM [Bool]
68+-- > getInt :<|> getBools = client api
69+client :: HasClient ClientM api => Proxy api -> Client ClientM api
70+client api = api `clientIn` (Proxy :: Proxy ClientM)
72+-- | Change the monad the client functions live in, by
73+-- supplying a conversion function
74+-- (a natural transformation to be precise).
76+-- For example, assuming you have some @manager :: 'Manager'@ and
77+-- @baseurl :: 'BaseUrl'@ around:
79+-- > type API = Get '[JSON] Int :<|> Capture "n" Int :> Post '[JSON] Int
83+-- > postInt :: Int -> IO Int
84+-- > getInt :<|> postInt = hoistClient api (flip runClientM cenv) (client api)
85+-- > where cenv = mkClientEnv manager baseurl
87+ :: HasClient ClientM api
89+ -> (forall a. m a -> n a)
92+hoistClient = hoistClientMonad (Proxy :: Proxy ClientM)
94+-- | @ClientM@ is the monad in which client functions run. Contains the
95+-- 'Client.Manager' and 'BaseUrl' used for requests in the reader environment.
96+newtype ClientM a = ClientM
97+ { unClientM :: ReaderT ClientEnv (ExceptT ServantError (Codensity IO)) a }
98+ deriving ( Functor, Applicative, Monad, MonadIO, Generic
99+ , MonadReader ClientEnv, MonadError ServantError)
101+instance MonadBase IO ClientM where
102+ liftBase = ClientM . liftIO
104+-- | Try clients in order, last error is preserved.
105+instance Alt ClientM where
106+ a <!> b = a `catchError` \_ -> b
108+instance RunClient ClientM where
109+ runRequest = performRequest
110+ throwServantError = throwError
112+instance RunStreamingClient ClientM where
113+ withStreamingRequest = performWithStreamingRequest
115+instance ClientLike (ClientM a) (ClientM a) where
118+withClientM :: ClientM a -> ClientEnv -> (Either ServantError a -> IO b) -> IO b
119+withClientM cm env k =
120+ let Codensity f = runExceptT $ flip runReaderT env $ unClientM cm
123+performRequest :: Request -> ClientM Response
124+performRequest req = do
125+ -- TODO: should use Client.withResponse here too
126+ ClientEnv m burl cookieJar' <- ask
127+ let clientRequest = requestToClientRequest burl req
128+ request <- case cookieJar' of
129+ Nothing -> pure clientRequest
130+ Just cj -> liftIO $ do
131+ now <- getCurrentTime
133+ oldCookieJar <- readTVar cj
134+ let (newRequest, newCookieJar) =
135+ Client.insertCookiesIntoRequest
136+ (requestToClientRequest burl req)
139+ writeTVar cj newCookieJar
142+ eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request m
144+ Left err -> throwError err
145+ Right response -> do
146+ for_ cookieJar' $ \cj -> liftIO $ do
147+ now' <- getCurrentTime
148+ atomically $ modifyTVar' cj (fst . Client.updateCookieJar response request now')
149+ let status = Client.responseStatus response
150+ status_code = statusCode status
151+ ourResponse = clientResponseToResponse response
152+ unless (status_code >= 200 && status_code < 300) $
153+ throwError $ FailureResponse ourResponse
156+performWithStreamingRequest :: Request -> (StreamingResponse -> IO a) -> ClientM a
157+performWithStreamingRequest req k = do
159+ burl <- asks baseUrl
160+ let request = requestToClientRequest burl req
161+ ClientM $ lift $ lift $ Codensity $ \k1 ->
162+ Client.withResponse request m $ \res -> do
163+ let status = Client.responseStatus res
164+ status_code = statusCode status
166+ -- we throw FailureResponse in IO :(
167+ unless (status_code >= 200 && status_code < 300) $ do
168+ b <- BSL.fromChunks <$> Client.brConsume (Client.responseBody res)
169+ throwIO $ FailureResponse $ clientResponseToResponse res { Client.responseBody = b }
171+ x <- k (clientResponseToResponse res)