From d140fda2c3bbe11baf0358fa5ae1c1edb6a72053 Mon Sep 17 00:00:00 2001
From: Robert Klotzner <robert.klotzner@gmx.at>
Date: Mon, 19 Nov 2018 15:15:38 +0100
Subject: [PATCH] Fix xhr response handlers getting called 3 times.

`onreadystatechange` gets fired four times:

```
    1 (OPENED): the request starts
    2 (HEADERS_RECEIVED): the HTTP headers have been received
    3 (LOADING): the response begins to download
    4 (DONE): the response has been downloaded
```

The problem: between 2, 3 and 4 barely any time passes. Due to the
asynchronous nature of ghcjs and even worse with jsaddle the following
seems to happen:

`onreadystatechange` triggers, because of a transition from 1 to 2, so
the reflex-dom handler gets called (eventually). Unfortunately, when the
handler finally gets executed, `readystate` might already be in state 4, so
the check  in Reflex.Dom.Xhr:

```haskell
when (readyState == 4) $ do
...
```

passes and the user callback will be called. The problem, afterwards the
handler will be called again for the transitions from 2 to 3 and from 3
t 4, resulting in the user callback getting called three times instead
of once.

At first, I simply disconnected the event handler in the handler, which
worked. But depending on the actual implementation and ghcjs/jsaddle
internals this solution might fail itself for some race condition, so I
decided to simply encode my intent: Check and set atomically whether or
not the caller has already been called or not, and don't do anything if
that was already the case.
---
 reflex-dom-core/src/Reflex/Dom/Xhr.hs | 8 +++++++-
 1 file changed, 7 insertions(+), 1 deletion(-)

diff --git a/reflex-dom-core/src/Reflex/Dom/Xhr.hs b/reflex-dom-core/src/Reflex/Dom/Xhr.hs
index 8bdf1e19..d4f76605 100644
--- a/reflex-dom-core/src/Reflex/Dom/Xhr.hs
+++ b/reflex-dom-core/src/Reflex/Dom/Xhr.hs
@@ -153,6 +153,7 @@ import Control.Lens
 import Control.Monad hiding (forM)
 import Control.Monad.IO.Class
 import Data.Aeson
+import Data.IORef (newIORef, atomicModifyIORef')
 #if MIN_VERSION_aeson(1,0,0)
 import Data.Aeson.Text
 #else
@@ -262,11 +263,16 @@ newXMLHttpRequestWithError req cb = do
     iforM_ (_xhrRequestConfig_headers c) $ xmlHttpRequestSetRequestHeader xhr
     maybe (return ()) (xmlHttpRequestSetResponseType xhr . fromResponseType) rt
     xmlHttpRequestSetWithCredentials xhr creds
+    -- Avoid handler being called more than once.
+    -- This is needed until jsaddle/ghcjs-dom: https://github.com/ghcjs/ghcjs-dom/issues/89 is fixed.
+    alreadyHandled <- liftIO $ newIORef False
     _ <- xmlHttpRequestOnreadystatechange xhr $ do
       readyState <- xmlHttpRequestGetReadyState xhr
       status <- xmlHttpRequestGetStatus xhr
       statusText <- xmlHttpRequestGetStatusText xhr
-      when (readyState == 4) $ do
+      handled <- liftIO $ atomicModifyIORef' alreadyHandled $ \handled ->
+        if readyState == 4 then (True, handled) else (handled, handled)
+      when (readyState == 4 && not handled) $ do
         t <- if rt == Just XhrResponseType_Text || isNothing rt
              then xmlHttpRequestGetResponseText xhr
              else return Nothing