@@ -37,6 +37,8 @@ import Foreign.StablePtr
3737import GHC.Generics
3838import GHCJS.Foreign.Callback
3939import GHCJS.Prim
40+import GHCJS.Types
41+import JavaScript.Web.Location
4042import Network.HTTP.Types
4143import Network.HTTP.Media (renderHeader)
4244import Servant.Client.Core
@@ -81,8 +83,34 @@ instance RunClient ClientM where
8183instance ClientLike (ClientM a) (ClientM a) where
8284 mkClient = id
8385
84−runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a)
85−runClientM cm env = runExceptT $ flip runReaderT env $ runClientM' cm
86+runClientMOrigin :: ClientM a -> ClientEnv -> IO (Either ServantError a)
87+runClientMOrigin cm env = runExceptT $ flip runReaderT env $ runClientM' cm
88+
89+runClientM :: ClientM a -> IO (Either ServantError a)
90+runClientM m = do
91+ curLoc <- getWindowLocation
92+
93+ jsStr_protocol <- getProtocol curLoc
94+ jsStr_port <- getPort curLoc
95+ jsStr_hostname <- getHostname curLoc
96+
97+ let protocol
98+ | jsStr_protocol == "https:" = Https
99+ | otherwise = Http
100+
101+ portStr :: String
102+ portStr = fromJSString $ jsval jsStr_port
103+
104+ port :: Int
105+ port | null portStr = case protocol of
106+ Http -> 80
107+ Https -> 443
108+ | otherwise = read portStr
109+
110+ hostname :: String
111+ hostname = fromJSString $ jsval jsStr_hostname
112+
113+ runClientMOrigin m (ClientEnv (BaseUrl protocol hostname port ""))
86114
87115performRequest :: Request -> ClientM Response
88116performRequest req = do