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

Cookies are added to the CookieJar for all intermediate/redirected requests.

Browse source
This commit is contained in:
Michael Dunn 2019-01-04 17:04:20 -06:00
parent a3d335b436
commit 37a38d7a9b
1 changed files with 38 additions and 16 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

54
servant-client/src/Servant/Client/Internal/HttpClient.hs
View file

@ -23,6 +23,8 @@ import Control.Monad.Catch
(MonadCatch, MonadThrow) (MonadCatch, MonadThrow)
import Control.Monad.Error.Class import Control.Monad.Error.Class
(MonadError (..)) (MonadError (..))
import Control.Monad.IO.Class
(liftIO)
import Control.Monad.Reader import Control.Monad.Reader
import Control.Monad.STM import Control.Monad.STM
(atomically) (atomically)
@ -32,12 +34,14 @@ import Control.Monad.Trans.Except
import Data.ByteString.Builder import Data.ByteString.Builder
(toLazyByteString) (toLazyByteString)
import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.Lazy as BSL
import Data.Either
(either)
import Data.Foldable import Data.Foldable
(for_, toList) (toList)
import Data.Functor.Alt import Data.Functor.Alt
(Alt (..)) (Alt (..))
import Data.Maybe import Data.Maybe
(maybeToList) (maybe, maybeToList)
import Data.Proxy import Data.Proxy
(Proxy (..)) (Proxy (..))
import Data.Semigroup import Data.Semigroup
@ -48,7 +52,7 @@ import Data.String
(fromString) (fromString)
import qualified Data.Text as T import qualified Data.Text as T
import Data.Time.Clock import Data.Time.Clock
(getCurrentTime) (UTCTime, getCurrentTime)
import GHC.Generics import GHC.Generics
import Network.HTTP.Media import Network.HTTP.Media
(renderHeader) (renderHeader)
@ -158,19 +162,37 @@ performRequest req = do
writeTVar cj newCookieJar writeTVar cj newCookieJar
pure newRequest pure newRequest
eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request m response <- maybe (requestWithoutCookieJar m request) (requestWithCookieJar m request) cookieJar'
case eResponse of let status = Client.responseStatus response
Left err -> throwError err status_code = statusCode status
Right response -> do ourResponse = clientResponseToResponse response
for_ cookieJar' $ \cj -> liftIO $ do unless (status_code >= 200 && status_code < 300) $
now' <- getCurrentTime throwError $ FailureResponse ourResponse
atomically $ modifyTVar' cj (fst . Client.updateCookieJar response request now') return ourResponse
let status = Client.responseStatus response where
status_code = statusCode status requestWithoutCookieJar :: Client.Manager -> Client.Request -> ClientM (Client.Response BSL.ByteString)
ourResponse = clientResponseToResponse response requestWithoutCookieJar m' request' = do
unless (status_code >= 200 && status_code < 300) $ eResponse <- liftIO . catchConnectionError $ Client.httpLbs request' m'
throwError $ FailureResponse ourResponse either throwError return eResponse
return ourResponse
requestWithCookieJar :: Client.Manager -> Client.Request -> TVar Client.CookieJar -> ClientM (Client.Response BSL.ByteString)
requestWithCookieJar m' request' cj = do
eResponse <- liftIO . catchConnectionError . Client.withResponseHistory request' m' $ updateWithResponseCookies cj
either throwError return eResponse
updateWithResponseCookies :: TVar Client.CookieJar -> Client.HistoriedResponse Client.BodyReader -> IO (Client.Response BSL.ByteString)
updateWithResponseCookies cj responses = do
now <- getCurrentTime
bss <- Client.brConsume $ Client.responseBody fRes
let fRes' = fRes { Client.responseBody = BSL.fromChunks bss }
mapM_ (updateCookieJar now) $ Client.hrRedirects responses <> [(fReq, fRes')]
return fRes'
where
updateCookieJar :: UTCTime -> (Client.Request, Client.Response BSL.ByteString) -> IO ()
updateCookieJar now' (req', res') = atomically $ modifyTVar' cj (fst . Client.updateCookieJar res' req' now')
fReq = Client.hrFinalRequest responses
fRes = Client.hrFinalResponse responses
clientResponseToResponse :: Client.Response a -> GenResponse a clientResponseToResponse :: Client.Response a -> GenResponse a
clientResponseToResponse r = Response clientResponseToResponse r = Response