Support http-client’s CookieJar in servant-client

doc/cookbook/basic-auth/BasicAuth.lhs

@@ -164,7 +164,7 @@ main :: IO ()
 main = do
   mgr <- newManager defaultManagerSettings
   bracket (forkIO $ runApp userDB) killThread $ \_ ->
-    runClientM (getSite u) (ClientEnv mgr (BaseUrl Http "localhost" 8080 ""))
+    runClientM (getSite u) (mkClientEnv mgr (BaseUrl Http "localhost" 8080 ""))
       >>= print
 
   where u = BasicAuthData "foo" "bar"

doc/cookbook/db-postgres-pool/PostgresPool.lhs

@@ -125,7 +125,7 @@ main = do
   initDB connStr
   mgr <- newManager defaultManagerSettings
   bracket (forkIO $ runApp pool) killThread $ \_ -> do
-    ms <- flip runClientM (ClientEnv mgr (BaseUrl Http "localhost" 8080 "")) $ do
+    ms <- flip runClientM (mkClientEnv mgr (BaseUrl Http "localhost" 8080 "")) $ do
       postMsg "hello"
       postMsg "world"
       getMsgs

doc/cookbook/db-sqlite-simple/DBConnection.lhs

@@ -86,7 +86,7 @@ main = do
   initDB dbfile
   mgr <- newManager defaultManagerSettings
   bracket (forkIO $ runApp dbfile) killThread $ \_ -> do
-    ms <- flip runClientM (ClientEnv mgr (BaseUrl Http "localhost" 8080 "")) $ do
+    ms <- flip runClientM (mkClientEnv mgr (BaseUrl Http "localhost" 8080 "")) $ do
       postMsg "hello"
       postMsg "world"
       getMsgs

doc/cookbook/jwt-and-basic-auth/JWTAndBasicAuth.lhs

@@ -151,7 +151,7 @@ testClient = do
   let (foo :<|> _) = client (Proxy :: Proxy TestAPIClient)
                      (BasicAuthData "name" "pass")
   res <- runClientM (foo 42)
-    (ClientEnv mgr (BaseUrl Http "localhost" port ""))
+    (mkClientEnv mgr (BaseUrl Http "localhost" port ""))
   hPutStrLn stderr $ case res of
     Left err -> "Error: " ++ show err
     Right r -> "Success: " ++ show r

doc/cookbook/using-custom-monad/UsingCustomMonad.lhs

@@ -95,7 +95,7 @@ main = do
   bracket (forkIO runApp) killThread $ \_ -> do
     let getBooksClient :<|> addBookClient = client api
     let printBooks = getBooksClient >>= liftIO . print
-    _ <- flip runClientM (ClientEnv mgr (BaseUrl Http "localhost" port "")) $ do
+    _ <- flip runClientM (mkClientEnv mgr (BaseUrl Http "localhost" port "")) $ do
       _ <- printBooks
       _ <- addBookClient $ Book "Harry Potter and the Order of the Phoenix"
       _ <- printBooks

doc/tutorial/Client.lhs

@@ -136,7 +136,7 @@ queries = do
 run :: IO ()
 run = do
   manager' <- newManager defaultManagerSettings
