8028cce · servant · git.iko.soy

git.iko.soy/servant

ReqBody content types.

commit8028cceee72fc2beaff1fda54912c654f41320b1 authorJulian K. Arni <jkarni@gmail.com> dateTue 13 Jan 2015, 20:40 (12 years ago) parent380acb3

7 files changed+195−75

compare with master

unifiedsplit

CHANGELOG.md+5 example/greet.hs+3−3 servant-server.cabal+18−18 src/Servant/Server.hs+7−2 src/Servant/Server/ContentTypes.hs+100−15 src/Servant/Server/Internal.hs+45−26 test/Servant/ServerSpec.hs+17−11

CHANGELOG.md+5

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

22------

44* 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)

510

6110.2.3

712-----

example/greet.hs+3−3

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

1818-- * Example

1919

2020-- | A greet message data type

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

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

2222 deriving (Generic, Show)

2323

2424instance FromJSON Greet

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

2727-- API specification

2828type TestApi =

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

3131

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

3333 -- returns a Greet as JSON

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

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

3535

3636 -- DELETE /greet/:greetid

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

servant-server.cabal+18−18

@@ -35,24 +35,24 @@ library

3535 Servant.Server.Internal

3636 Servant.Utils.StaticFiles

3737 build-depends:

38− base >=4.7 && <5

39− , aeson

40− , attoparsec

41− , bytestring

42− , either >= 4.3

43− , http-types

44− , network-uri >= 2.6

45− , http-media == 0.4.*

46− , safe

47− , servant >= 0.2.2

48− , split

49− , string-conversions

50− , system-filepath

51− , text

52− , transformers

53− , wai

54− , wai-app-static >= 3.0.0.6

55− , warp

38+ base >= 4.7 && < 5

39+ , aeson >= 0.7 && < 0.9

40+ , attoparsec >= 0.12 && < 0.13

41+ , bytestring >= 0.10 && < 0.11

42+ , either >= 4.3 && < 4.4

43+ , http-media >= 0.4 && < 0.5

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

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

46+ , safe >= 0.3 && < 0.4

47+ , servant >= 0.2 && < 0.4

48+ , split >= 0.2 && < 0.3

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

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

51+ , text >= 1.2 && < 1.3

52+ , transformers >= 0.3 && < 0.5

53+ , wai >= 3.0 && < 3.1

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

55+ , warp >= 3.0 && < 3.1

5656 hs-source-dirs: src

5757 default-language: Haskell2010

5858 ghc-options: -Wall

src/Servant/Server.hs+7−2

@@ -9,12 +9,17 @@ module Servant.Server

1010 , -- * Handlers for all standard combinators

1111 HasServer(..)

12+

13+ , -- * Building new Content-Types

14+ Accept(..)

15+ , MimeRender(..)

1216 ) where

1317

1418import Data.Proxy (Proxy)

1519import Network.Wai (Application)

1620

1721import Servant.Server.Internal

22+import Servant.Server.ContentTypes (Accept(..), MimeRender(..))

1823

1924

2025-- * Implementing Servers

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

2328--

2429-- Example:

2530--

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

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

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

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

2833-- >

2934-- > server :: Server MyApi

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

src/Servant/Server/ContentTypes.hs+100−15

@@ -9,15 +9,21 @@

