Skip to content

Commit 002ee3c

Browse files
phadejphadej
authored
Merge pull request #1228 from haskell-servant/pull-1219-no-content-verb-1028
Pull 1219: no content verb 1028
2 parents 164f757 + b4372b5 commit 002ee3c

File tree

14 files changed

+105
-46
lines changed

14 files changed

+105
-46
lines changed

‎doc/tutorial/ApiType.lhs

Lines changed: 3 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -177,13 +177,12 @@ type UserAPI5 = "user" :> Capture "userid" Integer :> Get '[JSON] User
177177
-- except that we explicitly say that "userid"
178178
-- must be an integer
179179
180-
:<|> "user" :> Capture "userid" Integer :> DeleteNoContent '[JSON] NoContent
180+
:<|> "user" :> Capture "userid" Integer :> DeleteNoContent
181181
-- equivalent to 'DELETE /user/:userid'
182182
```
183183
184-
In the second case, `DeleteNoContent` specifies a 204 response code,
185-
`JSON` specifies the content types on which the handler will match,
186-
and `NoContent` says that the response will always be empty.
184+
In the second case, `DeleteNoContent` specifies a 204 response code
185+
and that the response will always be empty.
187186
188187
### `QueryParam`, `QueryParams`, `QueryFlag`
189188

‎doc/tutorial/Server.lhs

Lines changed: 13 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -830,15 +830,15 @@ type UserAPI3 = -- view the user with given userid, in JSON
830830
Capture "userid" Int :> Get '[JSON] User
831831
832832
:<|> -- delete the user with given userid. empty response
833-
Capture "userid" Int :> DeleteNoContent '[JSON] NoContent
833+
Capture "userid" Int :> DeleteNoContent
834834
```
835835
836836
We can instead factor out the `userid`:
837837
838838
``` haskell
839839
type UserAPI4 = Capture "userid" Int :>
840840
( Get '[JSON] User
841-
:<|> DeleteNoContent '[JSON] NoContent
841+
:<|> DeleteNoContent
842842
)
843843
```
844844
@@ -896,13 +896,13 @@ type API1 = "users" :>
896896
-- we factor out the Request Body
897897
type API2 = ReqBody '[JSON] User :>
898898
( Get '[JSON] User -- just display the same user back, don't register it
899-
:<|> PostNoContent '[JSON] NoContent -- register the user. empty response
899+
:<|> PostNoContent -- register the user. empty response
900900
)
901901

902902
-- we factor out a Header
903903
type API3 = Header "Authorization" Token :>
904904
( Get '[JSON] SecretData -- get some secret data, if authorized
905-
:<|> ReqBody '[JSON] SecretData :> PostNoContent '[JSON] NoContent -- add some secret data, if authorized
905+
:<|> ReqBody '[JSON] SecretData :> PostNoContent -- add some secret data, if authorized
906906
)
907907

908908
newtype Token = Token ByteString
@@ -915,11 +915,11 @@ API type only at the end.
915915
``` haskell
916916
type UsersAPI =
917917
Get '[JSON] [User] -- list users
918-
:<|> ReqBody '[JSON] User :> PostNoContent '[JSON] NoContent -- add a user
918+
:<|> ReqBody '[JSON] User :> PostNoContent -- add a user
919919
:<|> Capture "userid" Int :>
920920
( Get '[JSON] User -- view a user
921-
:<|> ReqBody '[JSON] User :> PutNoContent '[JSON] NoContent -- update a user
922-
:<|> DeleteNoContent '[JSON] NoContent -- delete a user
921+
:<|> ReqBody '[JSON] User :> PutNoContent -- update a user
922+
:<|> DeleteNoContent -- delete a user
923923
)
924924

925925
usersServer :: Server UsersAPI
@@ -948,11 +948,11 @@ usersServer = getUsers :<|> newUser :<|> userOperations
948948
``` haskell
949949
type ProductsAPI =
950950
Get '[JSON] [Product] -- list products
951-
:<|> ReqBody '[JSON] Product :> PostNoContent '[JSON] NoContent -- add a product
951+
:<|> ReqBody '[JSON] Product :> PostNoContent -- add a product
952952
:<|> Capture "productid" Int :>
953953
( Get '[JSON] Product -- view a product
954-
:<|> ReqBody '[JSON] Product :> PutNoContent '[JSON] NoContent -- update a product
955-
:<|> DeleteNoContent '[JSON] NoContent -- delete a product
954+
:<|> ReqBody '[JSON] Product :> PutNoContent -- update a product
955+
:<|> DeleteNoContent -- delete a product
956956
)
957957

