From 3f905ea41cc91eac9c1a69b291760ca41c15f696 Mon Sep 17 00:00:00 2001
From: Falco Peijnenburg <falco@lumiguide.nl>
Date: Sat, 21 Oct 2017 21:27:57 +0200
Subject: [PATCH] servant-client-ghcjs: Default runClientM doesn't accept
 ClientEnv, runClientMOrigin does.

CORS are rare. Most requests by far will be to the origin that served the javascript.
---
 .../src/Servant/Client/Internal/XhrClient.hs  | 32 +++++++++++++++++--
 1 file changed, 30 insertions(+), 2 deletions(-)

diff --git a/servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hs b/servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hs
index d1212a99..8cb77d22 100644
--- a/servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hs
+++ b/servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hs
@@ -37,6 +37,8 @@ import           Foreign.StablePtr
 import           GHC.Generics
 import           GHCJS.Foreign.Callback
 import           GHCJS.Prim
+import           GHCJS.Types
+import           JavaScript.Web.Location
 import           Network.HTTP.Types
 import           Network.HTTP.Media (renderHeader)
 import           Servant.Client.Core
@@ -81,8 +83,34 @@ instance RunClient ClientM where
 instance ClientLike (ClientM a) (ClientM a) where
   mkClient = id
 
-runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a)
-runClientM cm env = runExceptT $ flip runReaderT env $ runClientM' cm
+runClientMOrigin :: ClientM a -> ClientEnv -> IO (Either ServantError a)
+runClientMOrigin cm env = runExceptT $ flip runReaderT env $ runClientM' cm
+
+runClientM :: ClientM a -> IO (Either ServantError a)
+runClientM m = do
+    curLoc <- getWindowLocation
+
+    jsStr_protocol <- getProtocol curLoc
+    jsStr_port     <- getPort     curLoc
+    jsStr_hostname <- getHostname curLoc
+
+    let protocol
+          | jsStr_protocol == "https:" = Https
+          | otherwise                  = Http
+
+        portStr :: String
+        portStr = fromJSString $ jsval jsStr_port
+
+        port :: Int
+        port | null portStr = case protocol of
+                 Http  ->  80
+                 Https -> 443
+             | otherwise = read portStr
+
+        hostname :: String
+        hostname = fromJSString $ jsval jsStr_hostname
+
+    runClientMOrigin m (ClientEnv (BaseUrl protocol hostname port ""))
 
 performRequest :: Request -> ClientM Response
 performRequest req = do