f71c7a8 · servant · git.iko.soy

git.iko.soy/servant

on master help sign in

Merge branch 'master' into canonical-types

f71c7a8Alp Mestanogullari12 years ago

CHANGELOG.md+2

compare with master

unifiedsplit

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

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

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

8* 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

100.2.4

120.2.4

11-----

13-----

servant-server.cabal+1

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

80 base == 4.*

81 , aeson

82 , bytestring

83+ , bytestring-conversion

83 , directory

84 , directory

84 , either

85 , either

85 , exceptions

86 , exceptions

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

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

1−{-# LANGUAGE DataKinds #-}

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE FlexibleContexts #-}

3+{-# LANGUAGE FlexibleInstances #-}

4+{-# LANGUAGE OverlappingInstances #-}

5+{-# LANGUAGE OverloadedStrings #-}

2−{-# LANGUAGE PolyKinds #-}

6+{-# LANGUAGE PolyKinds #-}

7+{-# LANGUAGE ScopedTypeVariables #-}

3−{-# LANGUAGE TypeFamilies #-}

8+{-# LANGUAGE TypeFamilies #-}

4−{-# LANGUAGE TypeOperators #-}

9+{-# LANGUAGE TypeOperators #-}

5−{-# LANGUAGE FlexibleInstances #-}

6−{-# LANGUAGE OverloadedStrings #-}

7−{-# LANGUAGE ScopedTypeVariables #-}

8module Servant.Server.Internal where

10module Servant.Server.Internal where

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

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

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

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

12−import Data.Aeson (ToJSON)

13−import qualified Data.ByteString as B

14+import qualified Data.ByteString as B

14−import qualified Data.ByteString.Lazy as BL

15+import qualified Data.ByteString.Lazy as BL

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

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

16−import Data.List (unfoldr)

17+import Data.List (unfoldr)

17−import Data.Maybe (catMaybes, fromMaybe)

18+import Data.Maybe (catMaybes, fromMaybe)

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

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

19−import Data.String (fromString)

20+import Data.String (fromString)

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

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

22+import Data.Text (Text)

23+import qualified Data.Text as T

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

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

22−import Data.Text (Text)

23−import qualified Data.Text as T

24−import Data.Typeable

25+import Data.Typeable

25−import GHC.TypeLits (KnownSymbol, symbolVal)

26+import GHC.TypeLits (KnownSymbol, symbolVal)

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

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

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

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

28− , pathInfo, requestBody, strictRequestBody

29+ ResponseReceived, lazyRequestBody,

30+ pathInfo, rawQueryString,

29− , lazyRequestBody, requestHeaders, requestMethod,

31+ requestBody, requestHeaders,

30− rawQueryString, responseLBS)

32+ requestMethod, responseLBS,

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

33+ strictRequestBody)

32− , MatrixParams, MatrixParam, MatrixFlag

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

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

35+ Canonicalize, Delete, Get, Header,

34− , Canonicalize)

36+ MatrixFlag, MatrixParam, MatrixParams,

37+ Patch, Post, Put, QueryFlag,

38+ QueryParam, QueryParams, Raw,

39+ ReqBody)

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

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

41+ AllCTRender (..),

36− , AllCTUnrender(..),)

42+ AllCTUnrender (..))

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

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

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

38−

40data ReqBodyState = Uncalled

46data ReqBodyState = Uncalled

41 | Called !B.ByteString

47 | Called !B.ByteString

42 | Done !B.ByteString

48 | Done !B.ByteString

50+

44toApplication :: RoutingApplication -> Application

51toApplication :: RoutingApplication -> Application

45toApplication ra request respond = do

52toApplication ra request respond = do

46 reqBodyRef <- newIORef Uncalled

53 reqBodyRef <- newIORef Uncalled

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

281 route Proxy action request respond

288 route Proxy action request respond

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

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

283 e <- runEitherT action

290 e <- runEitherT action

284− respond . succeedWith $ case e of

291+ respond $ case e of

285 Right output -> do

292 Right output -> do

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

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

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

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

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

295+ Nothing -> failWith UnsupportedMediaType

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

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

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

290− , 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 [] ""

291 Left (status, message) ->

312 Left (status, message) ->

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

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

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

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

294 respond $ failWith WrongMethod

315 respond $ failWith WrongMethod

295 | otherwise = respond $ failWith NotFound

316 | otherwise = respond $ failWith NotFound

296

317

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+

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

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

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

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

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

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

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

347 route Proxy action request respond

388 route Proxy action request respond

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

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

349 e <- runEitherT action

390 e <- runEitherT action

350− respond . succeedWith $ case e of

391+ respond $ case e of

351 Right output -> do

392 Right output -> do

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

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

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

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

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

395+ Nothing -> failWith UnsupportedMediaType

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

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

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

356− , 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 [] ""

357 Left (status, message) ->

411 Left (status, message) ->

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

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

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

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

360 respond $ failWith WrongMethod

414 respond $ failWith WrongMethod

361 | otherwise = respond $ failWith NotFound

415 | otherwise = respond $ failWith NotFound

362

416

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+

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

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

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

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

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

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

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

370--

444--

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

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

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

446-- 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

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

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

375-- list.

449-- list.

376instance ( AllCTRender ctypes a

450instance ( AllCTRender ctypes a

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

381 route Proxy action request respond

455 route Proxy action request respond

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

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

383 e <- runEitherT action

457 e <- runEitherT action

384− respond . succeedWith $ case e of

458+ respond $ case e of

385 Right output -> do

459 Right output -> do

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

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

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

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

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

462+ Nothing -> failWith UnsupportedMediaType

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

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

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

390− , 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 [] ""

391 Left (status, message) ->

478 Left (status, message) ->

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

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

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

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

394 respond $ failWith WrongMethod

481 respond $ failWith WrongMethod

482+ | otherwise = respond $ failWith NotFound

395

483

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

396 | otherwise = respond $ failWith NotFound

502 | otherwise = respond $ failWith NotFound

397

503

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

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

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

405--

511--

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

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

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

513-- 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.

409instance ( AllCTRender ctypes a

515instance ( AllCTRender ctypes a

410− , Typeable a

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

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

412−

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

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

414

518

415 route Proxy action request respond

519 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

417 e <- runEitherT action

539 e <- runEitherT action

418 respond . succeedWith $ case e of

540 respond . succeedWith $ case e of

419− Right out -> case cast out of

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

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 [] ""

427 Left (status, message) ->

542 Left (status, message) ->

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

543 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 =

430 respond $ failWith WrongMethod

565 respond $ failWith WrongMethod

431 | otherwise = respond $ failWith NotFound

566 | otherwise = respond $ failWith NotFound

432

567

test/Servant/ServerSpec.hs+207−37

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

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 #-}

6+{-# LANGUAGE TypeSynonymInstances #-}

7+{-# LANGUAGE FlexibleInstances #-}

8module Servant.ServerSpec where

9module Servant.ServerSpec where

11−import Control.Monad (when)

12+import Control.Monad (forM_, when)

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

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

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

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

15+import Data.ByteString.Conversion ()

14−import Data.Char (toUpper)

16+import Data.Char (toUpper)

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

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

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

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

17−import Data.String (fromString)

19+import Data.String (fromString)

18−import Data.String.Conversions (cs)

20+import Data.String.Conversions (cs)

21+import qualified Data.Text as T

19−import GHC.Generics (Generic)

22+import GHC.Generics (Generic)

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

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

21− , methodDelete, hContentType)

24+ methodDelete, methodGet,

25+ methodPatch, methodPost, methodPut,

26+ ok200, parseQuery, status409)

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

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

23− , queryString, rawQueryString )

28+ queryString, rawQueryString,

29+ responseLBS)

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

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

31+ runSession, simpleBody)

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

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

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

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

27− , matchStatus, request )

34+ matchStatus, post, request,

28−

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

36+

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

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

30− , QueryParams, QueryFlag, MatrixParam, MatrixParams

38+ AddHeader (addHeader), Capture,

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

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

40+ JSON, MatrixFlag, MatrixParam,

41+ MatrixParams, Patch, PlainText,

42+ Post, Put, QueryFlag, QueryParam,

43+ QueryParams, Raw, ReqBody)

32−import Servant.Server (Server, serve)

44+import Servant.Server (Server, serve)

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

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

36-- * test data types

48-- * test data types

38data Person = Person {

50data Person = Person {

39 name :: String,

51 name :: String,

40− age :: Integer

52+ age :: Integer

41 }

53 }

42 deriving (Eq, Show, Generic)

54 deriving (Eq, Show, Generic)

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

48alice = Person "Alice" 42

60alice = Person "Alice" 42

50data Animal = Animal {

62data Animal = Animal {

51− species :: String,

63+ species :: String,

52 numberOfLegs :: Integer

64 numberOfLegs :: Integer

53 }

65 }

54 deriving (Eq, Show, Generic)

66 deriving (Eq, Show, Generic)

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

69spec = do

81spec = do

70 captureSpec

82 captureSpec

71 getSpec

83 getSpec

84+ postSpec

85+ putSpec

86+ patchSpec

72 queryParamSpec

87 queryParamSpec

73 matrixParamSpec

88 matrixParamSpec

74− postSpec

75 headerSpec

89 headerSpec

76 rawSpec

90 rawSpec

77 unionSpec

91 unionSpec

78 errorsSpec

92 errorsSpec

93+ responseHeadersSpec

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

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

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

91captureSpec = do

106captureSpec = do

92 describe "Servant.API.Capture" $ do

107 describe "Servant.API.Capture" $ do

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

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

109+

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

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

95 response <- get "/2"

111 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

116

99 with (return (serve

117 with (return (serve

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

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

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

105

123

106

124

107type GetApi = Get '[JSON] Person

125type GetApi = Get '[JSON] Person

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

108getApi :: Proxy GetApi

127getApi :: Proxy GetApi

109getApi = Proxy

128getApi = Proxy

110

129

111getSpec :: Spec

130getSpec :: Spec

112getSpec = do

131getSpec = do

113 describe "Servant.API.Get" $ do

132 describe "Servant.API.Get" $ do

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

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

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

135+

115 it "allows to GET a Person" $ do

136 it "allows to GET a Person" $ do

116 response <- get "/"

137 response <- get "/"

117 return response `shouldRespondWith` 200

138 return response `shouldRespondWith` 200

118− liftIO $ do

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

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

120

140

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

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

122 post "/" "" `shouldRespondWith` 405

142 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+

123

152

124

153

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

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

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

291type PostApi =

320type PostApi =

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

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

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

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

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

324+

294postApi :: Proxy PostApi

325postApi :: Proxy PostApi

295postApi = Proxy

326postApi = Proxy

296

327

297postSpec :: Spec

328postSpec :: Spec

298postSpec = do

329postSpec = do

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

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

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

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

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

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

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

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

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

303

335

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

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

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

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

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

321

353

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

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

356+

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

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

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

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

324 , "application/nonsense")]

359 , "application/nonsense")]

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

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

326

361

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+

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

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

328headerApi :: Proxy (HeaderApi a)

447headerApi :: Proxy (HeaderApi a)

329headerApi = Proxy

448headerApi = Proxy

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

381type AlternativeApi =

500type AlternativeApi =

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

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

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

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

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

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

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

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

384unionApi :: Proxy AlternativeApi

507unionApi :: Proxy AlternativeApi

385unionApi = Proxy

508unionApi = Proxy

386

509

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

388unionServer =

511unionServer =

389 return alice

512 return alice

390 :<|> return jerry

513 :<|> return jerry

514+ :<|> return "a string"

515+ :<|> return jerry

516+ :<|> return jerry

517+ :<|> return ()

391

518

392unionSpec :: Spec

519unionSpec :: Spec

393unionSpec = do

520unionSpec = do

394 describe "Servant.API.Alternative" $ do

521 describe "Servant.API.Alternative" $ do

395 with (return $ serve unionApi unionServer) $ do

522 with (return $ serve unionApi unionServer) $ do

523+

396 it "unions endpoints" $ do

524 it "unions endpoints" $ do

397 response <- get "/foo"

525 response <- get "/foo"

398 liftIO $ do

526 liftIO $ do

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

403 decode' (simpleBody response_) `shouldBe`

531 decode' (simpleBody response_) `shouldBe`

404 Just jerry

532 Just jerry

405

533

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+

406-- | Test server error functionality.

576-- | Test server error functionality.

407errorsSpec :: Spec

577errorsSpec :: Spec

408errorsSpec = do

578errorsSpec = do