29d2553 · typeable/servant

git.iko.soy/typeable/servant

on master help sign in

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

29d2553Giorgio Marinelli5 years ago

changelog.d/1469new file+11

compare with master

unifiedsplit

@@ -0,0 +1,11 @@

1+synopsis: Derive HasClient good response status from Verb status

2+prs: #1469

3+description: {

4+`HasClient` instances for the `Verb` datatype use `runRequest` in

5+`clientWithRoute` definitions.

6+This means that a request performed with `runClientM` will be successful if and

7+only if the endpoint specify a response status code >=200 and <300.

8+This change replaces `runRequest` with `runRequestAcceptStatus` in `Verb`

9+instances for the `HasClient` class, deriving the good response status from

10+the `Verb` status.

11+}

servant-client-core/src/Servant/Client/Core/HasClient.hs+22−13

@@ -65,7 +65,7 @@ import Data.Text

65import Data.Proxy

66 (Proxy (Proxy))

67import GHC.TypeLits

68− (KnownSymbol, symbolVal)

68+ (KnownNat, KnownSymbol, symbolVal)

69import Network.HTTP.Types

70 (Status)

71import qualified Network.HTTP.Types as H

@@ -86,6 +86,8 @@ import Servant.API.Generic

86 , GenericServant, toServant, fromServant)

87import Servant.API.ContentTypes

88 (contentTypes, AllMime (allMime), AllMimeUnrender (allMimeUnrender))

89+import Servant.API.Status

90+ (statusFromNat)

89import Servant.API.TypeLevel (FragmentUnique, AtLeastOneFragment)

91import Servant.API.TypeLevel (FragmentUnique, AtLeastOneFragment)

90import Servant.API.Modifiers

92import Servant.API.Modifiers

91 (FoldRequired, RequiredArgument, foldRequiredArgument)

93 (FoldRequired, RequiredArgument, foldRequiredArgument)

@@ -250,10 +252,11 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient m sublayout)

