eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

servant-client-ghcjs: Fixed Accept and Content-Type headers not being set

Browse source
This commit is contained in:
Falco Peijnenburg 2017-10-04 23:54:46 +02:00
parent 7b38e77b00
commit 74bde0a73d
2 changed files with 20 additions and 5 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
servant-client-ghcjs/servant-client-ghcjs.cabal
View file

@ -38,6 +38,7 @@ library
, exceptions >= 0.8 && < 0.9
, ghcjs-base >= 0.2.0.0 && < 0.3.0.0
, ghcjs-prim >= 0.1.0.0 && < 0.2.0.0
, http-media >= 0.6.2 && < 0.8
, http-types >= 0.8.6 && < 0.10
, monad-control >= 1.0.0.4 && < 1.1
, mtl >= 2.1 && < 2.3
@ -51,4 +52,3 @@ library
ghc-options: -Wall
if impl(ghc >= 8.0)
ghc-options: -Wno-redundant-constraints
include-dirs: include

21
servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hs
View file

@ -38,6 +38,7 @@ import GHC.Generics
import GHCJS.Foreign.Callback
import GHCJS.Prim
import Network.HTTP.Types
import Network.HTTP.Media (renderHeader)
import Servant.Client.Core
newtype JSXMLHttpRequest = JSXMLHttpRequest JSVal
@ -117,7 +118,7 @@ performXhr xhr burl request = do
s <- newStablePtr t
openXhr xhr (cs $ requestMethod request) (toUrl burl request) True
setHeaders xhr $ toList $ requestHeaders request
setHeaders xhr request
sendXhr xhr (toBody request)
takeMVar waiter
@ -161,9 +162,23 @@ toUrl burl request =
requestQueryString request
in showBaseUrl burl ++ pathS ++ queryS
setHeaders :: JSXMLHttpRequest -> RequestHeaders -> IO ()
setHeaders xhr headers = forM_ headers $ \ (key, value) ->
setHeaders :: JSXMLHttpRequest -> Request -> IO ()
setHeaders xhr request = do
forM_ (toList $ requestAccept request) $ \mediaType ->
js_setRequestHeader
xhr
(toJSString "Accept")
(toJSString $ cs $ renderHeader mediaType)
forM_ (requestBody request) $ \(_, mediaType) ->
js_setRequestHeader
xhr
(toJSString "Content-Type")
(toJSString $ cs $ renderHeader mediaType)
forM_ (toList $ requestHeaders request) $ \(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 ()