b440af9 · servant · git.iko.soy

servant-server/src/Servant/Server/Internal.hs+24−2

compare with master

unifiedsplit

@@ -75,10 +75,12 @@ import Servant.API

75 IsSecure (..), QueryFlag, QueryParam', QueryParams, Raw,

76 ReflectMethod (reflectMethod), RemoteHost, ReqBody',

77 SBool (..), SBoolI (..), SourceIO, Stream, StreamBody',

78− Summary, ToSourceIO (..), Vault, Verb, WithNamedContext)

78+ Summary, ToSourceIO (..), Vault, Verb, NoContentVerb,

79+ WithNamedContext)

79import Servant.API.ContentTypes

80import Servant.API.ContentTypes

80 (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..),

81 (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..),

81− AllMime, MimeRender (..), MimeUnrender (..), canHandleAcceptH)

82+ AllMime, MimeRender (..), MimeUnrender (..), canHandleAcceptH,

83+ NoContent (NoContent))

82import Servant.API.Modifiers

84import Servant.API.Modifiers

83 (FoldLenient, FoldRequired, RequestArgument,

85 (FoldLenient, FoldRequired, RequestArgument,

84 unfoldRequestArgument)

86 unfoldRequestArgument)

@@ -262,6 +264,17 @@ methodRouter splitHeaders method proxy status action = leafRouter route'

262 let bdy = if allowedMethodHead method request then "" else body

264 let bdy = if allowedMethodHead method request then "" else body

263 in Route $ responseLBS status ((hContentType, cs contentT) : headers) bdy

265 in Route $ responseLBS status ((hContentType, cs contentT) : headers) bdy

264

266

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+

265instance {-# OVERLAPPABLE #-}

278instance {-# OVERLAPPABLE #-}

266 ( AllCTRender ctypes a, ReflectMethod method, KnownNat status

279 ( AllCTRender ctypes a, ReflectMethod method, KnownNat status

267 ) => HasServer (Verb method status ctypes a) context where

280 ) => HasServer (Verb method status ctypes a) context where

@@ -285,6 +298,15 @@ instance {-# OVERLAPPING #-}

285 where method = reflectMethod (Proxy :: Proxy method)

298 where method = reflectMethod (Proxy :: Proxy method)

286 status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)

299 status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)

287

300

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)

288

310

289instance {-# OVERLAPPABLE #-}

311instance {-# OVERLAPPABLE #-}

290 ( MimeRender ctype chunk, ReflectMethod method, KnownNat status,

312 ( MimeRender ctype chunk, ReflectMethod method, KnownNat status,

servant-server/test/Servant/ServerSpec.hs+3−3

@@ -51,7 +51,7 @@ import Servant.API

51 JSON, NoContent (..), NoFraming, OctetStream, Patch,

52 PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, Raw,

53 RemoteHost, ReqBody, SourceIO, StdMethod (..), Stream, Verb,

54− addHeader)

54+ NoContentVerb, addHeader)

55import Servant.Server

56 (Context ((:.), EmptyContext), Handler, Server, Tagged (..),

57 emptyServer, err400, err401, err403, err404, serve, serveWithContext)

@@ -103,7 +103,7 @@ spec = do

103

104type VerbApi method status

105 = Verb method status '[JSON] Person

106− :<|> "noContent" :> Verb method status '[JSON] NoContent

106+ :<|> "noContent" :> NoContentVerb method

107 :<|> "header" :> Verb method status '[JSON] (Headers '[Header "H" Int] Person)

108 :<|> "headerNC" :> Verb method status '[JSON] (Headers '[Header "H" Int] NoContent)

109 :<|> "accept" :> ( Verb method status '[JSON] Person

@@ -140,7 +140,7 @@ verbSpec = describe "Servant.API.Verb" $ do

140

141 it "returns no content on NoContent" $ do

142 response <- THW.request method "/noContent" [] ""

143− liftIO $ statusCode (simpleStatus response) `shouldBe` status

143+ liftIO $ statusCode (simpleStatus response) `shouldBe` 204

144 liftIO $ simpleBody response `shouldBe` ""

145

146 -- HEAD should not return body

servant/src/Servant/API.hs+2−1

@@ -130,7 +130,8 @@ import Servant.API.Verbs

130 Post, PostAccepted, PostCreated, PostNoContent,

131 PostNonAuthoritative, PostResetContent, Put, PutAccepted,

132 PutCreated, PutNoContent, PutNonAuthoritative,

133− ReflectMethod (reflectMethod), StdMethod (..), Verb)

