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

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

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