From 17b55634b350f26754ed83c1b6707351594eefa2 Mon Sep 17 00:00:00 2001
From: Mika Tammi <mikatammi@gmail.com>
Date: Fri, 11 Feb 2022 20:42:03 +0200
Subject: [PATCH] servant-client-ghcjs: Fix performRequest function

Fix performRequest function to be compatible with the latest
servant-client-core RunClient typeclass
---
 changelog.d/1529                                    | 10 ++++++++++
 .../src/Servant/Client/Internal/XhrClient.hs        | 13 ++++++++-----
 2 files changed, 18 insertions(+), 5 deletions(-)
 create mode 100644 changelog.d/1529

diff --git a/changelog.d/1529 b/changelog.d/1529
new file mode 100644
index 00000000..92925ee3
--- /dev/null
+++ b/changelog.d/1529
@@ -0,0 +1,10 @@
+synopsis: Fix performRequest in servant-client-ghcjs
+prs: #1529
+
+description: {
+
+performRequest function in servant-client-ghcjs was not compatible with the
+latest RunClient typeclass. Added the acceptStatus parameter and fixed the
+functionality to match what servant-client provides.
+
+}
diff --git a/servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hs b/servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hs
index 2e941460..5d017d62 100644
--- a/servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hs
+++ b/servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hs
@@ -120,7 +120,7 @@ instance Exception StreamingNotSupportedException where
   displayException _ = "streamingRequest: streaming is not supported!"
 
 instance RunClient ClientM where
-  runRequest = performRequest
+  runRequestAcceptStatus = performRequest
   throwClientError = throwError
 
 runClientMOrigin :: ClientM a -> ClientEnv -> IO (Either ClientError a)
@@ -152,15 +152,18 @@ runClientM m = do
 
     runClientMOrigin m (ClientEnv (BaseUrl protocol hostname port ""))
 
-performRequest :: Request -> ClientM Response
-performRequest req = do
+performRequest :: Maybe [Status] -> Request -> ClientM Response
+performRequest acceptStatus req = do
   xhr <- liftIO initXhr
   burl <- asks baseUrl
   liftIO $ performXhr xhr burl req
   resp <- toResponse xhr
 
-  let status = statusCode (responseStatusCode resp)
-  unless (status >= 200 && status < 300) $ do
+  let status = responseStatusCode resp
+      goodStatus = case acceptStatus of
+        Nothing -> statusIsSuccessful status
+        Just good -> status `elem` good
+  unless goodStatus $ do
     let f b = (burl, BL.toStrict $ toLazyByteString b)
     throwError $ FailureResponse (bimap (const ()) f req) resp