-  res <- runClientM queries (ClientEnv manager' (BaseUrl Http "localhost" 8081 ""))
+  res <- runClientM queries (mkClientEnv manager' (BaseUrl Http "localhost" 8081 ""))
   case res of
     Left err -> putStrLn $ "Error: " ++ show err
     Right (pos, message, em) -> do

servant-client-ghcjs/README.md

@@ -170,6 +170,6 @@ main :: IO ()
 main = do
     mgr <- newManager defaultManagerSettings
     let clientBaseUrl = BaseUrl Http "www.example.com" 80 ""
-    ePos <- runClientM (position apiClient 10 20) $ ClientEnv mgr clientBaseUrl
+    ePos <- runClientM (position apiClient 10 20) $ mkClientEnv mgr clientBaseUrl
     print ePos
 ```

servant-client/servant-client.cabal

@@ -46,6 +46,7 @@ library
     , containers            >= 0.5.5.1  && < 0.6
     , mtl                   >= 2.1      && < 2.3
     , text                  >= 1.2.3.0  && < 1.3
+    , time                  >= 1.4.2    && < 1.9
     , transformers          >= 0.3.0.0  && < 0.6
 
   -- Servant dependencies
@@ -65,6 +66,7 @@ library
     , exceptions            >= 0.8.3    && < 0.9
     , monad-control         >= 1.0.0.4  && < 1.1
     , semigroupoids         >= 5.2.1    && < 5.3
+    , stm                   >= 2.4.4.1  && < 2.5
     , transformers-base     >= 0.4.4    && < 0.5
     , transformers-compat   >= 0.5.1    && < 0.6
 

servant-client/src/Servant/Client.hs

@@ -6,6 +6,7 @@ module Servant.Client
   , ClientM
   , runClientM
   , ClientEnv(..)
+  , mkClientEnv
   , module Servant.Client.Core.Reexport
   ) where
 

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

@@ -16,17 +16,19 @@ module Servant.Client.Internal.HttpClient where
 import           Prelude                     ()
 import           Prelude.Compat
 
+import           Control.Concurrent.STM.TVar
 import           Control.Exception
 import           Control.Monad
 import           Control.Monad.Base          (MonadBase (..))
 import           Control.Monad.Catch         (MonadCatch, MonadThrow)
 import           Control.Monad.Error.Class   (MonadError (..))
 import           Control.Monad.Reader
+import           Control.Monad.STM           (atomically)
 import           Control.Monad.Trans.Control (MonadBaseControl (..))
 import           Control.Monad.Trans.Except
 import           Data.ByteString.Builder     (toLazyByteString)
 import qualified Data.ByteString.Lazy        as BSL
-import           Data.Foldable               (toList)
+import           Data.Foldable               (toList, for_)
 import           Data.Functor.Alt            (Alt (..))
 import           Data.Maybe                  (maybeToList)
 import           Data.Monoid                 ((<>))
@@ -34,6 +36,7 @@ import           Data.Proxy                  (Proxy (..))
 import           Data.Sequence               (fromList)
 import           Data.String                 (fromString)
 import qualified Data.Text                   as T
+import           Data.Time.Clock             (getCurrentTime)
 import           GHC.Generics
 import           Network.HTTP.Media          (renderHeader)
 import           Network.HTTP.Types          (hContentType, renderQuery,
@@ -47,8 +50,13 @@ data ClientEnv
   = ClientEnv
   { manager :: Client.Manager
   , baseUrl :: BaseUrl
+  , cookieJar :: Maybe (TVar Client.CookieJar)
   }
 
+-- | 'ClientEnv' smart constructor.
+mkClientEnv :: Client.Manager -> BaseUrl -> ClientEnv
+mkClientEnv mgr burl = ClientEnv mgr burl Nothing
+
 -- | Generates a set of client functions for an API.
 --
 -- Example:
@@ -68,7 +76,7 @@ client api = api `clientIn` (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
-  { runClientM' :: ReaderT ClientEnv (ExceptT ServantError IO) a }
+  { unClientM :: ReaderT ClientEnv (ExceptT ServantError IO) a }
   deriving ( Functor, Applicative, Monad, MonadIO, Generic
            , MonadReader ClientEnv, MonadError ServantError, MonadThrow
            , MonadCatch)
@@ -79,7 +87,7 @@ instance MonadBase IO ClientM where
 instance MonadBaseControl IO ClientM where
   type StM ClientM a = Either ServantError a
 
-  liftBaseWith f = ClientM (liftBaseWith (\g -> f (g . runClientM')))
+  liftBaseWith f = ClientM (liftBaseWith (\g -> f (g . unClientM)))
 
   restoreM st = ClientM (restoreM st)
 
@@ -97,19 +105,33 @@ instance ClientLike (ClientM a) (ClientM a) where
   mkClient = id
 
 runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a)
-runClientM cm env = runExceptT $ (flip runReaderT env) $ runClientM' cm
+runClientM cm env = runExceptT $ flip runReaderT env $ unClientM cm
-
 
 performRequest :: Request -> ClientM Response
 performRequest req = do
-  m <- asks manager
+  ClientEnv m burl cookieJar' <- ask
-  burl <- asks baseUrl
+  let clientRequest = requestToClientRequest burl req
-  let request = requestToClientRequest 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
+                (requestToClientRequest burl req)
+                oldCookieJar
+                now
+        writeTVar cj newCookieJar
+        pure newRequest
 
   eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request m
   case eResponse of
-    Left err -> throwError $ err
+    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
           ourResponse = clientResponseToResponse response

servant-client/test/Servant/ClientSpec.hs

@@ -302,7 +302,7 @@ manager' :: C.Manager
 manager' = unsafePerformIO $ C.newManager C.defaultManagerSettings
 
 runClient :: ClientM a -> BaseUrl -> IO (Either ServantError a)
-runClient x baseUrl' = runClientM x (ClientEnv manager' baseUrl')
+runClient x baseUrl' = runClientM x (mkClientEnv manager' baseUrl')
 
 sucessSpec :: Spec
 sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do

servant-client/test/Servant/StreamSpec.hs

@@ -92,7 +92,7 @@ manager' :: C.Manager
 manager' = unsafePerformIO $ C.newManager C.defaultManagerSettings
 
 runClient :: ClientM a -> BaseUrl -> IO (Either ServantError a)
-runClient x baseUrl' = runClientM x (ClientEnv manager' baseUrl')
+runClient x baseUrl' = runClientM x (mkClientEnv manager' baseUrl')
 
 runResultStream :: ResultStream a -> IO (Maybe (Either String a), Maybe (Either String a), Maybe (Either String a), Maybe (Either String a))
 runResultStream (ResultStream k) = k $ \act -> (,,,) <$> act <*> act <*> act <*> act

sources.txt

@@ -1,5 +1,6 @@
 servant
 servant-server
 servant-client
+servant-client-core
 servant-docs
 servant-foreign