250instance {-# OVERLAPPABLE #-}

252instance {-# OVERLAPPABLE #-}

251 -- Note [Non-Empty Content Types]

253 -- Note [Non-Empty Content Types]

252 ( RunClient m, MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)

254 ( RunClient m, MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)

255+ , KnownNat status

253 ) => HasClient m (Verb method status cts' a) where

256 ) => HasClient m (Verb method status cts' a) where

254 type Client m (Verb method status cts' a) = m a

257 type Client m (Verb method status cts' a) = m a

255 clientWithRoute _pm Proxy req = do

258 clientWithRoute _pm Proxy req = do

256− response <- runRequest req

259+ response <- runRequestAcceptStatus (Just [status]) req

257 { requestAccept = fromList $ toList accept

260 { requestAccept = fromList $ toList accept

258 , requestMethod = method

261 , requestMethod = method

259 }

262 }

@@ -261,18 +264,20 @@ instance {-# OVERLAPPABLE #-}

261 where

264 where

262 accept = contentTypes (Proxy :: Proxy ct)

265 accept = contentTypes (Proxy :: Proxy ct)

263 method = reflectMethod (Proxy :: Proxy method)

266 method = reflectMethod (Proxy :: Proxy method)

267+ status = statusFromNat (Proxy :: Proxy status)

264

268

265 hoistClientMonad _ _ f ma = f ma

269 hoistClientMonad _ _ f ma = f ma

266

270

267instance {-# OVERLAPPING #-}

271instance {-# OVERLAPPING #-}

268− ( RunClient m, ReflectMethod method

272+ ( RunClient m, ReflectMethod method, KnownNat status

269 ) => HasClient m (Verb method status cts NoContent) where

273 ) => HasClient m (Verb method status cts NoContent) where

270 type Client m (Verb method status cts NoContent)

274 type Client m (Verb method status cts NoContent)

271 = m NoContent

275 = m NoContent

272 clientWithRoute _pm Proxy req = do

276 clientWithRoute _pm Proxy req = do

273− _response <- runRequest req { requestMethod = method }

277+ _response <- runRequestAcceptStatus (Just [status]) req { requestMethod = method }

274 return NoContent

278 return NoContent

275 where method = reflectMethod (Proxy :: Proxy method)

279 where method = reflectMethod (Proxy :: Proxy method)

280+ status = statusFromNat (Proxy :: Proxy status)

276

281

277 hoistClientMonad _ _ f ma = f ma

282 hoistClientMonad _ _ f ma = f ma

278

283

@@ -289,13 +294,13 @@ instance (RunClient m, ReflectMethod method) =>

289

294

290instance {-# OVERLAPPING #-}

295instance {-# OVERLAPPING #-}

291 -- Note [Non-Empty Content Types]

296 -- Note [Non-Empty Content Types]

292− ( RunClient m, MimeUnrender ct a, BuildHeadersTo ls

297+ ( RunClient m, MimeUnrender ct a, BuildHeadersTo ls, KnownNat status

293 , ReflectMethod method, cts' ~ (ct ': cts)

298 , ReflectMethod method, cts' ~ (ct ': cts)

294 ) => HasClient m (Verb method status cts' (Headers ls a)) where

299 ) => HasClient m (Verb method status cts' (Headers ls a)) where

295 type Client m (Verb method status cts' (Headers ls a))

300 type Client m (Verb method status cts' (Headers ls a))

296 = m (Headers ls a)

301 = m (Headers ls a)

297 clientWithRoute _pm Proxy req = do

302 clientWithRoute _pm Proxy req = do

298− response <- runRequest req

303+ response <- runRequestAcceptStatus (Just [status]) req

299 { requestMethod = method

304 { requestMethod = method

300 , requestAccept = fromList $ toList accept

305 , requestAccept = fromList $ toList accept

301 }

306 }

@@ -303,22 +308,26 @@ instance {-# OVERLAPPING #-}

303 return $ Headers { getResponse = val

308 return $ Headers { getResponse = val

304 , getHeadersHList = buildHeadersTo . toList $ responseHeaders response

309 , getHeadersHList = buildHeadersTo . toList $ responseHeaders response

305 }

310 }

311+ where

306− where method = reflectMethod (Proxy :: Proxy method)

312+ method = reflectMethod (Proxy :: Proxy method)

307− accept = contentTypes (Proxy :: Proxy ct)

313+ accept = contentTypes (Proxy :: Proxy ct)

314+ status = statusFromNat (Proxy :: Proxy status)

308

315

309 hoistClientMonad _ _ f ma = f ma

316 hoistClientMonad _ _ f ma = f ma

310

317

311instance {-# OVERLAPPING #-}

318instance {-# OVERLAPPING #-}

312− ( RunClient m, BuildHeadersTo ls, ReflectMethod method

319+ ( RunClient m, BuildHeadersTo ls, ReflectMethod method, KnownNat status

313 ) => HasClient m (Verb method status cts (Headers ls NoContent)) where

320 ) => HasClient m (Verb method status cts (Headers ls NoContent)) where

314 type Client m (Verb method status cts (Headers ls NoContent))

321 type Client m (Verb method status cts (Headers ls NoContent))

315 = m (Headers ls NoContent)

322 = m (Headers ls NoContent)

316 clientWithRoute _pm Proxy req = do

323 clientWithRoute _pm Proxy req = do

317− let method = reflectMethod (Proxy :: Proxy method)

318− response <- runRequest req { requestMethod = method }

324+ response <- runRequestAcceptStatus (Just [status]) req { requestMethod = method }

319 return $ Headers { getResponse = NoContent

325 return $ Headers { getResponse = NoContent

320 , getHeadersHList = buildHeadersTo . toList $ responseHeaders response

326 , getHeadersHList = buildHeadersTo . toList $ responseHeaders response

321 }

327 }

328+ where

329+ method = reflectMethod (Proxy :: Proxy method)

330+ status = statusFromNat (Proxy :: Proxy status)

322

331

323 hoistClientMonad _ _ f ma = f ma

332 hoistClientMonad _ _ f ma = f ma

324

333

@@ -784,7 +793,7 @@ instance ( HasClient m api

784

793

785-- | Ignore @'Fragment'@ in client functions.

794-- | Ignore @'Fragment'@ in client functions.

786-- See <https://ietf.org/rfc/rfc2616.html#section-15.1.3> for more details.

795-- See <https://ietf.org/rfc/rfc2616.html#section-15.1.3> for more details.

787−--

796+--

788-- Example:

797-- Example:

789--

798--

790-- > type MyApi = "books" :> Fragment Text :> Get '[JSON] [Book]

799-- > type MyApi = "books" :> Fragment Text :> Get '[JSON] [Book]

@@ -801,7 +810,7 @@ instance (AtLeastOneFragment api, FragmentUnique (Fragment a :> api), HasClient

801

810

802 type Client m (Fragment a :> api) = Client m api

811 type Client m (Fragment a :> api) = Client m api

803

812

804− clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api)

813+ clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api)

805

814

806 hoistClientMonad pm _ = hoistClientMonad pm (Proxy :: Proxy api)

815 hoistClientMonad pm _ = hoistClientMonad pm (Proxy :: Proxy api)

807

816

servant-client/servant-client.cabal+1

@@ -89,6 +89,7 @@ test-suite spec

89 main-is: Spec.hs

90 other-modules:

91 Servant.BasicAuthSpec

92+ Servant.BrokenSpec

92 Servant.ClientTestUtils

93 Servant.ClientTestUtils

93 Servant.ConnectionErrorSpec

94 Servant.ConnectionErrorSpec

94 Servant.FailSpec

95 Servant.FailSpec

servant-client/src/Servant/Client/Internal/HttpClient.hs+2−3

@@ -63,7 +63,7 @@ import GHC.Generics

63import Network.HTTP.Media

64 (renderHeader)

65import Network.HTTP.Types

66− (hContentType, renderQuery, statusCode, urlEncode, Status)

66+ (hContentType, renderQuery, statusIsSuccessful, urlEncode, Status)

67import Servant.Client.Core

69import qualified Network.HTTP.Client as Client

@@ -179,10 +179,9 @@ performRequest acceptStatus req = do

179

180 response <- maybe (requestWithoutCookieJar m request) (requestWithCookieJar m request) cookieJar'

181 let status = Client.responseStatus response

182− status_code = statusCode status

183 ourResponse = clientResponseToResponse id response

182 ourResponse = clientResponseToResponse id response

184 goodStatus = case acceptStatus of

183 goodStatus = case acceptStatus of

185− Nothing -> status_code >= 200 && status_code < 300

184+ Nothing -> statusIsSuccessful status

186 Just good -> status `elem` good

185 Just good -> status `elem` good

187 unless goodStatus $ do

186 unless goodStatus $ do

188 throwError $ mkFailureResponse burl req ourResponse

187 throwError $ mkFailureResponse burl req ourResponse

servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs+3−5

@@ -47,7 +47,7 @@ import Data.Time.Clock

47 (getCurrentTime)

48import GHC.Generics

49import Network.HTTP.Types

50− (Status, statusCode)

50+ (Status, statusIsSuccessful)

52import qualified Network.HTTP.Client as Client

@@ -163,10 +163,9 @@ performRequest acceptStatus req = do

163 now' <- getCurrentTime

164 atomically $ modifyTVar' cj (fst . Client.updateCookieJar response request now')

165 let status = Client.responseStatus response

166− status_code = statusCode status

167 ourResponse = clientResponseToResponse id response

166 ourResponse = clientResponseToResponse id response

168 goodStatus = case acceptStatus of

167 goodStatus = case acceptStatus of

169− Nothing -> status_code >= 200 && status_code < 300

168+ Nothing -> statusIsSuccessful status

170 Just good -> status `elem` good

169 Just good -> status `elem` good

171 unless goodStatus $ do

170 unless goodStatus $ do

172 throwError $ mkFailureResponse burl req ourResponse

171 throwError $ mkFailureResponse burl req ourResponse

@@ -182,10 +181,9 @@ performWithStreamingRequest req k = do

182 ClientM $ lift $ lift $ Codensity $ \k1 ->

181 ClientM $ lift $ lift $ Codensity $ \k1 ->

183 Client.withResponse request m $ \res -> do

182 Client.withResponse request m $ \res -> do

184 let status = Client.responseStatus res

183 let status = Client.responseStatus res

185− status_code = statusCode status

186

184

187 -- we throw FailureResponse in IO :(

185 -- we throw FailureResponse in IO :(

188− unless (status_code >= 200 && status_code < 300) $ do

186+ unless (statusIsSuccessful status) $ do

189 b <- BSL.fromChunks <$> Client.brConsume (Client.responseBody res)

187 b <- BSL.fromChunks <$> Client.brConsume (Client.responseBody res)

190 throwIO $ mkFailureResponse burl req (clientResponseToResponse (const b) res)

188 throwIO $ mkFailureResponse burl req (clientResponseToResponse (const b) res)

191

189

servant-client/test/Servant/BrokenSpec.hsnew file+71

@@ -0,0 +1,71 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE TypeOperators #-}

3+{-# OPTIONS_GHC -freduction-depth=100 #-}

4+{-# OPTIONS_GHC -fno-warn-orphans #-}

5+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}

7+module Servant.BrokenSpec (spec) where

9+import Prelude ()

10+import Prelude.Compat

11+

12+import Data.Monoid ()

13+import Data.Proxy

14+import qualified Network.HTTP.Types as HTTP

15+import Test.Hspec

16+

17+import Servant.API

18+ ((:<|>) ((:<|>)), (:>), JSON, Verb, Get, StdMethod (GET))

19+import Servant.Client

20+import Servant.ClientTestUtils

21+import Servant.Server

22+

23+-- * api for testing inconsistencies between client and server

24+

25+type Get201 = Verb 'GET 201

26+type Get301 = Verb 'GET 301

27+

28+type BrokenAPI =

29+ -- the server should respond with 200, but returns 201

30+ "get200" :> Get201 '[JSON] ()

31+ -- the server should respond with 307, but returns 301

32+ :<|> "get307" :> Get301 '[JSON] ()

33+

34+brokenApi :: Proxy BrokenAPI

35+brokenApi = Proxy

36+

37+brokenServer :: Application

38+brokenServer = serve brokenApi (pure () :<|> pure ())

39+

40+type PublicAPI =

41+ -- the client expects 200

42+ "get200" :> Get '[JSON] ()

43+ -- the client expects 307

44+ :<|> "get307" :> Get307 '[JSON] ()

45+

46+publicApi :: Proxy PublicAPI

47+publicApi = Proxy

48+

49+get200Client :: ClientM ()

50+get307Client :: ClientM ()

51+get200Client :<|> get307Client = client publicApi

52+

53+

54+spec :: Spec

55+spec = describe "Servant.BrokenSpec" $ do

56+ brokenSpec

57+

58+brokenSpec :: Spec

59+brokenSpec = beforeAll (startWaiApp brokenServer) $ afterAll endWaiApp $ do

60+ context "client returns errors for inconsistencies between client and server api" $ do

61+ it "reports FailureResponse with wrong 2xx status code" $ \(_, baseUrl) -> do

62+ res <- runClient get200Client baseUrl

63+ case res of

64+ Left (FailureResponse _ r) | responseStatusCode r == HTTP.status201 -> return ()

65+ _ -> fail $ "expected 201 broken response, but got " <> show res

66+

67+ it "reports FailureResponse with wrong 3xx status code" $ \(_, baseUrl) -> do

68+ res <- runClient get307Client baseUrl

69+ case res of

70+ Left (FailureResponse _ r) | responseStatusCode r == HTTP.status301 -> return ()

71+ _ -> fail $ "expected 301 broken response, but got " <> show res

servant-client/test/Servant/ClientTestUtils.hs+14−3

@@ -64,7 +64,7 @@ import Servant.API

64 JSON, MimeRender (mimeRender), MimeUnrender (mimeUnrender),

65 NoContent (NoContent), PlainText, Post, QueryFlag, QueryParam,

66 QueryParams, Raw, ReqBody, StdMethod (GET), ToHttpApiData (..), UVerb, Union,

67− WithStatus (WithStatus), NamedRoutes, addHeader)

67+ Verb, WithStatus (WithStatus), NamedRoutes, addHeader)

68import Servant.API.Generic ((:-))

69import Servant.Client

70import qualified Servant.Client.Core.Auth as Auth

@@ -118,9 +118,16 @@ data OtherRoutes mode = OtherRoutes

118 { something :: mode :- "something" :> Get '[JSON] [String]

119 } deriving Generic

120

121+-- Get for HTTP 307 Temporary Redirect

122+type Get307 = Verb 'GET 307

123+

121type Api =

124type Api =

122 Get '[JSON] Person

125 Get '[JSON] Person

123 :<|> "get" :> Get '[JSON] Person

126 :<|> "get" :> Get '[JSON] Person

127+ -- This endpoint returns a response with status code 307 Temporary Redirect,

128+ -- different from the ones in the 2xx successful class, to test derivation

129+ -- of clients' api.

130+ :<|> "get307" :> Get307 '[PlainText] Text

124 :<|> "deleteEmpty" :> DeleteNoContent

131 :<|> "deleteEmpty" :> DeleteNoContent

125 :<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person

132 :<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person

126 :<|> "captureAll" :> CaptureAll "names" String :> Get '[JSON] [Person]

133 :<|> "captureAll" :> CaptureAll "names" String :> Get '[JSON] [Person]

@@ -154,12 +161,12 @@ type Api =

154 :<|> "uverb-get-created" :> UVerb 'GET '[PlainText] '[WithStatus 201 Person]

161 :<|> "uverb-get-created" :> UVerb 'GET '[PlainText] '[WithStatus 201 Person]

155 :<|> NamedRoutes RecordRoutes

162 :<|> NamedRoutes RecordRoutes

156

163

157−

158api :: Proxy Api

164api :: Proxy Api

159api = Proxy

165api = Proxy

160

166

161getRoot :: ClientM Person

167getRoot :: ClientM Person

162getGet :: ClientM Person

168getGet :: ClientM Person

169+getGet307 :: ClientM Text

163getDeleteEmpty :: ClientM NoContent

170getDeleteEmpty :: ClientM NoContent

164getCapture :: String -> ClientM Person

171getCapture :: String -> ClientM Person

165getCaptureAll :: [String] -> ClientM [Person]

172getCaptureAll :: [String] -> ClientM [Person]

@@ -186,6 +193,7 @@ recordRoutes :: RecordRoutes (AsClientT ClientM)

186

193

187getRoot

194getRoot

188 :<|> getGet

195 :<|> getGet

196+ :<|> getGet307

189 :<|> getDeleteEmpty

197 :<|> getDeleteEmpty

190 :<|> getCapture

198 :<|> getCapture

191 :<|> getCaptureAll

199 :<|> getCaptureAll

@@ -212,6 +220,7 @@ server :: Application

212server = serve api (

220server = serve api (

213 return carol

221 return carol

214 :<|> return alice

222 :<|> return alice

223+ :<|> return "redirecting"

215 :<|> return NoContent

224 :<|> return NoContent

216 :<|> (\ name -> return $ Person name 0)

225 :<|> (\ name -> return $ Person name 0)

217 :<|> (\ names -> return (zipWith Person names [0..]))

226 :<|> (\ names -> return (zipWith Person names [0..]))

@@ -252,6 +261,8 @@ server = serve api (

252 }

261 }

253 )

262 )

254

263

264+-- * api for testing failures

265+

255type FailApi =

266type FailApi =

256 "get" :> Raw

267 "get" :> Raw

257 :<|> "capture" :> Capture "name" String :> Raw

268 :<|> "capture" :> Capture "name" String :> Raw

@@ -266,7 +277,7 @@ failServer = serve failApi (

266 :<|> (\ _capture -> Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "application/json")] "")

277 :<|> (\ _capture -> Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "application/json")] "")

267 :<|> (Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "fooooo")] "")

278 :<|> (Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "fooooo")] "")

268 :<|> (Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "application/x-www-form-urlencoded"), ("X-Example1", "1"), ("X-Example2", "foo")] "")

279 :<|> (Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "application/x-www-form-urlencoded"), ("X-Example1", "1"), ("X-Example2", "foo")] "")

269− )

280+ )

