From 74bde0a73d1ea6a00e606c3a852f4f553336083a Mon Sep 17 00:00:00 2001
From: Falco Peijnenburg <falco@lumiguide.nl>
Date: Wed, 4 Oct 2017 23:54:46 +0200
Subject: [PATCH] servant-client-ghcjs: Fixed Accept and Content-Type headers
 not being set

---
 .../servant-client-ghcjs.cabal                |  2 +-
 .../src/Servant/Client/Internal/XhrClient.hs  | 23 +++++++++++++++----
 2 files changed, 20 insertions(+), 5 deletions(-)

diff --git a/servant-client-ghcjs/servant-client-ghcjs.cabal b/servant-client-ghcjs/servant-client-ghcjs.cabal
index 1fdd1336..cd5550bb 100644
--- a/servant-client-ghcjs/servant-client-ghcjs.cabal
+++ b/servant-client-ghcjs/servant-client-ghcjs.cabal
@@ -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
diff --git a/servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hs b/servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hs
index e9601015..030aebf7 100644
--- a/servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hs
+++ b/servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hs
@@ -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) ->
-  js_setRequestHeader xhr (toJSString $ cs $ original key) (toJSString $ cs 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 ()