Merge pull request #1228 from haskell-servant/pull-1219-no-content-verb-1028

Pull 1219: no content verb 1028

doc/tutorial/ApiType.lhs

@@ -177,13 +177,12 @@ type UserAPI5 = "user" :> Capture "userid" Integer :> Get '[JSON] User
                 -- except that we explicitly say that "userid"
                 -- must be an integer
 
-           :<|> "user" :> Capture "userid" Integer :> DeleteNoContent '[JSON] NoContent
+           :<|> "user" :> Capture "userid" Integer :> DeleteNoContent
                 -- equivalent to 'DELETE /user/:userid'
 ```
 
-In the second case, `DeleteNoContent` specifies a 204 response code,
+In the second case, `DeleteNoContent` specifies a 204 response code
-`JSON` specifies the content types on which the handler will match,
+and that the response will always be empty.
-and `NoContent` says that the response will always be empty.
 
 ### `QueryParam`, `QueryParams`, `QueryFlag`
 

doc/tutorial/Server.lhs

@@ -830,7 +830,7 @@ type UserAPI3 = -- view the user with given userid, in JSON
                 Capture "userid" Int :> Get '[JSON] User
 
            :<|> -- delete the user with given userid. empty response
-                Capture "userid" Int :> DeleteNoContent '[JSON] NoContent
+                Capture "userid" Int :> DeleteNoContent
 ```
 
 We can instead factor out the `userid`:
@@ -838,7 +838,7 @@ We can instead factor out the `userid`:
 ``` haskell
 type UserAPI4 = Capture "userid" Int :>
   (    Get '[JSON] User
-  :<|> DeleteNoContent '[JSON] NoContent
+  :<|> DeleteNoContent
   )
 ```
 
@@ -896,13 +896,13 @@ type API1 = "users" :>
 -- we factor out the Request Body
 type API2 = ReqBody '[JSON] User :>
   (    Get '[JSON] User -- just display the same user back, don't register it
-  :<|> PostNoContent '[JSON] NoContent  -- register the user. empty response
+  :<|> PostNoContent -- register the user. empty response
   )
 
 -- we factor out a Header
 type API3 = Header "Authorization" Token :>
   (    Get '[JSON] SecretData -- get some secret data, if authorized
-  :<|> ReqBody '[JSON] SecretData :> PostNoContent '[JSON] NoContent -- add some secret data, if authorized
+  :<|> ReqBody '[JSON] SecretData :> PostNoContent -- add some secret data, if authorized
   )
 
 newtype Token = Token ByteString
@@ -915,11 +915,11 @@ API type only at the end.
 ``` haskell
 type UsersAPI =
        Get '[JSON] [User] -- list users
-  :<|> ReqBody '[JSON] User :> PostNoContent '[JSON] NoContent -- add a user
+  :<|> ReqBody '[JSON] User :> PostNoContent -- add a user
   :<|> Capture "userid" Int :>
          ( Get '[JSON] User -- view a user
-      :<|> ReqBody '[JSON] User :> PutNoContent '[JSON] NoContent -- update a user
+      :<|> ReqBody '[JSON] User :> PutNoContent -- update a user
-      :<|> DeleteNoContent '[JSON] NoContent -- delete a user
+      :<|> DeleteNoContent -- delete a user
          )
 
 usersServer :: Server UsersAPI
@@ -948,11 +948,11 @@ usersServer = getUsers :<|> newUser :<|> userOperations
 ``` haskell
 type ProductsAPI =
        Get '[JSON] [Product] -- list products
-  :<|> ReqBody '[JSON] Product :> PostNoContent '[JSON] NoContent -- add a product
+  :<|> ReqBody '[JSON] Product :> PostNoContent -- add a product
   :<|> Capture "productid" Int :>
          ( Get '[JSON] Product -- view a product
-      :<|> ReqBody '[JSON] Product :> PutNoContent '[JSON] NoContent -- update a product
+      :<|> ReqBody '[JSON] Product :> PutNoContent -- update a product
-      :<|> DeleteNoContent '[JSON] NoContent -- delete a product
+      :<|> DeleteNoContent -- delete a product
          )
 
 data Product = Product { productId :: Int }
@@ -996,11 +996,11 @@ abstract that away:
 -- indexed by values of type 'i'
 type APIFor a i =
        Get '[JSON] [a] -- list 'a's
-  :<|> ReqBody '[JSON] a :> PostNoContent '[JSON] NoContent -- add an 'a'
+  :<|> ReqBody '[JSON] a :> PostNoContent -- add an 'a'
   :<|> Capture "id" i :>
          ( Get '[JSON] a -- view an 'a' given its "identifier" of type 'i'
-      :<|> ReqBody '[JSON] a :> PutNoContent '[JSON] NoContent -- update an 'a'
+      :<|> ReqBody '[JSON] a :> PutNoContent -- update an 'a'
-      :<|> DeleteNoContent '[JSON] NoContent -- delete an 'a'
+      :<|> DeleteNoContent -- delete an 'a'
          )
 
 -- Build the appropriate 'Server'

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

