@@ -0,0 +1,172 @@
1+{-# LANGUAGE CPP #-}
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,
12+ ClientEnv (..),
13+ mkClientEnv,
14+ clientResponseToResponse,
15+ requestToClientRequest,
16+ catchConnectionError,
17+ ) where
18+
19+import Prelude ()
20+import Prelude.Compat
21+
22+import Control.Concurrent.STM.TVar
23+import Control.Exception
24+import Control.Monad
25+import Control.Monad.Base
26+ (MonadBase (..))
27+import Control.Monad.Codensity
28+ (Codensity (..))
29+import Control.Monad.Error.Class
30+ (MonadError (..))
31+import Control.Monad.Reader
32+import Control.Monad.STM
33+ (atomically)
34+import Control.Monad.Trans.Except
35+import qualified Data.ByteString.Lazy as BSL
36+import Data.Foldable
37+ (for_)
38+import Data.Functor.Alt
39+ (Alt (..))
40+import Data.Proxy
41+ (Proxy (..))
42+import Data.Time.Clock
43+ (getCurrentTime)
44+import GHC.Generics
45+import Network.HTTP.Types
46+ (statusCode)
47+
48+import qualified Network.HTTP.Client as Client
49+
50+import Servant.Client.Core
51+import Servant.Client.Internal.HttpClient
52+ (ClientEnv (..), catchConnectionError,
53+ clientResponseToResponse, mkClientEnv, requestToClientRequest)
54+
55+
56+-- | Generates a set of client functions for an API.
57+--
58+-- Example:
59+--
60+-- > type API = Capture "no" Int :> Get '[JSON] Int
61+-- > :<|> Get '[JSON] [Bool]
62+-- >
63+-- > api :: Proxy API
64+-- > api = Proxy
65+-- >
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)
71+
72+-- | Change the monad the client functions live in, by
73+-- supplying a conversion function
74+-- (a natural transformation to be precise).
75+--
76+-- For example, assuming you have some @manager :: 'Manager'@ and
77+-- @baseurl :: 'BaseUrl'@ around:
78+--
79+-- > type API = Get '[JSON] Int :<|> Capture "n" Int :> Post '[JSON] Int
80+-- > api :: Proxy API
81+-- > api = Proxy
82+-- > getInt :: IO Int
83+-- > postInt :: Int -> IO Int
84+-- > getInt :<|> postInt = hoistClient api (flip runClientM cenv) (client api)
85+-- > where cenv = mkClientEnv manager baseurl
86+hoistClient
87+ :: HasClient ClientM api
88+ => Proxy api
89+ -> (forall a. m a -> n a)
90+ -> Client m api
91+ -> Client n api
92+hoistClient = hoistClientMonad (Proxy :: Proxy ClientM)
93+
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)
100+
101+instance MonadBase IO ClientM where
102+ liftBase = ClientM . liftIO
103+
104+-- | Try clients in order, last error is preserved.
105+instance Alt ClientM where
106+ a <!> b = a `catchError` \_ -> b
107+
108+instance RunClient ClientM where
109+ runRequest = performRequest
110+ throwServantError = throwError
111+
112+instance RunStreamingClient ClientM where
113+ withStreamingRequest = performWithStreamingRequest
114+
115+instance ClientLike (ClientM a) (ClientM a) where
116+ mkClient = id
117+
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
121+ in f k
122+
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
132+ atomically $ do
133+ oldCookieJar <- readTVar cj
134+ let (newRequest, newCookieJar) =
135+ Client.insertCookiesIntoRequest
136+ (requestToClientRequest burl req)
137+ oldCookieJar
138+ now
139+ writeTVar cj newCookieJar
140+ pure newRequest
141+
142+ eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request m
143+ case eResponse of
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
154+ return ourResponse
155+
156+performWithStreamingRequest :: Request -> (StreamingResponse -> IO a) -> ClientM a
157+performWithStreamingRequest req k = do
158+ m <- asks manager
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
165+
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 }
170+
171+ x <- k (clientResponseToResponse res)
172+ k1 x