eeva
/
servant
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

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

This commit is contained in:
Giorgio Marinelli 2021-12-09 10:09:18 +01:00 committed by GitHub
parent cb294aa2b3
commit 29d2553e74
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
12 changed files with 156 additions and 44 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
changelog.d/1469 Normal file
View File

@ -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.
}

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

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

1
servant-client/servant-client.cabal
View File

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

5
servant-client/src/Servant/Client/Internal/HttpClient.hs
View File

@ -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

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

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

71
servant-client/test/Servant/BrokenSpec.hs Normal file
View File

@ -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

17
servant-client/test/Servant/ClientTestUtils.hs
View File

@ -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

6
servant-client/test/Servant/FailSpec.hs
View File

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

15
servant-client/test/Servant/SuccessSpec.hs
View File

@ -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
left show <$> runClient getRoot baseUrl `shouldReturn` Right carol
describe "Servant.API.Get" $ do
it "get root endpoint" $ \(_, baseUrl) -> do
left show <$> runClient getRoot baseUrl `shouldReturn` Right carol
it "Servant.API.Get" $ \(_, baseUrl) -> do
left show <$> runClient getGet baseUrl `shouldReturn` Right alice
it "get simple endpoint" $ \(_, baseUrl) -> do
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 ->

12
servant-http-streams/src/Servant/HttpStreams/Internal.hs
View File

@ -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
Just good -> sc `elem` (statusCode <$> good)
Nothing -> statusIsSuccessful status
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'
unless (sc >= 200 && sc < 300) $ do
let status = toEnum $ Client.getStatusCode res'
unless (statusIsSuccessful status) $ do
lbs <- BSL.fromChunks <$> Streams.toList body'
throwIO $ mkFailureResponse burl req (clientResponseToResponse res' lbs)

12
servant-server/src/Servant/Server/Internal.hs
View File

@ -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) =>

7
servant/src/Servant/API/Status.hs
View File

@ -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