99{-# LANGUAGE UndecidableInstances #-}

1010module Servant.Server.ContentTypes where

1111

12−import Data.Aeson (ToJSON(..), encode)

12+import Control.Monad (join)

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

1314import Data.ByteString.Lazy (ByteString)

1415import qualified Data.ByteString as BS

1516import Data.Proxy (Proxy(..))

1617import Data.String.Conversions (cs)

18+import qualified Data.Text.Lazy.Encoding as Text

19+import qualified Data.Text.Lazy as Text

1720import qualified Network.HTTP.Media as M

1821

1922

20−import Servant.API (XML, HTML, JSON, JavaScript, CSS, PlainText)

23+import Servant.API ( XML, HTML, JSON, JavaScript, CSS, PlainText

24+ , OctetStream)

25+

26+-- * Accept class

2127

2228-- | Instances of 'Accept' represent mimetypes. They are used for matching

2329-- against the @Accept@ HTTP header of the request, and for setting the

@@ -25,35 +31,59 @@ import Servant.API (XML, HTML, JSON, JavaScript, CSS, PlainText)

2531--

2632-- Example:

2733--

28−-- instance Accept HTML where

29−-- contentType _ = "text" // "html"

34+-- > instance Accept HTML where

35+-- > contentType _ = "text" // "html"

3036--

3137class Accept ctype where

3238 contentType :: Proxy ctype -> M.MediaType

3339

40+-- | @text/html;charset=utf-8@

3441instance Accept HTML where

3542 contentType _ = "text" M.// "html"

3643

44+-- | @application/json;charset=utf-8@

3745instance Accept JSON where

38− contentType _ = "application" M.// "json"

46+ contentType _ = "application" M.// "json" M./: ("charset", "utf-8")

3947

48+-- | @application/xml;charset=utf-8@

4049instance Accept XML where

4150 contentType _ = "application" M.// "xml"

4251

52+-- | @application/javascript;charset=utf-8@

4353instance Accept JavaScript where

4454 contentType _ = "application" M.// "javascript"

4555

56+-- | @text/css;charset=utf-8@

4657instance Accept CSS where

4758 contentType _ = "text" M.// "css"

4859

60+-- | @text/plain;charset=utf-8@

4961instance Accept PlainText where

5062 contentType _ = "text" M.// "plain"

5163

64+-- | @application/octet-stream@

65+instance Accept OctetStream where

66+ contentType _ = "application" M.// "octet-stream"

67+

5268newtype AcceptHeader = AcceptHeader BS.ByteString

5369 deriving (Eq, Show)

5470

71+-- * Render (serializing)

72+

5573-- | Instantiate this class to register a way of serializing a type based

5674-- on the @Accept@ header.

75+--

76+-- Example:

77+--

78+-- > data MyContentType

79+-- >

80+-- > instance Accept MyContentType where

81+-- > contentType _ = "example" // "prs.me.mine" /: ("charset", "utf-8")

82+-- >

83+-- > instance Show a => MimeRender MyContentType where

84+-- > toByteString _ val = pack ("This is MINE! " ++ show val)

85+-- >

86+-- > type MyAPI = "path" :> Get '[MyContentType] Int

5787class Accept ctype => MimeRender ctype a where

5888 toByteString :: Proxy ctype -> a -> ByteString

5989

@@ -71,18 +101,53 @@ instance ( AllMimeRender ctyps a, IsEmpty ctyps ~ 'False

71101 lkup = zip (map fst amrs) $ map (\(a,b) -> (cs $ show a, b)) amrs

72102

73103

104+

105+

106+--------------------------------------------------------------------------

107+-- * MimeRender Instances

108+

109+-- | @encode@

110+instance ToJSON a => MimeRender JSON a where

111+ toByteString _ = encode

112+

113+-- | @encodeUtf8@

114+instance MimeRender PlainText Text.Text where

115+ toByteString _ = Text.encodeUtf8

116+

117+--------------------------------------------------------------------------

118+-- * Unrender

119+class Accept ctype => MimeUnrender ctype a where

120+ fromByteString :: Proxy ctype -> ByteString -> Maybe a

121+

122+class AllCTUnrender list a where

123+ handleCTypeH :: Proxy list

124+ -> ByteString -- Content-Type header

125+ -> ByteString -- Request body

126+ -> Maybe a

127+

128+instance ( AllMimeUnrender ctyps a, IsEmpty ctyps ~ 'False

129+ ) => AllCTUnrender ctyps a where

130+ handleCTypeH _ ctypeH body = join $ M.mapContentMedia lkup (cs ctypeH)

131+ where lkup = amu (Proxy :: Proxy ctyps) body

132+

133+--------------------------------------------------------------------------

134+-- * Utils (Internal)

135+

136+

74137--------------------------------------------------------------------------

75138-- Check that all elements of list are instances of MimeRender

76139--------------------------------------------------------------------------

77140class AllMimeRender ls a where

78− amr :: Proxy ls -> a -> [(M.MediaType, ByteString)] -- list of content-types/response pairs

141+ amr :: Proxy ls

142+ -> a -- value to serialize

143+ -> [(M.MediaType, ByteString)] -- content-types/response pairs

79144

80145instance ( MimeRender ctyp a ) => AllMimeRender '[ctyp] a where

81146 amr _ a = [(contentType pctyp, toByteString pctyp a)]

82147 where pctyp = Proxy :: Proxy ctyp

83148

84149instance ( MimeRender ctyp a

85− , MimeRender ctyp' a

150+ , MimeRender ctyp' a -- at least two elems to avoid overlap

86151 , AllMimeRender ctyps a

87152 ) => AllMimeRender (ctyp ': ctyp' ': ctyps) a where

88153 amr _ a = (contentType pctyp, toByteString pctyp a)

@@ -96,19 +161,39 @@ instance ( MimeRender ctyp a

96161instance AllMimeRender '[] a where

97162 amr _ _ = []

98163

164+--------------------------------------------------------------------------

165+-- Check that all elements of list are instances of MimeUnrender

166+--------------------------------------------------------------------------

167+class AllMimeUnrender ls a where

168+ amu :: Proxy ls -> ByteString -> [(M.MediaType, Maybe a)]

169+

170+instance ( MimeUnrender ctyp a ) => AllMimeUnrender '[ctyp] a where

171+ amu _ val = [(contentType pctyp, fromByteString pctyp val)]

172+ where pctyp = Proxy :: Proxy ctyp

173+

174+instance ( MimeUnrender ctyp a

175+ , MimeUnrender ctyp' a

176+ , AllMimeUnrender ctyps a

177+ ) => AllMimeUnrender (ctyp ': ctyp' ': ctyps) a where

178+ amu _ val = (contentType pctyp, fromByteString pctyp val)

179+ :(contentType pctyp', fromByteString pctyp' val)

180+ :(amu pctyps val)

181+ where pctyp = Proxy :: Proxy ctyp

182+ pctyps = Proxy :: Proxy ctyps

183+ pctyp' = Proxy :: Proxy ctyp'

184+

99185type family IsEmpty (ls::[*]) where

100186 IsEmpty '[] = 'True

101187 IsEmpty x = 'False

102188

103189--------------------------------------------------------------------------

104−-- MimeRender Instances

105−--------------------------------------------------------------------------

190+-- * MimeUnrender Instances

106191

107−instance ToJSON a => MimeRender JSON a where

108− toByteString _ = encode

192+-- | @decode@

193+instance FromJSON a => MimeUnrender JSON a where

194+ fromByteString _ = decode

109195

110−instance Show a => MimeRender PlainText a where

111− toByteString _ = encode . show

196+-- | @Text.decodeUtf8'@

197+instance MimeUnrender PlainText Text.Text where

198+ fromByteString _ = either (const Nothing) Just . Text.decodeUtf8'

112199

113−instance MimeRender PlainText String where

114− toByteString _ = encode

src/Servant/Server/Internal.hs+45−26

@@ -31,9 +31,11 @@ import Network.Wai ( Response, Request, ResponseReceived, Application

3131import Servant.API ( QueryParams, QueryParam, QueryFlag, ReqBody, Header

3232 , MatrixParams, MatrixParam, MatrixFlag,

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

34−import Servant.Server.ContentTypes (AllCTRender(..), AcceptHeader(..))

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

35+ , AllCTUnrender(..) )

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

3637

38+

3739data ReqBodyState = Uncalled

3840 | Called !B.ByteString

3941 | Done !B.ByteString

@@ -175,8 +177,8 @@ class HasServer layout where

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

176178-- handler for each route.

177179--

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

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

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

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

180182-- >

181183-- > server :: Server MyApi

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

@@ -207,7 +209,7 @@ captured _ = fromText

207209--

208210-- Example:

209211--

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

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

211213-- >

212214-- > server :: Server MyApi

213215-- > server = getBook

@@ -265,10 +267,12 @@ instance HasServer Delete where

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

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

267269--

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

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

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

271−instance ( AllCTRender ctypes a, ToJSON a

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

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

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

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

274+-- list.

275+instance ( AllCTRender ctypes a

272276 ) => HasServer (Get ctypes a) where

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

274278 route Proxy action request respond

@@ -301,7 +305,7 @@ instance ( AllCTRender ctypes a, ToJSON a

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

302306-- >

303307-- > -- GET /view-my-referer

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

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

305309-- >

306310-- > server :: Server MyApi

307311-- > server = viewReferer

@@ -327,11 +331,13 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)

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

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

329333--

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

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

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

333−instance ( AllCTRender ctypes a, ToJSON a

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

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

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

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

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

338+-- list.

339+instance ( AllCTRender ctypes a

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

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

336342

337343 route Proxy action request respond

@@ -358,10 +364,12 @@ instance ( AllCTRender ctypes a, ToJSON a

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

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

360366--

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

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

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

364−instance ( AllCTRender ctypes a, ToJSON a

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

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

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

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

371+-- list.

372+instance ( AllCTRender ctypes a

365373 ) => HasServer (Put ctypes a) where

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

367375

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

423431--

424432-- Example:

425433--

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

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

427435-- >

428436-- > server :: Server MyApi

429437-- > server = getBooksBy

@@ -462,7 +470,7 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)

462470--

463471-- Example:

464472--

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

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

466474-- >

467475-- > server :: Server MyApi

468476-- > server = getBooksBy

@@ -495,7 +503,7 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)

495503--

496504-- Example:

497505--

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

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

499507-- >

500508-- > server :: Server MyApi

501509-- > server = getBooks

@@ -654,27 +662,38 @@ instance HasServer Raw where

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

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

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

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

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

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

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

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

659670--

671+--

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

661673--

662674-- Example:

663675--

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

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

665677-- >

666678-- > server :: Server MyApi

667679-- > server = postBook

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

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

670−instance (FromJSON a, HasServer sublayout)

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

682+instance ( AllCTUnrender list a, HasServer sublayout

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

672684

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

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

674686 a -> Server sublayout

675687

676688 route Proxy subserver request respond = do

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

689+ -- See HTTP RFC 2616, section 7.2.1

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

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

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

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

694+ $ lookup hContentType $ requestHeaders request

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

696+ <$> lazyRequestBody request

678697 case mrqbody of

679698 Left e -> respond . failWith $ InvalidBody e

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

test/Servant/ServerSpec.hs+17−11

@@ -16,11 +16,13 @@ import Data.Proxy (Proxy(Proxy))

1616import Data.String (fromString)

1717import Data.String.Conversions (cs)

1818import GHC.Generics (Generic)

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

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

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

19+import Network.HTTP.Types (parseQuery, ok200, status409, methodPost, hContentType)

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

21+ , queryString, rawQueryString )

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

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

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

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

25+ , matchStatus, request )

2426

2527import Servant.API (JSON)

2628import Servant.API.Capture (Capture)

@@ -171,6 +173,7 @@ queryParamSpec = do

171173 name = "john"

172174 }

173175

176+

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

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

176179 let params3 = "?capitalize"

@@ -290,8 +293,8 @@ matrixParamSpec = do

290293 }

291294

292295type PostApi =

293− ReqBody Person :> Post '[JSON] Integer

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

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

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

295298postApi :: Proxy PostApi

296299postApi = Proxy

297300

@@ -299,23 +302,26 @@ postSpec :: Spec

299302postSpec = do

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

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

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

306+ , "application/json")]

307+

302308 it "allows to POST a Person" $ do

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

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

304310 matchStatus = 201

305311 }

306312

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

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

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

309315 matchStatus = 201

310316 }

311317

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

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

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

314320 matchStatus = 201

315321 }

316322

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

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

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

319325

320326

321327type RawApi = "foo" :> Raw

@@ -376,7 +382,7 @@ errorsSpec = do

376382 let ib = InvalidBody "The body is invalid"

377383 let wm = WrongMethod

378384 let nf = NotFound

379−

385+

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

381387 it "HttpError > *" $ do

382388 ib <> he `shouldBe` he