From 5880bdfd73483397fa56303bb39b6398a40299b0 Mon Sep 17 00:00:00 2001 From: Michal Rus Date: Sun, 31 Dec 2017 02:48:44 +0100 Subject: [PATCH] =?UTF-8?q?Support=20http-client=E2=80=99s=20CookieJar=20i?= =?UTF-8?q?n=20servant-client?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- doc/cookbook/basic-auth/BasicAuth.lhs | 2 +- .../db-postgres-pool/PostgresPool.lhs | 2 +- .../db-sqlite-simple/DBConnection.lhs | 2 +- .../jwt-and-basic-auth/JWTAndBasicAuth.lhs | 2 +- .../using-custom-monad/UsingCustomMonad.lhs | 4 +-- doc/tutorial/Client.lhs | 2 +- servant-client-ghcjs/README.md | 2 +- servant-client/servant-client.cabal | 2 ++ .../src/Servant/Client/Internal/HttpClient.hs | 26 +++++++++++++++++-- servant-client/test/Servant/ClientSpec.hs | 2 +- servant-client/test/Servant/StreamSpec.hs | 2 +- sources.txt | 1 + 12 files changed, 37 insertions(+), 12 deletions(-) diff --git a/doc/cookbook/basic-auth/BasicAuth.lhs b/doc/cookbook/basic-auth/BasicAuth.lhs index 68b7bfd5..2373a0ec 100644 --- a/doc/cookbook/basic-auth/BasicAuth.lhs +++ b/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" diff --git a/doc/cookbook/db-postgres-pool/PostgresPool.lhs b/doc/cookbook/db-postgres-pool/PostgresPool.lhs index f5ac7d1f..d8c6274e 100644 --- a/doc/cookbook/db-postgres-pool/PostgresPool.lhs +++ b/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 diff --git a/doc/cookbook/db-sqlite-simple/DBConnection.lhs b/doc/cookbook/db-sqlite-simple/DBConnection.lhs index 2ae108eb..5e65a4af 100644 --- a/doc/cookbook/db-sqlite-simple/DBConnection.lhs +++ b/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 diff --git a/doc/cookbook/jwt-and-basic-auth/JWTAndBasicAuth.lhs b/doc/cookbook/jwt-and-basic-auth/JWTAndBasicAuth.lhs index 92c0ec0b..a896d450 100644 --- a/doc/cookbook/jwt-and-basic-auth/JWTAndBasicAuth.lhs +++ b/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 diff --git a/doc/cookbook/using-custom-monad/UsingCustomMonad.lhs b/doc/cookbook/using-custom-monad/UsingCustomMonad.lhs index 6a250685..4991409e 100644 --- a/doc/cookbook/using-custom-monad/UsingCustomMonad.lhs +++ b/doc/cookbook/using-custom-monad/UsingCustomMonad.lhs @@ -11,7 +11,7 @@ We start with a pretty standard set of imports and definition of the model: {-# LANGUAGE TypeOperators #-} import Control.Concurrent (forkIO, killThread) -import Control.Concurrent.STM.TVar (TVar, newTVar, readTVar, +import Control.Concurrent.STM.TVar (TVar, newTVar, readTVar, writeTVar) import Control.Exception (bracket) import Control.Monad.IO.Class (liftIO) @@ -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 diff --git a/doc/tutorial/Client.lhs b/doc/tutorial/Client.lhs index 34891ed5..5f36c428 100644 --- a/doc/tutorial/Client.lhs +++ b/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 diff --git a/servant-client-ghcjs/README.md b/servant-client-ghcjs/README.md index bc27d9b0..1427508c 100644 --- a/servant-client-ghcjs/README.md +++ b/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 ``` diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal index 89ab1ab9..cef50672 100644 --- a/servant-client/servant-client.cabal +++ b/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 diff --git a/servant-client/src/Servant/Client/Internal/HttpClient.hs b/servant-client/src/Servant/Client/Internal/HttpClient.hs index b52d83ca..38cf8fe5 100644 --- a/servant-client/src/Servant/Client/Internal/HttpClient.hs +++ b/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 diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index 342593e2..0d6092ec 100644 --- a/servant-client/test/Servant/ClientSpec.hs +++ b/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 diff --git a/servant-client/test/Servant/StreamSpec.hs b/servant-client/test/Servant/StreamSpec.hs index df9003ab..0a8d668b 100644 --- a/servant-client/test/Servant/StreamSpec.hs +++ b/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 diff --git a/sources.txt b/sources.txt index dc546170..c2c35f05 100644 --- a/sources.txt +++ b/sources.txt @@ -1,5 +1,6 @@ servant servant-server servant-client +servant-client-core servant-docs servant-foreign