servant-client: 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/src/Servant/Client/PerformRequest/GHCJS.hs

@@ -0,0 +1,190 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ViewPatterns #-}
+
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+
+module Servant.Client.PerformRequest.GHCJS (
+  ServantError(..),
+  performHttpRequest,
+
+  -- exported for testing
+  parseHeaders,
+  ) where
+
+import           Control.Arrow
+import           Control.Concurrent
+import           Control.Exception
+import           Control.Monad
+import qualified Data.ByteString.Char8 as BS
+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
+
+newtype JSXMLHttpRequestClass = JSXMLHttpRequestClass JSVal
+
+performHttpRequest :: Manager -> Request -> IO (Either ServantError (Response LBS.ByteString))
+performHttpRequest _ request = do
+  xhr <- initXhr
+  performXhr xhr request
+  toResponse xhr
+
+-- * initialization
+
+initXhr :: IO JSXMLHttpRequest
+initXhr = do
+  lib <- requireXMLHttpRequestClass
+  newXMLHttpRequest lib
+
+foreign import javascript unsafe
+  -- branching between node (for testing) and browsers
+  "(function () {if (typeof require !== 'undefined') { return require('xhr2'); } else { return XMLHttpRequest; };})()"
+  requireXMLHttpRequestClass :: IO JSXMLHttpRequestClass
+
+foreign import javascript unsafe "new $1()"
+  newXMLHttpRequest :: JSXMLHttpRequestClass -> IO JSXMLHttpRequest
+
+-- * performing requests
+
+-- Performs the xhr and blocks until the response was received
+performXhr :: JSXMLHttpRequest -> Request -> IO ()
+performXhr xhr request = do
+    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
+  callback <- asyncCallback action
+  js_onReadyStateChange xhr callback
+  return callback
+foreign import javascript safe "$1.onreadystatechange = $2;"
+  js_onReadyStateChange :: JSXMLHttpRequest -> Callback (IO ()) -> IO ()
+
+foreign import javascript unsafe "$1.readyState"
+  readyState :: JSXMLHttpRequest -> IO Int
+
+openXhr :: JSXMLHttpRequest -> String -> String -> Bool -> IO ()
+openXhr xhr method url async =
+  js_openXhr xhr (toJSString method) (toJSString url) async
+foreign import javascript unsafe "$1.open($2, $3, $4)"
+  js_openXhr :: JSXMLHttpRequest -> JSVal -> JSVal -> Bool -> IO ()
+
+toUrl :: Request -> String
+toUrl request =
+  let protocol = if secure request then "https" else "http"
+      hostS = cs $ host request
+      portS = show $ port request
+      pathS = cs $ path request
+      queryS = cs $ queryString request
+  in protocol ++ "://" ++ hostS ++ ":" ++ portS ++ pathS ++ queryS
+
+setHeaders :: JSXMLHttpRequest -> RequestHeaders -> IO ()
+setHeaders xhr headers = forM_ headers $ \ (key, value) ->
+  js_setRequestHeader xhr (toJSString $ cs $ original key) (toJSString $ cs value)
+foreign import javascript unsafe "$1.setRequestHeader($2, $3)"
+  js_setRequestHeader :: JSXMLHttpRequest -> JSVal -> JSVal -> IO ()
+
+sendXhr :: JSXMLHttpRequest -> Maybe String -> IO ()
+sendXhr xhr Nothing = js_sendXhr xhr
+sendXhr xhr (Just body) =
+  js_sendXhrWithBody xhr (toJSString body)
+foreign import javascript unsafe "$1.send()"
+  js_sendXhr :: JSXMLHttpRequest -> IO ()
+foreign import javascript unsafe "$1.send($2)"
+  js_sendXhrWithBody :: JSXMLHttpRequest -> JSVal -> IO ()
+
+toBody :: Request -> Maybe String
+toBody request = case requestBody request of
+  RequestBodyLBS "" -> Nothing
+  RequestBodyLBS x -> Just $ cs x
+  _ -> error "servant-client only uses RequestBodyLBS"
+
+-- * inspecting the xhr response
+
+-- This function is only supposed to handle 'ConnectionError's. Other
+-- 'ServantError's are created in Servant.Client.Req.
+toResponse :: JSXMLHttpRequest -> IO (Either ServantError (Response LBS.ByteString))
+toResponse xhr = do
+  status <- getStatus xhr
+  case status of
+    0 -> return $ Left $ ConnectionError $ SomeException $ ErrorCall "connection error"
+    _ -> do
+      statusText <- cs <$> getStatusText xhr
+      headers <- parseHeaders <$> getAllResponseHeaders xhr
+      responseText <- cs <$> getResponseText xhr
+      return $ Right $ Response {
+        HttpClient.responseStatus = mkStatus status statusText,
+        responseVersion = http11, -- this is made up
+        responseHeaders = headers,
+        HttpClient.responseBody = responseText,
+        responseCookieJar = mempty,
+        responseClose' = ResponseClose (return ())
+      }
+
+foreign import javascript unsafe "$1.status"
+  getStatus :: JSXMLHttpRequest -> IO Int
+
+getStatusText :: JSXMLHttpRequest -> IO String
+getStatusText = fmap fromJSString . js_statusText
+foreign import javascript unsafe "$1.statusText"
+  js_statusText :: JSXMLHttpRequest -> IO JSVal
+
+getAllResponseHeaders :: JSXMLHttpRequest -> IO String
+getAllResponseHeaders xhr =
+  fromJSString <$> js_getAllResponseHeaders xhr
+foreign import javascript unsafe "$1.getAllResponseHeaders()"
+  js_getAllResponseHeaders :: JSXMLHttpRequest -> IO JSVal
+
+getResponseText :: JSXMLHttpRequest -> IO String
+getResponseText xhr = fromJSString <$> js_responseText xhr
+foreign import javascript unsafe "$1.responseText"
+  js_responseText :: JSXMLHttpRequest -> IO JSVal
+
+parseHeaders :: String -> ResponseHeaders
+parseHeaders s =
+  fmap (first mk) $
+  fmap (first strip . second strip) $
+  fmap parseHeader $
+  splitOn "\r\n" (cs s)
+  where
+    parseHeader :: BS.ByteString -> (BS.ByteString, BS.ByteString)
+    parseHeader h = case BS.breakSubstring ":" (cs h) of
+      (key, (BS.drop 1 -> value)) -> (key, value)
+
+    splitOn :: BS.ByteString -> BS.ByteString -> [BS.ByteString]
+    splitOn separator input = case BS.breakSubstring separator input of
+      (prefix, "") -> [prefix]
+      (prefix, rest) -> prefix : splitOn separator (BS.drop (BS.length separator) rest)
+
+    strip :: BS.ByteString -> BS.ByteString
+    strip = BS.dropWhile isSpace . BS.reverse . BS.dropWhile isSpace . BS.reverse