cae0b6e · servant · git.iko.soy

git.iko.soy/servant

on master help sign in

Merge pull request #13 from haskell-servant/jkarni/content-types

cae0b6eJulian Arni12 years ago

CHANGELOG.md+5

compare with master

unifiedsplit

@@ -2,6 +2,11 @@ master

2------

4* Added support for matrix parameters, see e.g. http://www.w3.org/DesignIssues/MatrixURIs.html

5+* Add support for serializing based on Accept header

6+ (https://github.com/haskell-servant/servant-server/issues/9)

7+* Ignore trailing slashes

8+ (https://github.com/haskell-servant/servant-server/issues/5)

60.2.3

110.2.3

7-----

12-----

default.nixnew file+15

@@ -0,0 +1,15 @@

1+{ pkgs ? import <nixpkgs> { config.allowUnfree = true; }

2+, src ? builtins.filterSource (path: type:

3+ type != "unknown" &&

4+ baseNameOf path != ".git" &&

5+ baseNameOf path != "result" &&

6+ baseNameOf path != "dist") ./.

7+, servant ? import ../servant {}

8+}:

9+pkgs.haskellPackages.buildLocalCabalWithArgs {

10+ name = "servant-server";

11+ inherit src;

12+ args = {

13+ inherit servant;

14+ };

15+}

example/greet.hs+3−3

@@ -18,7 +18,7 @@ import Servant

18-- * Example

20-- | A greet message data type

21−newtype Greet = Greet { msg :: Text }

21+newtype Greet = Greet { _msg :: Text }

22 deriving (Generic, Show)

24instance FromJSON Greet

@@ -27,11 +27,11 @@ instance ToJSON Greet

27-- API specification

28type TestApi =

29 -- GET /hello/:name?capital={true, false} returns a Greet as JSON

30− "hello" :> Capture "name" Text :> QueryParam "capital" Bool :> Get Greet

30+ "hello" :> Capture "name" Text :> QueryParam "capital" Bool :> Get '[JSON] Greet

32 -- POST /greet with a Greet as JSON in the request body,

33 -- returns a Greet as JSON

34− :<|> "greet" :> ReqBody Greet :> Post Greet

34+ :<|> "greet" :> ReqBody '[JSON] Greet :> Post '[JSON] Greet

36 -- DELETE /greet/:greetid

37 :<|> "greet" :> Capture "greetid" Text :> Delete

servant-server.cabal+17−17

@@ -34,23 +34,23 @@ library

34 Servant.Server.Internal

35 Servant.Utils.StaticFiles

36 build-depends:

37− base >=4.7 && <5

37+ base >= 4.7 && < 5

38− , aeson

38+ , aeson >= 0.7 && < 0.9

39− , attoparsec

39+ , attoparsec >= 0.12 && < 0.13

40− , bytestring

40+ , bytestring >= 0.10 && < 0.11

41− , either >= 4.3

41+ , either >= 4.3 && < 4.4

42− , http-types

42+ , http-types >= 0.8 && < 0.9

43− , network-uri >= 2.6

43+ , network-uri >= 2.6 && < 2.7

44− , safe

44+ , safe >= 0.3 && < 0.4

45− , servant >= 0.2.2

45+ , servant >= 0.2 && < 0.4

46− , split

46+ , split >= 0.2 && < 0.3

47− , string-conversions

47+ , string-conversions >= 0.3 && < 0.4

48− , system-filepath

48+ , system-filepath >= 0.4 && < 0.5

49− , text

49+ , text >= 1.2 && < 1.3

50− , transformers

50+ , transformers >= 0.3 && < 0.5

51− , wai

51+ , wai >= 3.0 && < 3.1

52− , wai-app-static >= 3.0.0.6

52+ , wai-app-static >= 3.0 && < 3.1

53− , warp

53+ , warp >= 3.0 && < 3.1

54 hs-source-dirs: src

55 default-language: Haskell2010

56 ghc-options: -Wall

src/Servant.hs−2

@@ -8,7 +8,6 @@ module Servant (

8 -- | Using your types in request paths and query string parameters

9 module Servant.Common.Text,

10 -- | Utilities on top of the servant core

11− module Servant.QQ,

12 module Servant.Utils.Links,

11 module Servant.Utils.Links,

13 module Servant.Utils.StaticFiles,

12 module Servant.Utils.StaticFiles,

14 -- | Useful re-exports

13 -- | Useful re-exports

@@ -19,6 +18,5 @@ import Data.Proxy

19import Servant.API

18import Servant.API

20import Servant.Common.Text

19import Servant.Common.Text

21import Servant.Server

20import Servant.Server

22−import Servant.QQ

23import Servant.Utils.Links

21import Servant.Utils.Links

24import Servant.Utils.StaticFiles

22import Servant.Utils.StaticFiles

src/Servant/Server.hs+3−2

@@ -9,6 +9,7 @@ module Servant.Server

10 , -- * Handlers for all standard combinators

11 HasServer(..)

12+

12 ) where

13 ) where

14import Data.Proxy (Proxy)

15import Data.Proxy (Proxy)

@@ -23,8 +24,8 @@ import Servant.Server.Internal

23--

24--

24-- Example:

25-- Example:

25--

26--

26−-- > type MyApi = "books" :> Get [Book] -- GET /books

27+-- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books

27−-- > :<|> "books" :> ReqBody Book :> Post Book -- POST /books

28+-- > :<|> "books" :> ReqBody Book :> Post '[JSON] Book -- POST /books

28-- >

29-- >

29-- > server :: Server MyApi

30-- > server :: Server MyApi

30-- > server = listAllBooks :<|> postBook

31-- > server = listAllBooks :<|> postBook

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

@@ -9,7 +9,7 @@ module Servant.Server.Internal where

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

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

12−import Data.Aeson (ToJSON, FromJSON, encode, eitherDecode')

12+import Data.Aeson (ToJSON)

13import qualified Data.ByteString as B

14import qualified Data.ByteString.Lazy as BL

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

@@ -24,12 +24,18 @@ import qualified Data.Text as T

24import Data.Typeable

25import GHC.TypeLits (KnownSymbol, symbolVal)

26import Network.HTTP.Types hiding (Header)

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

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

28+ , pathInfo, requestBody, strictRequestBody

28− strictRequestBody, lazyRequestBody, requestHeaders, requestMethod,

29+ , lazyRequestBody, requestHeaders, requestMethod,

29 rawQueryString, responseLBS)

30 rawQueryString, responseLBS)