958958
data Product = Product { productId :: Int }
@@ -996,11 +996,11 @@ abstract that away:
996996
-- indexed by values of type 'i'
997997
type APIFor a i =
998998
Get '[JSON] [a] -- list 'a's
999-
:<|> ReqBody '[JSON] a :> PostNoContent '[JSON] NoContent -- add an 'a'
999+
:<|> ReqBody '[JSON] a :> PostNoContent -- add an 'a'
10001000
:<|> Capture "id" i :>
10011001
( Get '[JSON] a -- view an 'a' given its "identifier" of type 'i'
1002-
:<|> ReqBody '[JSON] a :> PutNoContent '[JSON] NoContent -- update an 'a'
1003-
:<|> DeleteNoContent '[JSON] NoContent -- delete an 'a'
1002+
:<|> ReqBody '[JSON] a :> PutNoContent -- update an 'a'
1003+
:<|> DeleteNoContent -- delete an 'a'
10041004
)
10051005

10061006
-- Build the appropriate 'Server'

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

Lines changed: 14 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -50,8 +50,9 @@ import Servant.API
5050
MimeUnrender (mimeUnrender), NoContent (NoContent), QueryFlag,
5151
QueryParam', QueryParams, Raw, ReflectMethod (..), RemoteHost,
5252
ReqBody', SBoolI, Stream, StreamBody', Summary, ToHttpApiData,
53-
ToSourceIO (..), Vault, Verb, WithNamedContext, contentType,
54-
getHeadersHList, getResponse, toQueryParam, toUrlPiece)
53+
ToSourceIO (..), Vault, Verb, NoContentVerb, WithNamedContext,
54+
contentType, getHeadersHList, getResponse, toQueryParam,
55+
toUrlPiece)
5556
import Servant.API.ContentTypes
5657
(contentTypes)
5758
import Servant.API.Modifiers
@@ -241,6 +242,17 @@ instance {-# OVERLAPPING #-}
241242

242243
hoistClientMonad _ _ f ma = f ma
243244

245+
instance (RunClient m, ReflectMethod method) =>
246+
HasClient m (NoContentVerb method) where
247+
type Client m (NoContentVerb method)
248+
= m NoContent
249+
clientWithRoute _pm Proxy req = do
250+
_response <- runRequest req { requestMethod = method }
251+
return NoContent
252+
where method = reflectMethod (Proxy :: Proxy method)
253+
254+
hoistClientMonad _ _ f ma = f ma
255+
244256
instance {-# OVERLAPPING #-}
245257
-- Note [Non-Empty Content Types]
246258
( RunClient m, MimeUnrender ct a, BuildHeadersTo ls

‎servant-client/test/Servant/ClientTestUtils.hs

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -85,7 +85,7 @@ type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String]
8585
type Api =
8686
Get '[JSON] Person
8787
:<|> "get" :> Get '[JSON] Person
88-
:<|> "deleteEmpty" :> DeleteNoContent '[JSON] NoContent
88+
:<|> "deleteEmpty" :> DeleteNoContent
8989
:<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person
9090
:<|> "captureAll" :> CaptureAll "names" String :> Get '[JSON] [Person]
9191
:<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person
@@ -101,7 +101,7 @@ type Api =
101101
ReqBody '[JSON] [(String, [Rational])] :>
102102
Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])])
103103
:<|> "headers" :> Get '[JSON] (Headers TestHeaders Bool)
104-
:<|> "deleteContentType" :> DeleteNoContent '[JSON] NoContent
104+
:<|> "deleteContentType" :> DeleteNoContent
105105
:<|> "redirectWithCookie" :> Raw
106106
:<|> "empty" :> EmptyAPI
107107

