From 798d9e896726aac7e4a279d78c840772b589137f Mon Sep 17 00:00:00 2001
From: Falco Peijnenburg <falco@lumiguide.nl>
Date: Fri, 30 Sep 2016 18:12:22 +0200
Subject: [PATCH] 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.
---
 .../Servant/Client/PerformRequest/GHCJS.hs    | 36 ++++++++++++-------
 1 file changed, 24 insertions(+), 12 deletions(-)

diff --git a/servant-client/src/Servant/Client/PerformRequest/GHCJS.hs b/servant-client/src/Servant/Client/PerformRequest/GHCJS.hs
index 1969c3bf..ca26632d 100644
--- a/servant-client/src/Servant/Client/PerformRequest/GHCJS.hs
+++ b/servant-client/src/Servant/Client/PerformRequest/GHCJS.hs
@@ -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