30−import Servant.API (QueryParams, QueryParam, QueryFlag, MatrixParams, MatrixParam, MatrixFlag, ReqBody, Header, Capture, Get, Delete, Put, Post, Patch, Raw, (:>), (:<|>)(..))

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

32+ , MatrixParams, MatrixParam, MatrixFlag

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

34+import Servant.API.ContentTypes ( AllCTRender(..), AcceptHeader(..)

35+ , AllCTUnrender(..),)

31import Servant.Common.Text (FromText, fromText)

36import Servant.Common.Text (FromText, fromText)

38+

33data ReqBodyState = Uncalled

39data ReqBodyState = Uncalled

34 | Called !B.ByteString

40 | Called !B.ByteString

35 | Done !B.ByteString

41 | Done !B.ByteString

@@ -66,39 +72,33 @@ toApplication ra request respond = do

66 respond $ responseLBS methodNotAllowed405 [] "method not allowed"

72 respond $ responseLBS methodNotAllowed405 [] "method not allowed"

67 routingRespond (Left (InvalidBody err)) =

73 routingRespond (Left (InvalidBody err)) =

68 respond $ responseLBS badRequest400 [] $ fromString $ "Invalid JSON in request body: " ++ err

74 respond $ responseLBS badRequest400 [] $ fromString $ "Invalid JSON in request body: " ++ err

75+ routingRespond (Left UnsupportedMediaType) =

