@@ -23,6 +23,8 @@ 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
2830 (atomically)
@@ -32,12 +34,14 @@ import 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,37 @@ 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+ mapM_ (updateCookieJar now) $ Client.hrRedirects responses <> [(fReq, fRes')]
189+ return fRes'
190+ where
191+ updateCookieJar :: UTCTime -> (Client.Request, Client.Response BSL.ByteString) -> IO ()
192+ updateCookieJar now' (req', res') = atomically $ modifyTVar' cj (fst . Client.updateCookieJar res' req' now')
193+
194+ fReq = Client.hrFinalRequest responses
195+ fRes = Client.hrFinalResponse responses
174196
175197clientResponseToResponse :: Client.Response a -> GenResponse a
176198clientResponseToResponse r = Response