270

281

271-- * basic auth stuff

282-- * basic auth stuff

272

283

servant-client/test/Servant/FailSpec.hs+3−3

@@ -38,14 +38,14 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do

39 context "client returns errors appropriately" $ do

40 it "reports FailureResponse" $ \(_, baseUrl) -> do

41− let (_ :<|> _ :<|> getDeleteEmpty :<|> _) = client api

41+ let (_ :<|> _ :<|> _ :<|> getDeleteEmpty :<|> _) = client api

42 Left res <- runClient getDeleteEmpty baseUrl

43 case res of

44 FailureResponse _ r | responseStatusCode r == HTTP.status404 -> return ()

45 _ -> fail $ "expected 404 response, but got " <> show res

47 it "reports DecodeFailure" $ \(_, baseUrl) -> do

48− let (_ :<|> _ :<|> _ :<|> getCapture :<|> _) = client api

48+ let (_ :<|> _ :<|> _ :<|> _ :<|> getCapture :<|> _) = client api

49 Left res <- runClient (getCapture "foo") baseUrl

50 case res of

51 DecodeFailure _ _ -> return ()

@@ -72,7 +72,7 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do

72 _ -> fail $ "expected UnsupportedContentType, but got " <> show res

74 it "reports InvalidContentTypeHeader" $ \(_, baseUrl) -> do