76+ respond $ responseLBS unsupportedMediaType415 [] "unsupported media type"

69 routingRespond (Left (HttpError status body)) =

77 routingRespond (Left (HttpError status body)) =

70 respond $ responseLBS status [] $ fromMaybe (BL.fromStrict $ statusMessage status) body

78 respond $ responseLBS status [] $ fromMaybe (BL.fromStrict $ statusMessage status) body

71 routingRespond (Right response) =

79 routingRespond (Right response) =

72 respond response

80 respond response

82+-- Note that the ordering of the constructors has great significance! It

83+-- determines the Ord instance and, consequently, the monoid instance.

74-- * Route mismatch

84-- * Route mismatch

75data RouteMismatch =

85data RouteMismatch =

76 NotFound -- ^ the usual "not found" error

86 NotFound -- ^ the usual "not found" error

77 | WrongMethod -- ^ a more informative "you just got the HTTP method wrong" error

87 | WrongMethod -- ^ a more informative "you just got the HTTP method wrong" error

88+ | UnsupportedMediaType -- ^ request body has unsupported media type

78 | InvalidBody String -- ^ an even more informative "your json request body wasn't valid" error

89 | InvalidBody String -- ^ an even more informative "your json request body wasn't valid" error

79 | HttpError Status (Maybe BL.ByteString) -- ^ an even even more informative arbitrary HTTP response code error.

90 | HttpError Status (Maybe BL.ByteString) -- ^ an even even more informative arbitrary HTTP response code error.

80− deriving (Eq, Show)

91+ deriving (Eq, Ord, Show)

82−-- |

83−-- @

84−-- > mempty = NotFound

85−-- >

86−-- > _ `mappend` HttpError s b = HttpError s b

87−-- > HttpError s b `mappend` _ = HttpError s b

88−-- > NotFound `mappend` x = x

89−-- > WrongMethod `mappend` InvalidBody s = InvalidBody s

90−-- > WrongMethod `mappend` _ = WrongMethod

91−-- > InvalidBody s `mappend` _ = InvalidBody s

92−-- @

93instance Monoid RouteMismatch where

94 mempty = NotFound

95+ -- The following isn't great, since it picks @InvalidBody@ based on

96+ -- alphabetical ordering, but any choice would be arbitrary.

97+ --

98+ -- "As one judge said to the other, 'Be just and if you can't be just, be

99+ -- arbitrary'" -- William Burroughs

100+ mappend = max

101

96− _ `mappend` HttpError s b = HttpError s b

97− HttpError s b `mappend` _ = HttpError s b

98− NotFound `mappend` x = x

99− WrongMethod `mappend` InvalidBody s = InvalidBody s

100− WrongMethod `mappend` _ = WrongMethod

101− InvalidBody s `mappend` _ = InvalidBody s

102

103-- | A wrapper around @'Either' 'RouteMismatch' a@.

104newtype RouteResult a =

@@ -171,8 +171,8 @@ class HasServer layout where

171-- represented by @a@ and if it fails tries @b@. You must provide a request

172-- handler for each route.

173--

174−-- > type MyApi = "books" :> Get [Book] -- GET /books

174+-- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books

175−-- > :<|> "books" :> ReqBody Book :> Post Book -- POST /books

175+-- > :<|> "books" :> ReqBody Book :> Post '[JSON] Book -- POST /books

176-- >

177-- > server :: Server MyApi

178-- > server = listAllBooks :<|> postBook

@@ -203,7 +203,7 @@ captured _ = fromText

203--

204-- Example:

205--

206−-- > type MyApi = "books" :> Capture "isbn" Text :> Get Book

206+-- > type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book

207-- >

208-- > server :: Server MyApi

209-- > server = getBook

@@ -225,7 +225,7 @@ instance (KnownSymbol capture, FromText a, HasServer sublayout)

225 _ -> respond $ failWith NotFound

226

227 where captureProxy = Proxy :: Proxy (Capture capture a)

228−

228+

229

