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:
parent
2082abf17b
commit
798d9e8967
|
@ -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
|
||||
|
|
Loading…
Reference in New Issue
Block a user