git.iko.soy/typeable/servant
on master help sign in
servant-client-ghcjs: Default runClientM doesn't accept ClientEnv, runClientMOrigin does.
3f905eaFalco Peijnenburg
servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hs+30−2
compare with master
unifiedsplit
@@ -37,6 +37,8 @@ import Foreign.StablePtr
37import GHC.Generics
37import GHC.Generics
38import GHCJS.Foreign.Callback
38import GHCJS.Foreign.Callback
39import GHCJS.Prim
39import GHCJS.Prim
40+import GHCJS.Types
41+import JavaScript.Web.Location
40import Network.HTTP.Types
42import Network.HTTP.Types
41import Network.HTTP.Media (renderHeader)
43import Network.HTTP.Media (renderHeader)
42import Servant.Client.Core
44import Servant.Client.Core
@@ -81,8 +83,34 @@ instance RunClient ClientM where
81instance ClientLike (ClientM a) (ClientM a) where
83instance ClientLike (ClientM a) (ClientM a) where
82 mkClient = id
84 mkClient = id
83
85
84−runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a)
86+runClientMOrigin :: ClientM a -> ClientEnv -> IO (Either ServantError a)
85−runClientM cm env = runExceptT $ flip runReaderT env $ runClientM' cm
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 ""))
86
114
87performRequest :: Request -> ClientM Response
115performRequest :: Request -> ClientM Response
88performRequest req = do
116performRequest req = do