git.iko.soy/typeable/servant
on master help sign in
Merge pull request #1228 from haskell-servant/pull-1219-no-content-verb-1028

Pull 1219: no content verb 1028

commit002ee3cd8ff21b8d786d7a86c5b3599dd062e5aa authorOleg Grenrus <oleg.grenrus@iki.fi> dateSun 29 Sep 2019, 21:22 (7 years ago) parent164f757b4372b5
14 files changed+105−46
compare with master
unifiedsplit
doc/tutorial/ApiType.lhs+3−4 doc/tutorial/Server.lhs+13−13 servant-client-core/src/Servant/Client/Core/HasClient.hs+14−2 servant-client/test/Servant/ClientTestUtils.hs+2−2 servant-docs/golden/comprehensive.md+1−10 servant-docs/src/Servant/Docs/Internal.hs+12 servant-foreign/src/Servant/Foreign/Internal.hs+13 servant-http-streams/test/Servant/ClientSpec.hs+2−2 servant-server/src/Servant/Server/Internal.hs+23−2 servant-server/test/Servant/ServerSpec.hs+3−3 servant/src/Servant/API.hs+2−1 servant/src/Servant/API/Verbs.hs+11−5 servant/src/Servant/Links.hs+5−1 servant/src/Servant/Test/ComprehensiveAPI.hs+1−1
doc/tutorial/ApiType.lhs+3−4
@@ -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+13−13
@@ -830,7 +830,7 @@ 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
836836We can instead factor out the `userid`:
@@ -838,7 +838,7 @@ We can instead factor out the `userid`:
838838``` haskell
839839type 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
897897type 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
903903type 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
908908newtype Token = Token ByteString
@@ -915,11 +915,11 @@ API type only at the end.
915915``` haskell
916916type 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
925925usersServer :: Server UsersAPI
@@ -948,11 +948,11 @@ usersServer = getUsers :<|> newUser :<|> userOperations
948948``` haskell
949949type 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
958958data Product = Product { productId :: Int }
@@ -996,11 +996,11 @@ abstract that away:
996996-- indexed by values of type 'i'
997997type 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+14−2
@@ -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)
5556import Servant.API.ContentTypes
5657 (contentTypes)
5758import 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+
244256instance {-# OVERLAPPING #-}
245257 -- Note [Non-Empty Content Types]
246258 ( RunClient m, MimeUnrender ct a, BuildHeadersTo ls
servant-client/test/Servant/ClientTestUtils.hs+2−2
@@ -85,7 +85,7 @@ type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String]
8585type 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+1−10
@@ -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+12
@@ -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+13
@@ -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.
248261instance (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+2−2
@@ -115,7 +115,7 @@ type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String]
115115type 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+23−2
@@ -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)
7980import Servant.API.ContentTypes
8081 (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..),
81− AllMime, MimeRender (..), MimeUnrender (..), canHandleAcceptH)
82+ AllMime, MimeRender (..), MimeUnrender (..), canHandleAcceptH,
83+ NoContent (NoContent))
8284import 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+
265278instance {-# 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
289310instance {-# OVERLAPPABLE #-}
290311 ( MimeRender ctype chunk, ReflectMethod method, KnownNat status,
servant-server/test/Servant/ServerSpec.hs+3−3
@@ -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)
5555import Servant.Server
5656 (Context ((:.), EmptyContext), Handler, Server, Tagged (..),
5757 emptyServer, err400, err401, err403, err404, serve, serveWithContext)
@@ -103,7 +103,7 @@ spec = do
103103
104104type 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
servant/src/Servant/API.hs+2−1
@@ -130,7 +130,8 @@ import Servant.API.Verbs
130130 Post, PostAccepted, PostCreated, PostNoContent,
131131 PostNonAuthoritative, PostResetContent, Put, PutAccepted,
132132 PutCreated, PutNoContent, PutNonAuthoritative,
133− ReflectMethod (reflectMethod), StdMethod (..), Verb)
133+ ReflectMethod (reflectMethod), StdMethod (..),
134+ Verb, NoContentVerb)
134135import Servant.API.WithNamedContext
135136 (WithNamedContext)
136137import Servant.Links
servant/src/Servant/API/Verbs.hs+11−5
@@ -29,6 +29,12 @@ import Network.HTTP.Types.Method
2929data Verb (method :: k1) (statusCode :: Nat) (contentTypes :: [*]) (a :: *)
3030 deriving (Typeable, Generic)
3131
32+-- | @NoContentVerb@ is a specific type to represent 'NoContent' responses.
33+-- It does not require either a list of content types (because there's
34+-- no content) or a status code (because it should always be 204).
35+data NoContentVerb (method :: k1)
36+ deriving (Typeable, Generic)
37+
3238-- * 200 responses
3339--
3440-- The 200 response is the workhorse of web servers, but also fairly generic.
@@ -113,15 +119,15 @@ type PutNonAuthoritative = Verb 'PUT 203
113119-- If the document view should be reset, use @205 Reset Content@.
114120
115121-- | 'GET' with 204 status code.
116−type GetNoContent = Verb 'GET 204
122+type GetNoContent = NoContentVerb 'GET
117123-- | 'POST' with 204 status code.
118−type PostNoContent = Verb 'POST 204
124+type PostNoContent = NoContentVerb 'POST
119125-- | 'DELETE' with 204 status code.
120−type DeleteNoContent = Verb 'DELETE 204
126+type DeleteNoContent = NoContentVerb 'DELETE
121127-- | 'PATCH' with 204 status code.
122−type PatchNoContent = Verb 'PATCH 204
128+type PatchNoContent = NoContentVerb 'PATCH
123129-- | 'PUT' with 204 status code.
124−type PutNoContent = Verb 'PUT 204
130+type PutNoContent = NoContentVerb 'PUT
125131
126132
127133-- ** 205 Reset Content
servant/src/Servant/Links.hs+5−1
@@ -177,7 +177,7 @@ import Servant.API.TypeLevel
177177import Servant.API.Vault
178178 (Vault)
179179import Servant.API.Verbs
180− (Verb)
180+ (Verb, NoContentVerb)
181181import Servant.API.WithNamedContext
182182 (WithNamedContext)
183183import Web.HttpApiData
@@ -546,6 +546,10 @@ instance HasLink (Verb m s ct a) where
546546 type MkLink (Verb m s ct a) r = r
547547 toLink toA _ = toA
548548
549+instance HasLink (NoContentVerb m) where
550+ type MkLink (NoContentVerb m) r = r
551+ toLink toA _ = toA
552+
549553instance HasLink Raw where
550554 type MkLink Raw a = a
551555 toLink toA _ = toA
servant/src/Servant/Test/ComprehensiveAPI.hs+1−1
@@ -64,7 +64,7 @@ type ComprehensiveAPIWithoutStreamingOrRaw' endpoint =
6464 :<|> "res-headers" :> Get '[JSON] (Headers '[Header "foo" Int] NoContent)
6565 :<|> "foo" :> GET
6666 :<|> "vault" :> Vault :> GET
67− :<|> "post-no-content" :> Verb 'POST 204 '[JSON] NoContent
67+ :<|> "post-no-content" :> PostNoContent
6868 :<|> "post-int" :> Verb 'POST 204 '[JSON] Int
6969 :<|> "named-context" :> WithNamedContext "foo" '[] GET
7070 :<|> "capture-all" :> CaptureAll "foo" Int :> GET