git.iko.soy/servant
on master help sign in
ReqBody content types.
8028cceJulian K. Arni
CHANGELOG.md+5
compare with master
unifiedsplit
@@ -2,6 +2,11 @@ master
2------
2------
3
3
4* Added support for matrix parameters, see e.g. http://www.w3.org/DesignIssues/MatrixURIs.html
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)
9+
5
10
60.2.3
110.2.3
7-----
12-----
example/greet.hs+3−3
@@ -18,7 +18,7 @@ import Servant
18-- * Example
18-- * Example
19
19
20-- | A greet message data type
20-- | A greet message data type
21−newtype Greet = Greet { msg :: Text }
21+newtype Greet = Greet { _msg :: Text }
22 deriving (Generic, Show)
22 deriving (Generic, Show)
23
23
24instance FromJSON Greet
24instance FromJSON Greet
@@ -27,11 +27,11 @@ instance ToJSON Greet
27-- API specification
27-- API specification
28type TestApi =
28type TestApi =
29 -- GET /hello/:name?capital={true, false} returns a Greet as JSON
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
31
31
32 -- POST /greet with a Greet as JSON in the request body,
32 -- POST /greet with a Greet as JSON in the request body,
33 -- returns a Greet as JSON
33 -- returns a Greet as JSON
34− :<|> "greet" :> ReqBody Greet :> Post Greet
34+ :<|> "greet" :> ReqBody '[JSON] Greet :> Post '[JSON] Greet
35
35
36 -- DELETE /greet/:greetid
36 -- DELETE /greet/:greetid
37 :<|> "greet" :> Capture "greetid" Text :> Delete
37 :<|> "greet" :> Capture "greetid" Text :> Delete
servant-server.cabal+18−18
@@ -35,24 +35,24 @@ library
35 Servant.Server.Internal
35 Servant.Server.Internal
36 Servant.Utils.StaticFiles
36 Servant.Utils.StaticFiles
37 build-depends:
37 build-depends:
38− base >=4.7 && <5
38+ base >= 4.7 && < 5
39− , aeson
39+ , aeson >= 0.7 && < 0.9
40− , attoparsec
40+ , attoparsec >= 0.12 && < 0.13
41− , bytestring
41+ , bytestring >= 0.10 && < 0.11
42− , either >= 4.3
42+ , either >= 4.3 && < 4.4
43+ , http-media >= 0.4 && < 0.5
43− , http-types
44+ , http-types >= 0.8 && < 0.9
44− , network-uri >= 2.6
45+ , network-uri >= 2.6 && < 2.7
45− , http-media == 0.4.*
46− , safe
46+ , safe >= 0.3 && < 0.4
47− , servant >= 0.2.2
47+ , servant >= 0.2 && < 0.4
48− , split
48+ , split >= 0.2 && < 0.3
49− , string-conversions
49+ , string-conversions >= 0.3 && < 0.4
50− , system-filepath
50+ , system-filepath >= 0.4 && < 0.5
51− , text
51+ , text >= 1.2 && < 1.3
52− , transformers
52+ , transformers >= 0.3 && < 0.5
53− , wai
53+ , wai >= 3.0 && < 3.1
54− , wai-app-static >= 3.0.0.6
54+ , wai-app-static >= 3.0 && < 3.1
55− , warp
55+ , warp >= 3.0 && < 3.1
56 hs-source-dirs: src
56 hs-source-dirs: src
57 default-language: Haskell2010
57 default-language: Haskell2010
58 ghc-options: -Wall
58 ghc-options: -Wall
src/Servant/Server.hs+7−2
@@ -9,12 +9,17 @@ module Servant.Server
9
9
10 , -- * Handlers for all standard combinators
10 , -- * Handlers for all standard combinators
11 HasServer(..)
11 HasServer(..)
12+
13+ , -- * Building new Content-Types
14+ Accept(..)
15+ , MimeRender(..)
12 ) where
16 ) where
13
17
14import Data.Proxy (Proxy)
18import Data.Proxy (Proxy)
15import Network.Wai (Application)
19import Network.Wai (Application)
16
20
17import Servant.Server.Internal
21import Servant.Server.Internal
22+import Servant.Server.ContentTypes (Accept(..), MimeRender(..))
18
23
19
24
20-- * Implementing Servers
25-- * Implementing Servers
@@ -23,8 +28,8 @@ import Servant.Server.Internal
23--
28--
24-- Example:
29-- Example:
25--
30--
26−-- > type MyApi = "books" :> Get [Book] -- GET /books
31+-- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books
27−-- > :<|> "books" :> ReqBody Book :> Post Book -- POST /books
32+-- > :<|> "books" :> ReqBody Book :> Post '[JSON] Book -- POST /books
28-- >
33-- >
29-- > server :: Server MyApi
34-- > server :: Server MyApi
30-- > server = listAllBooks :<|> postBook
35-- > server = listAllBooks :<|> postBook
src/Servant/Server/ContentTypes.hs+100−15
@@ -9,15 +9,21 @@
9{-# LANGUAGE UndecidableInstances #-}
9{-# LANGUAGE UndecidableInstances #-}
10module Servant.Server.ContentTypes where
10module Servant.Server.ContentTypes where
11
11
12+import Control.Monad (join)
12−import Data.Aeson (ToJSON(..), encode)
13+import Data.Aeson (ToJSON(..), FromJSON(..), encode, decode)
13import Data.ByteString.Lazy (ByteString)
14import Data.ByteString.Lazy (ByteString)
14import qualified Data.ByteString as BS
15import qualified Data.ByteString as BS
15import Data.Proxy (Proxy(..))
16import Data.Proxy (Proxy(..))
16import Data.String.Conversions (cs)
17import Data.String.Conversions (cs)
18+import qualified Data.Text.Lazy.Encoding as Text
19+import qualified Data.Text.Lazy as Text
17import qualified Network.HTTP.Media as M
20import qualified Network.HTTP.Media as M
18
21
19
22
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
21
27
22-- | Instances of 'Accept' represent mimetypes. They are used for matching
28-- | Instances of 'Accept' represent mimetypes. They are used for matching
23-- against the @Accept@ HTTP header of the request, and for setting the
29-- 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)
25--
31--
26-- Example:
32-- Example:
27--
33--
28−-- instance Accept HTML where
34+-- > instance Accept HTML where
29−-- contentType _ = "text" // "html"
35+-- > contentType _ = "text" // "html"
30--
36--
31class Accept ctype where
37class Accept ctype where
32 contentType :: Proxy ctype -> M.MediaType
38 contentType :: Proxy ctype -> M.MediaType
33
39
40+-- | @text/html;charset=utf-8@
34instance Accept HTML where
41instance Accept HTML where
35 contentType _ = "text" M.// "html"
42 contentType _ = "text" M.// "html"
36
43
44+-- | @application/json;charset=utf-8@
37instance Accept JSON where
45instance Accept JSON where
38− contentType _ = "application" M.// "json"
46+ contentType _ = "application" M.// "json" M./: ("charset", "utf-8")
39
47
48+-- | @application/xml;charset=utf-8@
40instance Accept XML where
49instance Accept XML where
41 contentType _ = "application" M.// "xml"
50 contentType _ = "application" M.// "xml"
42
51
52+-- | @application/javascript;charset=utf-8@
43instance Accept JavaScript where
53instance Accept JavaScript where
44 contentType _ = "application" M.// "javascript"
54 contentType _ = "application" M.// "javascript"
45
55
56+-- | @text/css;charset=utf-8@
46instance Accept CSS where
57instance Accept CSS where
47 contentType _ = "text" M.// "css"
58 contentType _ = "text" M.// "css"
48
59
60+-- | @text/plain;charset=utf-8@
49instance Accept PlainText where
61instance Accept PlainText where
50 contentType _ = "text" M.// "plain"
62 contentType _ = "text" M.// "plain"
51
63
64+-- | @application/octet-stream@
65+instance Accept OctetStream where
66+ contentType _ = "application" M.// "octet-stream"
67+
52newtype AcceptHeader = AcceptHeader BS.ByteString
68newtype AcceptHeader = AcceptHeader BS.ByteString
53 deriving (Eq, Show)
69 deriving (Eq, Show)
54
70
71+-- * Render (serializing)
72+
55-- | Instantiate this class to register a way of serializing a type based
73-- | Instantiate this class to register a way of serializing a type based
56-- on the @Accept@ header.
74-- 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
57class Accept ctype => MimeRender ctype a where
87class Accept ctype => MimeRender ctype a where
58 toByteString :: Proxy ctype -> a -> ByteString
88 toByteString :: Proxy ctype -> a -> ByteString
59
89
@@ -71,18 +101,53 @@ instance ( AllMimeRender ctyps a, IsEmpty ctyps ~ 'False
71 lkup = zip (map fst amrs) $ map (\(a,b) -> (cs $ show a, b)) amrs
101 lkup = zip (map fst amrs) $ map (\(a,b) -> (cs $ show a, b)) amrs
72
102
73
103
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+
74--------------------------------------------------------------------------
137--------------------------------------------------------------------------
75-- Check that all elements of list are instances of MimeRender
138-- Check that all elements of list are instances of MimeRender
76--------------------------------------------------------------------------
139--------------------------------------------------------------------------
77class AllMimeRender ls a where
140class AllMimeRender ls a where
141+ amr :: Proxy ls
142+ -> a -- value to serialize
78− amr :: Proxy ls -> a -> [(M.MediaType, ByteString)] -- list of content-types/response pairs
143+ -> [(M.MediaType, ByteString)] -- content-types/response pairs
79
144
80instance ( MimeRender ctyp a ) => AllMimeRender '[ctyp] a where
145instance ( MimeRender ctyp a ) => AllMimeRender '[ctyp] a where
81 amr _ a = [(contentType pctyp, toByteString pctyp a)]
146 amr _ a = [(contentType pctyp, toByteString pctyp a)]
82 where pctyp = Proxy :: Proxy ctyp
147 where pctyp = Proxy :: Proxy ctyp
83
148
84instance ( MimeRender ctyp a
149instance ( MimeRender ctyp a
85− , MimeRender ctyp' a
150+ , MimeRender ctyp' a -- at least two elems to avoid overlap
86 , AllMimeRender ctyps a
151 , AllMimeRender ctyps a
87 ) => AllMimeRender (ctyp ': ctyp' ': ctyps) a where
152 ) => AllMimeRender (ctyp ': ctyp' ': ctyps) a where
88 amr _ a = (contentType pctyp, toByteString pctyp a)
153 amr _ a = (contentType pctyp, toByteString pctyp a)
@@ -96,19 +161,39 @@ instance ( MimeRender ctyp a
96instance AllMimeRender '[] a where
161instance AllMimeRender '[] a where
97 amr _ _ = []
162 amr _ _ = []
98
163
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+
99type family IsEmpty (ls::[*]) where
185type family IsEmpty (ls::[*]) where
100 IsEmpty '[] = 'True
186 IsEmpty '[] = 'True
101 IsEmpty x = 'False
187 IsEmpty x = 'False
102
188
103--------------------------------------------------------------------------
189--------------------------------------------------------------------------
104−-- MimeRender Instances
190+-- * MimeUnrender Instances
105−--------------------------------------------------------------------------
106
191
192+-- | @decode@
107−instance ToJSON a => MimeRender JSON a where
193+instance FromJSON a => MimeUnrender JSON a where
108− toByteString _ = encode
194+ fromByteString _ = decode
109
195
196+-- | @Text.decodeUtf8'@
110−instance Show a => MimeRender PlainText a where
197+instance MimeUnrender PlainText Text.Text where
111− toByteString _ = encode . show
198+ fromByteString _ = either (const Nothing) Just . Text.decodeUtf8'
112
199
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
31import Servant.API ( QueryParams, QueryParam, QueryFlag, ReqBody, Header
31import Servant.API ( QueryParams, QueryParam, QueryFlag, ReqBody, Header
32 , MatrixParams, MatrixParam, MatrixFlag,
32 , MatrixParams, MatrixParam, MatrixFlag,
33 , Capture, Get, Delete, Put, Post, Patch, Raw, (:>), (:<|>)(..))
33 , Capture, Get, Delete, Put, Post, Patch, Raw, (:>), (:<|>)(..))
34−import Servant.Server.ContentTypes (AllCTRender(..), AcceptHeader(..))
34+import Servant.Server.ContentTypes ( AllCTRender(..), AcceptHeader(..)
35+ , AllCTUnrender(..) )
35import Servant.Common.Text (FromText, fromText)
36import Servant.Common.Text (FromText, fromText)
36
37
38+
37data ReqBodyState = Uncalled
39data ReqBodyState = Uncalled
38 | Called !B.ByteString
40 | Called !B.ByteString
39 | Done !B.ByteString
41 | Done !B.ByteString
@@ -175,8 +177,8 @@ class HasServer layout where
175-- represented by @a@ and if it fails tries @b@. You must provide a request
177-- represented by @a@ and if it fails tries @b@. You must provide a request
176-- handler for each route.
178-- handler for each route.
177--
179--
178−-- > type MyApi = "books" :> Get [Book] -- GET /books
180+-- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books
179−-- > :<|> "books" :> ReqBody Book :> Post Book -- POST /books
181+-- > :<|> "books" :> ReqBody Book :> Post '[JSON] Book -- POST /books
180-- >
182-- >
181-- > server :: Server MyApi
183-- > server :: Server MyApi
182-- > server = listAllBooks :<|> postBook
184-- > server = listAllBooks :<|> postBook
@@ -207,7 +209,7 @@ captured _ = fromText
207--
209--
208-- Example:
210-- Example:
209--
211--
210−-- > type MyApi = "books" :> Capture "isbn" Text :> Get Book
212+-- > type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book
211-- >
213-- >
212-- > server :: Server MyApi
214-- > server :: Server MyApi
213-- > server = getBook
215-- > server = getBook
@@ -265,10 +267,12 @@ instance HasServer Delete where
265-- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left'
267-- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left'
266-- to quickly fail if some conditions are not met.
268-- to quickly fail if some conditions are not met.
267--
269--
268−-- If successfully returning a value, we just require that its type has
270+-- If successfully returning a value, we use the type-level list, combined
269−-- a 'ToJSON' instance and servant takes care of encoding it for you,
271+-- with the request's @Accept@ header, to encode the value for you
270−-- yielding status code 200 along the way.
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.
271−instance ( AllCTRender ctypes a, ToJSON a
275+instance ( AllCTRender ctypes a
272 ) => HasServer (Get ctypes a) where
276 ) => HasServer (Get ctypes a) where
273 type Server (Get ctypes a) = EitherT (Int, String) IO a
277 type Server (Get ctypes a) = EitherT (Int, String) IO a
274 route Proxy action request respond
278 route Proxy action request respond
@@ -301,7 +305,7 @@ instance ( AllCTRender ctypes a, ToJSON a
301-- > deriving (Eq, Show, FromText, ToText)
305-- > deriving (Eq, Show, FromText, ToText)
302-- >
306-- >
303-- > -- GET /view-my-referer
307-- > -- 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
305-- >
309-- >
306-- > server :: Server MyApi
310-- > server :: Server MyApi
307-- > server = viewReferer
311-- > server = viewReferer
@@ -327,11 +331,13 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
327-- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left'
331-- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left'
328-- to quickly fail if some conditions are not met.
332-- to quickly fail if some conditions are not met.
329--
333--
330−-- If successfully returning a value, we just require that its type has
334+-- If successfully returning a value, we use the type-level list, combined
331−-- a 'ToJSON' instance and servant takes care of encoding it for you,
335+-- with the request's @Accept@ header, to encode the value for you
332−-- yielding status code 201 along the way.
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.
333−instance ( AllCTRender ctypes a, ToJSON a
339+instance ( AllCTRender ctypes a
334− )=> HasServer (Post ctypes a) where
340+ ) => HasServer (Post ctypes a) where
335 type Server (Post ctypes a) = EitherT (Int, String) IO a
341 type Server (Post ctypes a) = EitherT (Int, String) IO a
336
342
337 route Proxy action request respond
343 route Proxy action request respond
@@ -358,10 +364,12 @@ instance ( AllCTRender ctypes a, ToJSON a
358-- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left'
364-- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left'
359-- to quickly fail if some conditions are not met.
365-- to quickly fail if some conditions are not met.
360--
366--
361−-- If successfully returning a value, we just require that its type has
367+-- If successfully returning a value, we use the type-level list, combined
362−-- a 'ToJSON' instance and servant takes care of encoding it for you,
368+-- with the request's @Accept@ header, to encode the value for you
363−-- yielding status code 200 along the way.
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.
364−instance ( AllCTRender ctypes a, ToJSON a
372+instance ( AllCTRender ctypes a
365 ) => HasServer (Put ctypes a) where
373 ) => HasServer (Put ctypes a) where
366 type Server (Put ctypes a) = EitherT (Int, String) IO a
374 type Server (Put ctypes a) = EitherT (Int, String) IO a
367
375
@@ -423,7 +431,7 @@ instance (Typeable a, ToJSON a) => HasServer (Patch a) where
423--
431--
424-- Example:
432-- Example:
425--
433--
426−-- > type MyApi = "books" :> QueryParam "author" Text :> Get [Book]
434+-- > type MyApi = "books" :> QueryParam "author" Text :> Get '[JSON] [Book]
427-- >
435-- >
428-- > server :: Server MyApi
436-- > server :: Server MyApi
429-- > server = getBooksBy
437-- > server = getBooksBy
@@ -462,7 +470,7 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
462--
470--
463-- Example:
471-- Example:
464--
472--
465−-- > type MyApi = "books" :> QueryParams "authors" Text :> Get [Book]
473+-- > type MyApi = "books" :> QueryParams "authors" Text :> Get '[JSON] [Book]
466-- >
474-- >
467-- > server :: Server MyApi
475-- > server :: Server MyApi
468-- > server = getBooksBy
476-- > server = getBooksBy
@@ -495,7 +503,7 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
495--
503--
496-- Example:
504-- Example:
497--
505--
498−-- > type MyApi = "books" :> QueryFlag "published" :> Get [Book]
506+-- > type MyApi = "books" :> QueryFlag "published" :> Get '[JSON] [Book]
499-- >
507-- >
500-- > server :: Server MyApi
508-- > server :: Server MyApi
501-- > server = getBooks
509-- > server = getBooks
@@ -654,27 +662,38 @@ instance HasServer Raw where
654-- | If you use 'ReqBody' in one of the endpoints for your API,
662-- | If you use 'ReqBody' in one of the endpoints for your API,
655-- this automatically requires your server-side handler to be a function
663-- this automatically requires your server-side handler to be a function
656-- that takes an argument of the type specified by 'ReqBody'.
664-- 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@.
657-- This lets servant worry about extracting it from the request and turning
668-- This lets servant worry about extracting it from the request and turning
658-- it into a value of the type you specify.
669-- it into a value of the type you specify.
659--
670--
671+--
660-- All it asks is for a 'FromJSON' instance.
672-- All it asks is for a 'FromJSON' instance.
661--
673--
662-- Example:
674-- Example:
663--
675--
664−-- > type MyApi = "books" :> ReqBody Book :> Post Book
676+-- > type MyApi = "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book
665-- >
677-- >
666-- > server :: Server MyApi
678-- > server :: Server MyApi
667-- > server = postBook
679-- > server = postBook
668-- > where postBook :: Book -> EitherT (Int, String) IO Book
680-- > where postBook :: Book -> EitherT (Int, String) IO Book
669-- > postBook book = ...insert into your db...
681-- > postBook book = ...insert into your db...
670−instance (FromJSON a, HasServer sublayout)
682+instance ( AllCTUnrender list a, HasServer sublayout
671− => HasServer (ReqBody a :> sublayout) where
683+ ) => HasServer (ReqBody list a :> sublayout) where
672
684
673− type Server (ReqBody a :> sublayout) =
685+ type Server (ReqBody list a :> sublayout) =
674 a -> Server sublayout
686 a -> Server sublayout
675
687
676 route Proxy subserver request respond = do
688 route Proxy subserver request respond = do
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)
677− mrqbody <- eitherDecode' <$> lazyRequestBody request
696+ <$> lazyRequestBody request
678 case mrqbody of
697 case mrqbody of
679 Left e -> respond . failWith $ InvalidBody e
698 Left e -> respond . failWith $ InvalidBody e
680 Right v -> route (Proxy :: Proxy sublayout) (subserver v) request respond
699 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))
16import Data.String (fromString)
16import Data.String (fromString)
17import Data.String.Conversions (cs)
17import Data.String.Conversions (cs)
18import GHC.Generics (Generic)
18import GHC.Generics (Generic)
19−import Network.HTTP.Types (parseQuery, ok200, status409)
19+import Network.HTTP.Types (parseQuery, ok200, status409, methodPost, hContentType)
20−import Network.Wai (Application, Request, responseLBS, pathInfo, queryString, rawQueryString)
20+import Network.Wai ( Application, Request, responseLBS, pathInfo
21+ , queryString, rawQueryString )
21−import Network.Wai.Test (runSession, request, defaultRequest, simpleBody)
22+import Network.Wai.Test (runSession, defaultRequest, simpleBody, request)
22import Test.Hspec (Spec, describe, it, shouldBe)
23import 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 )
24
26
25import Servant.API (JSON)
27import Servant.API (JSON)
26import Servant.API.Capture (Capture)
28import Servant.API.Capture (Capture)
@@ -171,6 +173,7 @@ queryParamSpec = do
171 name = "john"
173 name = "john"
172 }
174 }
173
175
176+
174 it "allows to retrieve value-less GET parameters" $
177 it "allows to retrieve value-less GET parameters" $
175 (flip runSession) (serve queryParamApi qpServer) $ do
178 (flip runSession) (serve queryParamApi qpServer) $ do
176 let params3 = "?capitalize"
179 let params3 = "?capitalize"
@@ -290,8 +293,8 @@ matrixParamSpec = do
290 }
293 }
291
294
292type PostApi =
295type PostApi =
293− ReqBody Person :> Post '[JSON] Integer
296+ ReqBody '[JSON] Person :> Post '[JSON] Integer
294− :<|> "bla" :> ReqBody Person :> Post '[JSON] Integer
297+ :<|> "bla" :> ReqBody '[JSON] Person :> Post '[JSON] Integer
295postApi :: Proxy PostApi
298postApi :: Proxy PostApi
296postApi = Proxy
299postApi = Proxy
297
300
@@ -299,23 +302,26 @@ postSpec :: Spec
299postSpec = do
302postSpec = do
300 describe "Servant.API.Post and .ReqBody" $ do
303 describe "Servant.API.Post and .ReqBody" $ do
301 with (return (serve postApi (return . age :<|> return . age))) $ do
304 with (return (serve postApi (return . age :<|> return . age))) $ do
305+ let post' x = Test.Hspec.Wai.request methodPost x [(hContentType
306+ , "application/json")]
307+
302 it "allows to POST a Person" $ do
308 it "allows to POST a Person" $ do
303− post "/" (encode alice) `shouldRespondWith` "42"{
309+ post' "/" (encode alice) `shouldRespondWith` "42"{
304 matchStatus = 201
310 matchStatus = 201
305 }
311 }
306
312
307 it "allows alternative routes if all have request bodies" $ do
313 it "allows alternative routes if all have request bodies" $ do
308− post "/bla" (encode alice) `shouldRespondWith` "42"{
314+ post' "/bla" (encode alice) `shouldRespondWith` "42"{
309 matchStatus = 201
315 matchStatus = 201
310 }
316 }
311
317
312 it "handles trailing '/' gracefully" $ do
318 it "handles trailing '/' gracefully" $ do
313− post "/bla/" (encode alice) `shouldRespondWith` "42"{
319+ post' "/bla/" (encode alice) `shouldRespondWith` "42"{
314 matchStatus = 201
320 matchStatus = 201
315 }
321 }
316
322
317 it "correctly rejects invalid request bodies with status 400" $ do
323 it "correctly rejects invalid request bodies with status 400" $ do
318− post "/" "some invalid body" `shouldRespondWith` 400
324+ post' "/" "some invalid body" `shouldRespondWith` 400
319
325
320
326
321type RawApi = "foo" :> Raw
327type RawApi = "foo" :> Raw
@@ -376,7 +382,7 @@ errorsSpec = do
376 let ib = InvalidBody "The body is invalid"
382 let ib = InvalidBody "The body is invalid"
377 let wm = WrongMethod
383 let wm = WrongMethod
378 let nf = NotFound
384 let nf = NotFound
379−
385+
380 describe "Servant.Server.Internal.RouteMismatch" $ do
386 describe "Servant.Server.Internal.RouteMismatch" $ do
381 it "HttpError > *" $ do
387 it "HttpError > *" $ do
382 ib <> he `shouldBe` he
388 ib <> he `shouldBe` he