git.iko.soy/typeable/servant
on master help sign in
Implemented NoContentVerb and server instances for it
commitb440af900b083864faecc38a2e6083dd0a8b3562 authorCatherine Galkina <anais94@yandex.ru> dateSat 7 Sep 2019, 18:13 (7 years ago) parent164f757
6 files changed+46−13
compare with master
unifiedsplit
servant-server/src/Servant/Server/Internal.hs+24−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
servant-server/src/Servant/Server/Internal.hs+24−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,15 @@ instance {-# OVERLAPPING #-}
285298 where method = reflectMethod (Proxy :: Proxy method)
286299 status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
287300
301+instance {-# OVERLAPPABLE #-}
302+ (ReflectMethod method
303+ ) => HasServer (NoContentVerb method) context where
304+
305+ type ServerT (NoContentVerb method) m = m NoContent
306+ hoistServerWithContext _ _ nt s = nt s
307+
308+ route Proxy _ = noContentRouter method status204
309+ where method = reflectMethod (Proxy :: Proxy method)
288310
289311instance {-# OVERLAPPABLE #-}
290312 ( 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