Refactor NoContentVerb into NoContentVerbWithStatus (#1532)

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`
+
+}

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
 

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
 --

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 :)

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,

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

servant-swagger/src/Servant/Swagger/Internal.hs

@@ -132,18 +132,18 @@ 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 ?~
     (mempty & method ?~ (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

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

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.

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