servant-client-ghcjs: Fix performRequest function

Fix performRequest function to be compatible with the latest
servant-client-core RunClient typeclass
This commit is contained in:
Mika Tammi 2022-02-11 20:42:03 +02:00
parent 3158809631
commit 17b55634b3
No known key found for this signature in database
GPG Key ID: BF5BDF55A9735223
2 changed files with 18 additions and 5 deletions

10
changelog.d/1529 Normal file
View File

@ -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.
}

View File

@ -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