From 0a1d32d21e25699153c6604d24e4b8bd139c0da4 Mon Sep 17 00:00:00 2001 From: Nicolas BACQUEY Date: Thu, 3 Mar 2022 16:37:29 +0100 Subject: [PATCH 1/3] Refactor NoContentVerb into NoContentVerbWithStatus (#1532) There are several HTTP status codes that correspond to a response body with `NoContent`. This commit 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. --- .../src/Servant/Client/Core/HasClient.hs | 12 +++++++----- servant-docs/src/Servant/Docs/Internal.hs | 7 ++++--- servant-foreign/src/Servant/Foreign/Internal.hs | 4 ++-- servant-server/src/Servant/Server/Internal.hs | 11 ++++++----- servant-swagger/src/Servant/Swagger/Internal.hs | 10 +++++----- servant/src/Servant/API.hs | 11 ++++++----- servant/src/Servant/API/Verbs.hs | 13 +++++++++---- servant/src/Servant/Links.hs | 6 +++--- 8 files changed, 42 insertions(+), 32 deletions(-) diff --git a/servant-client-core/src/Servant/Client/Core/HasClient.hs b/servant-client-core/src/Servant/Client/Core/HasClient.hs index ef03cb4e..747068f4 100644 --- a/servant-client-core/src/Servant/Client/Core/HasClient.hs +++ b/servant-client-core/src/Servant/Client/Core/HasClient.hs @@ -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, 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 diff --git a/servant-docs/src/Servant/Docs/Internal.hs b/servant-docs/src/Servant/Docs/Internal.hs index 0b37b1d4..4b35156f 100644 --- a/servant-docs/src/Servant/Docs/Internal.hs +++ b/servant-docs/src/Servant/Docs/Internal.hs @@ -961,17 +961,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 -- diff --git a/servant-foreign/src/Servant/Foreign/Internal.hs b/servant-foreign/src/Servant/Foreign/Internal.hs index d77cdb84..795def58 100644 --- a/servant-foreign/src/Servant/Foreign/Internal.hs +++ b/servant-foreign/src/Servant/Foreign/Internal.hs @@ -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 :) diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index e2df2c4a..163bf82e 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -72,7 +72,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, @@ -315,14 +315,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, diff --git a/servant-swagger/src/Servant/Swagger/Internal.hs b/servant-swagger/src/Servant/Swagger/Internal.hs index c4cc2780..73e49510 100644 --- a/servant-swagger/src/Servant/Swagger/Internal.hs +++ b/servant-swagger/src/Servant/Swagger/Internal.hs @@ -132,10 +132,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 ?~ @@ -143,7 +143,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 @@ -266,7 +266,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 diff --git a/servant/src/Servant/API.hs b/servant/src/Servant/API.hs index de4b805c..12b023bd 100644 --- a/servant/src/Servant/API.hs +++ b/servant/src/Servant/API.hs @@ -139,11 +139,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.Links diff --git a/servant/src/Servant/API/Verbs.hs b/servant/src/Servant/API/Verbs.hs index e7115d5a..e5c8340e 100644 --- a/servant/src/Servant/API/Verbs.hs +++ b/servant/src/Servant/API/Verbs.hs @@ -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. diff --git a/servant/src/Servant/Links.hs b/servant/src/Servant/Links.hs index ce07e22d..b7c7694e 100644 --- a/servant/src/Servant/Links.hs +++ b/servant/src/Servant/Links.hs @@ -189,7 +189,7 @@ import Servant.API.UVerb import Servant.API.Vault (Vault) import Servant.API.Verbs - (Verb, NoContentVerb) + (Verb, NoContentVerbWithStatus) import Servant.API.WithNamedContext (WithNamedContext) import Web.HttpApiData @@ -572,8 +572,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 From 2f9fcdb45d48503496585fef4abf0d0155000630 Mon Sep 17 00:00:00 2001 From: Nicolas BACQUEY Date: Thu, 3 Mar 2022 16:49:41 +0100 Subject: [PATCH 2/3] Add server spec for `NoContentVerbWithStatus` --- servant-server/test/Servant/ServerSpec.hs | 30 ++++++++++++++--------- 1 file changed, 19 insertions(+), 11 deletions(-) diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index 39e75cd4..6471aff7 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -51,10 +51,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, @@ -109,19 +110,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) @@ -150,6 +153,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 From 0aaf3b25d9a7c990baa2bc78c498aaadd8e565b3 Mon Sep 17 00:00:00 2001 From: Nicolas BACQUEY Date: Thu, 3 Mar 2022 17:24:12 +0100 Subject: [PATCH 3/3] Update changelog --- changelog.d/1550 | 13 +++++++++++++ 1 file changed, 13 insertions(+) create mode 100644 changelog.d/1550 diff --git a/changelog.d/1550 b/changelog.d/1550 new file mode 100644 index 00000000..42ba820f --- /dev/null +++ b/changelog.d/1550 @@ -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` + +}