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

Merge 0aaf3b25d9 into a2e003367d

This commit is contained in:
nbacquey 2023-02-15 11:54:15 +01:00 committed by GitHub
parent a2e003367d 0aaf3b25d9
commit 53e74829a6
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
10 changed files with 74 additions and 43 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
changelog.d/1550 Normal file
View File

@ -0,0 +1,13 @@
synopsis: Refactor NoContentVerb into NoContentVerbWithStatus
prs: #1550
issues: #1532
description: {
There are several HTTP status codes that correspond to a response body with `NoContent`. This PR introduces `NoContentVerbWithStatus` which generalizes `NoContentVerb` to cases when the return status may be
different from `204`. The former replaces the latter anywhere possible.
`NoContentVerb` is kept as a special case of `NoContentVerbWithStatus` for backwards compatibility.
This PR also adds a test case for `NoContentVerbWithStatus` in `ServerSpec.hs`
}

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

@ -74,7 +74,7 @@ import Servant.API
FromSourceIO (..), Header', Headers (..), HttpVersion,
IsSecure, MimeRender (mimeRender),
MimeUnrender (mimeUnrender), NoContent (NoContent),
NoContentVerb, QueryFlag, QueryParam', QueryParams, Raw,
NoContentVerbWithStatus, QueryFlag, QueryParam', QueryParams, Raw,
ReflectMethod (..), RemoteHost, ReqBody', SBoolI, Stream,
StreamBody', Summary, ToHttpApiData, ToSourceIO (..), Vault,
Verb, WithNamedContext, WithResource, WithStatus (..), contentType, getHeadersHList,
@ -280,14 +280,16 @@ instance {-# OVERLAPPING #-}
hoistClientMonad _ _ f ma = f ma
instance (RunClient m, ReflectMethod method) =>
HasClient m (NoContentVerb method) where
type Client m (NoContentVerb method)
instance
( RunClient m, ReflectMethod method, KnownNat status
) => HasClient m (NoContentVerbWithStatus method status) where
type Client m (NoContentVerbWithStatus method status)
= 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

7
servant-docs/src/Servant/Docs/Internal.hs
View File

@ -962,17 +962,18 @@ instance {-# OVERLAPPABLE #-}
status = fromInteger $ natVal (Proxy :: Proxy status)
p = Proxy :: Proxy a
instance (ReflectMethod method) =>
HasDocs (NoContentVerb method) where
instance (KnownNat status, ReflectMethod method) =>
HasDocs (NoContentVerbWithStatus method status) where
docsFor Proxy (endpoint, action) DocOptions{..} =
single endpoint' action'
where endpoint' = endpoint & method .~ method'
action' = action & response.respStatus .~ 204
action' = action & response.respStatus .~ status
& response.respTypes .~ []
& response.respBody .~ []
& response.respHeaders .~ []
method' = reflectMethod (Proxy :: Proxy method)
status = fromInteger $ natVal (Proxy :: Proxy status)
-- | TODO: mention the endpoint is streaming, its framing strategy
--

4
servant-foreign/src/Servant/Foreign/Internal.hs
View File

@ -337,8 +337,8 @@ instance (Elem JSON list, HasForeignType lang ftype a, ReflectMethod method)
methodLC = toLower $ decodeUtf8 method
instance (HasForeignType lang ftype NoContent, ReflectMethod method)
=> HasForeign lang ftype (NoContentVerb method) where
type Foreign ftype (NoContentVerb method) = Req ftype
=> HasForeign lang ftype (NoContentVerbWithStatus method status) where
type Foreign ftype (NoContentVerbWithStatus method status) = Req ftype
foreignFor lang Proxy Proxy req =
req & reqFuncName . _FunctionName %~ (methodLC :)

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

@ -74,7 +74,7 @@ import Servant.API
((:<|>) (..), (:>), Accept (..), BasicAuth, Capture',
CaptureAll, Description, EmptyAPI, Fragment,
FramingRender (..), FramingUnrender (..), FromSourceIO (..),
Header', If, IsSecure (..), NoContentVerb, QueryFlag,
Header', If, IsSecure (..), NoContentVerbWithStatus, QueryFlag,
QueryParam', QueryParams, Raw, ReflectMethod (reflectMethod),
RemoteHost, ReqBody', SBool (..), SBoolI (..), SourceIO,
Stream, StreamBody', Summary, ToSourceIO (..), Vault, Verb,
@ -361,14 +361,15 @@ instance {-# OVERLAPPING #-}
where method = reflectMethod (Proxy :: Proxy method)
status = statusFromNat (Proxy :: Proxy status)
instance (ReflectMethod method) =>
HasServer (NoContentVerb method) context where
instance (KnownNat status, ReflectMethod method) =>
HasServer (NoContentVerbWithStatus method status) context where
type ServerT (NoContentVerb method) m = m NoContent
type ServerT (NoContentVerbWithStatus method status) m = m NoContent
hoistServerWithContext _ _ nt s = nt s
route Proxy _ = noContentRouter method status204
route Proxy _ = noContentRouter method status
where method = reflectMethod (Proxy :: Proxy method)
status = statusFromNat (Proxy :: Proxy status)
instance {-# OVERLAPPABLE #-}
( MimeRender ctype chunk, ReflectMethod method, KnownNat status,

30
servant-server/test/Servant/ServerSpec.hs
View File

@ -53,10 +53,11 @@ import Servant.API
BasicAuthData (BasicAuthData), Capture, Capture', CaptureAll,
Delete, EmptyAPI, Fragment, Get, HasStatus (StatusOf), Header,
Headers, HttpVersion, IsSecure (..), JSON, Lenient,
NoContent (..), NoContentVerb, NoFraming, OctetStream, Patch,
PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, Raw,
RemoteHost, ReqBody, SourceIO, StdMethod (..), Stream, Strict,
UVerb, Union, Verb, WithStatus (..), addHeader)
NoContent (..), NoContentVerb, NoContentVerbWithStatus,
NoFraming, OctetStream, Patch, PlainText, Post, Put,
QueryFlag, QueryParam, QueryParams, Raw, RemoteHost, ReqBody,
SourceIO, StdMethod (..), Stream, Strict, UVerb, Union, Verb,
WithStatus (..), addHeader)
import Servant.Server
(Context ((:.), EmptyContext), Handler, Server, Tagged (..),
emptyServer, err401, err403, err404, respond, serve,
@ -114,19 +115,21 @@ spec = do
------------------------------------------------------------------------------
type VerbApi method status
= Verb method status '[JSON] Person
:<|> "noContent" :> NoContentVerb method
:<|> "header" :> Verb method status '[JSON] (Headers '[Header "H" Int] Person)
:<|> "headerNC" :> Verb method status '[JSON] (Headers '[Header "H" Int] NoContent)
:<|> "accept" :> ( Verb method status '[JSON] Person
:<|> Verb method status '[PlainText] String
)
= Verb method status '[JSON] Person
:<|> "noContent" :> NoContentVerb method
:<|> "permanentRedirection" :> NoContentVerbWithStatus method 308
:<|> "header" :> Verb method status '[JSON] (Headers '[Header "H" Int] Person)
:<|> "headerNC" :> Verb method status '[JSON] (Headers '[Header "H" Int] NoContent)
:<|> "accept" :> ( Verb method status '[JSON] Person
:<|> Verb method status '[PlainText] String
)
:<|> "stream" :> Stream method status NoFraming OctetStream (SourceIO BS.ByteString)
verbSpec :: Spec
verbSpec = describe "Servant.API.Verb" $ do
let server :: Server (VerbApi method status)
server = return alice
:<|> return NoContent
:<|> return NoContent
:<|> return (addHeader 5 alice)
:<|> return (addHeader 10 NoContent)
@ -155,6 +158,11 @@ verbSpec = describe "Servant.API.Verb" $ do
liftIO $ statusCode (simpleStatus response) `shouldBe` 204
liftIO $ simpleBody response `shouldBe` ""
it "returns no content on Permanent Redirection" $ do
response <- THW.request method "/permanentRedirection" [] ""
liftIO $ statusCode (simpleStatus response) `shouldBe` 308
liftIO $ simpleBody response `shouldBe` ""
-- HEAD should not return body
when (method == methodHead) $
it "HEAD returns no content body" $ do

10
servant-swagger/src/Servant/Swagger/Internal.hs
View File

@ -136,10 +136,10 @@ mkEndpointWithSchemaRef mref path _ = mempty
responseContentTypes = allContentType (Proxy :: Proxy cs)
responseHeaders = toAllResponseHeaders (Proxy :: Proxy hs)
mkEndpointNoContentVerb :: forall proxy method.
(SwaggerMethod method)
mkEndpointNoContentVerb :: forall proxy method status.
(SwaggerMethod method, KnownNat status)
=> FilePath -- ^ Endpoint path.
-> proxy (NoContentVerb method) -- ^ Method
-> proxy (NoContentVerbWithStatus method status) -- ^ Method
-> Swagger
mkEndpointNoContentVerb path _ = mempty
& paths.at path ?~
@ -147,7 +147,7 @@ mkEndpointNoContentVerb path _ = mempty
& at code ?~ Inline mempty))
where
method = swaggerMethod (Proxy :: Proxy method)
code = 204 -- hardcoded in servant-server
code = fromIntegral (natVal (Proxy :: Proxy status))
-- | Add parameter to every operation in the spec.
addParam :: Param -> Swagger -> Swagger
@ -274,7 +274,7 @@ instance (AllAccept cs, AllToResponseHeader hs, KnownNat status, SwaggerMethod m
=> HasSwagger (Verb method status cs (Headers hs NoContent)) where
toSwagger = mkEndpointNoContent "/"
instance (SwaggerMethod method) => HasSwagger (NoContentVerb method) where
instance (KnownNat status, SwaggerMethod method) => HasSwagger (NoContentVerbWithStatus method status) where
toSwagger = mkEndpointNoContentVerb "/"
instance (HasSwagger a, HasSwagger b) => HasSwagger (a :<|> b) where

11
servant/src/Servant/API.hs
View File

@ -145,11 +145,12 @@ import Servant.API.Verbs
(Delete, DeleteAccepted, DeleteNoContent,
DeleteNonAuthoritative, Get, GetAccepted, GetNoContent,
GetNonAuthoritative, GetPartialContent, GetResetContent,
NoContentVerb, Patch, PatchAccepted, PatchNoContent,
PatchNonAuthoritative, Post, PostAccepted, PostCreated,
PostNoContent, PostNonAuthoritative, PostResetContent, Put,
PutAccepted, PutCreated, PutNoContent, PutNonAuthoritative,
ReflectMethod (reflectMethod), StdMethod (..), Verb)
NoContentVerb, NoContentVerbWithStatus, Patch, PatchAccepted,
PatchNoContent, PatchNonAuthoritative, Post, PostAccepted,
PostCreated, PostNoContent, PostNonAuthoritative,
PostResetContent, Put, PutAccepted, PutCreated, PutNoContent,
PutNonAuthoritative, ReflectMethod (reflectMethod),
StdMethod (..), Verb)
import Servant.API.WithNamedContext
(WithNamedContext)
import Servant.API.WithResource

