eeva
/
servant
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Support http-client’s CookieJar in servant-client

This commit is contained in:
Michal Rus 2017-12-31 02:48:44 +01:00 committed by Oleg Grenrus
parent 030cbbc363
commit e4bd07a907
13 changed files with 46 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
doc/cookbook/basic-auth/BasicAuth.lhs
View File

@ -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"

2
doc/cookbook/db-postgres-pool/PostgresPool.lhs
View File

@ -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

2
doc/cookbook/db-sqlite-simple/DBConnection.lhs
View File

@ -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

2
doc/cookbook/jwt-and-basic-auth/JWTAndBasicAuth.lhs
View File

@ -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

6
doc/cookbook/using-custom-monad/UsingCustomMonad.lhs
View File

@ -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"]
```
```

2
doc/tutorial/Client.lhs
View File

@ -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

2
servant-client-ghcjs/README.md
View File

@ -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
```

2
servant-client/servant-client.cabal
View File

@ -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

1
servant-client/src/Servant/Client.hs
View File

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

40
servant-client/src/Servant/Client/Internal/HttpClient.hs
View File

@ -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

2
servant-client/test/Servant/ClientSpec.hs
View File

@ -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

2
servant-client/test/Servant/StreamSpec.hs
View File

@ -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

1
sources.txt
View File

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