75− let (_ :<|> _ :<|> _ :<|> _ :<|> _ :<|> getBody :<|> _) = client api

75+ let (_ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> getBody :<|> _) = client api

76 Left res <- runClient (getBody alice) baseUrl

77 case res of

78 InvalidContentTypeHeader _ -> return ()

servant-client/test/Servant/SuccessSpec.hs+10−5

@@ -59,11 +59,15 @@ spec = describe "Servant.SuccessSpec" $ do

60successSpec :: Spec

61successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do

62− it "Servant.API.Get root" $ \(_, baseUrl) -> do

62+ describe "Servant.API.Get" $ do

63+ it "get root endpoint" $ \(_, baseUrl) -> do

63− left show <$> runClient getRoot baseUrl `shouldReturn` Right carol

64+ left show <$> runClient getRoot baseUrl `shouldReturn` Right carol

65− it "Servant.API.Get" $ \(_, baseUrl) -> do

66+ it "get simple endpoint" $ \(_, baseUrl) -> do

66− left show <$> runClient getGet baseUrl `shouldReturn` Right alice

67+ left show <$> runClient getGet baseUrl `shouldReturn` Right alice

68+

69+ it "get redirection endpoint" $ \(_, baseUrl) -> do

70+ left show <$> runClient getGet307 baseUrl `shouldReturn` Right "redirecting"

