Merge pull request #1529 from purefunsolutions/fix-servant-client-ghc…

…js-for-servant-0.19 Fix servant-client-ghcjs for servant 0.19
haskell-servant · Feb 14, 2022 · d35b3e9 · d35b3e9
2 parents 002fa21 + 17b5563
commit d35b3e9
Show file tree

Hide file tree

Showing 3 changed files with 19 additions and 6 deletions.
diff --git a/changelog.d/1529 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/servant-client-ghcjs.cabal b/servant-client-ghcjs/servant-client-ghcjs.cabal
@@ -38,7 +38,7 @@ library
     Servant.Client.Internal.XhrClient
 
   build-depends:
-      base                >=4.11    && <4.12
+      base                >=4.11    && <5
     , bytestring          >=0.10    && <0.12
     , case-insensitive    >=1.2.0.0 && <1.3.0.0
     , containers          >=0.5     && <0.7

diff --git 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