Implemented NoContentVerb and server instances for it

servant-server/src/Servant/Server/Internal.hs

@@ -75,10 +75,12 @@ import           Servant.API
                  IsSecure (..), QueryFlag, QueryParam', QueryParams, Raw,
                  ReflectMethod (reflectMethod), RemoteHost, ReqBody',
                  SBool (..), SBoolI (..), SourceIO, Stream, StreamBody',
-                 Summary, ToSourceIO (..), Vault, Verb, WithNamedContext)
+                 Summary, ToSourceIO (..), Vault, Verb, NoContentVerb,
+                 WithNamedContext)
 import           Servant.API.ContentTypes
                  (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..),
-                 AllMime, MimeRender (..), MimeUnrender (..), canHandleAcceptH)
+                 AllMime, MimeRender (..), MimeUnrender (..), canHandleAcceptH,
+                 NoContent (NoContent))
 import           Servant.API.Modifiers
                  (FoldLenient, FoldRequired, RequestArgument,
                  unfoldRequestArgument)
@@ -262,6 +264,17 @@ methodRouter splitHeaders method proxy status action = leafRouter route'
                       let bdy = if allowedMethodHead method request then "" else body
                       in Route $ responseLBS status ((hContentType, cs contentT) : headers) bdy
 
+noContentRouter :: Method
+             -> Status
+             -> Delayed env (Handler b)
+             -> Router env
+noContentRouter method status action = leafRouter route'
+  where
+    route' env request respond =
+          runAction (action `addMethodCheck` methodCheck method request)
+                    env request respond $ \ output ->
+                      Route $ responseLBS status [] ""
+
 instance {-# OVERLAPPABLE #-}
          ( AllCTRender ctypes a, ReflectMethod method, KnownNat status
          ) => HasServer (Verb method status ctypes a) context where
@@ -285,6 +298,15 @@ instance {-# OVERLAPPING #-}
     where method = reflectMethod (Proxy :: Proxy method)
           status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
 
+instance {-# OVERLAPPABLE #-}
+         (ReflectMethod method
+         ) => HasServer (NoContentVerb method) context where
+
+  type ServerT (NoContentVerb method) m = m NoContent
+  hoistServerWithContext _ _ nt s = nt s
+
+  route Proxy _ = noContentRouter method status204
+    where method = reflectMethod (Proxy :: Proxy method)
 
 instance {-# OVERLAPPABLE #-}
          ( MimeRender ctype chunk, ReflectMethod method, KnownNat status,

servant-server/test/Servant/ServerSpec.hs

@@ -51,7 +51,7 @@ import           Servant.API
                  JSON, NoContent (..), NoFraming, OctetStream, Patch,
                  PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, Raw,
                  RemoteHost, ReqBody, SourceIO, StdMethod (..), Stream, Verb,
-                 addHeader)
+                 NoContentVerb, addHeader)
 import           Servant.Server
                  (Context ((:.), EmptyContext), Handler, Server, Tagged (..),
                  emptyServer, err400, err401, err403, err404, serve, serveWithContext)
@@ -103,7 +103,7 @@ spec = do
 
 type VerbApi method status
     =                Verb method status '[JSON] Person
- :<|> "noContent" :> Verb method status '[JSON] NoContent
+ :<|> "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
@@ -140,7 +140,7 @@ verbSpec = describe "Servant.API.Verb" $ do
 
           it "returns no content on NoContent" $ do
               response <- THW.request method "/noContent" [] ""
-              liftIO $ statusCode (simpleStatus response) `shouldBe` status
+              liftIO $ statusCode (simpleStatus response) `shouldBe` 204
               liftIO $ simpleBody response `shouldBe` ""
 
           -- HEAD should not return body

servant/src/Servant/API.hs

@@ -130,7 +130,8 @@ import           Servant.API.Verbs
                  Post, PostAccepted, PostCreated, PostNoContent,
                  PostNonAuthoritative, PostResetContent, Put, PutAccepted,
                  PutCreated, PutNoContent, PutNonAuthoritative,
-                 ReflectMethod (reflectMethod), StdMethod (..), Verb)
+                 ReflectMethod (reflectMethod), StdMethod (..),
+                 Verb, NoContentVerb)
 import           Servant.API.WithNamedContext
                  (WithNamedContext)
 import           Servant.Links

servant/src/Servant/API/Verbs.hs

@@ -29,6 +29,12 @@ 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)
+  deriving (Typeable, Generic)
+
 -- * 200 responses
 --
 -- The 200 response is the workhorse of web servers, but also fairly generic.
@@ -113,15 +119,15 @@ type PutNonAuthoritative    = Verb 'PUT 203
 -- If the document view should be reset, use @205 Reset Content@.
 
 -- | 'GET' with 204 status code.
-type GetNoContent    = Verb 'GET 204
+type GetNoContent    = NoContentVerb 'GET
 -- | 'POST' with 204 status code.
-type PostNoContent   = Verb 'POST 204
+type PostNoContent   = NoContentVerb 'POST
 -- | 'DELETE' with 204 status code.
-type DeleteNoContent = Verb 'DELETE 204
+type DeleteNoContent = NoContentVerb 'DELETE
 -- | 'PATCH' with 204 status code.
-type PatchNoContent  = Verb 'PATCH 204
+type PatchNoContent  = NoContentVerb 'PATCH
 -- | 'PUT' with 204 status code.
-type PutNoContent    = Verb 'PUT 204
+type PutNoContent    = NoContentVerb 'PUT
 
 
 -- ** 205 Reset Content

servant/src/Servant/Links.hs

@@ -177,7 +177,7 @@ import           Servant.API.TypeLevel
 import           Servant.API.Vault
                  (Vault)
 import           Servant.API.Verbs
-                 (Verb)
+                 (Verb, NoContentVerb)
 import           Servant.API.WithNamedContext
                  (WithNamedContext)
 import           Web.HttpApiData
@@ -546,6 +546,10 @@ 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
+    toLink toA _ = toA
+
 instance HasLink Raw where
     type MkLink Raw a = a
     toLink toA _ = toA

servant/src/Servant/Test/ComprehensiveAPI.hs

@@ -64,7 +64,7 @@ type ComprehensiveAPIWithoutStreamingOrRaw' endpoint =
     :<|> "res-headers"      :> Get '[JSON] (Headers '[Header "foo" Int] NoContent)
     :<|> "foo"              :> GET
     :<|> "vault"            :> Vault :> GET
-    :<|> "post-no-content"  :> Verb 'POST 204 '[JSON] NoContent
+    :<|> "post-no-content"  :> PostNoContent
     :<|> "post-int"         :> Verb 'POST 204 '[JSON] Int
     :<|> "named-context"    :> WithNamedContext "foo" '[] GET
     :<|> "capture-all"      :> CaptureAll "foo" Int :> GET