5eddb31 · servant · git.iko.soy

git.iko.soy/servant

on master help sign in

Make Post and Put return NoContent when response is ()

5eddb31Julian K. Arni12 years ago

src/Servant/Server/Internal.hs+61−13

compare with master

unifiedsplit

@@ -4,12 +4,12 @@

4{-# LANGUAGE TypeOperators #-}

5{-# LANGUAGE FlexibleInstances #-}

6{-# LANGUAGE OverloadedStrings #-}

7+{-# LANGUAGE OverlappingInstances #-}

7{-# LANGUAGE ScopedTypeVariables #-}

8{-# LANGUAGE ScopedTypeVariables #-}

8module Servant.Server.Internal where

9module Servant.Server.Internal where

10import Control.Applicative ((<$>))

11import Control.Applicative ((<$>))

11import Control.Monad.Trans.Either (EitherT, runEitherT)

12import Control.Monad.Trans.Either (EitherT, runEitherT)

12−import Data.Aeson (ToJSON)

13import qualified Data.ByteString as B

14import qualified Data.ByteString.Lazy as BL

15import Data.IORef (newIORef, readIORef, writeIORef)

@@ -286,6 +286,19 @@ instance ( AllCTRender ctypes a

286 respond $ failWith WrongMethod

287 | otherwise = respond $ failWith NotFound

288

289+instance HasServer (Get ctypes ()) where

290+ type ServerT (Get ctypes ()) m = m ()

291+ route Proxy action request respond

292+ | pathIsEmpty request && requestMethod request == methodGet = do

293+ e <- runEitherT action

294+ respond . succeedWith $ case e of

295+ Right () -> responseLBS noContent204 [] ""

296+ Left (status, message) ->

297+ responseLBS (mkStatus status (cs message)) [] (cs message)

298+ | pathIsEmpty request && requestMethod request /= methodGet =

299+ respond $ failWith WrongMethod

300+ | otherwise = respond $ failWith NotFound

301+

289-- | If you use 'Header' in one of the endpoints for your API,

302-- | If you use 'Header' in one of the endpoints for your API,

290-- this automatically requires your server-side handler to be a function

303-- this automatically requires your server-side handler to be a function

291-- that takes an argument of the type specified by 'Header'.

304-- that takes an argument of the type specified by 'Header'.

@@ -351,6 +364,19 @@ instance ( AllCTRender ctypes a

351 respond $ failWith WrongMethod

364 respond $ failWith WrongMethod

352 | otherwise = respond $ failWith NotFound

365 | otherwise = respond $ failWith NotFound

353

366

367+instance HasServer (Post ctypes ()) where

368+ type ServerT (Post ctypes ()) m = m ()

369+ route Proxy action request respond

370+ | pathIsEmpty request && requestMethod request == methodPost = do

371+ e <- runEitherT action

372+ respond . succeedWith $ case e of

373+ Right () -> responseLBS noContent204 [] ""

374+ Left (status, message) ->

375+ responseLBS (mkStatus status (cs message)) [] (cs message)

376+ | pathIsEmpty request && requestMethod request /= methodPost =

377+ respond $ failWith WrongMethod

378+ | otherwise = respond $ failWith NotFound

379+

354-- | When implementing the handler for a 'Put' endpoint,

380-- | When implementing the handler for a 'Put' endpoint,

355-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'

381-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'

356-- and 'Servant.API.Post.Post', the handler code runs in the

382-- and 'Servant.API.Post.Post', the handler code runs in the

@@ -382,7 +408,19 @@ instance ( AllCTRender ctypes a

382 responseLBS (mkStatus status (cs message)) [] (cs message)

408 responseLBS (mkStatus status (cs message)) [] (cs message)

383 | pathIsEmpty request && requestMethod request /= methodPut =

409 | pathIsEmpty request && requestMethod request /= methodPut =

384 respond $ failWith WrongMethod

410 respond $ failWith WrongMethod

411+ | otherwise = respond $ failWith NotFound

385

412

413+instance HasServer (Put ctypes ()) where

414+ type ServerT (Put ctypes ()) m = m ()

415+ route Proxy action request respond

416+ | pathIsEmpty request && requestMethod request == methodPut = do

417+ e <- runEitherT action

418+ respond . succeedWith $ case e of

419+ Right () -> responseLBS noContent204 [] ""

420+ Left (status, message) ->

421+ responseLBS (mkStatus status (cs message)) [] (cs message)

422+ | pathIsEmpty request && requestMethod request /= methodPut =

423+ respond $ failWith WrongMethod

386 | otherwise = respond $ failWith NotFound

424 | otherwise = respond $ failWith NotFound

387

425

388-- | When implementing the handler for a 'Patch' endpoint,

426-- | When implementing the handler for a 'Patch' endpoint,

@@ -397,25 +435,35 @@ instance ( AllCTRender ctypes a

397-- a 'ToJSON' instance and servant takes care of encoding it for you,

435-- a 'ToJSON' instance and servant takes care of encoding it for you,

398-- yielding status code 201 along the way.

436-- yielding status code 201 along the way.

399instance ( AllCTRender ctypes a

437instance ( AllCTRender ctypes a

400− , Typeable a

401− , ToJSON a) => HasServer (Patch ctypes a) where

438+ ) => HasServer (Patch ctypes a) where

402 type ServerT (Patch ctypes a) m = m a

439 type ServerT (Patch ctypes a) m = m a

403

440

404 route Proxy action request respond

441 route Proxy action request respond

405− | pathIsEmpty request && requestMethod request == methodPost = do

442+ | pathIsEmpty request && requestMethod request == methodPatch = do

443+ e <- runEitherT action

444+ respond . succeedWith $ case e of

445+ Right output -> do

446+ let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request

447+ case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of

448+ Nothing -> responseLBS (mkStatus 406 "") [] ""

449+ Just (contentT, body) -> responseLBS status200 [ ("Content-Type"

450+ , cs contentT)] body

451+ Left (status, message) ->

452+ responseLBS (mkStatus status (cs message)) [] (cs message)

453+ | pathIsEmpty request && requestMethod request /= methodPatch =

454+ respond $ failWith WrongMethod

455+ | otherwise = respond $ failWith NotFound

456+

457+instance HasServer (Patch ctypes ()) where

458+ type ServerT (Patch ctypes ()) m = m ()

459+ route Proxy action request respond

460+ | pathIsEmpty request && requestMethod request == methodPatch = do

406 e <- runEitherT action

461 e <- runEitherT action

407 respond . succeedWith $ case e of

462 respond . succeedWith $ case e of

408− Right out -> case cast out of

463+ Right () -> responseLBS noContent204 [] ""

409− Nothing -> do

410− let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request

411− case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) out of

412− Nothing -> responseLBS (mkStatus 406 "") [] ""

413− Just (contentT, body) -> responseLBS status200 [ ("Content-Type"

414− , cs contentT)] body

415− Just () -> responseLBS status204 [] ""

416 Left (status, message) ->

464 Left (status, message) ->

417 responseLBS (mkStatus status (cs message)) [] (cs message)

465 responseLBS (mkStatus status (cs message)) [] (cs message)

418− | pathIsEmpty request && requestMethod request /= methodPost =

466+ | pathIsEmpty request && requestMethod request /= methodPatch =

419 respond $ failWith WrongMethod

467 respond $ failWith WrongMethod

420 | otherwise = respond $ failWith NotFound

468 | otherwise = respond $ failWith NotFound

421

469

test/Servant/ServerSpec.hs+133−31

@@ -1,36 +1,40 @@

1−{-# LANGUAGE DataKinds #-}

1+{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE DeriveGeneric #-}

2+{-# LANGUAGE DeriveGeneric #-}

3−{-# LANGUAGE OverloadedStrings #-}

3+{-# LANGUAGE OverloadedStrings #-}

4−{-# LANGUAGE QuasiQuotes #-}

5{-# LANGUAGE ScopedTypeVariables #-}

4{-# LANGUAGE ScopedTypeVariables #-}

6−{-# LANGUAGE TypeOperators #-}

5+{-# LANGUAGE TypeOperators #-}

8module Servant.ServerSpec where

7module Servant.ServerSpec where

11−import Control.Monad (when)

10+import Control.Monad (when)

12−import Control.Monad.Trans.Either (EitherT, left)

11+import Control.Monad.Trans.Either (EitherT, left)

13−import Data.Aeson (ToJSON, FromJSON, encode, decode')

12+import Data.Aeson (FromJSON, ToJSON, decode', encode)

14−import Data.Char (toUpper)

13+import Data.Char (toUpper)

15−import Data.Monoid ((<>))

14+import Data.Monoid ((<>))

16−import Data.Proxy (Proxy(Proxy))

15+import Data.Proxy (Proxy (Proxy))

17−import Data.String (fromString)

16+import Data.String (fromString)

18−import Data.String.Conversions (cs)

17+import Data.String.Conversions (cs)

19−import GHC.Generics (Generic)

18+import GHC.Generics (Generic)

19+import Network.HTTP.Types (hContentType, methodDelete,

20+ methodPatch, methodPost, methodPut,

20−import Network.HTTP.Types ( parseQuery, ok200, status409, methodPost

21+ ok200, parseQuery, status409)

21− , methodDelete, hContentType)

22−import Network.Wai ( Application, Request, responseLBS, pathInfo

22+import Network.Wai (Application, Request, pathInfo,

23− , queryString, rawQueryString )

23+ queryString, rawQueryString,

24+ responseLBS)

24−import Network.Wai.Test (runSession, defaultRequest, simpleBody, request)

25+import Network.Wai.Test (defaultRequest, request,

26+ runSession, simpleBody)

25−import Test.Hspec (Spec, describe, it, shouldBe)

27+import Test.Hspec (Spec, describe, it, shouldBe)

26−import Test.Hspec.Wai ( liftIO, with, get, post, shouldRespondWith

28+import Test.Hspec.Wai (get, liftIO, matchStatus, post,

27− , matchStatus, request )

29+ request, shouldRespondWith, with)

28−

30+

29−import Servant.API (JSON, Capture, Get, ReqBody, Post, QueryParam

31+import Servant.API ((:<|>) (..), (:>), Capture, Delete,

30− , QueryParams, QueryFlag, MatrixParam, MatrixParams

32+ Get, Header, JSON, MatrixFlag,

31− , MatrixFlag, Raw, (:>), (:<|>)(..), Header, Delete )

33+ MatrixParam, MatrixParams, Patch,

34+ Post, Put, QueryFlag, QueryParam,

35+ QueryParams, Raw, ReqBody)

32−import Servant.Server (Server, serve)

36+import Servant.Server (Server, serve)

33−import Servant.Server.Internal (RouteMismatch(..))

37+import Servant.Server.Internal (RouteMismatch (..))

36-- * test data types

40-- * test data types

@@ -69,9 +73,11 @@ spec :: Spec

69spec = do

73spec = do

70 captureSpec

74 captureSpec

71 getSpec

75 getSpec

76+ postSpec

77+ putSpec

78+ patchSpec

72 queryParamSpec

79 queryParamSpec

73 matrixParamSpec

80 matrixParamSpec

74− postSpec

75 headerSpec

81 headerSpec

76 rawSpec

82 rawSpec

77 unionSpec

83 unionSpec

@@ -105,13 +111,15 @@ captureSpec = do

105

111

106

112

107type GetApi = Get '[JSON] Person

113type GetApi = Get '[JSON] Person

114+ :<|> "empty" :> Get '[] ()

108getApi :: Proxy GetApi

115getApi :: Proxy GetApi

109getApi = Proxy

116getApi = Proxy

110

117

111getSpec :: Spec

118getSpec :: Spec

112getSpec = do

119getSpec = do

113 describe "Servant.API.Get" $ do

120 describe "Servant.API.Get" $ do

121+ let server = return alice :<|> return ()

114− with (return (serve getApi (return alice))) $ do

122+ with (return $ serve getApi server) $ do

115 it "allows to GET a Person" $ do

123 it "allows to GET a Person" $ do

116 response <- get "/"

124 response <- get "/"

117 return response `shouldRespondWith` 200

125 return response `shouldRespondWith` 200

@@ -121,6 +129,10 @@ getSpec = do

121 it "throws 405 (wrong method) on POSTs" $ do

129 it "throws 405 (wrong method) on POSTs" $ do

122 post "/" "" `shouldRespondWith` 405

130 post "/" "" `shouldRespondWith` 405

123

131

132+ it "returns 204 if the type is '()'" $ do

133+ get "empty" `shouldRespondWith` ""{ matchStatus = 204 }

134+

135+

124

136

125type QueryParamApi = QueryParam "name" String :> Get '[JSON] Person

137type QueryParamApi = QueryParam "name" String :> Get '[JSON] Person

126 :<|> "a" :> QueryParams "names" String :> Get '[JSON] Person

138 :<|> "a" :> QueryParams "names" String :> Get '[JSON] Person

@@ -291,13 +303,16 @@ matrixParamSpec = do

291type PostApi =

303type PostApi =

292 ReqBody '[JSON] Person :> Post '[JSON] Integer

304 ReqBody '[JSON] Person :> Post '[JSON] Integer

293 :<|> "bla" :> ReqBody '[JSON] Person :> Post '[JSON] Integer

305 :<|> "bla" :> ReqBody '[JSON] Person :> Post '[JSON] Integer

306+ :<|> "empty" :> Post '[] ()

307+

294postApi :: Proxy PostApi

308postApi :: Proxy PostApi

295postApi = Proxy

309postApi = Proxy

296

310

297postSpec :: Spec

311postSpec :: Spec

298postSpec = do

312postSpec = do

299 describe "Servant.API.Post and .ReqBody" $ do

313 describe "Servant.API.Post and .ReqBody" $ do

314+ let server = return . age :<|> return . age :<|> return ()

300− with (return (serve postApi (return . age :<|> return . age))) $ do

315+ with (return $ serve postApi server) $ do

301 let post' x = Test.Hspec.Wai.request methodPost x [(hContentType

316 let post' x = Test.Hspec.Wai.request methodPost x [(hContentType

302 , "application/json;charset=utf-8")]

317 , "application/json;charset=utf-8")]

303

318

@@ -319,11 +334,98 @@ postSpec = do

319 it "correctly rejects invalid request bodies with status 400" $ do

334 it "correctly rejects invalid request bodies with status 400" $ do

320 post' "/" "some invalid body" `shouldRespondWith` 400

335 post' "/" "some invalid body" `shouldRespondWith` 400

321

336

337+ it "returns 204 if the type is '()'" $ do

338+ post' "empty" "" `shouldRespondWith` ""{ matchStatus = 204 }

339+

322 it "responds with 415 if the requested media type is unsupported" $ do

340 it "responds with 415 if the requested media type is unsupported" $ do

323 let post'' x = Test.Hspec.Wai.request methodPost x [(hContentType

341 let post'' x = Test.Hspec.Wai.request methodPost x [(hContentType

324 , "application/nonsense")]

342 , "application/nonsense")]

325 post'' "/" "anything at all" `shouldRespondWith` 415

343 post'' "/" "anything at all" `shouldRespondWith` 415

326

344

345+type PutApi =

346+ ReqBody '[JSON] Person :> Put '[JSON] Integer

347+ :<|> "bla" :> ReqBody '[JSON] Person :> Put '[JSON] Integer

348+ :<|> "empty" :> Put '[] ()

349+

350+putApi :: Proxy PutApi

351+putApi = Proxy

352+

353+putSpec :: Spec

354+putSpec = do

355+ describe "Servant.API.Put and .ReqBody" $ do

356+ let server = return . age :<|> return . age :<|> return ()

357+ with (return $ serve putApi server) $ do

358+ let put' x = Test.Hspec.Wai.request methodPut x [(hContentType

359+ , "application/json;charset=utf-8")]

360+

361+ it "allows to put a Person" $ do

362+ put' "/" (encode alice) `shouldRespondWith` "42"{

363+ matchStatus = 200

364+ }

365+

366+ it "allows alternative routes if all have request bodies" $ do

367+ put' "/bla" (encode alice) `shouldRespondWith` "42"{

368+ matchStatus = 200

369+ }

370+

371+ it "handles trailing '/' gracefully" $ do

372+ put' "/bla/" (encode alice) `shouldRespondWith` "42"{

373+ matchStatus = 200

374+ }

375+

376+ it "correctly rejects invalid request bodies with status 400" $ do

377+ put' "/" "some invalid body" `shouldRespondWith` 400

378+

379+ it "returns 204 if the type is '()'" $ do

380+ put' "empty" "" `shouldRespondWith` ""{ matchStatus = 204 }

381+

382+ it "responds with 415 if the requested media type is unsupported" $ do

383+ let put'' x = Test.Hspec.Wai.request methodPut x [(hContentType

384+ , "application/nonsense")]

385+ put'' "/" "anything at all" `shouldRespondWith` 415

386+

387+type PatchApi =

388+ ReqBody '[JSON] Person :> Patch '[JSON] Integer

389+ :<|> "bla" :> ReqBody '[JSON] Person :> Patch '[JSON] Integer

390+ :<|> "empty" :> Patch '[] ()

391+

392+patchApi :: Proxy PatchApi

393+patchApi = Proxy

394+

395+patchSpec :: Spec

396+patchSpec = do

397+ describe "Servant.API.Patch and .ReqBody" $ do

398+ let server = return . age :<|> return . age :<|> return ()

399+ with (return $ serve patchApi server) $ do

400+ let patch' x = Test.Hspec.Wai.request methodPatch x [(hContentType

401+ , "application/json;charset=utf-8")]

402+

403+ it "allows to patch a Person" $ do

404+ patch' "/" (encode alice) `shouldRespondWith` "42"{

405+ matchStatus = 200

406+ }

407+

408+ it "allows alternative routes if all have request bodies" $ do

409+ patch' "/bla" (encode alice) `shouldRespondWith` "42"{

410+ matchStatus = 200

411+ }

412+

413+ it "handles trailing '/' gracefully" $ do

414+ patch' "/bla/" (encode alice) `shouldRespondWith` "42"{

415+ matchStatus = 200

416+ }

417+

418+ it "correctly rejects invalid request bodies with status 400" $ do

419+ patch' "/" "some invalid body" `shouldRespondWith` 400

420+

421+ it "returns 204 if the type is '()'" $ do

422+ patch' "empty" "" `shouldRespondWith` ""{ matchStatus = 204 }

423+

424+ it "responds with 415 if the requested media type is unsupported" $ do

425+ let patch'' x = Test.Hspec.Wai.request methodPatch x [(hContentType

426+ , "application/nonsense")]

427+ patch'' "/" "anything at all" `shouldRespondWith` 415

428+

327type HeaderApi a = Header "MyHeader" a :> Delete

429type HeaderApi a = Header "MyHeader" a :> Delete

328headerApi :: Proxy (HeaderApi a)

430headerApi :: Proxy (HeaderApi a)

329headerApi = Proxy

431headerApi = Proxy