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

updateCookieJar is now in STM to only allow for a single atomic update.

Browse source
This commit is contained in:
Michael Dunn 2019-01-26 18:01:53 -06:00
parent 07b3236eb6
commit c33f27de04
1 changed files with 4 additions and 4 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -27,7 +27,7 @@ import Control.Monad.IO.Class
(liftIO) (liftIO)
import Control.Monad.Reader import Control.Monad.Reader
import Control.Monad.STM import Control.Monad.STM
(atomically) (STM, atomically)
import Control.Monad.Trans.Control import Control.Monad.Trans.Control
(MonadBaseControl (..)) (MonadBaseControl (..))
import Control.Monad.Trans.Except import Control.Monad.Trans.Except
@ -185,11 +185,11 @@ performRequest req = do
now <- getCurrentTime now <- getCurrentTime
bss <- Client.brConsume $ Client.responseBody fRes bss <- Client.brConsume $ Client.responseBody fRes
let fRes' = fRes { Client.responseBody = BSL.fromChunks bss } let fRes' = fRes { Client.responseBody = BSL.fromChunks bss }
mapM_ (updateCookieJar now) $ Client.hrRedirects responses <> [(fReq, fRes')] mapM_ (atomically . updateCookieJar now) $ Client.hrRedirects responses <> [(fReq, fRes')]
return fRes' return fRes'
where where
updateCookieJar :: UTCTime -> (Client.Request, Client.Response BSL.ByteString) -> IO () updateCookieJar :: UTCTime -> (Client.Request, Client.Response BSL.ByteString) -> STM ()
updateCookieJar now' (req', res') = atomically $ modifyTVar' cj (fst . Client.updateCookieJar res' req' now') updateCookieJar now' (req', res') = modifyTVar' cj (fst . Client.updateCookieJar res' req' now')
fReq = Client.hrFinalRequest responses fReq = Client.hrFinalRequest responses
fRes = Client.hrFinalResponse responses fRes = Client.hrFinalResponse responses