git.iko.soy/typeable/servant
on master help sign in
Derive HasClient good response status from Verb status (#1469)
commit29d2553e74785f696186e2e62cf973d13ac18833 authorGiorgio Marinelli <marinelli@users.noreply.github.com> dateThu 9 Dec 2021, 10:09 (5 years ago) parentcb294aa
12 files changed+156−44
compare with master
unifiedsplit
changelog.d/1469+11 servant-client-core/src/Servant/Client/Core/HasClient.hs+22−13 servant-client/servant-client.cabal+1 servant-client/src/Servant/Client/Internal/HttpClient.hs+2−3 servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs+3−5 servant-client/test/Servant/BrokenSpec.hs+71 servant-client/test/Servant/ClientTestUtils.hs+14−3 servant-client/test/Servant/FailSpec.hs+3−3 servant-client/test/Servant/SuccessSpec.hs+10−5 servant-http-streams/src/Servant/HttpStreams/Internal.hs+6−6 servant-server/src/Servant/Server/Internal.hs+7−5 servant/src/Servant/API/Status.hs+6−1
changelog.d/1469new file+11
@@ -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
6565import Data.Proxy
6666 (Proxy (Proxy))
6767import GHC.TypeLits
68− (KnownSymbol, symbolVal)
68+ (KnownNat, KnownSymbol, symbolVal)
6969import Network.HTTP.Types
7070 (Status)
7171import qualified Network.HTTP.Types as H
@@ -86,6 +86,8 @@ import Servant.API.Generic
8686 , GenericServant, toServant, fromServant)
8787import Servant.API.ContentTypes
8888 (contentTypes, AllMime (allMime), AllMimeUnrender (allMimeUnrender))
89+import Servant.API.Status
90+ (statusFromNat)
8991import Servant.API.TypeLevel (FragmentUnique, AtLeastOneFragment)
9092import Servant.API.Modifiers
9193 (FoldRequired, RequiredArgument, foldRequiredArgument)
@@ -250,10 +252,11 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient m sublayout)
250252instance {-# OVERLAPPABLE #-}
251253 -- Note [Non-Empty Content Types]
252254 ( RunClient m, MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)
255+ , KnownNat status
253256 ) => HasClient m (Verb method status cts' a) where
254257 type Client m (Verb method status cts' a) = m a
255258 clientWithRoute _pm Proxy req = do
256− response <- runRequest req
259+ response <- runRequestAcceptStatus (Just [status]) req
257260 { requestAccept = fromList $ toList accept
258261 , requestMethod = method
259262 }
@@ -261,18 +264,20 @@ instance {-# OVERLAPPABLE #-}
261264 where
262265 accept = contentTypes (Proxy :: Proxy ct)
263266 method = reflectMethod (Proxy :: Proxy method)
267+ status = statusFromNat (Proxy :: Proxy status)
264268
265269 hoistClientMonad _ _ f ma = f ma
266270
267271instance {-# OVERLAPPING #-}
268− ( RunClient m, ReflectMethod method
272+ ( RunClient m, ReflectMethod method, KnownNat status
269273 ) => HasClient m (Verb method status cts NoContent) where
270274 type Client m (Verb method status cts NoContent)
271275 = m NoContent
272276 clientWithRoute _pm Proxy req = do
273− _response <- runRequest req { requestMethod = method }
277+ _response <- runRequestAcceptStatus (Just [status]) req { requestMethod = method }
274278 return NoContent
275279 where method = reflectMethod (Proxy :: Proxy method)
280+ status = statusFromNat (Proxy :: Proxy status)
276281
277282 hoistClientMonad _ _ f ma = f ma
278283
@@ -289,13 +294,13 @@ instance (RunClient m, ReflectMethod method) =>
289294
290295instance {-# OVERLAPPING #-}
291296 -- Note [Non-Empty Content Types]
292− ( RunClient m, MimeUnrender ct a, BuildHeadersTo ls
297+ ( RunClient m, MimeUnrender ct a, BuildHeadersTo ls, KnownNat status
293298 , ReflectMethod method, cts' ~ (ct ': cts)
294299 ) => HasClient m (Verb method status cts' (Headers ls a)) where
295300 type Client m (Verb method status cts' (Headers ls a))
296301 = m (Headers ls a)
297302 clientWithRoute _pm Proxy req = do
298− response <- runRequest req
303+ response <- runRequestAcceptStatus (Just [status]) req
299304 { requestMethod = method
300305 , requestAccept = fromList $ toList accept
301306 }
@@ -303,22 +308,26 @@ instance {-# OVERLAPPING #-}
303308 return $ Headers { getResponse = val
304309 , getHeadersHList = buildHeadersTo . toList $ responseHeaders response
305310 }
306− where method = reflectMethod (Proxy :: Proxy method)
307− accept = contentTypes (Proxy :: Proxy ct)
311+ where
312+ method = reflectMethod (Proxy :: Proxy method)
313+ accept = contentTypes (Proxy :: Proxy ct)
314+ status = statusFromNat (Proxy :: Proxy status)
308315
309316 hoistClientMonad _ _ f ma = f ma
310317
311318instance {-# OVERLAPPING #-}
312− ( RunClient m, BuildHeadersTo ls, ReflectMethod method
319+ ( RunClient m, BuildHeadersTo ls, ReflectMethod method, KnownNat status
313320 ) => HasClient m (Verb method status cts (Headers ls NoContent)) where
314321 type Client m (Verb method status cts (Headers ls NoContent))
315322 = m (Headers ls NoContent)
316323 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 }
319325 return $ Headers { getResponse = NoContent
320326 , getHeadersHList = buildHeadersTo . toList $ responseHeaders response
321327 }
328+ where
329+ method = reflectMethod (Proxy :: Proxy method)
330+ status = statusFromNat (Proxy :: Proxy status)
322331
323332 hoistClientMonad _ _ f ma = f ma
324333
@@ -784,7 +793,7 @@ instance ( HasClient m api
784793
785794-- | Ignore @'Fragment'@ in client functions.
786795-- See <https://ietf.org/rfc/rfc2616.html#section-15.1.3> for more details.
787−--
796+--
788797-- Example:
789798--
790799-- > type MyApi = "books" :> Fragment Text :> Get '[JSON] [Book]
@@ -801,7 +810,7 @@ instance (AtLeastOneFragment api, FragmentUnique (Fragment a :> api), HasClient
801810
802811 type Client m (Fragment a :> api) = Client m api
803812
804− clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api)
813+ clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api)
805814
806815 hoistClientMonad pm _ = hoistClientMonad pm (Proxy :: Proxy api)
807816
servant-client/servant-client.cabal+1
@@ -89,6 +89,7 @@ test-suite spec
8989 main-is: Spec.hs
9090 other-modules:
9191 Servant.BasicAuthSpec
92+ Servant.BrokenSpec
9293 Servant.ClientTestUtils
9394 Servant.ConnectionErrorSpec
9495 Servant.FailSpec
servant-client/src/Servant/Client/Internal/HttpClient.hs+2−3
@@ -63,7 +63,7 @@ import GHC.Generics
6363import Network.HTTP.Media
6464 (renderHeader)
6565import Network.HTTP.Types
66− (hContentType, renderQuery, statusCode, urlEncode, Status)
66+ (hContentType, renderQuery, statusIsSuccessful, urlEncode, Status)
6767import Servant.Client.Core
6868
6969import qualified Network.HTTP.Client as Client
@@ -179,10 +179,9 @@ performRequest acceptStatus req = do
179179
180180 response <- maybe (requestWithoutCookieJar m request) (requestWithCookieJar m request) cookieJar'
181181 let status = Client.responseStatus response
182− status_code = statusCode status
183182 ourResponse = clientResponseToResponse id response
184183 goodStatus = case acceptStatus of
185− Nothing -> status_code >= 200 && status_code < 300
184+ Nothing -> statusIsSuccessful status
186185 Just good -> status `elem` good
187186 unless goodStatus $ do
188187 throwError $ mkFailureResponse burl req ourResponse
servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs+3−5
@@ -47,7 +47,7 @@ import Data.Time.Clock
4747 (getCurrentTime)
4848import GHC.Generics
4949import Network.HTTP.Types
50− (Status, statusCode)
50+ (Status, statusIsSuccessful)
5151
5252import qualified Network.HTTP.Client as Client
5353
@@ -163,10 +163,9 @@ performRequest acceptStatus req = do
163163 now' <- getCurrentTime
164164 atomically $ modifyTVar' cj (fst . Client.updateCookieJar response request now')
165165 let status = Client.responseStatus response
166− status_code = statusCode status
167166 ourResponse = clientResponseToResponse id response
168167 goodStatus = case acceptStatus of
169− Nothing -> status_code >= 200 && status_code < 300
168+ Nothing -> statusIsSuccessful status
170169 Just good -> status `elem` good
171170 unless goodStatus $ do
172171 throwError $ mkFailureResponse burl req ourResponse
@@ -182,10 +181,9 @@ performWithStreamingRequest req k = do
182181 ClientM $ lift $ lift $ Codensity $ \k1 ->
183182 Client.withResponse request m $ \res -> do
184183 let status = Client.responseStatus res
185− status_code = statusCode status
186184
187185 -- we throw FailureResponse in IO :(
188− unless (status_code >= 200 && status_code < 300) $ do
186+ unless (statusIsSuccessful status) $ do
189187 b <- BSL.fromChunks <$> Client.brConsume (Client.responseBody res)
190188 throwIO $ mkFailureResponse burl req (clientResponseToResponse (const b) res)
191189
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 #-}
6+
7+module Servant.BrokenSpec (spec) where
8+
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
6464 JSON, MimeRender (mimeRender), MimeUnrender (mimeUnrender),
6565 NoContent (NoContent), PlainText, Post, QueryFlag, QueryParam,
6666 QueryParams, Raw, ReqBody, StdMethod (GET), ToHttpApiData (..), UVerb, Union,
67− WithStatus (WithStatus), NamedRoutes, addHeader)
67+ Verb, WithStatus (WithStatus), NamedRoutes, addHeader)
6868import Servant.API.Generic ((:-))
6969import Servant.Client
7070import qualified Servant.Client.Core.Auth as Auth
@@ -118,9 +118,16 @@ data OtherRoutes mode = OtherRoutes
118118 { something :: mode :- "something" :> Get '[JSON] [String]
119119 } deriving Generic
120120
121+-- Get for HTTP 307 Temporary Redirect
122+type Get307 = Verb 'GET 307
123+
121124type Api =
122125 Get '[JSON] Person
123126 :<|> "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
124131 :<|> "deleteEmpty" :> DeleteNoContent
125132 :<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person
126133 :<|> "captureAll" :> CaptureAll "names" String :> Get '[JSON] [Person]
@@ -154,12 +161,12 @@ type Api =
154161 :<|> "uverb-get-created" :> UVerb 'GET '[PlainText] '[WithStatus 201 Person]
155162 :<|> NamedRoutes RecordRoutes
156163
157−
158164api :: Proxy Api
159165api = Proxy
160166
161167getRoot :: ClientM Person
162168getGet :: ClientM Person
169+getGet307 :: ClientM Text
163170getDeleteEmpty :: ClientM NoContent
164171getCapture :: String -> ClientM Person
165172getCaptureAll :: [String] -> ClientM [Person]
@@ -186,6 +193,7 @@ recordRoutes :: RecordRoutes (AsClientT ClientM)
186193
187194getRoot
188195 :<|> getGet
196+ :<|> getGet307
189197 :<|> getDeleteEmpty
190198 :<|> getCapture
191199 :<|> getCaptureAll
@@ -212,6 +220,7 @@ server :: Application
212220server = serve api (
213221 return carol
214222 :<|> return alice
223+ :<|> return "redirecting"
215224 :<|> return NoContent
216225 :<|> (\ name -> return $ Person name 0)
217226 :<|> (\ names -> return (zipWith Person names [0..]))
@@ -252,6 +261,8 @@ server = serve api (
252261 }
253262 )
254263
264+-- * api for testing failures
265+
255266type FailApi =
256267 "get" :> Raw
257268 :<|> "capture" :> Capture "name" String :> Raw
@@ -266,7 +277,7 @@ failServer = serve failApi (
266277 :<|> (\ _capture -> Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "application/json")] "")
267278 :<|> (Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "fooooo")] "")
268279 :<|> (Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "application/x-www-form-urlencoded"), ("X-Example1", "1"), ("X-Example2", "foo")] "")
269− )
280+ )
270281
271282-- * basic auth stuff
272283
servant-client/test/Servant/FailSpec.hs+3−3
@@ -38,14 +38,14 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
3838
3939 context "client returns errors appropriately" $ do
4040 it "reports FailureResponse" $ \(_, baseUrl) -> do
41− let (_ :<|> _ :<|> getDeleteEmpty :<|> _) = client api
41+ let (_ :<|> _ :<|> _ :<|> getDeleteEmpty :<|> _) = client api
4242 Left res <- runClient getDeleteEmpty baseUrl
4343 case res of
4444 FailureResponse _ r | responseStatusCode r == HTTP.status404 -> return ()
4545 _ -> fail $ "expected 404 response, but got " <> show res
4646
4747 it "reports DecodeFailure" $ \(_, baseUrl) -> do
48− let (_ :<|> _ :<|> _ :<|> getCapture :<|> _) = client api
48+ let (_ :<|> _ :<|> _ :<|> _ :<|> getCapture :<|> _) = client api
4949 Left res <- runClient (getCapture "foo") baseUrl
5050 case res of
5151 DecodeFailure _ _ -> return ()
@@ -72,7 +72,7 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
7272 _ -> fail $ "expected UnsupportedContentType, but got " <> show res
7373
7474 it "reports InvalidContentTypeHeader" $ \(_, baseUrl) -> do
75− let (_ :<|> _ :<|> _ :<|> _ :<|> _ :<|> getBody :<|> _) = client api
75+ let (_ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> getBody :<|> _) = client api
7676 Left res <- runClient (getBody alice) baseUrl
7777 case res of
7878 InvalidContentTypeHeader _ -> return ()
servant-client/test/Servant/SuccessSpec.hs+10−5
@@ -59,11 +59,15 @@ spec = describe "Servant.SuccessSpec" $ do
5959
6060successSpec :: Spec
6161successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
62− it "Servant.API.Get root" $ \(_, baseUrl) -> do
63− left show <$> runClient getRoot baseUrl `shouldReturn` Right carol
62+ describe "Servant.API.Get" $ do
63+ it "get root endpoint" $ \(_, baseUrl) -> do
64+ left show <$> runClient getRoot baseUrl `shouldReturn` Right carol
6465
65− it "Servant.API.Get" $ \(_, baseUrl) -> do
66− left show <$> runClient getGet baseUrl `shouldReturn` Right alice
66+ it "get simple endpoint" $ \(_, baseUrl) -> do
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"
6771
6872 describe "Servant.API.Delete" $ do
6973 it "allows empty content type" $ \(_, baseUrl) -> do
@@ -111,6 +115,7 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
111115
112116 it "Servant.API.Fragment" $ \(_, baseUrl) -> do
113117 left id <$> runClient getFragment baseUrl `shouldReturn` Right alice
118+
114119 it "Servant.API.Raw on success" $ \(_, baseUrl) -> do
115120 res <- runClient (getRawSuccess HTTP.methodGet) baseUrl
116121 case res of
@@ -156,7 +161,7 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
156161 -- In proper situation, extra headers should probably be visible in API type.
157162 -- However, testing for response timeout is difficult, so we test with something which is easy to observe
158163 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 }
160165 res <- runClientM (getRawSuccessPassHeaders HTTP.methodGet) clientEnv
161166 case res of
162167 Left e ->
servant-http-streams/src/Servant/HttpStreams/Internal.hs+6−6
@@ -57,7 +57,7 @@ import GHC.Generics
5757import Network.HTTP.Media
5858 (renderHeader)
5959import Network.HTTP.Types
60− (Status (..), hContentType, http11, renderQuery)
60+ (Status (..), hContentType, http11, renderQuery, statusIsSuccessful)
6161import Servant.Client.Core
6262
6363import qualified Network.Http.Client as Client
@@ -160,12 +160,12 @@ performRequest acceptStatus req = do
160160 x <- ClientM $ lift $ lift $ Codensity $ \k -> do
161161 Client.sendRequest conn req' body
162162 Client.receiveResponse conn $ \res' body' -> do
163− let sc = Client.getStatusCode res'
163+ let status = toEnum $ Client.getStatusCode res'
164164 lbs <- BSL.fromChunks <$> Streams.toList body'
165165 let res'' = clientResponseToResponse res' lbs
166166 goodStatus = case acceptStatus of
167− Nothing -> sc >= 200 && sc < 300
168− Just good -> sc `elem` (statusCode <$> good)
167+ Nothing -> statusIsSuccessful status
168+ Just good -> status `elem` good
169169 if goodStatus
170170 then k (Right res'')
171171 else k (Left (mkFailureResponse burl req res''))
@@ -180,8 +180,8 @@ performWithStreamingRequest req k = do
180180 Client.sendRequest conn req' body
181181 Client.receiveResponseRaw conn $ \res' body' -> do
182182 -- check status code
183− let sc = Client.getStatusCode res'
184− unless (sc >= 200 && sc < 300) $ do
183+ let status = toEnum $ Client.getStatusCode res'
184+ unless (statusIsSuccessful status) $ do
185185 lbs <- BSL.fromChunks <$> Streams.toList body'
186186 throwIO $ mkFailureResponse burl req (clientResponseToResponse res' lbs)
187187
servant-server/src/Servant/Server/Internal.hs+7−5
@@ -56,7 +56,7 @@ import qualified Data.Text as T
5656import Data.Typeable
5757import GHC.Generics
5858import GHC.TypeLits
59− (KnownNat, KnownSymbol, natVal, symbolVal)
59+ (KnownNat, KnownSymbol, symbolVal)
6060import qualified Network.HTTP.Media as NHM
6161import Network.HTTP.Types hiding
6262 (Header, ResponseHeaders)
@@ -87,6 +87,8 @@ import Servant.API.Modifiers
8787 unfoldRequestArgument)
8888import Servant.API.ResponseHeaders
8989 (GetHeaders, Headers, getHeaders, getResponse)
90+import Servant.API.Status
91+ (statusFromNat)
9092import qualified Servant.Types.SourceT as S
9193import Web.HttpApiData
9294 (FromHttpApiData, parseHeader, parseQueryParam, parseUrlPiece,
@@ -298,7 +300,7 @@ instance {-# OVERLAPPABLE #-}
298300
299301 route Proxy _ = methodRouter ([],) method (Proxy :: Proxy ctypes) status
300302 where method = reflectMethod (Proxy :: Proxy method)
301− status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
303+ status = statusFromNat (Proxy :: Proxy status)
302304
303305instance {-# OVERLAPPING #-}
304306 ( AllCTRender ctypes a, ReflectMethod method, KnownNat status
@@ -310,7 +312,7 @@ instance {-# OVERLAPPING #-}
310312
311313 route Proxy _ = methodRouter (\x -> (getHeaders x, getResponse x)) method (Proxy :: Proxy ctypes) status
312314 where method = reflectMethod (Proxy :: Proxy method)
313− status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
315+ status = statusFromNat (Proxy :: Proxy status)
314316
315317instance (ReflectMethod method) =>
316318 HasServer (NoContentVerb method) context where
@@ -331,7 +333,7 @@ instance {-# OVERLAPPABLE #-}
331333
332334 route Proxy _ = streamRouter ([],) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype)
333335 where method = reflectMethod (Proxy :: Proxy method)
334− status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
336+ status = statusFromNat (Proxy :: Proxy status)
335337
336338
337339instance {-# OVERLAPPING #-}
@@ -345,7 +347,7 @@ instance {-# OVERLAPPING #-}
345347
346348 route Proxy _ = streamRouter (\x -> (getHeaders x, getResponse x)) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype)
347349 where method = reflectMethod (Proxy :: Proxy method)
348− status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
350+ status = statusFromNat (Proxy :: Proxy status)
349351
350352
351353streamRouter :: 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 @@
11{-# LANGUAGE DataKinds #-}
22-- Flexible instances is necessary on GHC 8.4 and earlier
33{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE ScopedTypeVariables #-}
45module Servant.API.Status where
56
7+import GHC.TypeLits (KnownNat, natVal)
68import Network.HTTP.Types.Status
7−import GHC.TypeLits
9+
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
813
914-- | Witness that a type-level natural number corresponds to a HTTP status code
1015class KnownNat n => KnownStatus n where