68 describe "Servant.API.Delete" $ do

72 describe "Servant.API.Delete" $ do

69 it "allows empty content type" $ \(_, baseUrl) -> do

73 it "allows empty content type" $ \(_, baseUrl) -> do

@@ -111,6 +115,7 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do

111

115

112 it "Servant.API.Fragment" $ \(_, baseUrl) -> do

116 it "Servant.API.Fragment" $ \(_, baseUrl) -> do

113 left id <$> runClient getFragment baseUrl `shouldReturn` Right alice

117 left id <$> runClient getFragment baseUrl `shouldReturn` Right alice

118+

114 it "Servant.API.Raw on success" $ \(_, baseUrl) -> do

119 it "Servant.API.Raw on success" $ \(_, baseUrl) -> do

115 res <- runClient (getRawSuccess HTTP.methodGet) baseUrl

120 res <- runClient (getRawSuccess HTTP.methodGet) baseUrl

116 case res of

121 case res of

@@ -156,7 +161,7 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do

156 -- In proper situation, extra headers should probably be visible in API type.

161 -- In proper situation, extra headers should probably be visible in API type.

157 -- However, testing for response timeout is difficult, so we test with something which is easy to observe

162 -- However, testing for response timeout is difficult, so we test with something which is easy to observe

158 let createClientRequest url r = (defaultMakeClientRequest url r) { C.requestHeaders = [("X-Added-Header", "XXX")] }

