@@ -23,6 +23,8 @@ import Control.Monad.Catch
23 (MonadCatch, MonadThrow)
23 (MonadCatch, MonadThrow)
24import Control.Monad.Error.Class
24import Control.Monad.Error.Class
25 (MonadError (..))
25 (MonadError (..))
26+import Control.Monad.IO.Class
26import Control.Monad.Reader
28import Control.Monad.Reader
27import Control.Monad.STM
29import Control.Monad.STM
28 (atomically)
30 (atomically)
@@ -32,12 +34,14 @@ import 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
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,37 @@ performRequest req = do
158 writeTVar cj newCookieJar
162 writeTVar cj newCookieJar
159 pure newRequest
163 pure newRequest
161− eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request m
165+ response <- maybe (requestWithoutCookieJar m request) (requestWithCookieJar m request) cookieJar'
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
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
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
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')]
191+ updateCookieJar :: UTCTime -> (Client.Request, Client.Response BSL.ByteString) -> IO ()
192+ updateCookieJar now' (req', res') = atomically $ modifyTVar' cj (fst . Client.updateCookieJar res' req' now')
194+ fReq = Client.hrFinalRequest responses
195+ fRes = Client.hrFinalResponse responses
175clientResponseToResponse :: Client.Response a -> GenResponse a
197clientResponseToResponse :: Client.Response a -> GenResponse a
176clientResponseToResponse r = Response
198clientResponseToResponse r = Response