Merge pull request #249 from haskell-servant/jkarni/clientCodes

More generous acceptable status codes for servant-client

servant-client/CHANGELOG.md

@@ -6,6 +6,7 @@ HEAD
 * Added support for `path` on `BaseUrl`.
 * `client` now takes an explicit `Manager` argument.
 * Use `http-api-data` instead of `Servant.Common.Text`
+* Client functions now consider any 2xx succesful.
 
 0.4.1
 -----

servant-client/src/Servant/Client.hs

@@ -130,10 +130,8 @@ instance
   (MimeUnrender ct a, cts' ~ (ct ': cts)) => HasClient (Delete cts' a) where
   type Client (Delete cts' a) = ExceptT ServantError IO a
   clientWithRoute Proxy req baseurl manager =
-    snd <$> performRequestCT (Proxy :: Proxy ct) H.methodDelete req [200, 202] baseurl manager
+    snd <$> performRequestCT (Proxy :: Proxy ct) H.methodDelete req baseurl manager
 
--- | If you have a 'Delete xs ()' endpoint, the client expects a 204 No Content
--- HTTP header.
 instance
 #if MIN_VERSION_base(4,8,0)
          {-# OVERLAPPING #-}
@@ -141,7 +139,7 @@ instance
   HasClient (Delete cts ()) where
   type Client (Delete cts ()) = ExceptT ServantError IO ()
   clientWithRoute Proxy req baseurl manager =
-    void $ performRequestNoBody H.methodDelete req [204] baseurl manager
+    void $ performRequestNoBody H.methodDelete req baseurl manager
 
 -- | If you have a 'Delete xs (Headers ls x)' endpoint, the client expects the
 -- corresponding headers.
@@ -153,7 +151,7 @@ instance
   ) => HasClient (Delete cts' (Headers ls a)) where
   type Client (Delete cts' (Headers ls a)) = ExceptT ServantError IO (Headers ls a)
   clientWithRoute Proxy req baseurl manager = do
-    (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodDelete req [200, 202] baseurl manager
+    (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodDelete req baseurl manager
     return $ Headers { getResponse = resp
                      , getHeadersHList = buildHeadersTo hdrs
                      }
@@ -169,10 +167,8 @@ instance
   (MimeUnrender ct result) => HasClient (Get (ct ': cts) result) where
   type Client (Get (ct ': cts) result) = ExceptT ServantError IO result
   clientWithRoute Proxy req baseurl manager =
-    snd <$> performRequestCT (Proxy :: Proxy ct) H.methodGet req [200, 203] baseurl manager
+    snd <$> performRequestCT (Proxy :: Proxy ct) H.methodGet req baseurl manager
 
--- | If you have a 'Get xs ()' endpoint, the client expects a 204 No Content
--- HTTP status.
 instance
 #if MIN_VERSION_base(4,8,0)
          {-# OVERLAPPING #-}
@@ -180,7 +176,7 @@ instance
   HasClient (Get (ct ': cts) ()) where
   type Client (Get (ct ': cts) ()) = ExceptT ServantError IO ()
   clientWithRoute Proxy req baseurl manager =
-    performRequestNoBody H.methodGet req [204] baseurl manager
+    performRequestNoBody H.methodGet req baseurl manager
 
 -- | If you have a 'Get xs (Headers ls x)' endpoint, the client expects the
 -- corresponding headers.
@@ -192,7 +188,7 @@ instance
   ) => HasClient (Get (ct ': cts) (Headers ls a)) where
   type Client (Get (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a)
   clientWithRoute Proxy req baseurl manager = do
-    (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodGet req [200, 203, 204] baseurl manager
+    (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodGet req baseurl manager
     return $ Headers { getResponse = resp
                      , getHeadersHList = buildHeadersTo hdrs
                      }
@@ -251,10 +247,8 @@ instance
   (MimeUnrender ct a) => HasClient (Post (ct ': cts) a) where
   type Client (Post (ct ': cts) a) = ExceptT ServantError IO a
   clientWithRoute Proxy req baseurl manager =
-    snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPost req [200,201] baseurl manager
+    snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPost req baseurl manager
 
--- | If you have a 'Post xs ()' endpoint, the client expects a 204 No Content
--- HTTP header.
 instance
 #if MIN_VERSION_base(4,8,0)
          {-# OVERLAPPING #-}
@@ -262,7 +256,7 @@ instance
   HasClient (Post (ct ': cts) ()) where
   type Client (Post (ct ': cts) ()) = ExceptT ServantError IO ()
   clientWithRoute Proxy req baseurl manager =
-    void $ performRequestNoBody H.methodPost req [204] baseurl manager
+    void $ performRequestNoBody H.methodPost req baseurl manager
 
 -- | If you have a 'Post xs (Headers ls x)' endpoint, the client expects the
 -- corresponding headers.
@@ -274,7 +268,7 @@ instance
   ) => HasClient (Post (ct ': cts) (Headers ls a)) where
   type Client (Post (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a)
   clientWithRoute Proxy req baseurl manager = do
-    (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPost req [200, 201] baseurl manager
+    (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPost req baseurl manager
     return $ Headers { getResponse = resp
                      , getHeadersHList = buildHeadersTo hdrs
                      }
@@ -290,10 +284,8 @@ instance
   (MimeUnrender ct a) => HasClient (Put (ct ': cts) a) where
   type Client (Put (ct ': cts) a) = ExceptT ServantError IO a
   clientWithRoute Proxy req baseurl manager =
-    snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPut req [200,201] baseurl manager
+    snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPut req baseurl manager
 
--- | If you have a 'Put xs ()' endpoint, the client expects a 204 No Content
--- HTTP header.
 instance
 #if MIN_VERSION_base(4,8,0)
          {-# OVERLAPPING #-}
@@ -301,7 +293,7 @@ instance
   HasClient (Put (ct ': cts) ()) where
   type Client (Put (ct ': cts) ()) = ExceptT ServantError IO ()
   clientWithRoute Proxy req baseurl manager =
-    void $ performRequestNoBody H.methodPut req [204] baseurl manager
+    void $ performRequestNoBody H.methodPut req baseurl manager
 
 -- | If you have a 'Put xs (Headers ls x)' endpoint, the client expects the
 -- corresponding headers.
@@ -313,7 +305,7 @@ instance
   ) => HasClient (Put (ct ': cts) (Headers ls a)) where
   type Client (Put (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a)
   clientWithRoute Proxy req baseurl manager= do
-    (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPut req [200, 201] baseurl manager
+    (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPut req baseurl manager
     return $ Headers { getResponse = resp
                      , getHeadersHList = buildHeadersTo hdrs
                      }
@@ -329,10 +321,8 @@ instance
   (MimeUnrender ct a) => HasClient (Patch (ct ': cts) a) where
   type Client (Patch (ct ': cts) a) = ExceptT ServantError IO a
   clientWithRoute Proxy req baseurl manager =
-    snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPatch req [200,201] baseurl manager
+    snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPatch req baseurl manager
 
--- | If you have a 'Patch xs ()' endpoint, the client expects a 204 No Content
--- HTTP header.
 instance
 #if MIN_VERSION_base(4,8,0)
          {-# OVERLAPPING #-}
@@ -340,7 +330,7 @@ instance
   HasClient (Patch (ct ': cts) ()) where
   type Client (Patch (ct ': cts) ()) = ExceptT ServantError IO ()
   clientWithRoute Proxy req baseurl manager =
-    void $ performRequestNoBody H.methodPatch req [204] baseurl manager
+    void $ performRequestNoBody H.methodPatch req baseurl manager
 
 -- | If you have a 'Patch xs (Headers ls x)' endpoint, the client expects the
 -- corresponding headers.
@@ -352,7 +342,7 @@ instance
   ) => HasClient (Patch (ct ': cts) (Headers ls a)) where
   type Client (Patch (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a)
   clientWithRoute Proxy req baseurl manager = do
-    (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPatch req [200, 201, 204] baseurl manager
+    (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPatch req baseurl manager
     return $ Headers { getResponse = resp
                      , getHeadersHList = buildHeadersTo hdrs
                      }
@@ -623,7 +613,7 @@ instance HasClient Raw where
 
   clientWithRoute :: Proxy Raw -> Req -> BaseUrl -> Manager -> Client Raw
   clientWithRoute Proxy req baseurl manager httpMethod = do
-    performRequest httpMethod req (const True) baseurl manager
+    performRequest httpMethod req baseurl manager
 
 -- | If you use a 'ReqBody' in one of your endpoints in your API,
 -- the corresponding querying function will automatically take

servant-client/src/Servant/Common/Req.hs

@@ -131,10 +131,10 @@ displayHttpRequest :: Method -> String
 displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request"
 
 
-performRequest :: Method -> Req -> (Int -> Bool) -> BaseUrl -> Manager
+performRequest :: Method -> Req -> BaseUrl -> Manager
                -> ExceptT ServantError IO ( Int, ByteString, MediaType
                                           , [HTTP.Header], Response ByteString)
-performRequest reqMethod req isWantedStatus reqHost manager = do
+performRequest reqMethod req reqHost manager = do
   partialRequest <- liftIO $ reqToRequest req reqHost
 
   let request = partialRequest { Client.method = reqMethod
@@ -156,25 +156,25 @@ performRequest reqMethod req isWantedStatus reqHost manager = do
                  Just t -> case parseAccept t of
                    Nothing -> throwE $ InvalidContentTypeHeader (cs t) body
                    Just t' -> pure t'
-      unless (isWantedStatus status_code) $
+      unless (status_code >= 200 && status_code < 300) $
         throwE $ FailureResponse status ct body
       return (status_code, body, ct, hrds, response)
 
 
 performRequestCT :: MimeUnrender ct result =>
-  Proxy ct -> Method -> Req -> [Int] -> BaseUrl -> Manager -> ExceptT ServantError IO ([HTTP.Header], result)
-performRequestCT ct reqMethod req wantedStatus reqHost manager = do
+  Proxy ct -> Method -> Req -> BaseUrl -> Manager -> ExceptT ServantError IO ([HTTP.Header], result)
+performRequestCT ct reqMethod req reqHost manager = do
   let acceptCT = contentType ct
   (_status, respBody, respCT, hrds, _response) <-
-    performRequest reqMethod (req { reqAccept = [acceptCT] }) (`elem` wantedStatus) reqHost manager
+    performRequest reqMethod (req { reqAccept = [acceptCT] }) reqHost manager
   unless (matches respCT (acceptCT)) $ throwE $ UnsupportedContentType respCT respBody
   case mimeUnrender ct respBody of
     Left err -> throwE $ DecodeFailure err respCT respBody
     Right val -> return (hrds, val)
 
-performRequestNoBody :: Method -> Req -> [Int] -> BaseUrl -> Manager -> ExceptT ServantError IO ()
-performRequestNoBody reqMethod req wantedStatus reqHost manager =
-  void $ performRequest reqMethod req (`elem` wantedStatus) reqHost manager
+performRequestNoBody :: Method -> Req -> BaseUrl -> Manager -> ExceptT ServantError IO ()
+performRequestNoBody reqMethod req reqHost manager =
+  void $ performRequest reqMethod req reqHost manager
 
 catchConnectionError :: IO a -> IO (Either ServantError a)
 catchConnectionError action =

servant-client/test/Servant/ClientSpec.hs

@@ -226,15 +226,14 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
           C.responseBody response `shouldBe` body
           C.responseStatus response `shouldBe` ok200
 
-    it "Servant.API.Raw on failure" $ \(_, baseUrl) -> do
+    it "Servant.API.Raw should return a Left in case of failure" $ \(_, baseUrl) -> do
       let getRawFailure = getNth (Proxy :: Proxy 11) $ client api baseUrl manager
       res <- runExceptT (getRawFailure methodGet)
       case res of
-        Left e -> assertFailure $ show e
-        Right (code, body, ct, _, response) -> do
-          (code, body, ct) `shouldBe` (400, "rawFailure", "application"//"octet-stream")
-          C.responseBody response `shouldBe` body
-          C.responseStatus response `shouldBe` badRequest400
+        Right _ -> assertFailure "expected Left, but got Right"
+        Left e -> do
+          Servant.Client.responseStatus e `shouldBe` status400
+          Servant.Client.responseBody e `shouldBe` "rawFailure"
 
     it "Returns headers appropriately" $ \(_, baseUrl) -> do
       let getRespHeaders = getNth (Proxy :: Proxy 13) $ client api baseUrl manager
@@ -349,14 +348,14 @@ pathGen = fmap NonEmpty path
 class GetNth (n :: Nat) a b | n a -> b where
     getNth :: Proxy n -> a -> b
 
-instance 
+instance
 #if MIN_VERSION_base(4,8,0)
          {-# OVERLAPPING #-}
 #endif
   GetNth 0 (x :<|> y) x where
       getNth _ (x :<|> _) = x
 
-instance 
+instance
 #if MIN_VERSION_base(4,8,0)
          {-# OVERLAPPING #-}
 #endif
@@ -366,14 +365,14 @@ instance
 class GetLast a b | a -> b where
     getLast :: a -> b
 
-instance 
+instance
 #if MIN_VERSION_base(4,8,0)
          {-# OVERLAPPING #-}
 #endif
   (GetLast b c) => GetLast (a :<|> b) c where
       getLast (_ :<|> b) = getLast b
 
-instance 
+instance
 #if MIN_VERSION_base(4,8,0)
          {-# OVERLAPPING #-}
 #endif