git.iko.soy/typeable/servant
on master help sign in
servant-client-ghcjs: Fix performRequest function
17b5563Mika Tammi
changelog.d/1529new file+10
compare with master
unifiedsplit
@@ -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/src/Servant/Client/Internal/XhrClient.hs+8−5
@@ -120,7 +120,7 @@ instance Exception StreamingNotSupportedException where
120 displayException _ = "streamingRequest: streaming is not supported!"
120 displayException _ = "streamingRequest: streaming is not supported!"
121
121
122instance RunClient ClientM where
122instance RunClient ClientM where
123− runRequest = performRequest
123+ runRequestAcceptStatus = performRequest
124 throwClientError = throwError
124 throwClientError = throwError
125
125
126runClientMOrigin :: ClientM a -> ClientEnv -> IO (Either ClientError a)
126runClientMOrigin :: ClientM a -> ClientEnv -> IO (Either ClientError a)
@@ -152,15 +152,18 @@ runClientM m = do
152
152
153 runClientMOrigin m (ClientEnv (BaseUrl protocol hostname port ""))
153 runClientMOrigin m (ClientEnv (BaseUrl protocol hostname port ""))
154
154
155−performRequest :: Request -> ClientM Response
155+performRequest :: Maybe [Status] -> Request -> ClientM Response
156−performRequest req = do
156+performRequest acceptStatus req = do
157 xhr <- liftIO initXhr
157 xhr <- liftIO initXhr
158 burl <- asks baseUrl
158 burl <- asks baseUrl
159 liftIO $ performXhr xhr burl req
159 liftIO $ performXhr xhr burl req
160 resp <- toResponse xhr
160 resp <- toResponse xhr
161
161
162− let status = statusCode (responseStatusCode resp)
162+ let status = responseStatusCode resp
163− unless (status >= 200 && status < 300) $ do
163+ goodStatus = case acceptStatus of
164+ Nothing -> statusIsSuccessful status
165+ Just good -> status `elem` good
166+ unless goodStatus $ do
164 let f b = (burl, BL.toStrict $ toLazyByteString b)
167 let f b = (burl, BL.toStrict $ toLazyByteString b)
165 throwError $ FailureResponse (bimap (const ()) f req) resp
168 throwError $ FailureResponse (bimap (const ()) f req) resp
166
169