ReqBody content types.

This commit is contained in:
Julian K. Arni 2015-01-13 20:40:41 +01:00
parent 380acb3efa
commit 8028cceee7
7 changed files with 195 additions and 75 deletions

View file

@ -2,6 +2,11 @@ master
------ ------
* Added support for matrix parameters, see e.g. http://www.w3.org/DesignIssues/MatrixURIs.html * Added support for matrix parameters, see e.g. http://www.w3.org/DesignIssues/MatrixURIs.html
* Add support for serializing based on Accept header
(https://github.com/haskell-servant/servant-server/issues/9)
* Ignore trailing slashes
(https://github.com/haskell-servant/servant-server/issues/5)
0.2.3 0.2.3
----- -----

View file

@ -18,7 +18,7 @@ import Servant
-- * Example -- * Example
-- | A greet message data type -- | A greet message data type
newtype Greet = Greet { msg :: Text } newtype Greet = Greet { _msg :: Text }
deriving (Generic, Show) deriving (Generic, Show)
instance FromJSON Greet instance FromJSON Greet
@ -27,11 +27,11 @@ instance ToJSON Greet
-- API specification -- API specification
type TestApi = type TestApi =
-- GET /hello/:name?capital={true, false} returns a Greet as JSON -- GET /hello/:name?capital={true, false} returns a Greet as JSON
"hello" :> Capture "name" Text :> QueryParam "capital" Bool :> Get Greet "hello" :> Capture "name" Text :> QueryParam "capital" Bool :> Get '[JSON] Greet
-- POST /greet with a Greet as JSON in the request body, -- POST /greet with a Greet as JSON in the request body,
-- returns a Greet as JSON -- returns a Greet as JSON
:<|> "greet" :> ReqBody Greet :> Post Greet :<|> "greet" :> ReqBody '[JSON] Greet :> Post '[JSON] Greet
-- DELETE /greet/:greetid -- DELETE /greet/:greetid
:<|> "greet" :> Capture "greetid" Text :> Delete :<|> "greet" :> Capture "greetid" Text :> Delete

View file

@ -35,24 +35,24 @@ library
Servant.Server.Internal Servant.Server.Internal
Servant.Utils.StaticFiles Servant.Utils.StaticFiles
build-depends: build-depends:
base >=4.7 && <5 base >= 4.7 && < 5
, aeson , aeson >= 0.7 && < 0.9
, attoparsec , attoparsec >= 0.12 && < 0.13
, bytestring , bytestring >= 0.10 && < 0.11
, either >= 4.3 , either >= 4.3 && < 4.4
, http-types , http-media >= 0.4 && < 0.5
, network-uri >= 2.6 , http-types >= 0.8 && < 0.9
, http-media == 0.4.* , network-uri >= 2.6 && < 2.7
, safe , safe >= 0.3 && < 0.4
, servant >= 0.2.2 , servant >= 0.2 && < 0.4
, split , split >= 0.2 && < 0.3
, string-conversions , string-conversions >= 0.3 && < 0.4
, system-filepath , system-filepath >= 0.4 && < 0.5
, text , text >= 1.2 && < 1.3
, transformers , transformers >= 0.3 && < 0.5
, wai , wai >= 3.0 && < 3.1
, wai-app-static >= 3.0.0.6 , wai-app-static >= 3.0 && < 3.1
, warp , warp >= 3.0 && < 3.1
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010
ghc-options: -Wall ghc-options: -Wall

View file

@ -9,12 +9,17 @@ module Servant.Server
, -- * Handlers for all standard combinators , -- * Handlers for all standard combinators
HasServer(..) HasServer(..)
, -- * Building new Content-Types
Accept(..)
, MimeRender(..)
) where ) where
import Data.Proxy (Proxy) import Data.Proxy (Proxy)
import Network.Wai (Application) import Network.Wai (Application)
import Servant.Server.Internal import Servant.Server.Internal
import Servant.Server.ContentTypes (Accept(..), MimeRender(..))
-- * Implementing Servers -- * Implementing Servers
@ -23,8 +28,8 @@ import Servant.Server.Internal
-- --
-- Example: -- Example:
-- --
-- > type MyApi = "books" :> Get [Book] -- GET /books -- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books
-- > :<|> "books" :> ReqBody Book :> Post Book -- POST /books -- > :<|> "books" :> ReqBody Book :> Post '[JSON] Book -- POST /books
-- > -- >
-- > server :: Server MyApi -- > server :: Server MyApi
-- > server = listAllBooks :<|> postBook -- > server = listAllBooks :<|> postBook

