Derive HasClient good response status from Verb status (#1469)

Author: marinelli

changelog.d/1469

@@ -0,0 +1,11 @@
+synopsis: Derive HasClient good response status from Verb status
+prs: #1469
+description: {
+`HasClient` instances for the `Verb` datatype use `runRequest` in
+`clientWithRoute` definitions.
+This means that a request performed with `runClientM` will be successful if and
+only if the endpoint specify a response status code >=200 and <300.
+This change replaces `runRequest` with `runRequestAcceptStatus` in `Verb`
+instances for the `HasClient` class, deriving the good response status from
+the `Verb` status.
+}

servant-client-core/src/Servant/Client/Core/HasClient.hs

@@ -65,7 +65,7 @@ import           Data.Text
 import           Data.Proxy
                  (Proxy (Proxy))
 import           GHC.TypeLits
-                 (KnownSymbol, symbolVal)
+                 (KnownNat, KnownSymbol, symbolVal)
 import           Network.HTTP.Types
                  (Status)
 import qualified Network.HTTP.Types                       as H
@@ -86,6 +86,8 @@ import           Servant.API.Generic
                  , GenericServant, toServant, fromServant)
 import           Servant.API.ContentTypes
                  (contentTypes, AllMime (allMime), AllMimeUnrender (allMimeUnrender))
+import           Servant.API.Status
+                 (statusFromNat)
 import           Servant.API.TypeLevel (FragmentUnique, AtLeastOneFragment)
 import           Servant.API.Modifiers
                  (FoldRequired, RequiredArgument, foldRequiredArgument)
