28ac8c0 · servant · git.iko.soy

git.iko.soy/servant

on master help sign in

Merge pull request #1104 from michaelsdunn1/master

28ac8c0Oleg Grenrus8 years ago

servant-client/servant-client.cabal+1

compare with master

unifiedsplit

@@ -102,6 +102,7 @@ test-suite spec

102 , kan-extensions

103 , servant-client

104 , servant-client-core

105+ , stm

105 , text

106 , text

106 , transformers

107 , transformers

107 , transformers-compat

108 , transformers-compat

servant-client/src/Servant/Client/Internal/HttpClient.hs+40−17

@@ -23,21 +23,25 @@ import Control.Monad.Catch

23 (MonadCatch, MonadThrow)

24import Control.Monad.Error.Class

25 (MonadError (..))

26+import Control.Monad.IO.Class

27+ (liftIO)

26import Control.Monad.Reader

28import Control.Monad.Reader

27import Control.Monad.STM

29import Control.Monad.STM

28− (atomically)

30+ (STM, atomically)

29import Control.Monad.Trans.Control

31import Control.Monad.Trans.Control

30 (MonadBaseControl (..))

32 (MonadBaseControl (..))

31import Control.Monad.Trans.Except

33import Control.Monad.Trans.Except

32import Data.ByteString.Builder

34import Data.ByteString.Builder

33 (toLazyByteString)

35 (toLazyByteString)

34import qualified Data.ByteString.Lazy as BSL

36import qualified Data.ByteString.Lazy as BSL

37+import Data.Either

38+ (either)

35import Data.Foldable

39import Data.Foldable

36− (for_, toList)

40+ (toList)

37import Data.Functor.Alt

41import Data.Functor.Alt

38 (Alt (..))

42 (Alt (..))

39import Data.Maybe

43import Data.Maybe

40− (maybeToList)

44+ (maybe, maybeToList)

41import Data.Proxy

45import Data.Proxy

42 (Proxy (..))

46 (Proxy (..))

43import Data.Semigroup

47import Data.Semigroup

@@ -48,7 +52,7 @@ import Data.String

48 (fromString)

52 (fromString)

49import qualified Data.Text as T

53import qualified Data.Text as T

50import Data.Time.Clock

54import Data.Time.Clock

51− (getCurrentTime)

55+ (UTCTime, getCurrentTime)

52import GHC.Generics

56import GHC.Generics

53import Network.HTTP.Media

57import Network.HTTP.Media

54 (renderHeader)

58 (renderHeader)

@@ -158,19 +162,38 @@ performRequest req = do

158 writeTVar cj newCookieJar

162 writeTVar cj newCookieJar

159 pure newRequest

163 pure newRequest

160

164

161− eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request m

165+ response <- maybe (requestWithoutCookieJar m request) (requestWithCookieJar m request) cookieJar'

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

166+ let status = Client.responseStatus response

169− status_code = statusCode status

167+ status_code = statusCode status

170− ourResponse = clientResponseToResponse response

168+ ourResponse = clientResponseToResponse response

171− unless (status_code >= 200 && status_code < 300) $

169+ unless (status_code >= 200 && status_code < 300) $

172− throwError $ FailureResponse ourResponse

170+ throwError $ FailureResponse ourResponse

173− return 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

174

197

175clientResponseToResponse :: Client.Response a -> GenResponse a

198clientResponseToResponse :: Client.Response a -> GenResponse a

176clientResponseToResponse r = Response

199clientResponseToResponse r = Response

servant-client/test/Servant/ClientSpec.hs+25−8

@@ -28,6 +28,10 @@ import Control.Arrow

28 (left)

29import Control.Concurrent

30 (ThreadId, forkIO, killThread)

31+import Control.Concurrent.STM

32+ (atomically)

33+import Control.Concurrent.STM.TVar

34+ (newTVar, readTVar)

31import Control.Exception

35import Control.Exception

32 (bracket)

36 (bracket)

33import Control.Monad.Error.Class

37import Control.Monad.Error.Class

@@ -37,17 +41,19 @@ import Data.Char

37 (chr, isPrint)

41 (chr, isPrint)

38import Data.Foldable

42import Data.Foldable

39 (forM_)

43 (forM_)

44+import Data.Maybe

45+ (listToMaybe)

40import Data.Monoid ()

46import Data.Monoid ()

41import Data.Proxy

47import Data.Proxy

42import Data.Semigroup

48import Data.Semigroup

43 ((<>))

49 ((<>))

44−import qualified Generics.SOP as SOP

50+import qualified Generics.SOP as SOP

45import GHC.Generics

51import GHC.Generics

46 (Generic)

52 (Generic)

47−import qualified Network.HTTP.Client as C

53+import qualified Network.HTTP.Client as C