View file

@ -9,15 +9,21 @@
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
module Servant.Server.ContentTypes where module Servant.Server.ContentTypes where
import Data.Aeson (ToJSON(..), encode) import Control.Monad (join)
import Data.Aeson (ToJSON(..), FromJSON(..), encode, decode)
import Data.ByteString.Lazy (ByteString) import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
import Data.Proxy (Proxy(..)) import Data.Proxy (Proxy(..))
import Data.String.Conversions (cs) import Data.String.Conversions (cs)
import qualified Data.Text.Lazy.Encoding as Text
import qualified Data.Text.Lazy as Text
import qualified Network.HTTP.Media as M import qualified Network.HTTP.Media as M
import Servant.API (XML, HTML, JSON, JavaScript, CSS, PlainText) import Servant.API ( XML, HTML, JSON, JavaScript, CSS, PlainText
, OctetStream)
-- * Accept class
-- | Instances of 'Accept' represent mimetypes. They are used for matching -- | Instances of 'Accept' represent mimetypes. They are used for matching
-- against the @Accept@ HTTP header of the request, and for setting the -- 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)
-- --
-- Example: -- Example:
-- --
-- instance Accept HTML where -- > instance Accept HTML where
-- contentType _ = "text" // "html" -- > contentType _ = "text" // "html"
-- --
class Accept ctype where class Accept ctype where
contentType :: Proxy ctype -> M.MediaType contentType :: Proxy ctype -> M.MediaType
-- | @text/html;charset=utf-8@
instance Accept HTML where instance Accept HTML where
contentType _ = "text" M.// "html" contentType _ = "text" M.// "html"
-- | @application/json;charset=utf-8@
instance Accept JSON where instance Accept JSON where
contentType _ = "application" M.// "json" contentType _ = "application" M.// "json" M./: ("charset", "utf-8")
-- | @application/xml;charset=utf-8@
instance Accept XML where instance Accept XML where
contentType _ = "application" M.// "xml" contentType _ = "application" M.// "xml"
-- | @application/javascript;charset=utf-8@
instance Accept JavaScript where instance Accept JavaScript where
contentType _ = "application" M.// "javascript" contentType _ = "application" M.// "javascript"
-- | @text/css;charset=utf-8@
instance Accept CSS where instance Accept CSS where
contentType _ = "text" M.// "css" contentType _ = "text" M.// "css"
-- | @text/plain;charset=utf-8@
instance Accept PlainText where instance Accept PlainText where
contentType _ = "text" M.// "plain" contentType _ = "text" M.// "plain"
-- | @application/octet-stream@
instance Accept OctetStream where
contentType _ = "application" M.// "octet-stream"
newtype AcceptHeader = AcceptHeader BS.ByteString newtype AcceptHeader = AcceptHeader BS.ByteString
deriving (Eq, Show) deriving (Eq, Show)
-- * Render (serializing)
-- | Instantiate this class to register a way of serializing a type based -- | Instantiate this class to register a way of serializing a type based
-- on the @Accept@ header. -- on the @Accept@ header.
--
-- Example:
--
-- > data MyContentType
-- >
-- > instance Accept MyContentType where
-- > contentType _ = "example" // "prs.me.mine" /: ("charset", "utf-8")
-- >
-- > instance Show a => MimeRender MyContentType where
-- > toByteString _ val = pack ("This is MINE! " ++ show val)
-- >
-- > type MyAPI = "path" :> Get '[MyContentType] Int
class Accept ctype => MimeRender ctype a where class Accept ctype => MimeRender ctype a where
toByteString :: Proxy ctype -> a -> ByteString toByteString :: Proxy ctype -> a -> ByteString
@ -71,18 +101,53 @@ instance ( AllMimeRender ctyps a, IsEmpty ctyps ~ 'False
lkup = zip (map fst amrs) $ map (\(a,b) -> (cs $ show a, b)) amrs lkup = zip (map fst amrs) $ map (\(a,b) -> (cs $ show a, b)) amrs
--------------------------------------------------------------------------
-- * MimeRender Instances
-- | @encode@
instance ToJSON a => MimeRender JSON a where
toByteString _ = encode
-- | @encodeUtf8@
instance MimeRender PlainText Text.Text where
toByteString _ = Text.encodeUtf8
--------------------------------------------------------------------------
-- * Unrender
class Accept ctype => MimeUnrender ctype a where
fromByteString :: Proxy ctype -> ByteString -> Maybe a
class AllCTUnrender list a where
handleCTypeH :: Proxy list
-> ByteString -- Content-Type header
-> ByteString -- Request body
-> Maybe a
instance ( AllMimeUnrender ctyps a, IsEmpty ctyps ~ 'False
) => AllCTUnrender ctyps a where
handleCTypeH _ ctypeH body = join $ M.mapContentMedia lkup (cs ctypeH)
where lkup = amu (Proxy :: Proxy ctyps) body
--------------------------------------------------------------------------
-- * Utils (Internal)
-------------------------------------------------------------------------- --------------------------------------------------------------------------
-- Check that all elements of list are instances of MimeRender -- Check that all elements of list are instances of MimeRender
-------------------------------------------------------------------------- --------------------------------------------------------------------------
class AllMimeRender ls a where class AllMimeRender ls a where
amr :: Proxy ls -> a -> [(M.MediaType, ByteString)] -- list of content-types/response pairs amr :: Proxy ls
-> a -- value to serialize
-> [(M.MediaType, ByteString)] -- content-types/response pairs
instance ( MimeRender ctyp a ) => AllMimeRender '[ctyp] a where instance ( MimeRender ctyp a ) => AllMimeRender '[ctyp] a where
amr _ a = [(contentType pctyp, toByteString pctyp a)] amr _ a = [(contentType pctyp, toByteString pctyp a)]
where pctyp = Proxy :: Proxy ctyp where pctyp = Proxy :: Proxy ctyp
instance ( MimeRender ctyp a instance ( MimeRender ctyp a
, MimeRender ctyp' a , MimeRender ctyp' a -- at least two elems to avoid overlap
, AllMimeRender ctyps a , AllMimeRender ctyps a
) => AllMimeRender (ctyp ': ctyp' ': ctyps) a where ) => AllMimeRender (ctyp ': ctyp' ': ctyps) a where
amr _ a = (contentType pctyp, toByteString pctyp a) amr _ a = (contentType pctyp, toByteString pctyp a)
@ -96,19 +161,39 @@ instance ( MimeRender ctyp a
instance AllMimeRender '[] a where instance AllMimeRender '[] a where
amr _ _ = [] amr _ _ = []
--------------------------------------------------------------------------
-- Check that all elements of list are instances of MimeUnrender
--------------------------------------------------------------------------
class AllMimeUnrender ls a where
amu :: Proxy ls -> ByteString -> [(M.MediaType, Maybe a)]
instance ( MimeUnrender ctyp a ) => AllMimeUnrender '[ctyp] a where
amu _ val = [(contentType pctyp, fromByteString pctyp val)]
where pctyp = Proxy :: Proxy ctyp
instance ( MimeUnrender ctyp a
, MimeUnrender ctyp' a
, AllMimeUnrender ctyps a
) => AllMimeUnrender (ctyp ': ctyp' ': ctyps) a where
amu _ val = (contentType pctyp, fromByteString pctyp val)
:(contentType pctyp', fromByteString pctyp' val)
:(amu pctyps val)
where pctyp = Proxy :: Proxy ctyp
pctyps = Proxy :: Proxy ctyps
pctyp' = Proxy :: Proxy ctyp'
type family IsEmpty (ls::[*]) where type family IsEmpty (ls::[*]) where
IsEmpty '[] = 'True IsEmpty '[] = 'True
IsEmpty x = 'False IsEmpty x = 'False
-------------------------------------------------------------------------- --------------------------------------------------------------------------
-- MimeRender Instances -- * MimeUnrender Instances
--------------------------------------------------------------------------
instance ToJSON a => MimeRender JSON a where -- | @decode@
toByteString _ = encode instance FromJSON a => MimeUnrender JSON a where
fromByteString _ = decode
instance Show a => MimeRender PlainText a where -- | @Text.decodeUtf8'@
toByteString _ = encode . show instance MimeUnrender PlainText Text.Text where
fromByteString _ = either (const Nothing) Just . Text.decodeUtf8'
instance MimeRender PlainText String where
toByteString _ = encode

View file

@ -31,9 +31,11 @@ import Network.Wai ( Response, Request, ResponseReceived, Application
import Servant.API ( QueryParams, QueryParam, QueryFlag, ReqBody, Header import Servant.API ( QueryParams, QueryParam, QueryFlag, ReqBody, Header
, MatrixParams, MatrixParam, MatrixFlag, , MatrixParams, MatrixParam, MatrixFlag,
, Capture, Get, Delete, Put, Post, Patch, Raw, (:>), (:<|>)(..)) , Capture, Get, Delete, Put, Post, Patch, Raw, (:>), (:<|>)(..))
import Servant.Server.ContentTypes (AllCTRender(..), AcceptHeader(..)) import Servant.Server.ContentTypes ( AllCTRender(..), AcceptHeader(..)
, AllCTUnrender(..) )
import Servant.Common.Text (FromText, fromText) import Servant.Common.Text (FromText, fromText)
data ReqBodyState = Uncalled data ReqBodyState = Uncalled
| Called !B.ByteString | Called !B.ByteString
| Done !B.ByteString | Done !B.ByteString
@ -175,8 +177,8 @@ class HasServer layout where
-- represented by @a@ and if it fails tries @b@. You must provide a request -- represented by @a@ and if it fails tries @b@. You must provide a request
-- handler for each route. -- handler for each route.
-- --
-- > type MyApi = "books" :> Get [Book] -- GET /books -- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books
-- > :<|> "books" :> ReqBody Book :> Post Book -- POST /books -- > :<|> "books" :> ReqBody Book :> Post '[JSON] Book -- POST /books
-- > -- >
-- > server :: Server MyApi -- > server :: Server MyApi
-- > server = listAllBooks :<|> postBook -- > server = listAllBooks :<|> postBook
@ -207,7 +209,7 @@ captured _ = fromText
-- --
-- Example: -- Example:
-- --
-- > type MyApi = "books" :> Capture "isbn" Text :> Get Book -- > type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book
-- > -- >
-- > server :: Server MyApi -- > server :: Server MyApi
-- > server = getBook -- > server = getBook
@ -265,10 +267,12 @@ instance HasServer Delete where
-- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left' -- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left'
-- to quickly fail if some conditions are not met. -- to quickly fail if some conditions are not met.
-- --
-- If successfully returning a value, we just require that its type has -- If successfully returning a value, we use the type-level list, combined
-- a 'ToJSON' instance and servant takes care of encoding it for you, -- with the request's @Accept@ header, to encode the value for you
-- yielding status code 200 along the way. -- (returning a status code of 200). If there was no @Accept@ header or it
instance ( AllCTRender ctypes a, ToJSON a -- was @*/*@, we return encode using the first @Content-Type@ type on the
-- list.
instance ( AllCTRender ctypes a
) => HasServer (Get ctypes a) where ) => HasServer (Get ctypes a) where
type Server (Get ctypes a) = EitherT (Int, String) IO a type Server (Get ctypes a) = EitherT (Int, String) IO a
route Proxy action request respond route Proxy action request respond
@ -301,7 +305,7 @@ instance ( AllCTRender ctypes a, ToJSON a
-- > deriving (Eq, Show, FromText, ToText) -- > deriving (Eq, Show, FromText, ToText)
-- > -- >
-- > -- GET /view-my-referer -- > -- GET /view-my-referer
-- > type MyApi = "view-my-referer" :> Header "Referer" Referer :> Get Referer -- > type MyApi = "view-my-referer" :> Header "Referer" Referer :> Get '[JSON] Referer
-- > -- >
-- > server :: Server MyApi -- > server :: Server MyApi
-- > server = viewReferer -- > server = viewReferer
@ -327,11 +331,13 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
-- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left' -- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left'
-- to quickly fail if some conditions are not met. -- to quickly fail if some conditions are not met.
-- --
-- If successfully returning a value, we just require that its type has -- If successfully returning a value, we use the type-level list, combined
-- a 'ToJSON' instance and servant takes care of encoding it for you, -- with the request's @Accept@ header, to encode the value for you
-- yielding status code 201 along the way. -- (returning a status code of 201). If there was no @Accept@ header or it
instance ( AllCTRender ctypes a, ToJSON a -- was @*/*@, we return encode using the first @Content-Type@ type on the
)=> HasServer (Post ctypes a) where -- list.
instance ( AllCTRender ctypes a
) => HasServer (Post ctypes a) where
type Server (Post ctypes a) = EitherT (Int, String) IO a type Server (Post ctypes a) = EitherT (Int, String) IO a
route Proxy action request respond route Proxy action request respond
@ -358,10 +364,12 @@ instance ( AllCTRender ctypes a, ToJSON a
-- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left' -- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left'
-- to quickly fail if some conditions are not met. -- to quickly fail if some conditions are not met.
-- --
-- If successfully returning a value, we just require that its type has -- If successfully returning a value, we use the type-level list, combined
-- a 'ToJSON' instance and servant takes care of encoding it for you, -- with the request's @Accept@ header, to encode the value for you
-- yielding status code 200 along the way. -- (returning a status code of 201). If there was no @Accept@ header or it
instance ( AllCTRender ctypes a, ToJSON a -- was @*/*@, we return encode using the first @Content-Type@ type on the
-- list.
instance ( AllCTRender ctypes a
) => HasServer (Put ctypes a) where ) => HasServer (Put ctypes a) where
type Server (Put ctypes a) = EitherT (Int, String) IO a type Server (Put ctypes a) = EitherT (Int, String) IO a
@ -423,7 +431,7 @@ instance (Typeable a, ToJSON a) => HasServer (Patch a) where
-- --
-- Example: -- Example:
-- --
-- > type MyApi = "books" :> QueryParam "author" Text :> Get [Book] -- > type MyApi = "books" :> QueryParam "author" Text :> Get '[JSON] [Book]
-- > -- >
-- > server :: Server MyApi -- > server :: Server MyApi
-- > server = getBooksBy -- > server = getBooksBy
@ -462,7 +470,7 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
-- --
-- Example: -- Example:
-- --
-- > type MyApi = "books" :> QueryParams "authors" Text :> Get [Book] -- > type MyApi = "books" :> QueryParams "authors" Text :> Get '[JSON] [Book]
-- > -- >
-- > server :: Server MyApi -- > server :: Server MyApi
-- > server = getBooksBy -- > server = getBooksBy
@ -495,7 +503,7 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
-- --
-- Example: -- Example:
-- --
-- > type MyApi = "books" :> QueryFlag "published" :> Get [Book] -- > type MyApi = "books" :> QueryFlag "published" :> Get '[JSON] [Book]
-- > -- >
-- > server :: Server MyApi -- > server :: Server MyApi
-- > server = getBooks -- > server = getBooks
@ -654,27 +662,38 @@ instance HasServer Raw where
-- | If you use 'ReqBody' in one of the endpoints for your API, -- | If you use 'ReqBody' in one of the endpoints for your API,
-- this automatically requires your server-side handler to be a function -- this automatically requires your server-side handler to be a function
-- that takes an argument of the type specified by 'ReqBody'. -- that takes an argument of the type specified by 'ReqBody'.
-- The @Content-Type@ header is inspected, and the list provided is used to
-- attempt deserialization. If the request does not have a @Content-Type@
-- header, it is treated as @application/octet-stream@.
-- This lets servant worry about extracting it from the request and turning -- This lets servant worry about extracting it from the request and turning
-- it into a value of the type you specify. -- it into a value of the type you specify.
-- --
--
-- All it asks is for a 'FromJSON' instance. -- All it asks is for a 'FromJSON' instance.
-- --
-- Example: -- Example:
-- --
-- > type MyApi = "books" :> ReqBody Book :> Post Book -- > type MyApi = "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book
-- > -- >
-- > server :: Server MyApi -- > server :: Server MyApi
-- > server = postBook -- > server = postBook
-- > where postBook :: Book -> EitherT (Int, String) IO Book -- > where postBook :: Book -> EitherT (Int, String) IO Book
-- > postBook book = ...insert into your db... -- > postBook book = ...insert into your db...
instance (FromJSON a, HasServer sublayout) instance ( AllCTUnrender list a, HasServer sublayout
=> HasServer (ReqBody a :> sublayout) where ) => HasServer (ReqBody list a :> sublayout) where
type Server (ReqBody a :> sublayout) = type Server (ReqBody list a :> sublayout) =
a -> Server sublayout a -> Server sublayout
route Proxy subserver request respond = do route Proxy subserver request respond = do
mrqbody <- eitherDecode' <$> lazyRequestBody request -- See HTTP RFC 2616, section 7.2.1
-- http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1
-- See also "W3C Internet Media Type registration, consistency of use"
-- http://www.w3.org/2001/tag/2002/0129-mime
let contentTypeH = fromMaybe "application/octet-stream"
$ lookup hContentType $ requestHeaders request
mrqbody <- handleCTypeH (Proxy :: Proxy list) (cs contentTypeH)
<$> lazyRequestBody request
case mrqbody of case mrqbody of
Left e -> respond . failWith $ InvalidBody e Left e -> respond . failWith $ InvalidBody e
Right v -> route (Proxy :: Proxy sublayout) (subserver v) request respond Right v -> route (Proxy :: Proxy sublayout) (subserver v) request respond

View file

@ -16,11 +16,13 @@ import Data.Proxy (Proxy(Proxy))
import Data.String (fromString) import Data.String (fromString)
import Data.String.Conversions (cs) import Data.String.Conversions (cs)
import GHC.Generics (Generic) import GHC.Generics (Generic)
import Network.HTTP.Types (parseQuery, ok200, status409) import Network.HTTP.Types (parseQuery, ok200, status409, methodPost, hContentType)
import Network.Wai (Application, Request, responseLBS, pathInfo, queryString, rawQueryString) import Network.Wai ( Application, Request, responseLBS, pathInfo
import Network.Wai.Test (runSession, request, defaultRequest, simpleBody) , queryString, rawQueryString )
import Network.Wai.Test (runSession, defaultRequest, simpleBody, request)
import Test.Hspec (Spec, describe, it, shouldBe) import Test.Hspec (Spec, describe, it, shouldBe)
import Test.Hspec.Wai (liftIO, with, get, post, shouldRespondWith, matchStatus) import Test.Hspec.Wai ( liftIO, with, get, post, shouldRespondWith
, matchStatus, request )
import Servant.API (JSON) import Servant.API (JSON)
import Servant.API.Capture (Capture) import Servant.API.Capture (Capture)
@ -171,6 +173,7 @@ queryParamSpec = do
name = "john" name = "john"
} }
it "allows to retrieve value-less GET parameters" $ it "allows to retrieve value-less GET parameters" $
(flip runSession) (serve queryParamApi qpServer) $ do (flip runSession) (serve queryParamApi qpServer) $ do
let params3 = "?capitalize" let params3 = "?capitalize"
@ -290,8 +293,8 @@ matrixParamSpec = do
} }
type PostApi = type PostApi =
ReqBody Person :> Post '[JSON] Integer ReqBody '[JSON] Person :> Post '[JSON] Integer
:<|> "bla" :> ReqBody Person :> Post '[JSON] Integer :<|> "bla" :> ReqBody '[JSON] Person :> Post '[JSON] Integer
postApi :: Proxy PostApi postApi :: Proxy PostApi
postApi = Proxy postApi = Proxy
@ -299,23 +302,26 @@ postSpec :: Spec
postSpec = do postSpec = do
describe "Servant.API.Post and .ReqBody" $ do describe "Servant.API.Post and .ReqBody" $ do
with (return (serve postApi (return . age :<|> return . age))) $ do with (return (serve postApi (return . age :<|> return . age))) $ do
let post' x = Test.Hspec.Wai.request methodPost x [(hContentType
, "application/json")]
it "allows to POST a Person" $ do it "allows to POST a Person" $ do
post "/" (encode alice) `shouldRespondWith` "42"{ post' "/" (encode alice) `shouldRespondWith` "42"{
matchStatus = 201 matchStatus = 201
} }
it "allows alternative routes if all have request bodies" $ do it "allows alternative routes if all have request bodies" $ do
post "/bla" (encode alice) `shouldRespondWith` "42"{ post' "/bla" (encode alice) `shouldRespondWith` "42"{
matchStatus = 201 matchStatus = 201
} }
it "handles trailing '/' gracefully" $ do it "handles trailing '/' gracefully" $ do
post "/bla/" (encode alice) `shouldRespondWith` "42"{ post' "/bla/" (encode alice) `shouldRespondWith` "42"{
matchStatus = 201 matchStatus = 201
} }
it "correctly rejects invalid request bodies with status 400" $ do it "correctly rejects invalid request bodies with status 400" $ do
post "/" "some invalid body" `shouldRespondWith` 400 post' "/" "some invalid body" `shouldRespondWith` 400
type RawApi = "foo" :> Raw type RawApi = "foo" :> Raw