on master help sign in
Merge pull request #1529 from purefunsolutions/fix-servant-client-ghcjs-for-servant-0.19

Fix servant-client-ghcjs for servant 0.19

commitd35b3e9b702ef226da8b7de3c50d0e8678a11e62 authorGaël Deest <gael.deest@tweag.io> dateMon 14 Feb 2022, 16:39 (5 years ago) parent002fa2117b5563
3 files changed+19−6
changelog.d/1529+10 servant-client-ghcjs/servant-client-ghcjs.cabal+1−1 servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hs+8−5
changelog.d/1529new file+10
@@ -0,0 +1,10 @@
1+synopsis: Fix performRequest in servant-client-ghcjs
2+prs: #1529
3+
4+description: {
5+
6+performRequest function in servant-client-ghcjs was not compatible with the
7+latest RunClient typeclass. Added the acceptStatus parameter and fixed the
8+functionality to match what servant-client provides.
9+
10+}
servant-client-ghcjs/servant-client-ghcjs.cabal+1−1
@@ -38,7 +38,7 @@ library
3838 Servant.Client.Internal.XhrClient
3939
4040 build-depends:
41− base >=4.11 && <4.12
41+ base >=4.11 && <5
4242 , bytestring >=0.10 && <0.12
4343 , case-insensitive >=1.2.0.0 && <1.3.0.0
4444 , containers >=0.5 && <0.7
servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hs+8−5
@@ -120,7 +120,7 @@ instance Exception StreamingNotSupportedException where
120120 displayException _ = "streamingRequest: streaming is not supported!"
121121
122122instance RunClient ClientM where
123− runRequest = performRequest
123+ runRequestAcceptStatus = performRequest
124124 throwClientError = throwError
125125
126126runClientMOrigin :: ClientM a -> ClientEnv -> IO (Either ClientError a)
@@ -152,15 +152,18 @@ runClientM m = do
152152
153153 runClientMOrigin m (ClientEnv (BaseUrl protocol hostname port ""))
154154
155−performRequest :: Request -> ClientM Response
156−performRequest req = do
155+performRequest :: Maybe [Status] -> Request -> ClientM Response
156+performRequest acceptStatus req = do
157157 xhr <- liftIO initXhr
158158 burl <- asks baseUrl
159159 liftIO $ performXhr xhr burl req
160160 resp <- toResponse xhr
161161
162− let status = statusCode (responseStatusCode resp)
163− unless (status >= 200 && status < 300) $ do
162+ let status = responseStatusCode resp
163+ goodStatus = case acceptStatus of
164+ Nothing -> statusIsSuccessful status
165+ Just good -> status `elem` good
166+ unless goodStatus $ do
164167 let f b = (burl, BL.toStrict $ toLazyByteString b)
165168 throwError $ FailureResponse (bimap (const ()) f req) resp
166169