163 let createClientRequest url r = (defaultMakeClientRequest url r) { C.requestHeaders = [("X-Added-Header", "XXX")] }

159− let clientEnv = (mkClientEnv mgr baseUrl) { makeClientRequest = createClientRequest }

164+ clientEnv = (mkClientEnv mgr baseUrl) { makeClientRequest = createClientRequest }

160 res <- runClientM (getRawSuccessPassHeaders HTTP.methodGet) clientEnv

165 res <- runClientM (getRawSuccessPassHeaders HTTP.methodGet) clientEnv

161 case res of

166 case res of

162 Left e ->

167 Left e ->

servant-http-streams/src/Servant/HttpStreams/Internal.hs+6−6

@@ -57,7 +57,7 @@ import GHC.Generics

57import Network.HTTP.Media

58 (renderHeader)

59import Network.HTTP.Types

60− (Status (..), hContentType, http11, renderQuery)

60+ (Status (..), hContentType, http11, renderQuery, statusIsSuccessful)

61import Servant.Client.Core

63import qualified Network.Http.Client as Client

@@ -160,12 +160,12 @@ performRequest acceptStatus req = do

160 x <- ClientM $ lift $ lift $ Codensity $ \k -> do

161 Client.sendRequest conn req' body

162 Client.receiveResponse conn $ \res' body' -> do