230-- | If you have a 'Delete' endpoint in your API,

231-- the handler for this endpoint is meant to delete

@@ -261,17 +261,24 @@ instance HasServer Delete where

261-- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left'

262-- to quickly fail if some conditions are not met.

263--

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

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

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

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

266−-- yielding status code 200 along the way.

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

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

268+-- list.

269+instance ( AllCTRender ctypes a

267−instance ToJSON result => HasServer (Get result) where

270+ ) => HasServer (Get ctypes a) where

268− type Server (Get result) = EitherT (Int, String) IO result

271+ type Server (Get ctypes a) = EitherT (Int, String) IO a

269 route Proxy action request respond

272 route Proxy action request respond

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

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

271 e <- runEitherT action

274 e <- runEitherT action

272 respond . succeedWith $ case e of

275 respond . succeedWith $ case e of

273− Right output ->

276+ Right output -> do

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

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

279+ Nothing -> responseLBS (mkStatus 406 "Not Acceptable") [] ""

274− responseLBS ok200 [("Content-Type", "application/json")] (encode output)

280+ Just (contentT, body) -> responseLBS ok200 [ ("Content-Type"

281+ , cs contentT)] body

275 Left (status, message) ->

282 Left (status, message) ->

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

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

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

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

@@ -292,7 +299,7 @@ instance ToJSON result => HasServer (Get result) where

292-- > deriving (Eq, Show, FromText, ToText)

299-- > deriving (Eq, Show, FromText, ToText)

293-- >

300-- >

294-- > -- GET /view-my-referer

301-- > -- GET /view-my-referer

295−-- > type MyApi = "view-my-referer" :> Header "Referer" Referer :> Get Referer

302+-- > type MyApi = "view-my-referer" :> Header "Referer" Referer :> Get '[JSON] Referer

296-- >

303-- >

297-- > server :: Server MyApi

304-- > server :: Server MyApi

298-- > server = viewReferer

305-- > server = viewReferer

@@ -318,18 +325,25 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)

318-- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left'

325-- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left'

319-- to quickly fail if some conditions are not met.

326-- to quickly fail if some conditions are not met.

320--

327--

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

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

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

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

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

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

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

332+-- list.

333+instance ( AllCTRender ctypes a

324−instance ToJSON a => HasServer (Post a) where

334+ ) => HasServer (Post ctypes a) where

325− type Server (Post a) = EitherT (Int, String) IO a

335+ type Server (Post ctypes a) = EitherT (Int, String) IO a

326

336

327 route Proxy action request respond

337 route Proxy action request respond

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

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

329 e <- runEitherT action

339 e <- runEitherT action

330 respond . succeedWith $ case e of

340 respond . succeedWith $ case e of

331− Right out ->

341+ Right output -> do

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

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

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

332− responseLBS status201 [("Content-Type", "application/json")] (encode out)

345+ Just (contentT, body) -> responseLBS status201 [ ("Content-Type"

346+ , cs contentT)] body

333 Left (status, message) ->

347 Left (status, message) ->

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

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

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

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

@@ -344,18 +358,25 @@ instance ToJSON a => HasServer (Post a) where

344-- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left'

358-- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left'

345-- to quickly fail if some conditions are not met.

359-- to quickly fail if some conditions are not met.

346--

360--

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

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

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

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

349−-- yielding status code 200 along the way.

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

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

365+-- list.

366+instance ( AllCTRender ctypes a

350−instance ToJSON a => HasServer (Put a) where

367+ ) => HasServer (Put ctypes a) where

351− type Server (Put a) = EitherT (Int, String) IO a

368+ type Server (Put ctypes a) = EitherT (Int, String) IO a

352

369

353 route Proxy action request respond

370 route Proxy action request respond

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

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

355 e <- runEitherT action

372 e <- runEitherT action

356 respond . succeedWith $ case e of

373 respond . succeedWith $ case e of

357− Right out ->

374+ Right output -> do

358− responseLBS ok200 [("Content-Type", "application/json")] (encode out)

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

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

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

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

