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

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

View file

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

View file

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

View file

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

View file

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

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

View file

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

View file

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

View file

@ -59,11 +59,15 @@ spec = describe "Servant.SuccessSpec" $ do
successSpec :: Spec successSpec :: Spec
successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do 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 describe "Servant.API.Delete" $ do
it "allows empty content type" $ \(_, baseUrl) -> 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 it "Servant.API.Fragment" $ \(_, baseUrl) -> do
left id <$> runClient getFragment baseUrl `shouldReturn` Right alice left id <$> runClient getFragment baseUrl `shouldReturn` Right alice
it "Servant.API.Raw on success" $ \(_, baseUrl) -> do it "Servant.API.Raw on success" $ \(_, baseUrl) -> do
res <- runClient (getRawSuccess HTTP.methodGet) baseUrl res <- runClient (getRawSuccess HTTP.methodGet) baseUrl
case res of 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. -- 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 -- 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 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 res <- runClientM (getRawSuccessPassHeaders HTTP.methodGet) clientEnv
case res of case res of
Left e -> Left e ->

View file

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

View file

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

View file

@ -1,10 +1,15 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
-- Flexible instances is necessary on GHC 8.4 and earlier -- Flexible instances is necessary on GHC 8.4 and earlier
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Servant.API.Status where module Servant.API.Status where
import GHC.TypeLits (KnownNat, natVal)
import Network.HTTP.Types.Status 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 -- | Witness that a type-level natural number corresponds to a HTTP status code
class KnownNat n => KnownStatus n where class KnownNat n => KnownStatus n where