Skip to content

Commit f1baef6

Browse files
phadejphadej
authored
Merge pull request #897 from phadej/pull-883-cookie
Support http-client’s CookieJar in servant-client
2 parents 8cab121 + e4bd07a commit f1baef6

File tree

13 files changed

+46
-20
lines changed

13 files changed

+46
-20
lines changed

‎doc/cookbook/basic-auth/BasicAuth.lhs

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -164,7 +164,7 @@ main :: IO ()
164164
main = do
165165
mgr <- newManager defaultManagerSettings
166166
bracket (forkIO $ runApp userDB) killThread $ \_ ->
167-
runClientM (getSite u) (ClientEnv mgr (BaseUrl Http "localhost" 8080 ""))
167+
runClientM (getSite u) (mkClientEnv mgr (BaseUrl Http "localhost" 8080 ""))
168168
>>= print
169169
170170
where u = BasicAuthData "foo" "bar"

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

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -125,7 +125,7 @@ main = do
125125
initDB connStr
126126
mgr <- newManager defaultManagerSettings
127127
bracket (forkIO $ runApp pool) killThread $ \_ -> do
128-
ms <- flip runClientM (ClientEnv mgr (BaseUrl Http "localhost" 8080 "")) $ do
128+
ms <- flip runClientM (mkClientEnv mgr (BaseUrl Http "localhost" 8080 "")) $ do
129129
postMsg "hello"
130130
postMsg "world"
131131
getMsgs

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

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -86,7 +86,7 @@ main = do
8686
initDB dbfile
8787
mgr <- newManager defaultManagerSettings
8888
bracket (forkIO $ runApp dbfile) killThread $ \_ -> do
89-
ms <- flip runClientM (ClientEnv mgr (BaseUrl Http "localhost" 8080 "")) $ do
89+
ms <- flip runClientM (mkClientEnv mgr (BaseUrl Http "localhost" 8080 "")) $ do
9090
postMsg "hello"
9191
postMsg "world"
9292
getMsgs

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

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -151,7 +151,7 @@ testClient = do
151151
let (foo :<|> _) = client (Proxy :: Proxy TestAPIClient)
152152
(BasicAuthData "name" "pass")
153153
res <- runClientM (foo 42)
154-
(ClientEnv mgr (BaseUrl Http "localhost" port ""))
154+
(mkClientEnv mgr (BaseUrl Http "localhost" port ""))
155155
hPutStrLn stderr $ case res of
156156
Left err -> "Error: " ++ show err
157157
Right r -> "Success: " ++ show r

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

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -11,7 +11,7 @@ We start with a pretty standard set of imports and definition of the model:
1111
{-# LANGUAGE TypeOperators #-}
1212
1313
import Control.Concurrent (forkIO, killThread)
14-
import Control.Concurrent.STM.TVar (TVar, newTVar, readTVar,
14+
import Control.Concurrent.STM.TVar (TVar, newTVar, readTVar,
1515
writeTVar)
1616
import Control.Exception (bracket)
1717
import Control.Monad.IO.Class (liftIO)
@@ -95,7 +95,7 @@ main = do
9595
bracket (forkIO runApp) killThread $ \_ -> do
9696
let getBooksClient :<|> addBookClient = client api
9797
let printBooks = getBooksClient >>= liftIO . print
98-
_ <- flip runClientM (ClientEnv mgr (BaseUrl Http "localhost" port "")) $ do
98+
_ <- flip runClientM (mkClientEnv mgr (BaseUrl Http "localhost" port "")) $ do
9999
_ <- printBooks
100100
_ <- addBookClient $ Book "Harry Potter and the Order of the Phoenix"
101101
_ <- printBooks
@@ -114,4 +114,4 @@ Running cookbook-using-custom-monad...
114114
[Book "Harry Potter and the Order of the Phoenix"]
115115
[Book "To Kill a Mockingbird",Book "Harry Potter and the Order of the Phoenix"]
116116
[Book "The Picture of Dorian Gray",Book "To Kill a Mockingbird",Book "Harry Potter and the Order of the Phoenix"]
117-
```
117+
```

‎doc/tutorial/Client.lhs

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -136,7 +136,7 @@ queries = do
136136
run :: IO ()
137137
run = do
138138
manager' <- newManager defaultManagerSettings
139-
res <- runClientM queries (ClientEnv manager' (BaseUrl Http "localhost" 8081 ""))
139+
res <- runClientM queries (mkClientEnv manager' (BaseUrl Http "localhost" 8081 ""))
140140
case res of
141141
Left err -> putStrLn $ "Error: " ++ show err
142142
Right (pos, message, em) -> do

‎servant-client-ghcjs/README.md

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -170,6 +170,6 @@ main :: IO ()
170170
main = do
171171
mgr <- newManager defaultManagerSettings
172172
let clientBaseUrl = BaseUrl Http "www.example.com" 80 ""
173-
ePos <- runClientM (position apiClient 10 20) $ ClientEnv mgr clientBaseUrl
173+
ePos <- runClientM (position apiClient 10 20) $ mkClientEnv mgr clientBaseUrl
174174
print ePos
175175
```

‎servant-client/servant-client.cabal

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -46,6 +46,7 @@ library
4646
, containers >= 0.5.5.1 && < 0.6
4747
, mtl >= 2.1 && < 2.3
4848
, text >= 1.2.3.0 && < 1.3
49+
, time >= 1.4.2 && < 1.9
4950
, transformers >= 0.3.0.0 && < 0.6
5051

5152
-- Servant dependencies
@@ -65,6 +66,7 @@ library
6566
, exceptions >= 0.8.3 && < 0.9
6667
, monad-control >= 1.0.0.4 && < 1.1
6768
, semigroupoids >= 5.2.1 && < 5.3
69+
, stm >= 2.4.4.1 && < 2.5
6870
, transformers-base >= 0.4.4 && < 0.5
6971
, transformers-compat >= 0.5.1 && < 0.6
7072

‎servant-client/src/Servant/Client.hs

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -6,6 +6,7 @@ module Servant.Client
66
, ClientM
77
, runClientM
88
, ClientEnv(..)
9+
, mkClientEnv
910
, module Servant.Client.Core.Reexport
1011
) where
1112

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

Lines changed: 31 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -16,24 +16,27 @@ module Servant.Client.Internal.HttpClient where
1616
import Prelude ()
1717
import Prelude.Compat
1818

19+
import Control.Concurrent.STM.TVar
1920
import Control.Exception
2021
import Control.Monad
2122
import Control.Monad.Base (MonadBase (..))
2223
import Control.Monad.Catch (MonadCatch, MonadThrow)
2324
import Control.Monad.Error.Class (MonadError (..))
2425
import Control.Monad.Reader
26+
import Control.Monad.STM (atomically)
2527
import Control.Monad.Trans.Control (MonadBaseControl (..))
2628
import Control.Monad.Trans.Except
2729
import Data.ByteString.Builder (toLazyByteString)
2830
import qualified Data.ByteString.Lazy as BSL
29-
import Data.Foldable (toList)
31+
import Data.Foldable (toList, for_)
3032
import Data.Functor.Alt (Alt (..))
3133
import Data.Maybe (maybeToList)
3234
import Data.Monoid ((<>))
3335
import Data.Proxy (Proxy (..))
3436
import Data.Sequence (fromList)
3537
import Data.String (fromString)
3638
import qualified Data.Text as T
39+
import Data.Time.Clock (getCurrentTime)
3740
import GHC.Generics
3841
import Network.HTTP.Media (renderHeader)
3942
import 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.
7078
newtype 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
7987
instance 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

99107
runClientM :: 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

103110
performRequest :: Request -> ClientM Response
104111
performRequest 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

0 commit comments

Comments
 (0)