git.iko.soy/typeable/servant
on master help sign in
Merge pull request #1104 from michaelsdunn1/master

Update CookieJar with intermediate request/responses using Network.HTTP.Client.HistoriedResponse.

commit28ac8c072b073891400b6263a9e329c37364f96f authorOleg Grenrus <oleg.grenrus@iki.fi> dateSat 2 Feb 2019, 10:21 (8 years ago) parent15610f28490ccb
3 files changed+66−25
compare with master
unifiedsplit
servant-client/servant-client.cabal+1 servant-client/src/Servant/Client/Internal/HttpClient.hs+40−17 servant-client/test/Servant/ClientSpec.hs+25−8
servant-client/servant-client.cabal+1
@@ -102,6 +102,7 @@ test-suite spec
102102 , kan-extensions
103103 , servant-client
104104 , servant-client-core
105+ , stm
105106 , text
106107 , transformers
107108 , transformers-compat
servant-client/src/Servant/Client/Internal/HttpClient.hs+40−17
@@ -23,21 +23,25 @@ import Control.Monad.Catch
2323 (MonadCatch, MonadThrow)
2424import Control.Monad.Error.Class
2525 (MonadError (..))
26+import Control.Monad.IO.Class
27+ (liftIO)
2628import Control.Monad.Reader
2729import Control.Monad.STM
28− (atomically)
30+ (STM, atomically)
2931import Control.Monad.Trans.Control
3032 (MonadBaseControl (..))
3133import Control.Monad.Trans.Except
3234import Data.ByteString.Builder
3335 (toLazyByteString)
3436import qualified Data.ByteString.Lazy as BSL
37+import Data.Either
38+ (either)
3539import Data.Foldable
36− (for_, toList)
40+ (toList)
3741import Data.Functor.Alt
3842 (Alt (..))
3943import Data.Maybe
40− (maybeToList)
44+ (maybe, maybeToList)
4145import Data.Proxy
4246 (Proxy (..))
4347import Data.Semigroup
@@ -48,7 +52,7 @@ import Data.String
4852 (fromString)
4953import qualified Data.Text as T
5054import Data.Time.Clock
51− (getCurrentTime)
55+ (UTCTime, getCurrentTime)
5256import GHC.Generics
5357import Network.HTTP.Media
5458 (renderHeader)
@@ -158,19 +162,38 @@ performRequest req = do
158162 writeTVar cj newCookieJar
159163 pure newRequest
160164
161− eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request m
162− case eResponse of
163− Left err -> throwError err
164− Right response -> do
165− for_ cookieJar' $ \cj -> liftIO $ do
166− now' <- getCurrentTime
167− atomically $ modifyTVar' cj (fst . Client.updateCookieJar response request now')
168− let status = Client.responseStatus response
169− status_code = statusCode status
170− ourResponse = clientResponseToResponse response
171− unless (status_code >= 200 && status_code < 300) $
172− throwError $ FailureResponse ourResponse
173− return ourResponse
165+ response <- maybe (requestWithoutCookieJar m request) (requestWithCookieJar m request) cookieJar'
166+ let status = Client.responseStatus response
167+ status_code = statusCode status
168+ ourResponse = clientResponseToResponse response
169+ unless (status_code >= 200 && status_code < 300) $
170+ throwError $ FailureResponse ourResponse
171+ return ourResponse
172+ where
173+ requestWithoutCookieJar :: Client.Manager -> Client.Request -> ClientM (Client.Response BSL.ByteString)
174+ requestWithoutCookieJar m' request' = do
175+ eResponse <- liftIO . catchConnectionError $ Client.httpLbs request' m'
176+ either throwError return eResponse
177+
178+ requestWithCookieJar :: Client.Manager -> Client.Request -> TVar Client.CookieJar -> ClientM (Client.Response BSL.ByteString)
179+ requestWithCookieJar m' request' cj = do
180+ eResponse <- liftIO . catchConnectionError . Client.withResponseHistory request' m' $ updateWithResponseCookies cj
181+ either throwError return eResponse
182+
183+ updateWithResponseCookies :: TVar Client.CookieJar -> Client.HistoriedResponse Client.BodyReader -> IO (Client.Response BSL.ByteString)
184+ updateWithResponseCookies cj responses = do
185+ now <- getCurrentTime
186+ bss <- Client.brConsume $ Client.responseBody fRes
187+ let fRes' = fRes { Client.responseBody = BSL.fromChunks bss }
188+ allResponses = Client.hrRedirects responses <> [(fReq, fRes')]
189+ atomically $ mapM_ (updateCookieJar now) allResponses
190+ return fRes'
191+ where
192+ updateCookieJar :: UTCTime -> (Client.Request, Client.Response BSL.ByteString) -> STM ()
193+ updateCookieJar now' (req', res') = modifyTVar' cj (fst . Client.updateCookieJar res' req' now')
194+
195+ fReq = Client.hrFinalRequest responses
196+ fRes = Client.hrFinalResponse responses
174197
175198clientResponseToResponse :: Client.Response a -> GenResponse a
176199clientResponseToResponse r = Response
servant-client/test/Servant/ClientSpec.hs+25−8
@@ -28,6 +28,10 @@ import Control.Arrow
2828 (left)
2929import Control.Concurrent
3030 (ThreadId, forkIO, killThread)
31+import Control.Concurrent.STM
32+ (atomically)
33+import Control.Concurrent.STM.TVar
34+ (newTVar, readTVar)
3135import Control.Exception
3236 (bracket)
3337import Control.Monad.Error.Class
@@ -37,17 +41,19 @@ import Data.Char
3741 (chr, isPrint)
3842import Data.Foldable
3943 (forM_)
44+import Data.Maybe
45+ (listToMaybe)
4046import Data.Monoid ()
4147import Data.Proxy
4248import Data.Semigroup
4349 ((<>))
44−import qualified Generics.SOP as SOP
50+import qualified Generics.SOP as SOP
4551import GHC.Generics
4652 (Generic)
47−import qualified Network.HTTP.Client as C
48−import qualified Network.HTTP.Types as HTTP
53+import qualified Network.HTTP.Client as C
54+import qualified Network.HTTP.Types as HTTP
4955import Network.Socket
50−import qualified Network.Wai as Wai
56+import qualified Network.Wai as Wai
5157import Network.Wai.Handler.Warp
5258import System.IO.Unsafe
5359 (unsafePerformIO)
@@ -64,12 +70,12 @@ import Servant.API
6470 DeleteNoContent, EmptyAPI, FormUrlEncoded, Get, Header,
6571 Headers, JSON, NoContent (NoContent), Post, Put, QueryFlag,
6672 QueryParam, QueryParams, Raw, ReqBody, addHeader, getHeaders)
67−import Servant.Test.ComprehensiveAPI
6873import Servant.Client
69−import qualified Servant.Client.Core.Internal.Auth as Auth
70−import qualified Servant.Client.Core.Internal.Request as Req
74+import qualified Servant.Client.Core.Internal.Auth as Auth
75+import qualified Servant.Client.Core.Internal.Request as Req
7176import Servant.Server
7277import Servant.Server.Experimental.Auth
78+import Servant.Test.ComprehensiveAPI
7379
7480-- This declaration simply checks that all instances are in place.
7581_ = client comprehensiveAPIWithoutStreaming
@@ -128,6 +134,7 @@ type Api =
128134 Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])])
129135 :<|> "headers" :> Get '[JSON] (Headers TestHeaders Bool)
130136 :<|> "deleteContentType" :> DeleteNoContent '[JSON] NoContent
137+ :<|> "redirectWithCookie" :> Raw
131138 :<|> "empty" :> EmptyAPI
132139
133140api :: Proxy Api
@@ -148,6 +155,7 @@ getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]
148155 -> ClientM (String, Maybe Int, Bool, [(String, [Rational])])
149156getRespHeaders :: ClientM (Headers TestHeaders Bool)
150157getDeleteContentType :: ClientM NoContent
158+getRedirectWithCookie :: HTTP.Method -> ClientM Response
151159
152160getRoot
153161 :<|> getGet
@@ -163,6 +171,7 @@ getRoot
163171 :<|> getMultiple
164172 :<|> getRespHeaders
165173 :<|> getDeleteContentType
174+ :<|> getRedirectWithCookie
166175 :<|> EmptyClient = client api
167176
168177server :: Application
@@ -184,9 +193,9 @@ server = serve api (
184193 :<|> (\ a b c d -> return (a, b, c, d))
185194 :<|> (return $ addHeader 1729 $ addHeader "eg2" True)
186195 :<|> return NoContent
196+ :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.found302 [("Location", "testlocation"), ("Set-Cookie", "testcookie=test")] "")
187197 :<|> emptyServer)
188198
189−
190199type FailApi =
191200 "get" :> Raw
192201 :<|> "capture" :> Capture "name" String :> Raw
@@ -364,6 +373,14 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
364373 Left e -> assertFailure $ show e
365374 Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")]
366375
376+ it "Stores Cookie in CookieJar after a redirect" $ \(_, baseUrl) -> do
377+ mgr <- C.newManager C.defaultManagerSettings
378+ cj <- atomically . newTVar $ C.createCookieJar []
379+ _ <- runClientM (getRedirectWithCookie HTTP.methodGet) (ClientEnv mgr baseUrl (Just cj))
380+ cookie <- listToMaybe . C.destroyCookieJar <$> atomically (readTVar cj)
381+ C.cookie_name <$> cookie `shouldBe` Just "testcookie"
382+ C.cookie_value <$> cookie `shouldBe` Just "test"
383+
367384 modifyMaxSuccess (const 20) $ do
368385 it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \(_, baseUrl) ->
369386 property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body ->