eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

Merge pull request #1529 from purefunsolutions/fix-servant-client-ghcjs-for-servant-0.19

Browse source 
Fix servant-client-ghcjs for servant 0.19
This commit is contained in:
Gaël Deest 2022-02-14 16:39:00 +01:00 committed by GitHub
commit d35b3e9b70
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
3 changed files with 19 additions and 6 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

2
servant-client-ghcjs/servant-client-ghcjs.cabal
View file

@ -38,7 +38,7 @@ library
Servant.Client.Internal.XhrClient Servant.Client.Internal.XhrClient
build-depends: build-depends:
base >=4.11 && <4.12 base >=4.11 && <5
, bytestring >=0.10 && <0.12 , bytestring >=0.10 && <0.12
, case-insensitive >=1.2.0.0 && <1.3.0.0 , case-insensitive >=1.2.0.0 && <1.3.0.0
, containers >=0.5 && <0.7 , containers >=0.5 && <0.7

13
servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hs
View file

@ -120,7 +120,7 @@ instance Exception StreamingNotSupportedException where
displayException _ = "streamingRequest: streaming is not supported!" displayException _ = "streamingRequest: streaming is not supported!"
instance RunClient ClientM where instance RunClient ClientM where
runRequest = performRequest runRequestAcceptStatus = performRequest
throwClientError = throwError throwClientError = throwError
runClientMOrigin :: ClientM a -> ClientEnv -> IO (Either ClientError a) runClientMOrigin :: ClientM a -> ClientEnv -> IO (Either ClientError a)
@ -152,15 +152,18 @@ runClientM m = do
runClientMOrigin m (ClientEnv (BaseUrl protocol hostname port "")) runClientMOrigin m (ClientEnv (BaseUrl protocol hostname port ""))
performRequest :: Request -> ClientM Response performRequest :: Maybe [Status] -> Request -> ClientM Response
performRequest req = do performRequest acceptStatus req = do
xhr <- liftIO initXhr xhr <- liftIO initXhr
burl <- asks baseUrl burl <- asks baseUrl
liftIO $ performXhr xhr burl req liftIO $ performXhr xhr burl req
resp <- toResponse xhr resp <- toResponse xhr
let status = statusCode (responseStatusCode resp) let status = responseStatusCode resp
unless (status >= 200 && status < 300) $ do goodStatus = case acceptStatus of
Nothing -> statusIsSuccessful status
Just good -> status `elem` good
unless goodStatus $ do
let f b = (burl, BL.toStrict $ toLazyByteString b) let f b = (burl, BL.toStrict $ toLazyByteString b)
throwError $ FailureResponse (bimap (const ()) f req) resp throwError $ FailureResponse (bimap (const ()) f req) resp