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` + +} diff --git a/servant-client-core/src/Servant/Client/Core/HasClient.hs b/servant-client-core/src/Servant/Client/Core/HasClient.hs index a2e6ae25..a7bce70c 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, 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 diff --git a/servant-docs/src/Servant/Docs/Internal.hs b/servant-docs/src/Servant/Docs/Internal.hs index 1f5f1ea8..2378c236 100644 --- a/servant-docs/src/Servant/Docs/Internal.hs +++ b/servant-docs/src/Servant/Docs/Internal.hs @@ -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 -- diff --git a/servant-foreign/src/Servant/Foreign/Internal.hs b/servant-foreign/src/Servant/Foreign/Internal.hs index a184347c..3b79d412 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 d1bde0bf..3778354b 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -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, diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index 67c2bc1a..ce2aa7ce 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -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 diff --git a/servant-swagger/src/Servant/Swagger/Internal.hs b/servant-swagger/src/Servant/Swagger/Internal.hs index 5f7a1ff3..fc8780bd 100644 --- a/servant-swagger/src/Servant/Swagger/Internal.hs +++ b/servant-swagger/src/Servant/Swagger/Internal.hs @@ -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 diff --git a/servant/src/Servant/API.hs b/servant/src/Servant/API.hs index 88ce976a..62390c5b 100644 --- a/servant/src/Servant/API.hs +++ b/servant/src/Servant/API.hs @@ -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 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 52ff4ae4..423ba390 100644 --- a/servant/src/Servant/Links.hs +++ b/servant/src/Servant/Links.hs @@ -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