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) (ClientEnv mgr (BaseUrl Http "localhost" 8080 "") Nothing)
       >>= 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 (ClientEnv mgr (BaseUrl Http "localhost" 8080 "") Nothing) $ 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 (ClientEnv mgr (BaseUrl Http "localhost" 8080 "") Nothing) $ 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 ""))
+    (ClientEnv mgr (BaseUrl Http "localhost" port "") Nothing)
   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 (ClientEnv mgr (BaseUrl Http "localhost" port "") Nothing) $ 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 (ClientEnv manager' (BaseUrl Http "localhost" 8081 "") Nothing)
   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) $ ClientEnv mgr clientBaseUrl Nothing
     print ePos
 ```

servant-client/servant-client.cabal

@@ -51,7 +51,9 @@ library
     , mtl                   >= 2.1      && < 2.3
     , semigroupoids         >= 4.3      && < 5.3
     , servant-client-core   == 0.12.*
+    , stm                   >= 2.1      && < 2.5
     , text                  >= 1.2      && < 1.3
+    , time                  >= 1.7      && < 1.9
     , transformers          >= 0.3      && < 0.6
     , transformers-base     >= 0.4.4    && < 0.5
     , transformers-compat   >= 0.4      && < 0.6

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, traverse_)
 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,6 +50,7 @@ data ClientEnv
   = ClientEnv
   { manager :: Client.Manager
   , baseUrl :: BaseUrl
+  , cookieJar :: Maybe (TVar Client.CookieJar)
   }
 
 -- | Generates a set of client functions for an API.
@@ -104,12 +108,30 @@ performRequest :: Request -> ClientM Response
 performRequest req = do
   m <- asks manager
   burl <- asks baseUrl
-  let request = requestToClientRequest burl req
+  cookieJar' <- asks cookieJar
+  now <- liftIO getCurrentTime
+  request <- let clientRequest = requestToClientRequest burl req in
+    case cookieJar' of
+      Nothing -> pure clientRequest
+      Just cj -> liftIO . 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
     Right response -> do
+      now' <- liftIO getCurrentTime
+      traverse_
+        (liftIO . atomically . flip modifyTVar'
+          (fst . Client.updateCookieJar response request now'))
+        cookieJar'
       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 (ClientEnv manager' baseUrl' Nothing)
 
 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 (ClientEnv manager' baseUrl' Nothing)
 
 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