git.iko.soy/servant
on master help sign in
servant-client-ghcjs: Fixed Accept and Content-Type headers not being set
74bde0aFalco Peijnenburg
servant-client-ghcjs/servant-client-ghcjs.cabal+1−1
compare with master
unifiedsplit
@@ -38,6 +38,7 @@ library
38 , exceptions >= 0.8 && < 0.9
38 , exceptions >= 0.8 && < 0.9
39 , ghcjs-base >= 0.2.0.0 && < 0.3.0.0
39 , ghcjs-base >= 0.2.0.0 && < 0.3.0.0
40 , ghcjs-prim >= 0.1.0.0 && < 0.2.0.0
40 , ghcjs-prim >= 0.1.0.0 && < 0.2.0.0
41+ , http-media >= 0.6.2 && < 0.8
41 , http-types >= 0.8.6 && < 0.10
42 , http-types >= 0.8.6 && < 0.10
42 , monad-control >= 1.0.0.4 && < 1.1
43 , monad-control >= 1.0.0.4 && < 1.1
43 , mtl >= 2.1 && < 2.3
44 , mtl >= 2.1 && < 2.3
@@ -51,4 +52,3 @@ library
51 ghc-options: -Wall
52 ghc-options: -Wall
52 if impl(ghc >= 8.0)
53 if impl(ghc >= 8.0)
53 ghc-options: -Wno-redundant-constraints
54 ghc-options: -Wno-redundant-constraints
54− include-dirs: include
servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hs+19−4
@@ -38,6 +38,7 @@ import GHC.Generics
38import GHCJS.Foreign.Callback
38import GHCJS.Foreign.Callback
39import GHCJS.Prim
39import GHCJS.Prim
40import Network.HTTP.Types
40import Network.HTTP.Types
41+import Network.HTTP.Media (renderHeader)
41import Servant.Client.Core
42import Servant.Client.Core
42
43
43newtype JSXMLHttpRequest = JSXMLHttpRequest JSVal
44newtype JSXMLHttpRequest = JSXMLHttpRequest JSVal
@@ -117,7 +118,7 @@ performXhr xhr burl request = do
117 s <- newStablePtr t
118 s <- newStablePtr t
118
119
119 openXhr xhr (cs $ requestMethod request) (toUrl burl request) True
120 openXhr xhr (cs $ requestMethod request) (toUrl burl request) True
120− setHeaders xhr $ toList $ requestHeaders request
121+ setHeaders xhr request
121 sendXhr xhr (toBody request)
122 sendXhr xhr (toBody request)
122 takeMVar waiter
123 takeMVar waiter
123
124
@@ -161,9 +162,23 @@ toUrl burl request =
161 requestQueryString request
162 requestQueryString request
162 in showBaseUrl burl ++ pathS ++ queryS
163 in showBaseUrl burl ++ pathS ++ queryS
163
164
164−setHeaders :: JSXMLHttpRequest -> RequestHeaders -> IO ()
165+setHeaders :: JSXMLHttpRequest -> Request -> IO ()
165−setHeaders xhr headers = forM_ headers $ \ (key, value) ->
166+setHeaders xhr request = do
167+ forM_ (toList $ requestAccept request) $ \mediaType ->
168+ js_setRequestHeader
169+ xhr
170+ (toJSString "Accept")
171+ (toJSString $ cs $ renderHeader mediaType)
172+
173+ forM_ (requestBody request) $ \(_, mediaType) ->
174+ js_setRequestHeader
175+ xhr
176+ (toJSString "Content-Type")
177+ (toJSString $ cs $ renderHeader mediaType)
178+
179+ forM_ (toList $ requestHeaders request) $ \(key, value) ->
166− js_setRequestHeader xhr (toJSString $ cs $ original key) (toJSString $ cs value)
180+ js_setRequestHeader xhr (toJSString $ cs $ original key) (toJSString $ cs value)
181+
167foreign import javascript unsafe "$1.setRequestHeader($2, $3)"
182foreign import javascript unsafe "$1.setRequestHeader($2, $3)"
168 js_setRequestHeader :: JSXMLHttpRequest -> JSVal -> JSVal -> IO ()
183 js_setRequestHeader :: JSXMLHttpRequest -> JSVal -> JSVal -> IO ()
169
184