Derive HasClient good response status from Verb status (#1469)
This commit is contained in:
parent
cb294aa2b3
commit
29d2553e74
12 changed files with 156 additions and 44 deletions
11
changelog.d/1469
Normal file
11
changelog.d/1469
Normal 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.
|
||||
}
|
|
@ -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
|
||||
|
||||
|
|
|
@ -89,6 +89,7 @@ test-suite spec
|
|||
main-is: Spec.hs
|
||||
other-modules:
|
||||
Servant.BasicAuthSpec
|
||||
Servant.BrokenSpec
|
||||
Servant.ClientTestUtils
|
||||
Servant.ConnectionErrorSpec
|
||||
Servant.FailSpec
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
71
servant-client/test/Servant/BrokenSpec.hs
Normal 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
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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 ()
|
||||
|
|
|
@ -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 ->
|
||||
|
|
|
@ -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)
|
||||
|
||||
|
|
|
@ -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) =>
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in a new issue