163− let sc = Client.getStatusCode res'

163+ let status = toEnum $ Client.getStatusCode res'

164 lbs <- BSL.fromChunks <$> Streams.toList body'

165 let res'' = clientResponseToResponse res' lbs

166 goodStatus = case acceptStatus of

167− Nothing -> sc >= 200 && sc < 300

167+ Nothing -> statusIsSuccessful status

168− Just good -> sc `elem` (statusCode <$> good)

168+ Just good -> status `elem` good

169 if goodStatus

170 then k (Right res'')

171 else k (Left (mkFailureResponse burl req res''))

@@ -180,8 +180,8 @@ performWithStreamingRequest req k = do

180 Client.sendRequest conn req' body

181 Client.receiveResponseRaw conn $ \res' body' -> do

182 -- check status code

183− let sc = Client.getStatusCode res'

183+ let status = toEnum $ Client.getStatusCode res'

184− unless (sc >= 200 && sc < 300) $ do

184+ unless (statusIsSuccessful status) $ do

185 lbs <- BSL.fromChunks <$> Streams.toList body'

186 throwIO $ mkFailureResponse burl req (clientResponseToResponse res' lbs)

187

servant-server/src/Servant/Server/Internal.hs+7−5

@@ -56,7 +56,7 @@ import qualified Data.Text as T

56import Data.Typeable

57import GHC.Generics

58import GHC.TypeLits

59− (KnownNat, KnownSymbol, natVal, symbolVal)

59+ (KnownNat, KnownSymbol, symbolVal)

60import qualified Network.HTTP.Media as NHM

61import Network.HTTP.Types hiding

62 (Header, ResponseHeaders)

@@ -87,6 +87,8 @@ import Servant.API.Modifiers

87 unfoldRequestArgument)

88import Servant.API.ResponseHeaders

89 (GetHeaders, Headers, getHeaders, getResponse)

90+import Servant.API.Status

91+ (statusFromNat)

90import qualified Servant.Types.SourceT as S

92import qualified Servant.Types.SourceT as S

91import Web.HttpApiData

93import Web.HttpApiData

