@@ -16,17 +16,19 @@ module Servant.Client.Internal.HttpClient where
1616import Prelude ()
1717import Prelude.Compat
1818
19+import Control.Concurrent.STM.TVar
1920import Control.Exception
2021import Control.Monad
2122import Control.Monad.Base (MonadBase (..))
2223import Control.Monad.Catch (MonadCatch, MonadThrow)
2324import Control.Monad.Error.Class (MonadError (..))
2425import Control.Monad.Reader
26+import Control.Monad.STM (atomically)
2527import Control.Monad.Trans.Control (MonadBaseControl (..))
2628import Control.Monad.Trans.Except
2729import Data.ByteString.Builder (toLazyByteString)
2830import qualified Data.ByteString.Lazy as BSL
29−import Data.Foldable (toList)
31+import Data.Foldable (toList, for_)
3032import Data.Functor.Alt (Alt (..))
3133import Data.Maybe (maybeToList)
3234import Data.Monoid ((<>))
@@ -34,6 +36,7 @@ import Data.Proxy (Proxy (..))
3436import Data.Sequence (fromList)
3537import Data.String (fromString)
3638import qualified Data.Text as T
39+import Data.Time.Clock (getCurrentTime)
3740import GHC.Generics
3841import Network.HTTP.Media (renderHeader)
3942import Network.HTTP.Types (hContentType, renderQuery,
@@ -47,8 +50,13 @@ data ClientEnv
4750 = ClientEnv
4851 { manager :: Client.Manager
4952 , baseUrl :: BaseUrl
53+ , cookieJar :: Maybe (TVar Client.CookieJar)
5054 }
5155
56+-- | 'ClientEnv' smart constructor.
57+mkClientEnv :: Client.Manager -> BaseUrl -> ClientEnv
58+mkClientEnv mgr burl = ClientEnv mgr burl Nothing
59+
5260-- | Generates a set of client functions for an API.
5361--
5462-- Example:
@@ -68,7 +76,7 @@ client api = api `clientIn` (Proxy :: Proxy ClientM)
6876-- | @ClientM@ is the monad in which client functions run. Contains the
6977-- 'Client.Manager' and 'BaseUrl' used for requests in the reader environment.
7078newtype ClientM a = ClientM
71− { runClientM' :: ReaderT ClientEnv (ExceptT ServantError IO) a }
79+ { unClientM :: ReaderT ClientEnv (ExceptT ServantError IO) a }
7280 deriving ( Functor, Applicative, Monad, MonadIO, Generic
7381 , MonadReader ClientEnv, MonadError ServantError, MonadThrow
7482 , MonadCatch)
@@ -79,7 +87,7 @@ instance MonadBase IO ClientM where
7987instance MonadBaseControl IO ClientM where
8088 type StM ClientM a = Either ServantError a
8189
82− liftBaseWith f = ClientM (liftBaseWith (\g -> f (g . runClientM')))
90+ liftBaseWith f = ClientM (liftBaseWith (\g -> f (g . unClientM)))
8391
8492 restoreM st = ClientM (restoreM st)
8593
@@ -97,19 +105,33 @@ instance ClientLike (ClientM a) (ClientM a) where
97105 mkClient = id
98106
99107runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a)
100−runClientM cm env = runExceptT $ (flip runReaderT env) $ runClientM' cm
101−
108+runClientM cm env = runExceptT $ flip runReaderT env $ unClientM cm
102109
103110performRequest :: Request -> ClientM Response
104111performRequest req = do
105− m <- asks manager
106− burl <- asks baseUrl
107− let request = requestToClientRequest burl req
112+ ClientEnv m burl cookieJar' <- ask
113+ let clientRequest = requestToClientRequest burl req
114+ request <- case cookieJar' of
115+ Nothing -> pure clientRequest
116+ Just cj -> liftIO $ do
117+ now <- getCurrentTime
118+ atomically $ do
119+ oldCookieJar <- readTVar cj
120+ let (newRequest, newCookieJar) =
121+ Client.insertCookiesIntoRequest
122+ (requestToClientRequest burl req)
123+ oldCookieJar
124+ now
125+ writeTVar cj newCookieJar
126+ pure newRequest
108127
109128 eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request m
110129 case eResponse of
111− Left err -> throwError $ err
130+ Left err -> throwError err
112131 Right response -> do
132+ for_ cookieJar' $ \cj -> liftIO $ do
133+ now' <- getCurrentTime
134+ atomically $ modifyTVar' cj (fst . Client.updateCookieJar response request now')
113135 let status = Client.responseStatus response
114136 status_code = statusCode status
115137 ourResponse = clientResponseToResponse response