379+ , cs contentT)] body

359 Left (status, message) ->

380 Left (status, message) ->

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

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

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

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

@@ -374,15 +395,22 @@ instance ToJSON a => HasServer (Put a) where

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

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

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

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

376-- yielding status code 201 along the way.

397-- yielding status code 201 along the way.

398+instance ( AllCTRender ctypes a

399+ , Typeable a

377−instance (Typeable a, ToJSON a) => HasServer (Patch a) where

400+ , ToJSON a) => HasServer (Patch ctypes a) where

378− type Server (Patch a) = EitherT (Int, String) IO a

401+ type Server (Patch ctypes a) = EitherT (Int, String) IO a

379

402

380 route Proxy action request respond

403 route Proxy action request respond

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

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

382 e <- runEitherT action

405 e <- runEitherT action

383 respond . succeedWith $ case e of

406 respond . succeedWith $ case e of

384 Right out -> case cast out of

407 Right out -> case cast out of

408+ Nothing -> do

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

410+ case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) out of

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

385− Nothing -> responseLBS status200 [("Content-Type", "application/json")] (encode out)

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

413+ , cs contentT)] body

386 Just () -> responseLBS status204 [] ""

414 Just () -> responseLBS status204 [] ""

387 Left (status, message) ->

415 Left (status, message) ->

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

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

@@ -404,7 +432,7 @@ instance (Typeable a, ToJSON a) => HasServer (Patch a) where

404--

432--

405-- Example:

433-- Example:

406--

434--

407−-- > type MyApi = "books" :> QueryParam "author" Text :> Get [Book]

435+-- > type MyApi = "books" :> QueryParam "author" Text :> Get '[JSON] [Book]

408-- >

436-- >

409-- > server :: Server MyApi

437-- > server :: Server MyApi

410-- > server = getBooksBy

438-- > server = getBooksBy

@@ -443,7 +471,7 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)

443--

471--

444-- Example:

472-- Example:

445--

473--

446−-- > type MyApi = "books" :> QueryParams "authors" Text :> Get [Book]

474+-- > type MyApi = "books" :> QueryParams "authors" Text :> Get '[JSON] [Book]

447-- >

475-- >

448-- > server :: Server MyApi

476-- > server :: Server MyApi

449-- > server = getBooksBy

477-- > server = getBooksBy

@@ -476,7 +504,7 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)

476--

504--

477-- Example:

505-- Example:

478--

506--

479−-- > type MyApi = "books" :> QueryFlag "published" :> Get [Book]

507+-- > type MyApi = "books" :> QueryFlag "published" :> Get '[JSON] [Book]

480-- >

508-- >

481-- > server :: Server MyApi

509-- > server :: Server MyApi

482-- > server = getBooks

510-- > server = getBooks

@@ -635,30 +663,42 @@ instance HasServer Raw where

635-- | If you use 'ReqBody' in one of the endpoints for your API,

663-- | If you use 'ReqBody' in one of the endpoints for your API,

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

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

637-- that takes an argument of the type specified by 'ReqBody'.

665-- that takes an argument of the type specified by 'ReqBody'.

666+-- The @Content-Type@ header is inspected, and the list provided is used to

667+-- attempt deserialization. If the request does not have a @Content-Type@

668+-- header, it is treated as @application/octet-stream@.

638-- This lets servant worry about extracting it from the request and turning

669-- This lets servant worry about extracting it from the request and turning

639-- it into a value of the type you specify.

670-- it into a value of the type you specify.

640--

671--

672+--

641-- All it asks is for a 'FromJSON' instance.

673-- All it asks is for a 'FromJSON' instance.

642--

674--

643-- Example:

675-- Example:

644--

676--

645−-- > type MyApi = "books" :> ReqBody Book :> Post Book

677+-- > type MyApi = "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book

646-- >

678-- >

647-- > server :: Server MyApi

679-- > server :: Server MyApi

648-- > server = postBook

