From fcc0da55f4ffcb42a970672fb92bd1501f0d2340 Mon Sep 17 00:00:00 2001
From: Adrian Cochrane <adrian@openwork.nz>
Date: Wed, 15 Jan 2020 20:13:14 +1300
Subject: [PATCH] Add Accept header support, remove cookies support

---
 src/Network/URI/Fetch.hs | 16 +++++++++++-----
 1 file changed, 11 insertions(+), 5 deletions(-)

diff --git a/src/Network/URI/Fetch.hs b/src/Network/URI/Fetch.hs
index 7a8cc4e..39dddc6 100644
--- a/src/Network/URI/Fetch.hs
+++ b/src/Network/URI/Fetch.hs
@@ -11,6 +11,7 @@ import qualified Data.ByteString.Lazy as B
 import qualified Network.HTTP.Client as HTTP
 import           Network.HTTP.Types
 import           Network.URI.Charset
+import           Data.List (intercalate)
 #endif
 
 #ifdef WITH_DATA_URI
@@ -24,11 +25,16 @@ data Session = Session {
 #endif
 }
 
-fetchURL :: Session -> String -> URI -> IO (String, Either Text ByteString)
+fetchURL :: Session -> [String] -> URI -> IO (String, Either Text ByteString)
 #ifdef WITH_HTTP_URI
-fetchURL session defaultMIME uri | uriScheme uri `elem` ["http:", "https:"] = do
+fetchURL session accept@(defaultMIME:_) uri | uriScheme uri `elem` ["http:", "https:"] = do
     request <- HTTP.requestFromURI uri
-    response <- HTTP.httpLbs request $ managerHTTP session
+    response <- HTTP.httpLbs request {
+            HTTP.cookieJar = Nothing, -- Will only be supported by Rhapsode when submitting a form.
+            HTTP.requestHeaders = [
+                ("Accept", C8.pack $ intercalate ", " accept)
+            ]
+        } $ managerHTTP session
     return $ case (
             HTTP.responseBody response,
             [val | ("content-type", val) <- HTTP.responseHeaders response]
@@ -40,13 +46,13 @@ fetchURL session defaultMIME uri | uriScheme uri `elem` ["http:", "https:"] = do
 #endif
 
 #ifdef WITH_FILE_URI
-fetchURL _ defaultMIME uri@URI {uriScheme = "file:"} = do
+fetchURL _ (defaultMIME:_) uri@URI {uriScheme = "file:"} = do
     response <- B.readFile $ uriPath uri
     return (defaultMIME, Right response)
 #endif
 
 #ifdef WITH_DATA_URI
-fetchURL _ defaultMIME uri@URI {uriScheme = "data:"} =
+fetchURL _ (defaultMIME:_) uri@URI {uriScheme = "data:"} =
     let request = uriPath uri ++ uriQuery uri ++ uriFragment uri
     in case breakOn ',' $ unEscapeString request of
         ("", response) -> return (defaultMIME, Left $ Txt.pack response)
-- 
2.30.2