diff --git a/doc/cookbook/basic-auth/BasicAuth.lhs b/doc/cookbook/basic-auth/BasicAuth.lhs index 68b7bfd5..2b90df93 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) (mkClientEnv mgr (BaseUrl Http "localhost" 8080 "")) >>= 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..75ba2cee 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 (mkClientEnv mgr (BaseUrl Http "localhost" 8080 "")) $ 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..0b35968c 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 (mkClientEnv mgr (BaseUrl Http "localhost" 8080 "")) $ 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..5277b308 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 "")) + (mkClientEnv mgr (BaseUrl Http "localhost" port "")) 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..006a647b 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 (mkClientEnv mgr (BaseUrl Http "localhost" port "")) $ do _ <- printBooks _ <- addBookClient $ Book "Harry Potter and the Order of the Phoenix" _ <- printBooks @@ -114,4 +114,4 @@ Running cookbook-using-custom-monad... [Book "Harry Potter and the Order of the Phoenix"] [Book "To Kill a Mockingbird",Book "Harry Potter and the Order of the Phoenix"] [Book "The Picture of Dorian Gray",Book "To Kill a Mockingbird",Book "Harry Potter and the Order of the Phoenix"] -``` \ No newline at end of file +``` diff --git a/doc/tutorial/Client.lhs b/doc/tutorial/Client.lhs index 34891ed5..e221245a 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 (mkClientEnv manager' (BaseUrl Http "localhost" 8081 "")) 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..d34385e2 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) $ mkClientEnv mgr clientBaseUrl print ePos ``` diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal index fd24820e..368ddd7b 100644 --- a/servant-client/servant-client.cabal +++ b/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 diff --git a/servant-client/src/Servant/Client.hs b/servant-client/src/Servant/Client.hs index ac35a669..3de40365 100644 --- a/servant-client/src/Servant/Client.hs +++ b/servant-client/src/Servant/Client.hs @@ -6,6 +6,7 @@ module Servant.Client , ClientM , runClientM , ClientEnv(..) + , mkClientEnv , module Servant.Client.Core.Reexport ) where diff --git a/servant-client/src/Servant/Client/Internal/HttpClient.hs b/servant-client/src/Servant/Client/Internal/HttpClient.hs index b52d83ca..e0085070 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, 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 - burl <- asks baseUrl - let request = requestToClientRequest burl req + ClientEnv m burl cookieJar' <- ask + let clientRequest = 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 diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index 342593e2..c9a96cab 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 (mkClientEnv manager' baseUrl') 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..2df336da 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 (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 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