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

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,10 +252,11 @@ 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
       }
@@ -261,18 +264,20 @@ instance {-# OVERLAPPABLE #-}
     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,13 +294,13 @@ 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
        }
@@ -303,22 +308,26 @@ instance {-# OVERLAPPING #-}
     return $ Headers { getResponse = val
                      , getHeadersHList = buildHeadersTo . toList $ responseHeaders response
                      }
-      where method = reflectMethod (Proxy :: Proxy method)
+    where
-            accept = contentTypes (Proxy :: Proxy ct)
+      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 <- runRequestAcceptStatus (Just [status]) req { requestMethod = method }
-    response <- runRequest 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
 

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 ()

servant-client/test/Servant/SuccessSpec.hs

@@ -59,11 +59,15 @@ spec = describe "Servant.SuccessSpec" $ do
 
 successSpec :: Spec
 successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
-    it "Servant.API.Get root" $ \(_, baseUrl) -> do
+    describe "Servant.API.Get" $ do
-      left show <$> runClient getRoot baseUrl  `shouldReturn` Right carol
+      it "get root endpoint" $ \(_, baseUrl) -> do
+        left show <$> runClient getRoot baseUrl  `shouldReturn` Right carol
 
-    it "Servant.API.Get" $ \(_, baseUrl) -> do
+      it "get simple endpoint" $ \(_, baseUrl) -> do
-      left show <$> runClient getGet baseUrl  `shouldReturn` Right alice
+        left show <$> runClient getGet baseUrl  `shouldReturn` Right alice
+
+      it "get redirection endpoint" $ \(_, baseUrl) -> do
+        left show <$> runClient getGet307 baseUrl `shouldReturn` Right "redirecting"
 
     describe "Servant.API.Delete" $ do
       it "allows empty content type" $ \(_, baseUrl) -> do
@@ -111,6 +115,7 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
 
     it "Servant.API.Fragment" $ \(_, baseUrl) -> do
       left id <$> runClient getFragment baseUrl `shouldReturn` Right alice
+
     it "Servant.API.Raw on success" $ \(_, baseUrl) -> do
       res <- runClient (getRawSuccess HTTP.methodGet) baseUrl
       case res of
@@ -156,7 +161,7 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
       -- In proper situation, extra headers should probably be visible in API type.
       -- However, testing for response timeout is difficult, so we test with something which is easy to observe
       let createClientRequest url r = (defaultMakeClientRequest url r) { C.requestHeaders = [("X-Added-Header", "XXX")] }
-      let clientEnv = (mkClientEnv mgr baseUrl) { makeClientRequest = createClientRequest }
+          clientEnv = (mkClientEnv mgr baseUrl) { makeClientRequest = createClientRequest }
       res <- runClientM (getRawSuccessPassHeaders HTTP.methodGet) clientEnv
       case res of
         Left e ->

servant-http-streams/src/Servant/HttpStreams/Internal.hs

@@ -57,7 +57,7 @@ import           GHC.Generics
 import           Network.HTTP.Media
                  (renderHeader)
 import           Network.HTTP.Types
-                 (Status (..), hContentType, http11, renderQuery)
+                 (Status (..), hContentType, http11, renderQuery, statusIsSuccessful)
 import           Servant.Client.Core
 
 import qualified Network.Http.Client        as Client
@@ -160,12 +160,12 @@ performRequest acceptStatus req = do
     x <- ClientM $ lift $ lift $ Codensity $ \k -> do
         Client.sendRequest conn req' body
         Client.receiveResponse conn $ \res' body' -> do
-            let sc = Client.getStatusCode res'
+            let status = toEnum $ Client.getStatusCode res'
             lbs <- BSL.fromChunks <$> Streams.toList body'
             let res'' = clientResponseToResponse res' lbs
                 goodStatus = case acceptStatus of
-                  Nothing -> sc >= 200 && sc < 300
+                  Nothing -> statusIsSuccessful status
-                  Just good -> sc `elem` (statusCode <$> good)
+                  Just good -> status `elem` good
             if goodStatus
             then k (Right res'')
             else k (Left (mkFailureResponse burl req res''))
@@ -180,8 +180,8 @@ performWithStreamingRequest req k = do
         Client.sendRequest conn req' body
         Client.receiveResponseRaw conn $ \res' body' -> do
             -- check status code
-            let sc = Client.getStatusCode res'
+            let status = toEnum $ Client.getStatusCode res'
-            unless (sc >= 200 && sc < 300) $ do
+            unless (statusIsSuccessful status) $ do
                 lbs <- BSL.fromChunks <$> Streams.toList body'
                 throwIO $ mkFailureResponse burl req (clientResponseToResponse res' lbs)
 

servant-server/src/Servant/Server/Internal.hs

@@ -56,7 +56,7 @@ import qualified Data.Text                                  as T
 import           Data.Typeable
 import           GHC.Generics
 import           GHC.TypeLits
-                 (KnownNat, KnownSymbol, natVal, symbolVal)
+                 (KnownNat, KnownSymbol, symbolVal)
 import qualified Network.HTTP.Media                         as NHM
 import           Network.HTTP.Types                         hiding
                  (Header, ResponseHeaders)
@@ -87,6 +87,8 @@ import           Servant.API.Modifiers
                  unfoldRequestArgument)
 import           Servant.API.ResponseHeaders
                  (GetHeaders, Headers, getHeaders, getResponse)
+import           Servant.API.Status
+                 (statusFromNat)
 import qualified Servant.Types.SourceT                      as S
 import           Web.HttpApiData
                  (FromHttpApiData, parseHeader, parseQueryParam, parseUrlPiece,
@@ -298,7 +300,7 @@ instance {-# OVERLAPPABLE #-}
 
   route Proxy _ = methodRouter ([],) method (Proxy :: Proxy ctypes) status
     where method = reflectMethod (Proxy :: Proxy method)
-          status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
+          status = statusFromNat (Proxy :: Proxy status)
 
 instance {-# OVERLAPPING #-}
          ( AllCTRender ctypes a, ReflectMethod method, KnownNat status
@@ -310,7 +312,7 @@ instance {-# OVERLAPPING #-}
 
   route Proxy _ = methodRouter (\x -> (getHeaders x, getResponse x)) method (Proxy :: Proxy ctypes) status
     where method = reflectMethod (Proxy :: Proxy method)
-          status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
+          status = statusFromNat (Proxy :: Proxy status)
 
 instance (ReflectMethod method) =>
          HasServer (NoContentVerb method) context where
@@ -331,7 +333,7 @@ instance {-# OVERLAPPABLE #-}
 
   route Proxy _ = streamRouter ([],) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype)
       where method = reflectMethod (Proxy :: Proxy method)
-            status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
+            status = statusFromNat (Proxy :: Proxy status)
 
 
 instance {-# OVERLAPPING #-}
@@ -345,7 +347,7 @@ instance {-# OVERLAPPING #-}
 
   route Proxy _ = streamRouter (\x -> (getHeaders x, getResponse x)) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype)
       where method = reflectMethod (Proxy :: Proxy method)
-            status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
+            status = statusFromNat (Proxy :: Proxy status)
 
 
 streamRouter :: forall ctype a c chunk env framing. (MimeRender ctype chunk, FramingRender framing, ToSourceIO chunk a) =>

servant/src/Servant/API/Status.hs

@@ -1,10 +1,15 @@
 {-# LANGUAGE DataKinds #-}
 -- Flexible instances is necessary on GHC 8.4 and earlier
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 module Servant.API.Status where
 
+import GHC.TypeLits (KnownNat, natVal)
 import Network.HTTP.Types.Status
-import GHC.TypeLits
+
+-- | Retrieve a known or unknown Status from a KnownNat
+statusFromNat :: forall a proxy. KnownNat a => proxy a -> Status
+statusFromNat = toEnum . fromInteger . natVal
 
 -- | Witness that a type-level natural number corresponds to a HTTP status code
 class KnownNat n => KnownStatus n where