@@ -50,8 +50,9 @@ import           Servant.API
                  MimeUnrender (mimeUnrender), NoContent (NoContent), QueryFlag,
                  QueryParam', QueryParams, Raw, ReflectMethod (..), RemoteHost,
                  ReqBody', SBoolI, Stream, StreamBody', Summary, ToHttpApiData,
-                 ToSourceIO (..), Vault, Verb, WithNamedContext, contentType,
+                 ToSourceIO (..), Vault, Verb, NoContentVerb, WithNamedContext,
-                 getHeadersHList, getResponse, toQueryParam, toUrlPiece)
+                 contentType, getHeadersHList, getResponse, toQueryParam,
+                 toUrlPiece)
 import           Servant.API.ContentTypes
                  (contentTypes)
 import           Servant.API.Modifiers
@@ -241,6 +242,17 @@ instance {-# OVERLAPPING #-}
 
   hoistClientMonad _ _ f ma = f ma
 
+instance (RunClient m, ReflectMethod method) =>
+         HasClient m (NoContentVerb method) where
+  type Client m (NoContentVerb method)
+    = m NoContent
+  clientWithRoute _pm Proxy req = do
+    _response <- runRequest req { requestMethod = method }
+    return NoContent
+      where method = reflectMethod (Proxy :: Proxy method)
+
+  hoistClientMonad _ _ f ma = f ma
+
 instance {-# OVERLAPPING #-}
   -- Note [Non-Empty Content Types]
   ( RunClient m, MimeUnrender ct a, BuildHeadersTo ls

servant-client/test/Servant/ClientTestUtils.hs

@@ -85,7 +85,7 @@ type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String]
 type Api =
   Get '[JSON] Person
   :<|> "get" :> Get '[JSON] Person
-  :<|> "deleteEmpty" :> DeleteNoContent '[JSON] NoContent
+  :<|> "deleteEmpty" :> DeleteNoContent
   :<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person
   :<|> "captureAll" :> CaptureAll "names" String :> Get '[JSON] [Person]
   :<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person
@@ -101,7 +101,7 @@ type Api =
             ReqBody '[JSON] [(String, [Rational])] :>
             Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])])
   :<|> "headers" :> Get '[JSON] (Headers TestHeaders Bool)
-  :<|> "deleteContentType" :> DeleteNoContent '[JSON] NoContent
+  :<|> "deleteContentType" :> DeleteNoContent
   :<|> "redirectWithCookie" :> Raw
   :<|> "empty" :> EmptyAPI
 

servant-docs/golden/comprehensive.md

@@ -399,16 +399,7 @@
 - Status code 204
 - Headers: []
 
-- Supported content types are:
+- No response body
-
-    - `application/json;charset=utf-8`
-    - `application/json`
-
-- Example (`application/json;charset=utf-8`, `application/json`):
-
-```javascript
-
-```
 
 ## GET /raw
 

servant-docs/src/Servant/Docs/Internal.hs

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

servant-foreign/src/Servant/Foreign/Internal.hs

@@ -244,6 +244,19 @@ instance (Elem JSON list, HasForeignType lang ftype a, ReflectMethod method)
       method   = reflectMethod (Proxy :: Proxy 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
+
+  foreignFor lang Proxy Proxy req =
+    req & reqFuncName . _FunctionName %~ (methodLC :)
+        & reqMethod .~ method
+        & reqReturnType .~ Just retType
+    where
+      retType  = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy NoContent)
+      method   = reflectMethod (Proxy :: Proxy method)
+      methodLC = toLower $ decodeUtf8 method
+
 -- | TODO: doesn't taking framing into account.
 instance (ct ~ JSON, HasForeignType lang ftype a, ReflectMethod method)
   => HasForeign lang ftype (Stream method status framing ct a) where

servant-http-streams/test/Servant/ClientSpec.hs

@@ -115,7 +115,7 @@ type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String]
 type Api =
   Get '[JSON] Person
   :<|> "get" :> Get '[JSON] Person
-  :<|> "deleteEmpty" :> DeleteNoContent '[JSON] NoContent
+  :<|> "deleteEmpty" :> DeleteNoContent
   :<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person
   :<|> "captureAll" :> CaptureAll "names" String :> Get '[JSON] [Person]
   :<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person
@@ -131,7 +131,7 @@ type Api =
             ReqBody '[JSON] [(String, [Rational])] :>
             Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])])
   :<|> "headers" :> Get '[JSON] (Headers TestHeaders Bool)
-  :<|> "deleteContentType" :> DeleteNoContent '[JSON] NoContent
+  :<|> "deleteContentType" :> DeleteNoContent
   :<|> "redirectWithCookie" :> Raw
   :<|> "empty" :> EmptyAPI
 

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,14 @@ instance {-# OVERLAPPING #-}
     where method = reflectMethod (Proxy :: Proxy method)
           status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
 
+instance (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