680-- > server = postBook

649-- > where postBook :: Book -> EitherT (Int, String) IO Book

681-- > where postBook :: Book -> EitherT (Int, String) IO Book

650-- > postBook book = ...insert into your db...

682-- > postBook book = ...insert into your db...

651−instance (FromJSON a, HasServer sublayout)

683+instance ( AllCTUnrender list a, HasServer sublayout

652− => HasServer (ReqBody a :> sublayout) where

684+ ) => HasServer (ReqBody list a :> sublayout) where

653

685

654− type Server (ReqBody a :> sublayout) =

686+ type Server (ReqBody list a :> sublayout) =

655 a -> Server sublayout

687 a -> Server sublayout

656

688

657 route Proxy subserver request respond = do

689 route Proxy subserver request respond = do

690+ -- See HTTP RFC 2616, section 7.2.1

691+ -- http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1

692+ -- See also "W3C Internet Media Type registration, consistency of use"

693+ -- http://www.w3.org/2001/tag/2002/0129-mime

694+ let contentTypeH = fromMaybe "application/octet-stream"

695+ $ lookup hContentType $ requestHeaders request

696+ mrqbody <- handleCTypeH (Proxy :: Proxy list) (cs contentTypeH)

658− mrqbody <- eitherDecode' <$> lazyRequestBody request

697+ <$> lazyRequestBody request

659 case mrqbody of

698 case mrqbody of

699+ Nothing -> respond . failWith $ UnsupportedMediaType

660− Left e -> respond . failWith $ InvalidBody e

700+ Just (Left e) -> respond . failWith $ InvalidBody e

661− Right v -> route (Proxy :: Proxy sublayout) (subserver v) request respond

701+ Just (Right v) -> route (Proxy :: Proxy sublayout) (subserver v) request respond

662

702

663-- | Make sure the incoming request starts with @"/path"@, strip it and

703-- | Make sure the incoming request starts with @"/path"@, strip it and

664-- pass the rest of the request path to @sublayout@.

704-- pass the rest of the request path to @sublayout@.

test/Servant/ServerSpec.hs+67−32

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

8module Servant.ServerSpec where

11+import Control.Monad (when)

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

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

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

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

13import Data.Char (toUpper)

14import Data.Char (toUpper)

@@ -16,21 +17,18 @@ import Data.Proxy (Proxy(Proxy))

16import Data.String (fromString)

17import Data.String (fromString)

17import Data.String.Conversions (cs)

18import Data.String.Conversions (cs)

18import GHC.Generics (Generic)

19import GHC.Generics (Generic)

19−import Network.HTTP.Types (parseQuery, ok200, status409)

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

21+ , methodDelete, hContentType)

20−import Network.Wai (Application, Request, responseLBS, pathInfo, queryString, rawQueryString)

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

23+ , queryString, rawQueryString )

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

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

22import Test.Hspec (Spec, describe, it, shouldBe)

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

23−import Test.Hspec.Wai (liftIO, with, get, post, shouldRespondWith, matchStatus)

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

24−

27+ , matchStatus, request )

25−import Servant.API.Capture (Capture)

28+

26−import Servant.API.Get (Get)

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

27−import Servant.API.ReqBody (ReqBody)

28−import Servant.API.Post (Post)

29−import Servant.API.QueryParam (QueryParam, QueryParams, QueryFlag)

30−import Servant.API.MatrixParam (MatrixParam, MatrixParams, MatrixFlag)

30+ , QueryParams, QueryFlag, MatrixParam, MatrixParams

31−import Servant.API.Raw (Raw)

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

32−import Servant.API.Sub ((:>))

33−import Servant.API.Alternative ((:<|>)((:<|>)))

34import Servant.Server (Server, serve)

32import Servant.Server (Server, serve)

35import Servant.Server.Internal (RouteMismatch(..))

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

@@ -74,12 +72,13 @@ spec = do

74 queryParamSpec

72 queryParamSpec

75 matrixParamSpec