133+ ReflectMethod (reflectMethod), StdMethod (..),

134+ Verb, NoContentVerb)

134import Servant.API.WithNamedContext

135import Servant.API.WithNamedContext

135 (WithNamedContext)

136 (WithNamedContext)

136import Servant.Links

137import Servant.Links

servant/src/Servant/API/Verbs.hs+11−5

@@ -29,6 +29,12 @@ import Network.HTTP.Types.Method

29data Verb (method :: k1) (statusCode :: Nat) (contentTypes :: [*]) (a :: *)

30 deriving (Typeable, Generic)

31

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+

32-- * 200 responses

38-- * 200 responses

33--

39--

34-- The 200 response is the workhorse of web servers, but also fairly generic.

40-- The 200 response is the workhorse of web servers, but also fairly generic.

@@ -113,15 +119,15 @@ type PutNonAuthoritative = Verb 'PUT 203

113-- If the document view should be reset, use @205 Reset Content@.

119-- If the document view should be reset, use @205 Reset Content@.

114

120

115-- | 'GET' with 204 status code.

121-- | 'GET' with 204 status code.

116−type GetNoContent = Verb 'GET 204

122+type GetNoContent = NoContentVerb 'GET

117-- | 'POST' with 204 status code.

123-- | 'POST' with 204 status code.

118−type PostNoContent = Verb 'POST 204

124+type PostNoContent = NoContentVerb 'POST

119-- | 'DELETE' with 204 status code.

125-- | 'DELETE' with 204 status code.

120−type DeleteNoContent = Verb 'DELETE 204

126+type DeleteNoContent = NoContentVerb 'DELETE

121-- | 'PATCH' with 204 status code.

127-- | 'PATCH' with 204 status code.

122−type PatchNoContent = Verb 'PATCH 204

128+type PatchNoContent = NoContentVerb 'PATCH

123-- | 'PUT' with 204 status code.

129-- | 'PUT' with 204 status code.

124−type PutNoContent = Verb 'PUT 204

130+type PutNoContent = NoContentVerb 'PUT

125

131

126

132

127-- ** 205 Reset Content

133-- ** 205 Reset Content

servant/src/Servant/Links.hs+5−1

@@ -177,7 +177,7 @@ import Servant.API.TypeLevel

177import Servant.API.Vault

178 (Vault)

179import Servant.API.Verbs

180− (Verb)

180+ (Verb, NoContentVerb)

181import Servant.API.WithNamedContext

182 (WithNamedContext)

183import Web.HttpApiData

@@ -546,6 +546,10 @@ instance HasLink (Verb m s ct a) where

546 type MkLink (Verb m s ct a) r = r

547 toLink toA _ = toA

548

549+instance HasLink (NoContentVerb m) where

550+ type MkLink (NoContentVerb m) r = r

551+ toLink toA _ = toA

552+

549instance HasLink Raw where

553instance HasLink Raw where

550 type MkLink Raw a = a

554 type MkLink Raw a = a

551 toLink toA _ = toA

555 toLink toA _ = toA

servant/src/Servant/Test/ComprehensiveAPI.hs+1−1

@@ -64,7 +64,7 @@ type ComprehensiveAPIWithoutStreamingOrRaw' endpoint =

64 :<|> "res-headers" :> Get '[JSON] (Headers '[Header "foo" Int] NoContent)

65 :<|> "foo" :> GET

66 :<|> "vault" :> Vault :> GET

67− :<|> "post-no-content" :> Verb 'POST 204 '[JSON] NoContent

67+ :<|> "post-no-content" :> PostNoContent

68 :<|> "post-int" :> Verb 'POST 204 '[JSON] Int

69 :<|> "named-context" :> WithNamedContext "foo" '[] GET

70 :<|> "capture-all" :> CaptureAll "foo" Int :> GET