‎servant-docs/golden/comprehensive.md

Lines changed: 1 addition & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -399,16 +399,7 @@
399399
- Status code 204
400400
- Headers: []
401401

402-
- Supported content types are:
403-
404-
- `application/json;charset=utf-8`
405-
- `application/json`
406-
407-
- Example (`application/json;charset=utf-8`, `application/json`):
408-
409-
```javascript
410-
411-
```
402+
- No response body
412403

413404
## GET /raw
414405

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

Lines changed: 12 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -862,6 +862,18 @@ instance {-# OVERLAPPABLE #-}
862862
status = fromInteger $ natVal (Proxy :: Proxy status)
863863
p = Proxy :: Proxy a
864864

865+
instance (ReflectMethod method) =>
866+
HasDocs (NoContentVerb method) where
867+
docsFor Proxy (endpoint, action) DocOptions{..} =
868+
single endpoint' action'
869+
870+
where endpoint' = endpoint & method .~ method'
871+
action' = action & response.respStatus .~ 204
872+
& response.respTypes .~ []
873+
& response.respBody .~ []
874+
& response.respHeaders .~ []
875+
method' = reflectMethod (Proxy :: Proxy method)
876+
865877
-- | TODO: mention the endpoint is streaming, its framing strategy
866878
--
867879
-- Also there are no samples.

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

Lines changed: 13 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -244,6 +244,19 @@ instance (Elem JSON list, HasForeignType lang ftype a, ReflectMethod method)
244244
method = reflectMethod (Proxy :: Proxy method)
245245
methodLC = toLower $ decodeUtf8 method
246246

247+
instance (HasForeignType lang ftype NoContent, ReflectMethod method)
248+
=> HasForeign lang ftype (NoContentVerb method) where
249+
type Foreign ftype (NoContentVerb method) = Req ftype
250+
251+
foreignFor lang Proxy Proxy req =
252+
req & reqFuncName . _FunctionName %~ (methodLC :)
253+
& reqMethod .~ method
254+
& reqReturnType .~ Just retType
255+
where
256+
retType = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy NoContent)
257+
method = reflectMethod (Proxy :: Proxy method)
258+
methodLC = toLower $ decodeUtf8 method
259+
247260
-- | TODO: doesn't taking framing into account.
248261
instance (ct ~ JSON, HasForeignType lang ftype a, ReflectMethod method)
249262
=> HasForeign lang ftype (Stream method status framing ct a) where

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

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -115,7 +115,7 @@ type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String]
115115
type Api =
116116
Get '[JSON] Person
117117
:<|> "get" :> Get '[JSON] Person
118-
:<|> "deleteEmpty" :> DeleteNoContent '[JSON] NoContent
118+
:<|> "deleteEmpty" :> DeleteNoContent
119119
:<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person
120120
:<|> "captureAll" :> CaptureAll "names" String :> Get '[JSON] [Person]
121121
:<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person
@@ -131,7 +131,7 @@ type Api =
131131
ReqBody '[JSON] [(String, [Rational])] :>
132132
Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])])
133133
:<|> "headers" :> Get '[JSON] (Headers TestHeaders Bool)
134-
:<|> "deleteContentType" :> DeleteNoContent '[JSON] NoContent
134+
:<|> "deleteContentType" :> DeleteNoContent
135135
:<|> "redirectWithCookie" :> Raw
136136
:<|> "empty" :> EmptyAPI
137137

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