73 matrixParamSpec

76 postSpec

74 postSpec

75+ headerSpec

77 rawSpec

76 rawSpec

78 unionSpec

77 unionSpec

79 errorsSpec

78 errorsSpec

82−type CaptureApi = Capture "legs" Integer :> Get Animal

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

83captureApi :: Proxy CaptureApi

82captureApi :: Proxy CaptureApi

84captureApi = Proxy

83captureApi = Proxy

85captureServer :: Integer -> EitherT (Int, String) IO Animal

84captureServer :: Integer -> EitherT (Int, String) IO Animal

@@ -105,7 +104,7 @@ captureSpec = do

105 get "/captured/foo" `shouldRespondWith` (fromString (show ["foo" :: String]))

104 get "/captured/foo" `shouldRespondWith` (fromString (show ["foo" :: String]))

106

105

107

106

108−type GetApi = Get Person

107+type GetApi = Get '[JSON] Person

109getApi :: Proxy GetApi

108getApi :: Proxy GetApi

110getApi = Proxy

109getApi = Proxy

111

110

@@ -123,9 +122,9 @@ getSpec = do

123 post "/" "" `shouldRespondWith` 405

122 post "/" "" `shouldRespondWith` 405

124

123

125

124

126−type QueryParamApi = QueryParam "name" String :> Get Person

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

127− :<|> "a" :> QueryParams "names" String :> Get Person

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

128− :<|> "b" :> QueryFlag "capitalize" :> Get Person

127+ :<|> "b" :> QueryFlag "capitalize" :> Get '[JSON] Person

129

128

130queryParamApi :: Proxy QueryParamApi

129queryParamApi :: Proxy QueryParamApi

131queryParamApi = Proxy

130queryParamApi = Proxy

@@ -170,6 +169,7 @@ queryParamSpec = do

170 name = "john"

169 name = "john"

171 }

170 }

172

171

172+

173 it "allows to retrieve value-less GET parameters" $

174 (flip runSession) (serve queryParamApi qpServer) $ do

175 let params3 = "?capitalize"

@@ -205,10 +205,10 @@ queryParamSpec = do

205 name = "Alice"

206 }

207

208−type MatrixParamApi = "a" :> MatrixParam "name" String :> Get Person

208+type MatrixParamApi = "a" :> MatrixParam "name" String :> Get '[JSON] Person

209− :<|> "b" :> MatrixParams "names" String :> "bsub" :> MatrixParams "names" String :> Get Person

209+ :<|> "b" :> MatrixParams "names" String :> "bsub" :> MatrixParams "names" String :> Get '[JSON] Person

210− :<|> "c" :> MatrixFlag "capitalize" :> Get Person

210+ :<|> "c" :> MatrixFlag "capitalize" :> Get '[JSON] Person

211− :<|> "d" :> Capture "foo" Integer :> MatrixParam "name" String :> MatrixFlag "capitalize" :> "dsub" :> Get Person

211+ :<|> "d" :> Capture "foo" Integer :> MatrixParam "name" String :> MatrixFlag "capitalize" :> "dsub" :> Get '[JSON] Person

212

213matrixParamApi :: Proxy MatrixParamApi

214matrixParamApi = Proxy

@@ -289,8 +289,8 @@ matrixParamSpec = do

289 }

290

291type PostApi =

292− ReqBody Person :> Post Integer

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

293− :<|> "bla" :> ReqBody Person :> Post Integer

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

294postApi :: Proxy PostApi

295postApi = Proxy

296

@@ -298,23 +298,58 @@ postSpec :: Spec

298postSpec = do

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

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

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

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

303+

301 it "allows to POST a Person" $ do

304 it "allows to POST a Person" $ do

302− post "/" (encode alice) `shouldRespondWith` "42"{

305+ post' "/" (encode alice) `shouldRespondWith` "42"{

303 matchStatus = 201

306 matchStatus = 201

304 }

307 }

305

308

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

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

