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

Support http-client’s CookieJar in servant-client

Browse source
This commit is contained in:
Michal Rus 2017-12-31 02:48:44 +01:00
parent 0147f4b5c7
commit 5880bdfd73
No known key found for this signature in database
GPG key ID: 396762D2C75A20A7
12 changed files with 37 additions and 12 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) (ClientEnv mgr (BaseUrl Http "localhost" 8080 "") Nothing)
>>= 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 (ClientEnv mgr (BaseUrl Http "localhost" 8080 "") Nothing) $ 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 (ClientEnv mgr (BaseUrl Http "localhost" 8080 "") Nothing) $ 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 ""))
(ClientEnv mgr (BaseUrl Http "localhost" port "") Nothing)
hPutStrLn stderr $ case res of
Left err -> "Error: " ++ show err
Right r -> "Success: " ++ show r

2
doc/cookbook/using-custom-monad/UsingCustomMonad.lhs
View file

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

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

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

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

26
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, 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

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 (ClientEnv manager' baseUrl' Nothing)
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 (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

1
sources.txt
View file

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