f71c7a8 · servant · git.iko.soy

git.iko.soy/servant

Merge branch 'master' into canonical-types

Conflicts: CHANGELOG.md src/Servant/Server/Internal.hs

commitf71c7a813a906a0f9ba0445c5666b7ba6b72a6d6 authorAlp Mestanogullari <alpmestan@gmail.com> dateSun 19 Apr 2015, 11:17 (11 years ago) parentfc30c7e f6f120d

4 files changed+408−100

compare with master

unifiedsplit

CHANGELOG.md+2 servant-server.cabal+1 src/Servant/Server/Internal.hs+198−63 test/Servant/ServerSpec.hs+207−37

CHANGELOG.md+2

@@ -6,6 +6,8 @@

66* Export `toApplication` from `Servant.Server` (https://github.com/haskell-servant/servant-server/pull/29)

77* Support other Monads than just `EitherT (Int, String) IO` (https://github.com/haskell-servant/servant-server/pull/21)

88* Canonicalize API types before generating the handler types with `Server`

9+* Make methods return status code 204 if they return () (https://github.com/haskell-servant/servant-server/issues/28)

10+* Add server support for response headers

911

10120.2.4

1113-----

servant-server.cabal+1

@@ -80,6 +80,7 @@ test-suite spec

8080 base == 4.*

8181 , aeson

8282 , bytestring

83+ , bytestring-conversion

8384 , directory

8485 , either

8586 , exceptions

src/Servant/Server/Internal.hs+198−63

@@ -1,46 +1,53 @@

1−{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE PolyKinds #-}

3−{-# LANGUAGE TypeFamilies #-}

4−{-# LANGUAGE TypeOperators #-}

5−{-# LANGUAGE FlexibleInstances #-}

6−{-# LANGUAGE OverloadedStrings #-}

7−{-# LANGUAGE ScopedTypeVariables #-}

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE FlexibleContexts #-}

3+{-# LANGUAGE FlexibleInstances #-}

4+{-# LANGUAGE OverlappingInstances #-}

5+{-# LANGUAGE OverloadedStrings #-}

6+{-# LANGUAGE PolyKinds #-}

7+{-# LANGUAGE ScopedTypeVariables #-}

8+{-# LANGUAGE TypeFamilies #-}

9+{-# LANGUAGE TypeOperators #-}

810module Servant.Server.Internal where

911

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

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

12−import Data.Aeson (ToJSON)

13−import qualified Data.ByteString as B

14−import qualified Data.ByteString.Lazy as BL

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

16−import Data.List (unfoldr)

17−import Data.Maybe (catMaybes, fromMaybe)

18−import Data.Monoid (Monoid, mempty, mappend)

19−import Data.String (fromString)

20−import Data.String.Conversions (cs, (<>))

21−import Data.Text.Encoding (decodeUtf8, encodeUtf8)

22−import Data.Text (Text)

23−import qualified Data.Text as T

24−import Data.Typeable

25−import GHC.TypeLits (KnownSymbol, symbolVal)

26−import Network.HTTP.Types hiding (Header)

27−import Network.Wai ( Response, Request, ResponseReceived, Application

28− , pathInfo, requestBody, strictRequestBody

29− , lazyRequestBody, requestHeaders, requestMethod,

30− rawQueryString, responseLBS)

31−import Servant.API ( QueryParams, QueryParam, QueryFlag, ReqBody, Header

32− , MatrixParams, MatrixParam, MatrixFlag

33− , Capture, Get, Delete, Put, Post, Patch, Raw, (:>), (:<|>)(..)

34− , Canonicalize)

35−import Servant.API.ContentTypes ( AllCTRender(..), AcceptHeader(..)

36− , AllCTUnrender(..),)

37−import Servant.Common.Text (FromText, fromText)

38−

12+import Control.Applicative ((<$>))

13+import Control.Monad.Trans.Either (EitherT, runEitherT)

14+import qualified Data.ByteString as B

15+import qualified Data.ByteString.Lazy as BL

16+import Data.IORef (newIORef, readIORef, writeIORef)

17+import Data.List (unfoldr)

18+import Data.Maybe (catMaybes, fromMaybe)

19+import Data.Monoid (Monoid, mappend, mempty)

20+import Data.String (fromString)

21+import Data.String.Conversions (cs, (<>))

22+import Data.Text (Text)

23+import qualified Data.Text as T

24+import Data.Text.Encoding (decodeUtf8, encodeUtf8)

25+import Data.Typeable

26+import GHC.TypeLits (KnownSymbol, symbolVal)

27+import Network.HTTP.Types hiding (Header, ResponseHeaders)

28+import Network.Wai (Application, Request, Response,

29+ ResponseReceived, lazyRequestBody,

30+ pathInfo, rawQueryString,

31+ requestBody, requestHeaders,

32+ requestMethod, responseLBS,

33+ strictRequestBody)

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

35+ Canonicalize, Delete, Get, Header,

36+ MatrixFlag, MatrixParam, MatrixParams,

37+ Patch, Post, Put, QueryFlag,

38+ QueryParam, QueryParams, Raw,

39+ ReqBody)

40+import Servant.API.ContentTypes (AcceptHeader (..),

41+ AllCTRender (..),

42+ AllCTUnrender (..))

43+import Servant.API.ResponseHeaders (Headers, getResponse, getHeaders)

44+import Servant.Common.Text (FromText, fromText)

3945

4046data ReqBodyState = Uncalled

4147 | Called !B.ByteString

4248 | Done !B.ByteString

4349

50+

4451toApplication :: RoutingApplication -> Application

4552toApplication ra request respond = do

4653 reqBodyRef <- newIORef Uncalled

@@ -281,19 +288,53 @@ instance ( AllCTRender ctypes a

281288 route Proxy action request respond

282289 | pathIsEmpty request && requestMethod request == methodGet = do

283290 e <- runEitherT action

284− respond . succeedWith $ case e of

291+ respond $ case e of

285292 Right output -> do

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

287294 case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of

288− Nothing -> responseLBS (mkStatus 406 "Not Acceptable") [] ""

289− Just (contentT, body) -> responseLBS ok200 [ ("Content-Type"

290− , cs contentT)] body

295+ Nothing -> failWith UnsupportedMediaType

296+ Just (contentT, body) -> succeedWith $

297+ responseLBS ok200 [ ("Content-Type" , cs contentT)] body

298+ Left (status, message) -> succeedWith $

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

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

301+ respond $ failWith WrongMethod

302+ | otherwise = respond $ failWith NotFound

303+

304+-- '()' ==> 204 No Content

305+instance HasServer (Get ctypes ()) where

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

307+ route Proxy action request respond

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

309+ e <- runEitherT action

310+ respond . succeedWith $ case e of

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

291312 Left (status, message) ->

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

293314 | pathIsEmpty request && requestMethod request /= methodGet =

294315 respond $ failWith WrongMethod

295316 | otherwise = respond $ failWith NotFound

296317

318+-- Add response headers

319+instance ( AllCTRender ctypes v ) => HasServer (Get ctypes (Headers h v)) where

320+ type ServerT (Get ctypes (Headers h v)) m = m (Headers h v)

321+ route Proxy action request respond

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

323+ e <- runEitherT action

324+ respond $ case e of

325+ Right output -> do

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

327+ headers = getHeaders output

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

329+ Nothing -> failWith UnsupportedMediaType

330+ Just (contentT, body) -> succeedWith $

331+ responseLBS ok200 ( ("Content-Type" , cs contentT) : headers) body

332+ Left (status, message) -> succeedWith $

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

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

335+ respond $ failWith WrongMethod

336+ | otherwise = respond $ failWith NotFound

337+

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

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

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

@@ -347,19 +388,52 @@ instance ( AllCTRender ctypes a

347388 route Proxy action request respond

348389 | pathIsEmpty request && requestMethod request == methodPost = do

349390 e <- runEitherT action

350− respond . succeedWith $ case e of

391+ respond $ case e of

351392 Right output -> do

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

353394 case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of

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

355− Just (contentT, body) -> responseLBS status201 [ ("Content-Type"

356− , cs contentT)] body

395+ Nothing -> failWith UnsupportedMediaType

396+ Just (contentT, body) -> succeedWith $

397+ responseLBS status201 [ ("Content-Type" , cs contentT)] body

398+ Left (status, message) -> succeedWith $

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

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

401+ respond $ failWith WrongMethod

402+ | otherwise = respond $ failWith NotFound

403+

404+instance HasServer (Post ctypes ()) where

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

406+ route Proxy action request respond

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

408+ e <- runEitherT action

409+ respond . succeedWith $ case e of

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

357411 Left (status, message) ->

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

359413 | pathIsEmpty request && requestMethod request /= methodPost =

360414 respond $ failWith WrongMethod

361415 | otherwise = respond $ failWith NotFound

362416

417+-- Add response headers

418+instance ( AllCTRender ctypes v ) => HasServer (Post ctypes (Headers h v)) where

419+ type ServerT (Post ctypes (Headers h v)) m = m (Headers h v)

420+ route Proxy action request respond

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

422+ e <- runEitherT action

423+ respond $ case e of

424+ Right output -> do

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

426+ headers = getHeaders output

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

428+ Nothing -> failWith UnsupportedMediaType

429+ Just (contentT, body) -> succeedWith $

430+ responseLBS status201 ( ("Content-Type" , cs contentT) : headers) body

431+ Left (status, message) -> succeedWith $

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

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

434+ respond $ failWith WrongMethod

435+ | otherwise = respond $ failWith NotFound

436+

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

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

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

@@ -370,7 +444,7 @@ instance ( AllCTRender ctypes a

370444--

371445-- If successfully returning a value, we use the type-level list, combined

372446-- with the request's @Accept@ header, to encode the value for you

373−-- (returning a status code of 201). If there was no @Accept@ header or it

447+-- (returning a status code of 200). If there was no @Accept@ header or it

374448-- was @*/*@, we return encode using the first @Content-Type@ type on the

375449-- list.

376450instance ( AllCTRender ctypes a

@@ -381,18 +455,50 @@ instance ( AllCTRender ctypes a

381455 route Proxy action request respond

382456 | pathIsEmpty request && requestMethod request == methodPut = do

383457 e <- runEitherT action

384− respond . succeedWith $ case e of

458+ respond $ case e of

385459 Right output -> do

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

387461 case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of

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

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

390− , cs contentT)] body

462+ Nothing -> failWith UnsupportedMediaType

463+ Just (contentT, body) -> succeedWith $

464+ responseLBS status200 [ ("Content-Type" , cs contentT)] body

465+ Left (status, message) -> succeedWith $

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

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

468+ respond $ failWith WrongMethod

469+ | otherwise = respond $ failWith NotFound

470+

471+instance HasServer (Put ctypes ()) where

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

473+ route Proxy action request respond

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

475+ e <- runEitherT action

476+ respond . succeedWith $ case e of

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

391478 Left (status, message) ->

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

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

394481 respond $ failWith WrongMethod

482+ | otherwise = respond $ failWith NotFound

395483

484+-- Add response headers

485+instance ( AllCTRender ctypes v ) => HasServer (Put ctypes (Headers h v)) where

486+ type ServerT (Put ctypes (Headers h v)) m = m (Headers h v)

487+ route Proxy action request respond

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

489+ e <- runEitherT action

490+ respond $ case e of

491+ Right output -> do

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

493+ headers = getHeaders output

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

495+ Nothing -> failWith UnsupportedMediaType

496+ Just (contentT, body) -> succeedWith $

497+ responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body

498+ Left (status, message) -> succeedWith $

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

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

501+ respond $ failWith WrongMethod

396502 | otherwise = respond $ failWith NotFound

397503

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

@@ -405,28 +511,57 @@ instance ( AllCTRender ctypes a

405511--

406512-- If successfully returning a value, we just require that its type has

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

408−-- yielding status code 201 along the way.

514+-- yielding status code 200 along the way.

409515instance ( AllCTRender ctypes a

410− , Typeable a

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

412−

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

413517 type ServerT' (Patch ctypes a) m = m a

414518

415519 route Proxy action request respond

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

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

521+ e <- runEitherT action

522+ respond $ case e of

523+ Right output -> do

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

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

526+ Nothing -> failWith UnsupportedMediaType

527+ Just (contentT, body) -> succeedWith $

528+ responseLBS status200 [ ("Content-Type" , cs contentT)] body

529+ Left (status, message) -> succeedWith $

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

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

532+ respond $ failWith WrongMethod

533+ | otherwise = respond $ failWith NotFound

534+

535+instance HasServer (Patch ctypes ()) where

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

537+ route Proxy action request respond

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

417539 e <- runEitherT action

418540 respond . succeedWith $ case e of

419− Right out -> case cast out of

420− Nothing -> do

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

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

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

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

425− , cs contentT)] body

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

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

427542 Left (status, message) ->

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

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

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

545+ respond $ failWith WrongMethod

546+ | otherwise = respond $ failWith NotFound

547+

548+-- Add response headers

549+instance ( AllCTRender ctypes v ) => HasServer (Patch ctypes (Headers h v)) where

550+ type ServerT (Patch ctypes (Headers h v)) m = m (Headers h v)

551+ route Proxy action request respond

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

553+ e <- runEitherT action

554+ respond $ case e of

555+ Right outpatch -> do

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

557+ headers = getHeaders outpatch

558+ case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse outpatch) of

559+ Nothing -> failWith UnsupportedMediaType

560+ Just (contentT, body) -> succeedWith $

561+ responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body

562+ Left (status, message) -> succeedWith $

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

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

430565 respond $ failWith WrongMethod

431566 | otherwise = respond $ failWith NotFound

432567

test/Servant/ServerSpec.hs+207−37

@@ -1,43 +1,55 @@

1−{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE DeriveGeneric #-}

3−{-# LANGUAGE OverloadedStrings #-}

4−{-# LANGUAGE QuasiQuotes #-}

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE DeriveGeneric #-}

3+{-# LANGUAGE OverloadedStrings #-}

54{-# LANGUAGE ScopedTypeVariables #-}

6−{-# LANGUAGE TypeOperators #-}

5+{-# LANGUAGE TypeOperators #-}

6+{-# LANGUAGE TypeSynonymInstances #-}

7+{-# LANGUAGE FlexibleInstances #-}

89module Servant.ServerSpec where

910

1011

11−import Control.Monad (when)

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

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

14−import Data.Char (toUpper)

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

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

17−import Data.String (fromString)

18−import Data.String.Conversions (cs)

19−import GHC.Generics (Generic)

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

21− , methodDelete, hContentType)

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

23− , queryString, rawQueryString )

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

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

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

27− , matchStatus, request )

28−

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

30− , QueryParams, QueryFlag, MatrixParam, MatrixParams

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

32−import Servant.Server (Server, serve)

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

12+import Control.Monad (forM_, when)

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

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

15+import Data.ByteString.Conversion ()

16+import Data.Char (toUpper)

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

18+import Data.Proxy (Proxy (Proxy))

19+import Data.String (fromString)

20+import Data.String.Conversions (cs)

21+import qualified Data.Text as T

22+import GHC.Generics (Generic)

23+import Network.HTTP.Types (hAccept, hContentType,

24+ methodDelete, methodGet,

25+ methodPatch, methodPost, methodPut,

26+ ok200, parseQuery, status409)

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

28+ queryString, rawQueryString,

29+ responseLBS)

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

31+ runSession, simpleBody)

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

33+import Test.Hspec.Wai (get, liftIO, matchHeaders,

34+ matchStatus, post, request,

35+ shouldRespondWith, with, (<:>))

36+

37+import Servant.API ((:<|>) (..), (:>),

38+ AddHeader (addHeader), Capture,

39+ Delete, Get, Header (..), Headers,

40+ JSON, MatrixFlag, MatrixParam,

41+ MatrixParams, Patch, PlainText,

42+ Post, Put, QueryFlag, QueryParam,

43+ QueryParams, Raw, ReqBody)

44+import Servant.Server (Server, serve)

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

3446

3547

3648-- * test data types

3749

3850data Person = Person {

3951 name :: String,

40− age :: Integer

52+ age :: Integer

4153 }

4254 deriving (Eq, Show, Generic)

4355

@@ -48,7 +60,7 @@ alice :: Person

4860alice = Person "Alice" 42

4961

5062data Animal = Animal {

51− species :: String,

63+ species :: String,

5264 numberOfLegs :: Integer

5365 }

5466 deriving (Eq, Show, Generic)

@@ -69,13 +81,16 @@ spec :: Spec

6981spec = do

7082 captureSpec

7183 getSpec

84+ postSpec

85+ putSpec

86+ patchSpec

7287 queryParamSpec

7388 matrixParamSpec

74− postSpec

7589 headerSpec

7690 rawSpec

7791 unionSpec

7892 errorsSpec

93+ responseHeadersSpec

7994

8095

8196type CaptureApi = Capture "legs" Integer :> Get '[JSON] Animal

@@ -91,10 +106,13 @@ captureSpec :: Spec

91106captureSpec = do

92107 describe "Servant.API.Capture" $ do

93108 with (return (serve captureApi captureServer)) $ do

109+

94110 it "can capture parts of the 'pathInfo'" $ do

95111 response <- get "/2"

96− liftIO $ do

97− decode' (simpleBody response) `shouldBe` Just tweety

112+ liftIO $ decode' (simpleBody response) `shouldBe` Just tweety

113+

114+ it "returns 404 if the decoding fails" $ do

115+ get "/notAnInt" `shouldRespondWith` 404

98116

99117 with (return (serve

100118 (Proxy :: Proxy (Capture "captured" String :> Raw))

@@ -105,21 +123,32 @@ captureSpec = do

105123

106124

107125type GetApi = Get '[JSON] Person

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

108127getApi :: Proxy GetApi

109128getApi = Proxy

110129

111130getSpec :: Spec

112131getSpec = do

113132 describe "Servant.API.Get" $ do

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

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

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

135+

115136 it "allows to GET a Person" $ do

116137 response <- get "/"

117138 return response `shouldRespondWith` 200

118− liftIO $ do

119− decode' (simpleBody response) `shouldBe` Just alice

139+ liftIO $ decode' (simpleBody response) `shouldBe` Just alice

120140

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

122142 post "/" "" `shouldRespondWith` 405

143+ post "/empty" "" `shouldRespondWith` 405

144+

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

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

147+

148+ it "returns 415 if the Accept header is not supported" $ do

149+ Test.Hspec.Wai.request methodGet "" [(hAccept, "crazy/mime")] ""

150+ `shouldRespondWith` 415

151+

123152

124153

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

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

291320type PostApi =

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

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

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

324+

294325postApi :: Proxy PostApi

295326postApi = Proxy

296327

297328postSpec :: Spec

298329postSpec = do

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

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

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

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

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

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

303335

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

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

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

321353

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

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

356+

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

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

324359 , "application/nonsense")]

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

326361

362+type PutApi =

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

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

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

366+

367+putApi :: Proxy PutApi

368+putApi = Proxy

369+

370+putSpec :: Spec

371+putSpec = do

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

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

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

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

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

377+

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

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

380+ matchStatus = 200

381+ }

382+

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

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

385+ matchStatus = 200

386+ }

387+

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

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

390+ matchStatus = 200

391+ }

392+

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

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

395+

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

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

398+

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

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

401+ , "application/nonsense")]

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

403+

404+type PatchApi =

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

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

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

408+

409+patchApi :: Proxy PatchApi

410+patchApi = Proxy

411+

412+patchSpec :: Spec

413+patchSpec = do

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

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

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

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

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

419+

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

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

422+ matchStatus = 200

423+ }

424+

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

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

427+ matchStatus = 200

428+ }

429+

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

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

432+ matchStatus = 200

433+ }

434+

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

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

437+

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

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

440+

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

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

443+ , "application/nonsense")]

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

445+

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

328447headerApi :: Proxy (HeaderApi a)

329448headerApi = Proxy

@@ -381,6 +500,10 @@ rawSpec = do

381500type AlternativeApi =

382501 "foo" :> Get '[JSON] Person

383502 :<|> "bar" :> Get '[JSON] Animal

503+ :<|> "foo" :> Get '[PlainText] T.Text

504+ :<|> "bar" :> Post '[JSON] Animal

505+ :<|> "bar" :> Put '[JSON] Animal

506+ :<|> "bar" :> Delete

384507unionApi :: Proxy AlternativeApi

385508unionApi = Proxy

386509

@@ -388,11 +511,16 @@ unionServer :: Server AlternativeApi

388511unionServer =

389512 return alice

390513 :<|> return jerry

514+ :<|> return "a string"

515+ :<|> return jerry

516+ :<|> return jerry

517+ :<|> return ()

391518

392519unionSpec :: Spec

393520unionSpec = do

394521 describe "Servant.API.Alternative" $ do

395522 with (return $ serve unionApi unionServer) $ do

523+

396524 it "unions endpoints" $ do

397525 response <- get "/foo"

398526 liftIO $ do

@@ -403,6 +531,48 @@ unionSpec = do

403531 decode' (simpleBody response_) `shouldBe`

404532 Just jerry

405533

534+ it "checks all endpoints before returning 415" $ do

535+ get "/foo" `shouldRespondWith` 200

536+

537+ it "returns 404 if the path does not exist" $ do

538+ get "/nonexistent" `shouldRespondWith` 404

539+

540+type ResponseHeadersApi =

541+ Get '[JSON] (Headers '[Header "H1" Int, Header "H2" String] String)

542+ :<|> Post '[JSON] (Headers '[Header "H1" Int, Header "H2" String] String)

543+ :<|> Put '[JSON] (Headers '[Header "H1" Int, Header "H2" String] String)

544+ :<|> Patch '[JSON] (Headers '[Header "H1" Int, Header "H2" String] String)

545+

546+

547+responseHeadersServer :: Server ResponseHeadersApi

548+responseHeadersServer = let h = return $ addHeader 5 $ addHeader "kilroy" "hi"

549+ in h :<|> h :<|> h :<|> h

550+

551+

552+responseHeadersSpec :: Spec

553+responseHeadersSpec = describe "ResponseHeaders" $ do

554+ with (return $ serve (Proxy :: Proxy ResponseHeadersApi) responseHeadersServer) $ do

555+

556+ let methods = [(methodGet, 200), (methodPost, 201), (methodPut, 200), (methodPatch, 200)]

557+

558+ it "includes the headers in the response" $

559+ forM_ methods $ \(method, expected) ->

560+ Test.Hspec.Wai.request method "/" [] ""

561+ `shouldRespondWith` "\"hi\""{ matchHeaders = ["H1" <:> "5", "H2" <:> "kilroy"]

562+ , matchStatus = expected

563+ }

564+

565+ it "responds with not found for non-existent endpoints" $

566+ forM_ methods $ \(method,_) ->

567+ Test.Hspec.Wai.request method "blahblah" [] ""

568+ `shouldRespondWith` 404

569+

570+ it "returns 415 if the Accept header is not supported" $

571+ forM_ methods $ \(method,_) ->

572+ Test.Hspec.Wai.request method "" [(hAccept, "crazy/mime")] ""

573+ `shouldRespondWith` 415

574+

575+

406576-- | Test server error functionality.

407577errorsSpec :: Spec

408578errorsSpec = do