307− post "/bla" (encode alice) `shouldRespondWith` "42"{

310+ post' "/bla" (encode alice) `shouldRespondWith` "42"{

308 matchStatus = 201

311 matchStatus = 201

309 }

312 }

310

313

311 it "handles trailing '/' gracefully" $ do

314 it "handles trailing '/' gracefully" $ do

312− post "/bla/" (encode alice) `shouldRespondWith` "42"{

315+ post' "/bla/" (encode alice) `shouldRespondWith` "42"{

313 matchStatus = 201

316 matchStatus = 201

314 }

317 }

315

318

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

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

317− post "/" "some invalid body" `shouldRespondWith` 400

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

321+

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

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

324+ , "application/nonsense")]

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

326+

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

328+headerApi :: Proxy (HeaderApi a)

329+headerApi = Proxy

330+

331+headerSpec :: Spec

332+headerSpec = describe "Servant.API.Header" $ do

333+

334+ let expectsInt :: Maybe Int -> EitherT (Int,String) IO ()

335+ expectsInt (Just x) = when (x /= 5) $ error "Expected 5"

336+ expectsInt Nothing = error "Expected an int"

337+

338+ let expectsString :: Maybe String -> EitherT (Int,String) IO ()

339+ expectsString (Just x) = when (x /= "more from you") $ error "Expected more from you"

340+ expectsString Nothing = error "Expected a string"

341+

342+ with (return (serve headerApi expectsInt)) $ do

343+ let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader" ,"5")]

344+

345+ it "passes the header to the handler (Int)" $

346+ delete' "/" "" `shouldRespondWith` 204

347+

348+ with (return (serve headerApi expectsString)) $ do

349+ let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader" ,"more from you")]

350+

351+ it "passes the header to the handler (String)" $

352+ delete' "/" "" `shouldRespondWith` 204

318

353

319

354

320type RawApi = "foo" :> Raw

355type RawApi = "foo" :> Raw

@@ -344,8 +379,8 @@ rawSpec = do

344

379

345

380

346type AlternativeApi =

381type AlternativeApi =

347− "foo" :> Get Person

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

348− :<|> "bar" :> Get Animal

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

349unionApi :: Proxy AlternativeApi

384unionApi :: Proxy AlternativeApi

350unionApi = Proxy

385unionApi = Proxy

351

386

@@ -375,7 +410,7 @@ errorsSpec = do

375 let ib = InvalidBody "The body is invalid"

410 let ib = InvalidBody "The body is invalid"

376 let wm = WrongMethod

411 let wm = WrongMethod

377 let nf = NotFound

412 let nf = NotFound

378−

413+

379 describe "Servant.Server.Internal.RouteMismatch" $ do

414 describe "Servant.Server.Internal.RouteMismatch" $ do

380 it "HttpError > *" $ do

415 it "HttpError > *" $ do

381 ib <> he `shouldBe` he

416 ib <> he `shouldBe` he

test/Servant/Utils/StaticFilesSpec.hs+2−1

@@ -13,6 +13,7 @@ import System.IO.Temp (withSystemTempDirectory)

13import Test.Hspec (Spec, describe, it, around_)

14import Test.Hspec.Wai (with, get, shouldRespondWith)

16+import Servant.API (JSON)

16import Servant.API.Alternative ((:<|>)((:<|>)))

17import Servant.API.Alternative ((:<|>)((:<|>)))

17import Servant.API.Capture (Capture)

18import Servant.API.Capture (Capture)

18import Servant.API.Get (Get)

19import Servant.API.Get (Get)

@@ -23,7 +24,7 @@ import Servant.ServerSpec (Person(Person))

23import Servant.Utils.StaticFiles (serveDirectory)

24import Servant.Utils.StaticFiles (serveDirectory)

25type Api =

26type Api =

26− "dummy_api" :> Capture "person_name" String :> Get Person

27+ "dummy_api" :> Capture "person_name" String :> Get '[JSON] Person

27 :<|> "static" :> Raw

28 :<|> "static" :> Raw