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/servant-client-ghcjs.cabal b/servant-client-ghcjs/servant-client-ghcjs.cabal index 7249dc21..26d3aa78 100644 --- 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 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