92 (FromHttpApiData, parseHeader, parseQueryParam, parseUrlPiece,

94 (FromHttpApiData, parseHeader, parseQueryParam, parseUrlPiece,

@@ -298,7 +300,7 @@ instance {-# OVERLAPPABLE #-}

298

300

299 route Proxy _ = methodRouter ([],) method (Proxy :: Proxy ctypes) status

301 route Proxy _ = methodRouter ([],) method (Proxy :: Proxy ctypes) status

300 where method = reflectMethod (Proxy :: Proxy method)

302 where method = reflectMethod (Proxy :: Proxy method)

301− status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)

303+ status = statusFromNat (Proxy :: Proxy status)

302

304

303instance {-# OVERLAPPING #-}

305instance {-# OVERLAPPING #-}

304 ( AllCTRender ctypes a, ReflectMethod method, KnownNat status

306 ( AllCTRender ctypes a, ReflectMethod method, KnownNat status

@@ -310,7 +312,7 @@ instance {-# OVERLAPPING #-}

310

312

311 route Proxy _ = methodRouter (\x -> (getHeaders x, getResponse x)) method (Proxy :: Proxy ctypes) status

313 route Proxy _ = methodRouter (\x -> (getHeaders x, getResponse x)) method (Proxy :: Proxy ctypes) status

312 where method = reflectMethod (Proxy :: Proxy method)

314 where method = reflectMethod (Proxy :: Proxy method)

313− status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)

315+ status = statusFromNat (Proxy :: Proxy status)

314

316

315instance (ReflectMethod method) =>

317instance (ReflectMethod method) =>

316 HasServer (NoContentVerb method) context where

318 HasServer (NoContentVerb method) context where

@@ -331,7 +333,7 @@ instance {-# OVERLAPPABLE #-}

331

333

332 route Proxy _ = streamRouter ([],) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype)

334 route Proxy _ = streamRouter ([],) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype)

333 where method = reflectMethod (Proxy :: Proxy method)

335 where method = reflectMethod (Proxy :: Proxy method)

334− status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)

336+ status = statusFromNat (Proxy :: Proxy status)

335

337

336

338

337instance {-# OVERLAPPING #-}

339instance {-# OVERLAPPING #-}

@@ -345,7 +347,7 @@ instance {-# OVERLAPPING #-}

345

347

346 route Proxy _ = streamRouter (\x -> (getHeaders x, getResponse x)) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype)

348 route Proxy _ = streamRouter (\x -> (getHeaders x, getResponse x)) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype)

347 where method = reflectMethod (Proxy :: Proxy method)

349 where method = reflectMethod (Proxy :: Proxy method)

348− status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)

350+ status = statusFromNat (Proxy :: Proxy status)

349

351

350

352

351streamRouter :: forall ctype a c chunk env framing. (MimeRender ctype chunk, FramingRender framing, ToSourceIO chunk a) =>

353streamRouter :: forall ctype a c chunk env framing. (MimeRender ctype chunk, FramingRender framing, ToSourceIO chunk a) =>

servant/src/Servant/API/Status.hs+6−1

@@ -1,10 +1,15 @@

1{-# LANGUAGE DataKinds #-}

2-- Flexible instances is necessary on GHC 8.4 and earlier

3{-# LANGUAGE FlexibleInstances #-}

4+{-# LANGUAGE ScopedTypeVariables #-}

4module Servant.API.Status where

5module Servant.API.Status where

7+import GHC.TypeLits (KnownNat, natVal)

6import Network.HTTP.Types.Status

8import Network.HTTP.Types.Status

7−import GHC.TypeLits

10+-- | Retrieve a known or unknown Status from a KnownNat

11+statusFromNat :: forall a proxy. KnownNat a => proxy a -> Status

12+statusFromNat = toEnum . fromInteger . natVal

9-- | Witness that a type-level natural number corresponds to a HTTP status code

14-- | Witness that a type-level natural number corresponds to a HTTP status code

10class KnownNat n => KnownStatus n where

15class KnownNat n => KnownStatus n where