@@ -250,29 +252,32 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient m sublayout)
 instance {-# OVERLAPPABLE #-}
   -- Note [Non-Empty Content Types]
   ( RunClient m, MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)
+  , KnownNat status
   ) => HasClient m (Verb method status cts' a) where
   type Client m (Verb method status cts' a) = m a
   clientWithRoute _pm Proxy req = do
-    response <- runRequest req
+    response <- runRequestAcceptStatus (Just [status]) req
       { requestAccept = fromList $ toList accept
       , requestMethod = method
       }
     response `decodedAs` (Proxy :: Proxy ct)
     where
       accept = contentTypes (Proxy :: Proxy ct)
       method = reflectMethod (Proxy :: Proxy method)
+      status = statusFromNat (Proxy :: Proxy status)
 
   hoistClientMonad _ _ f ma = f ma
 
 instance {-# OVERLAPPING #-}
-  ( RunClient m, ReflectMethod method
+  ( RunClient m, ReflectMethod method, KnownNat status
   ) => HasClient m (Verb method status cts NoContent) where
   type Client m (Verb method status cts NoContent)
     = m NoContent
   clientWithRoute _pm Proxy req = do
-    _response <- runRequest req { requestMethod = method }
+    _response <- runRequestAcceptStatus (Just [status]) req { requestMethod = method }
     return NoContent
       where method = reflectMethod (Proxy :: Proxy method)
+            status = statusFromNat (Proxy :: Proxy status)
 
   hoistClientMonad _ _ f ma = f ma
 
@@ -289,36 +294,40 @@ instance (RunClient m, ReflectMethod method) =>
 
 instance {-# OVERLAPPING #-}
   -- Note [Non-Empty Content Types]
-  ( RunClient m, MimeUnrender ct a, BuildHeadersTo ls
+  ( RunClient m, MimeUnrender ct a, BuildHeadersTo ls, KnownNat status
   , ReflectMethod method, cts' ~ (ct ': cts)
   ) => HasClient m (Verb method status cts' (Headers ls a)) where
   type Client m (Verb method status cts' (Headers ls a))
     = m (Headers ls a)
   clientWithRoute _pm Proxy req = do
-    response <- runRequest req
+    response <- runRequestAcceptStatus (Just [status]) req
        { requestMethod = method
        , requestAccept = fromList $ toList accept
        }
     val <- response `decodedAs` (Proxy :: Proxy ct)
     return $ Headers { getResponse = val
                      , getHeadersHList = buildHeadersTo . toList $ responseHeaders response
                      }
-      where method = reflectMethod (Proxy :: Proxy method)
-            accept = contentTypes (Proxy :: Proxy ct)
+    where
+      method = reflectMethod (Proxy :: Proxy method)
+      accept = contentTypes (Proxy :: Proxy ct)
+      status = statusFromNat (Proxy :: Proxy status)
 
   hoistClientMonad _ _ f ma = f ma
 
 instance {-# OVERLAPPING #-}
-  ( RunClient m, BuildHeadersTo ls, ReflectMethod method
+  ( RunClient m, BuildHeadersTo ls, ReflectMethod method, KnownNat status
   ) => HasClient m (Verb method status cts (Headers ls NoContent)) where
   type Client m (Verb method status cts (Headers ls NoContent))
     = m (Headers ls NoContent)
   clientWithRoute _pm Proxy req = do
-    let method = reflectMethod (Proxy :: Proxy method)
-    response <- runRequest req { requestMethod = method }
+    response <- runRequestAcceptStatus (Just [status]) req { requestMethod = method }
     return $ Headers { getResponse = NoContent
                      , getHeadersHList = buildHeadersTo . toList $ responseHeaders response
                      }
+    where
+      method = reflectMethod (Proxy :: Proxy method)
+      status = statusFromNat (Proxy :: Proxy status)
 
   hoistClientMonad _ _ f ma = f ma
 
@@ -784,7 +793,7 @@ instance ( HasClient m api
 
 -- | Ignore @'Fragment'@ in client functions.
 -- See <https://ietf.org/rfc/rfc2616.html#section-15.1.3> for more details.
--- 
+--
 -- Example:
 --
 -- > type MyApi = "books" :> Fragment Text :> Get '[JSON] [Book]
@@ -801,7 +810,7 @@ instance (AtLeastOneFragment api, FragmentUnique (Fragment a :> api), HasClient
 
   type Client m (Fragment a :> api) = Client m api
 
-  clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api) 
+  clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api)
 
   hoistClientMonad pm _ = hoistClientMonad pm (Proxy :: Proxy api)
 

servant-client/servant-client.cabal

@@ -89,6 +89,7 @@ test-suite spec
   main-is: Spec.hs
   other-modules:
       Servant.BasicAuthSpec
+      Servant.BrokenSpec
       Servant.ClientTestUtils
       Servant.ConnectionErrorSpec
       Servant.FailSpec

servant-client/src/Servant/Client/Internal/HttpClient.hs

@@ -63,7 +63,7 @@ import           GHC.Generics
 import           Network.HTTP.Media
                  (renderHeader)
 import           Network.HTTP.Types
-                 (hContentType, renderQuery, statusCode, urlEncode, Status)
+                 (hContentType, renderQuery, statusIsSuccessful, urlEncode, Status)
 import           Servant.Client.Core
 
 import qualified Network.HTTP.Client         as Client
@@ -179,10 +179,9 @@ performRequest acceptStatus req = do
 
   response <- maybe (requestWithoutCookieJar m request) (requestWithCookieJar m request) cookieJar'
   let status = Client.responseStatus response
-      status_code = statusCode status
       ourResponse = clientResponseToResponse id response
       goodStatus = case acceptStatus of
-        Nothing -> status_code >= 200 && status_code < 300
+        Nothing -> statusIsSuccessful status
         Just good -> status `elem` good
   unless goodStatus $ do
     throwError $ mkFailureResponse burl req ourResponse

servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs

@@ -47,7 +47,7 @@ import           Data.Time.Clock
                  (getCurrentTime)
 import           GHC.Generics
 import           Network.HTTP.Types
-                 (Status, statusCode)
+                 (Status, statusIsSuccessful)
 
 import qualified Network.HTTP.Client                as Client
 
@@ -163,10 +163,9 @@ performRequest acceptStatus req = do
         now' <- getCurrentTime
         atomically $ modifyTVar' cj (fst . Client.updateCookieJar response request now')
       let status = Client.responseStatus response
-          status_code = statusCode status
           ourResponse = clientResponseToResponse id response
           goodStatus = case acceptStatus of
-            Nothing -> status_code >= 200 && status_code < 300
+            Nothing -> statusIsSuccessful status
             Just good -> status `elem` good
       unless goodStatus $ do
         throwError $ mkFailureResponse burl req ourResponse
@@ -182,10 +181,9 @@ performWithStreamingRequest req k = do
   ClientM $ lift $ lift $ Codensity $ \k1 ->
       Client.withResponse request m $ \res -> do
           let status = Client.responseStatus res
-              status_code = statusCode status
 
           -- we throw FailureResponse in IO :(
-          unless (status_code >= 200 && status_code < 300) $ do
+          unless (statusIsSuccessful status) $ do
               b <- BSL.fromChunks <$> Client.brConsume (Client.responseBody res)
               throwIO $ mkFailureResponse burl req (clientResponseToResponse (const b) res)
 

servant-client/test/Servant/BrokenSpec.hs

@@ -0,0 +1,71 @@
+{-# LANGUAGE DataKinds                   #-}
+{-# LANGUAGE TypeOperators               #-}
+{-# OPTIONS_GHC -freduction-depth=100    #-}
+{-# OPTIONS_GHC -fno-warn-orphans        #-}
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+
+module Servant.BrokenSpec (spec) where
+
+import           Prelude ()
+import           Prelude.Compat
+
+import           Data.Monoid ()
+import           Data.Proxy
+import qualified Network.HTTP.Types as HTTP
+import           Test.Hspec
+
+import           Servant.API
+                 ((:<|>) ((:<|>)), (:>), JSON, Verb, Get, StdMethod (GET))
+import           Servant.Client
+import           Servant.ClientTestUtils
+import           Servant.Server
+
+-- * api for testing inconsistencies between client and server
+
+type Get201 = Verb 'GET 201
+type Get301 = Verb 'GET 301
+
+type BrokenAPI =
+  -- the server should respond with 200, but returns 201
+       "get200" :> Get201 '[JSON] ()
+  -- the server should respond with 307, but returns 301
+  :<|> "get307" :> Get301 '[JSON] ()
+
+brokenApi :: Proxy BrokenAPI
+brokenApi = Proxy
+
+brokenServer :: Application
+brokenServer = serve brokenApi (pure () :<|> pure ())
+
+type PublicAPI =
+  -- the client expects 200
+       "get200" :> Get '[JSON] ()
+  -- the client expects 307
+  :<|> "get307" :> Get307 '[JSON] ()
+
+publicApi :: Proxy PublicAPI
+publicApi = Proxy
+
+get200Client :: ClientM ()
+get307Client :: ClientM ()
+get200Client :<|> get307Client = client publicApi
+
+
+spec :: Spec
+spec = describe "Servant.BrokenSpec" $ do
+    brokenSpec
+
+brokenSpec :: Spec
+brokenSpec = beforeAll (startWaiApp brokenServer) $ afterAll endWaiApp $ do
+    context "client returns errors for inconsistencies between client and server api" $ do
+      it "reports FailureResponse with wrong 2xx status code" $ \(_, baseUrl) -> do
+        res <- runClient get200Client baseUrl
+        case res of
+          Left (FailureResponse _ r) | responseStatusCode r == HTTP.status201 -> return ()
+          _ -> fail $ "expected 201 broken response, but got " <> show res
+
+      it "reports FailureResponse with wrong 3xx status code" $ \(_, baseUrl) -> do
+        res <- runClient get307Client baseUrl
+        case res of
+          Left (FailureResponse _ r) | responseStatusCode r == HTTP.status301 -> return ()
+          _ -> fail $ "expected 301 broken response, but got " <> show res

servant-client/test/Servant/ClientTestUtils.hs

@@ -64,7 +64,7 @@ import           Servant.API
                  JSON, MimeRender (mimeRender), MimeUnrender (mimeUnrender),
                  NoContent (NoContent), PlainText, Post, QueryFlag, QueryParam,
                  QueryParams, Raw, ReqBody, StdMethod (GET), ToHttpApiData (..), UVerb, Union,
-                 WithStatus (WithStatus), NamedRoutes, addHeader)
+                 Verb, WithStatus (WithStatus), NamedRoutes, addHeader)
 import           Servant.API.Generic ((:-))
 import           Servant.Client
 import qualified Servant.Client.Core.Auth         as Auth
@@ -118,9 +118,16 @@ data OtherRoutes mode = OtherRoutes
   { something :: mode :- "something" :> Get '[JSON] [String]
   } deriving Generic
 
+-- Get for HTTP 307 Temporary Redirect
+type Get307 = Verb 'GET 307
+
 type Api =
   Get '[JSON] Person
   :<|> "get" :> Get '[JSON] Person
+  -- This endpoint returns a response with status code 307 Temporary Redirect,
+  -- different from the ones in the 2xx successful class, to test derivation
+  -- of clients' api.
+  :<|> "get307" :> Get307 '[PlainText] Text
   :<|> "deleteEmpty" :> DeleteNoContent
   :<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person
   :<|> "captureAll" :> CaptureAll "names" String :> Get '[JSON] [Person]
@@ -154,12 +161,12 @@ type Api =
   :<|> "uverb-get-created" :> UVerb 'GET '[PlainText] '[WithStatus 201 Person]
   :<|> NamedRoutes RecordRoutes
 
-
 api :: Proxy Api
 api = Proxy
 
 getRoot         :: ClientM Person
 getGet          :: ClientM Person
+getGet307       :: ClientM Text
 getDeleteEmpty  :: ClientM NoContent
 getCapture      :: String -> ClientM Person
 getCaptureAll   :: [String] -> ClientM [Person]
@@ -186,6 +193,7 @@ recordRoutes :: RecordRoutes (AsClientT ClientM)
 
 getRoot
   :<|> getGet
+  :<|> getGet307
   :<|> getDeleteEmpty
   :<|> getCapture
   :<|> getCaptureAll
@@ -212,6 +220,7 @@ server :: Application
 server = serve api (
        return carol
   :<|> return alice
+  :<|> return "redirecting"
   :<|> return NoContent
   :<|> (\ name -> return $ Person name 0)
   :<|> (\ names -> return (zipWith Person names [0..]))
@@ -252,6 +261,8 @@ server = serve api (
          }
   )
 
+-- * api for testing failures
+
 type FailApi =
        "get" :> Raw
   :<|> "capture" :> Capture "name" String :> Raw
@@ -266,7 +277,7 @@ failServer = serve failApi (
   :<|> (\ _capture -> Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "application/json")] "")
   :<|> (Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "fooooo")] "")
   :<|> (Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "application/x-www-form-urlencoded"), ("X-Example1", "1"), ("X-Example2", "foo")] "")
- )
+  )
 
 -- * basic auth stuff
 

servant-client/test/Servant/FailSpec.hs

@@ -38,14 +38,14 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
 
     context "client returns errors appropriately" $ do
       it "reports FailureResponse" $ \(_, baseUrl) -> do
-        let (_ :<|> _ :<|> getDeleteEmpty :<|> _) = client api
+        let (_ :<|> _ :<|> _ :<|> getDeleteEmpty :<|> _) = client api
         Left res <- runClient getDeleteEmpty baseUrl
         case res of
           FailureResponse _ r | responseStatusCode r == HTTP.status404 -> return ()
           _ -> fail $ "expected 404 response, but got " <> show res
 
       it "reports DecodeFailure" $ \(_, baseUrl) -> do
-        let (_ :<|> _ :<|> _ :<|> getCapture :<|> _) = client api
+        let (_ :<|> _ :<|> _ :<|> _ :<|> getCapture :<|> _) = client api
         Left res <- runClient (getCapture "foo") baseUrl
         case res of
           DecodeFailure _ _ -> return ()
@@ -72,7 +72,7 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
           _ -> fail $ "expected UnsupportedContentType, but got " <> show res
 
       it "reports InvalidContentTypeHeader" $ \(_, baseUrl) -> do
-        let (_ :<|> _ :<|> _ :<|> _ :<|> _ :<|> getBody :<|> _) = client api
+        let (_ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> getBody :<|> _) = client api
         Left res <- runClient (getBody alice) baseUrl
         case res of
           InvalidContentTypeHeader _ -> return ()