git.iko.soy/servant
on master help sign in
Fixes MVar blocking exception

Uses the fix mentioned by @arianvp in https://github.com/haskell-servant/servant/pull/425. See also https://github.com/haskell-servant/servant/issues/51#issuecomment-250737727 The cause of the issue very is similar to the issue described in this blog post: https://www.fpcomplete.com/blog/2016/06/async-exceptions-stm-deadlocks The main thread creates a waiter, creates an asynchronous callback which is called when the `readyState` of the request changes. When the readyState changes to 4, which means 'request finished', the waiter MVar is put. The main thread takes the MVar and continues to do stuff with the response. The problem is that the `readyState` can change to 4 more than once, for some reason. The second time this happens, the waiter MVar can be put again, since the main thread took it. The main thread, however, won't take it again. After all, it only needed to take the MVar once to know that the request was finished. The third time `readyState` is set to 4, the putMVar would block, causing the following exception to be thrown: ``` thread blocked indefinitely in an MVar operation ``` Since state 4 should really mean that the response is ready, it seems appropriate to decide that all changes of the state to 4 after the initial one can be safely ignored.

commit798d9e896726aac7e4a279d78c840772b589137f authorFalco Peijnenburg <falco@lumiguide.nl> dateFri 30 Sep 2016, 18:12 (10 years ago) parent2082abf
1 file changed+24−12
compare with master
unifiedsplit
servant-client/src/Servant/Client/PerformRequest/GHCJS.hs+24−12
servant-client/src/Servant/Client/PerformRequest/GHCJS.hs+24−12
@@ -20,12 +20,12 @@ import qualified Data.ByteString.Lazy as LBS
2020import Data.CaseInsensitive
2121import Data.Char
2222import Data.String.Conversions
23+import Foreign.StablePtr
2324import GHCJS.Foreign.Callback
2425import GHCJS.Prim
2526import Network.HTTP.Client
2627import Network.HTTP.Client.Internal as HttpClient
2728import Network.HTTP.Types
28−
2929import Servant.Client.PerformRequest.Base
3030
3131newtype JSXMLHttpRequest = JSXMLHttpRequest JSVal
@@ -58,17 +58,29 @@ foreign import javascript unsafe "new $1()"
5858-- Performs the xhr and blocks until the response was received
5959performXhr :: JSXMLHttpRequest -> Request -> IO ()
6060performXhr xhr request = do
61− waiter <- newEmptyMVar
62− callback <- onReadyStateChange xhr $ do
63− state <- readyState xhr
64− case state of
65− 4 -> putMVar waiter ()
66− _ -> return ()
67− openXhr xhr (cs $ method request) (toUrl request) True
68− setHeaders xhr (requestHeaders request)
69− sendXhr xhr (toBody request)
70− takeMVar waiter
71− releaseCallback callback
61+ waiter <- newEmptyMVar
62+
63+ bracket (acquire waiter) releaseCallback $ \_callback -> do
64+ t <- myThreadId
65+ s <- newStablePtr t
66+
67+ openXhr xhr (cs $ method request) (toUrl request) True
68+ setHeaders xhr (requestHeaders request)
69+ sendXhr xhr (toBody request)
70+ takeMVar waiter
71+
72+ freeStablePtr s
73+ where
74+ acquire waiter = onReadyStateChange xhr $ do
75+ state <- readyState xhr
76+ case state of
77+ -- onReadyStateChange's callback can fire state 4
78+ -- (which means "request finished and response is ready")
79+ -- multiple times. By using tryPutMVar, only the first time
80+ -- state 4 is fired will cause an MVar to be put. Subsequent
81+ -- fires are ignored.
82+ 4 -> tryPutMVar waiter () >> return ()
83+ _ -> return ()
7284
7385onReadyStateChange :: JSXMLHttpRequest -> IO () -> IO (Callback (IO ()))
7486onReadyStateChange xhr action = do