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.
This commit is contained in:
Falco Peijnenburg 2016-09-30 18:12:22 +02:00
parent 2082abf17b
commit 798d9e8967

View File

@ -20,12 +20,12 @@ import qualified Data.ByteString.Lazy as LBS
import Data.CaseInsensitive
import Data.Char
import Data.String.Conversions
import Foreign.StablePtr
import GHCJS.Foreign.Callback
import GHCJS.Prim
import Network.HTTP.Client
import Network.HTTP.Client.Internal as HttpClient
import Network.HTTP.Types
import Servant.Client.PerformRequest.Base
newtype JSXMLHttpRequest = JSXMLHttpRequest JSVal
@ -58,17 +58,29 @@ foreign import javascript unsafe "new $1()"
-- Performs the xhr and blocks until the response was received
performXhr :: JSXMLHttpRequest -> Request -> IO ()
performXhr xhr request = do
waiter <- newEmptyMVar
callback <- onReadyStateChange xhr $ do
state <- readyState xhr
case state of
4 -> putMVar waiter ()
_ -> return ()
openXhr xhr (cs $ method request) (toUrl request) True
setHeaders xhr (requestHeaders request)
sendXhr xhr (toBody request)
takeMVar waiter
releaseCallback callback
waiter <- newEmptyMVar
bracket (acquire waiter) releaseCallback $ \_callback -> do
t <- myThreadId
s <- newStablePtr t
openXhr xhr (cs $ method request) (toUrl request) True
setHeaders xhr (requestHeaders request)
sendXhr xhr (toBody request)
takeMVar waiter
freeStablePtr s
where
acquire waiter = onReadyStateChange xhr $ do
state <- readyState xhr
case state of
-- onReadyStateChange's callback can fire state 4
-- (which means "request finished and response is ready")
-- multiple times. By using tryPutMVar, only the first time
-- state 4 is fired will cause an MVar to be put. Subsequent
-- fires are ignored.
4 -> tryPutMVar waiter () >> return ()
_ -> return ()
onReadyStateChange :: JSXMLHttpRequest -> IO () -> IO (Callback (IO ()))
onReadyStateChange xhr action = do