13
servant/src/Servant/API/Verbs.hs
View File

@ -29,12 +29,17 @@ import Network.HTTP.Types.Method
data Verb (method :: k1) (statusCode :: Nat) (contentTypes :: [*]) (a :: *)
deriving (Typeable, Generic)
-- | @NoContentVerb@ is a specific type to represent 'NoContent' responses.
-- It does not require either a list of content types (because there's
-- no content) or a status code (because it should always be 204).
data NoContentVerb (method :: k1)
-- | @NoContentVerbWithStatus@ is a specific type to represent 'NoContent' responses.
-- It does not require either a list of content types (because there's no content).
-- It still requires a status code, because several statuses may have no content.
-- (e.g. 204, 301, 302, or 303).
data NoContentVerbWithStatus (method :: k1) (statusCode :: Nat)
deriving (Typeable, Generic)
-- | @NoContentVerb@ is a specialization of type @NoContentVerbWithStatus@,
-- which is kept for backwards compatibility.
type NoContentVerb (method :: k1) = NoContentVerbWithStatus method 204
-- * 200 responses
--
-- The 200 response is the workhorse of web servers, but also fairly generic.

6
servant/src/Servant/Links.hs
View File

@ -190,7 +190,7 @@ import Servant.API.UVerb
import Servant.API.Vault
(Vault)
import Servant.API.Verbs
(Verb, NoContentVerb)
(Verb, NoContentVerbWithStatus)
import Servant.API.WithNamedContext
(WithNamedContext)
import Servant.API.WithResource
@ -581,8 +581,8 @@ instance HasLink (Verb m s ct a) where
type MkLink (Verb m s ct a) r = r
toLink toA _ = toA
instance HasLink (NoContentVerb m) where
type MkLink (NoContentVerb m) r = r
instance HasLink (NoContentVerbWithStatus m s) where
type MkLink (NoContentVerbWithStatus m s) r = r
toLink toA _ = toA
instance HasLink Raw where