48−import qualified Network.HTTP.Types as HTTP

54+import qualified Network.HTTP.Types as HTTP

49import Network.Socket

55import Network.Socket

50−import qualified Network.Wai as Wai

56+import qualified Network.Wai as Wai

51import Network.Wai.Handler.Warp

57import Network.Wai.Handler.Warp

52import System.IO.Unsafe

58import System.IO.Unsafe

53 (unsafePerformIO)

59 (unsafePerformIO)

@@ -64,12 +70,12 @@ import Servant.API

64 DeleteNoContent, EmptyAPI, FormUrlEncoded, Get, Header,

70 DeleteNoContent, EmptyAPI, FormUrlEncoded, Get, Header,

65 Headers, JSON, NoContent (NoContent), Post, Put, QueryFlag,

71 Headers, JSON, NoContent (NoContent), Post, Put, QueryFlag,

66 QueryParam, QueryParams, Raw, ReqBody, addHeader, getHeaders)

72 QueryParam, QueryParams, Raw, ReqBody, addHeader, getHeaders)

67−import Servant.Test.ComprehensiveAPI

68import Servant.Client

73import Servant.Client

69−import qualified Servant.Client.Core.Internal.Auth as Auth

74+import qualified Servant.Client.Core.Internal.Auth as Auth

70−import qualified Servant.Client.Core.Internal.Request as Req

75+import qualified Servant.Client.Core.Internal.Request as Req

71import Servant.Server

76import Servant.Server

72import Servant.Server.Experimental.Auth

77import Servant.Server.Experimental.Auth

78+import Servant.Test.ComprehensiveAPI

74-- This declaration simply checks that all instances are in place.

80-- This declaration simply checks that all instances are in place.

75_ = client comprehensiveAPIWithoutStreaming

81_ = client comprehensiveAPIWithoutStreaming

@@ -128,6 +134,7 @@ type Api =

128 Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])])

134 Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])])

129 :<|> "headers" :> Get '[JSON] (Headers TestHeaders Bool)

135 :<|> "headers" :> Get '[JSON] (Headers TestHeaders Bool)

130 :<|> "deleteContentType" :> DeleteNoContent '[JSON] NoContent

136 :<|> "deleteContentType" :> DeleteNoContent '[JSON] NoContent

137+ :<|> "redirectWithCookie" :> Raw

131 :<|> "empty" :> EmptyAPI

138 :<|> "empty" :> EmptyAPI

132

139

133api :: Proxy Api

140api :: Proxy Api

@@ -148,6 +155,7 @@ getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]

148 -> ClientM (String, Maybe Int, Bool, [(String, [Rational])])

155 -> ClientM (String, Maybe Int, Bool, [(String, [Rational])])

149getRespHeaders :: ClientM (Headers TestHeaders Bool)

156getRespHeaders :: ClientM (Headers TestHeaders Bool)

150getDeleteContentType :: ClientM NoContent

157getDeleteContentType :: ClientM NoContent

158+getRedirectWithCookie :: HTTP.Method -> ClientM Response

151

159

152getRoot

160getRoot

153 :<|> getGet

161 :<|> getGet

@@ -163,6 +171,7 @@ getRoot

163 :<|> getMultiple

171 :<|> getMultiple

164 :<|> getRespHeaders

172 :<|> getRespHeaders

165 :<|> getDeleteContentType

173 :<|> getDeleteContentType

174+ :<|> getRedirectWithCookie

166 :<|> EmptyClient = client api

175 :<|> EmptyClient = client api

167

176

168server :: Application

177server :: Application

@@ -184,9 +193,9 @@ server = serve api (

184 :<|> (\ a b c d -> return (a, b, c, d))

193 :<|> (\ a b c d -> return (a, b, c, d))

185 :<|> (return $ addHeader 1729 $ addHeader "eg2" True)

194 :<|> (return $ addHeader 1729 $ addHeader "eg2" True)

186 :<|> return NoContent

195 :<|> return NoContent

196+ :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.found302 [("Location", "testlocation"), ("Set-Cookie", "testcookie=test")] "")

187 :<|> emptyServer)

197 :<|> emptyServer)

188

198

189−

190type FailApi =

199type FailApi =

191 "get" :> Raw

200 "get" :> Raw

192 :<|> "capture" :> Capture "name" String :> Raw

201 :<|> "capture" :> Capture "name" String :> Raw

@@ -364,6 +373,14 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do

364 Left e -> assertFailure $ show e

373 Left e -> assertFailure $ show e

365 Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")]

374 Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")]

366

375

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+

367 modifyMaxSuccess (const 20) $ do

384 modifyMaxSuccess (const 20) $ do

368 it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \(_, baseUrl) ->

385 it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \(_, baseUrl) ->

369 property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body ->

386 property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body ->