From b440af900b083864faecc38a2e6083dd0a8b3562 Mon Sep 17 00:00:00 2001 From: Catherine Galkina Date: Sat, 7 Sep 2019 18:13:46 +0300 Subject: [PATCH] Implemented NoContentVerb and server instances for it --- servant-server/src/Servant/Server/Internal.hs | 26 +++++++++++++++++-- servant-server/test/Servant/ServerSpec.hs | 6 ++--- servant/src/Servant/API.hs | 3 ++- servant/src/Servant/API/Verbs.hs | 16 ++++++++---- servant/src/Servant/Links.hs | 6 ++++- servant/src/Servant/Test/ComprehensiveAPI.hs | 2 +- 6 files changed, 46 insertions(+), 13 deletions(-) diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 9b1a77eb..196895cf 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/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, diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index d7583dc2..ff87d04b 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/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 diff --git a/servant/src/Servant/API.hs b/servant/src/Servant/API.hs index b9c1c78b..772a3887 100644 --- a/servant/src/Servant/API.hs +++ b/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 diff --git a/servant/src/Servant/API/Verbs.hs b/servant/src/Servant/API/Verbs.hs index b7d4c048..9ae1c2fd 100644 --- a/servant/src/Servant/API/Verbs.hs +++ b/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 diff --git a/servant/src/Servant/Links.hs b/servant/src/Servant/Links.hs index 77f882df..0d07c201 100644 --- a/servant/src/Servant/Links.hs +++ b/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 diff --git a/servant/src/Servant/Test/ComprehensiveAPI.hs b/servant/src/Servant/Test/ComprehensiveAPI.hs index 76800be4..4445986a 100644 --- a/servant/src/Servant/Test/ComprehensiveAPI.hs +++ b/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