Lines changed: 23 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -75,10 +75,12 @@ import Servant.API
7575
IsSecure (..), QueryFlag, QueryParam', QueryParams, Raw,
7676
ReflectMethod (reflectMethod), RemoteHost, ReqBody',
7777
SBool (..), SBoolI (..), SourceIO, Stream, StreamBody',
78-
Summary, ToSourceIO (..), Vault, Verb, WithNamedContext)
78+
Summary, ToSourceIO (..), Vault, Verb, NoContentVerb,
79+
WithNamedContext)
7980
import Servant.API.ContentTypes
8081
(AcceptHeader (..), AllCTRender (..), AllCTUnrender (..),
81-
AllMime, MimeRender (..), MimeUnrender (..), canHandleAcceptH)
82+
AllMime, MimeRender (..), MimeUnrender (..), canHandleAcceptH,
83+
NoContent (NoContent))
8284
import Servant.API.Modifiers
8385
(FoldLenient, FoldRequired, RequestArgument,
8486
unfoldRequestArgument)
@@ -262,6 +264,17 @@ methodRouter splitHeaders method proxy status action = leafRouter route'
262264
let bdy = if allowedMethodHead method request then "" else body
263265
in Route $ responseLBS status ((hContentType, cs contentT) : headers) bdy
264266

267+
noContentRouter :: Method
268+
-> Status
269+
-> Delayed env (Handler b)
270+
-> Router env
271+
noContentRouter method status action = leafRouter route'
272+
where
273+
route' env request respond =
274+
runAction (action `addMethodCheck` methodCheck method request)
275+
env request respond $ \ output ->
276+
Route $ responseLBS status [] ""
277+
265278
instance {-# OVERLAPPABLE #-}
266279
( AllCTRender ctypes a, ReflectMethod method, KnownNat status
267280
) => HasServer (Verb method status ctypes a) context where
@@ -285,6 +298,14 @@ instance {-# OVERLAPPING #-}
285298
where method = reflectMethod (Proxy :: Proxy method)
286299
status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
287300

301+
instance (ReflectMethod method) =>
302+
HasServer (NoContentVerb method) context where
303+
304+
type ServerT (NoContentVerb method) m = m NoContent
305+
hoistServerWithContext _ _ nt s = nt s
306+
307+
route Proxy _ = noContentRouter method status204
308+
where method = reflectMethod (Proxy :: Proxy method)
288309

289310
instance {-# OVERLAPPABLE #-}
290311
( MimeRender ctype chunk, ReflectMethod method, KnownNat status,

‎servant-server/test/Servant/ServerSpec.hs

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -51,7 +51,7 @@ import Servant.API
5151
JSON, NoContent (..), NoFraming, OctetStream, Patch,
5252
PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, Raw,
5353
RemoteHost, ReqBody, SourceIO, StdMethod (..), Stream, Verb,
54-
addHeader)
54+
NoContentVerb, addHeader)
5555
import Servant.Server
5656
(Context ((:.), EmptyContext), Handler, Server, Tagged (..),
5757
emptyServer, err400, err401, err403, err404, serve, serveWithContext)
@@ -103,7 +103,7 @@ spec = do
103103

104104
type VerbApi method status
105105
= Verb method status '[JSON] Person
106-
:<|> "noContent" :> Verb method status '[JSON] NoContent
106+
:<|> "noContent" :> NoContentVerb method
107107
:<|> "header" :> Verb method status '[JSON] (Headers '[Header "H" Int] Person)
108108
:<|> "headerNC" :> Verb method status '[JSON] (Headers '[Header "H" Int] NoContent)
109109
:<|> "accept" :> ( Verb method status '[JSON] Person
@@ -140,7 +140,7 @@ verbSpec = describe "Servant.API.Verb" $ do
140140

141141
it "returns no content on NoContent" $ do
142142
response <- THW.request method "/noContent" [] ""
143-
liftIO $ statusCode (simpleStatus response) `shouldBe` status
143+
liftIO $ statusCode (simpleStatus response) `shouldBe` 204
144144
liftIO $ simpleBody response `shouldBe` ""
145145

146146
-- HEAD should not return body

0 commit comments

Comments
 (0)