eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

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

Browse source 
Pull 1219: no content verb 1028
This commit is contained in:
Oleg Grenrus 2019-09-29 21:22:23 +03:00 committed by GitHub
commit 002ee3cd8f
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
14 changed files with 105 additions and 46 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

7
doc/tutorial/ApiType.lhs
View file

@ -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,
`JSON` specifies the content types on which the handler will match,
and `NoContent` says that the response will always be empty.
In the second case, `DeleteNoContent` specifies a 204 response code
and that the response will always be empty.
### `QueryParam`, `QueryParams`, `QueryFlag`

26
doc/tutorial/Server.lhs
View file

@ -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
:<|> DeleteNoContent '[JSON] NoContent -- delete a user
:<|> ReqBody '[JSON] User :> PutNoContent -- update 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
:<|> DeleteNoContent '[JSON] NoContent -- delete a product
:<|> ReqBody '[JSON] Product :> PutNoContent -- update 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'
:<|> DeleteNoContent '[JSON] NoContent -- delete an 'a'
:<|> ReqBody '[JSON] a :> PutNoContent -- update an 'a'
:<|> DeleteNoContent -- delete an 'a'
)
-- Build the appropriate 'Server'

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

@ -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,
getHeadersHList, getResponse, toQueryParam, toUrlPiece)
ToSourceIO (..), Vault, Verb, NoContentVerb, WithNamedContext,
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

4
servant-client/test/Servant/ClientTestUtils.hs
View file

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

11
servant-docs/golden/comprehensive.md
View file

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

12
servant-docs/src/Servant/Docs/Internal.hs
View file

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

13
servant-foreign/src/Servant/Foreign/Internal.hs
View file

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

4
servant-http-streams/test/Servant/ClientSpec.hs
View file

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

25
servant-server/src/Servant/Server/Internal.hs
View file

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

6
servant-server/test/Servant/ServerSpec.hs
View file

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

3
servant/src/Servant/API.hs
View file

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

16
servant/src/Servant/API/Verbs.hs
View file

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

6
servant/src/Servant/Links.hs
View file

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

2
servant/src/Servant/Test/ComprehensiveAPI.hs
View file

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