ReqBody content types.

CHANGELOG.md

@@ -2,6 +2,11 @@ master
 ------
 
 * 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
 -----

example/greet.hs

@@ -18,7 +18,7 @@ import Servant
 -- * Example
 
 -- | A greet message data type
-newtype Greet = Greet { msg :: Text }
+newtype Greet = Greet { _msg :: Text }
   deriving (Generic, Show)
 
 instance FromJSON Greet
@@ -27,11 +27,11 @@ instance ToJSON Greet
 -- API specification
 type TestApi =
        -- 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,
        --             returns a Greet as JSON
-  :<|> "greet" :> ReqBody Greet :> Post Greet
+  :<|> "greet" :> ReqBody '[JSON] Greet :> Post '[JSON] Greet
 
        -- DELETE /greet/:greetid
   :<|> "greet" :> Capture "greetid" Text :> Delete

servant-server.cabal

@@ -36,23 +36,23 @@ library
     Servant.Utils.StaticFiles
   build-depends:
         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
   default-language: Haskell2010
   ghc-options: -Wall

src/Servant/Server.hs

@@ -9,12 +9,17 @@ module Servant.Server
 
   , -- * Handlers for all standard combinators
     HasServer(..)
+
+  , -- * Building new Content-Types
+    Accept(..)
+  , MimeRender(..)
   ) where
 
 import Data.Proxy (Proxy)
 import Network.Wai (Application)
 
 import Servant.Server.Internal
+import Servant.Server.ContentTypes (Accept(..), MimeRender(..))
 
 
 -- * Implementing Servers
@@ -23,8 +28,8 @@ import Servant.Server.Internal
 --
 -- 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 = listAllBooks :<|> postBook

src/Servant/Server/ContentTypes.hs

@@ -9,15 +9,21 @@
 {-# LANGUAGE UndecidableInstances #-}
 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 qualified Data.ByteString as BS
 import Data.Proxy (Proxy(..))
 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 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
 -- 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:
 --
---   instance Accept HTML where
+-- > instance Accept HTML where
---      contentType _ = "text" // "html"
+-- >    contentType _ = "text" // "html"
 --
 class Accept ctype where
     contentType   :: Proxy ctype -> M.MediaType
 
+-- | @text/html;charset=utf-8@
 instance Accept HTML where
     contentType _ = "text" M.// "html"
 
+-- | @application/json;charset=utf-8@
 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
     contentType _ = "application" M.// "xml"
 
+-- | @application/javascript;charset=utf-8@
 instance Accept JavaScript where
     contentType _ = "application" M.// "javascript"
 
+-- | @text/css;charset=utf-8@
 instance Accept CSS where
     contentType _ = "text" M.// "css"
 
+-- | @text/plain;charset=utf-8@
 instance Accept PlainText where
     contentType _ = "text" M.// "plain"
 
+-- | @application/octet-stream@
+instance Accept OctetStream where
+    contentType _ = "application" M.// "octet-stream"
+
 newtype AcceptHeader = AcceptHeader BS.ByteString
     deriving (Eq, Show)
 
+-- * Render (serializing)
+
 -- | Instantiate this class to register a way of serializing a type based
 -- 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
     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
 
 
+
+
+--------------------------------------------------------------------------
+-- * 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
 --------------------------------------------------------------------------
 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
     amr _ a = [(contentType pctyp, toByteString pctyp a)]
         where pctyp = Proxy :: Proxy ctyp
 
 instance ( MimeRender ctyp a
-         , MimeRender ctyp' a
+         , MimeRender ctyp' a        -- at least two elems to avoid overlap
          , AllMimeRender ctyps a
          ) => AllMimeRender (ctyp ': ctyp' ': ctyps) a where
     amr _ a = (contentType pctyp, toByteString pctyp a)
@@ -96,19 +161,39 @@ instance ( MimeRender ctyp a
 instance AllMimeRender '[] a where
     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
     IsEmpty '[] = 'True
     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

src/Servant/Server/Internal.hs

@@ -31,9 +31,11 @@ import Network.Wai ( Response, Request, ResponseReceived, Application
 import Servant.API ( QueryParams, QueryParam, QueryFlag, ReqBody, Header
                    , MatrixParams, MatrixParam, MatrixFlag,
                    , 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)
 
+
 data ReqBodyState = Uncalled
                   | Called !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
 --   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 = listAllBooks :<|> postBook
@@ -207,7 +209,7 @@ captured _ = fromText
 --
 -- Example:
 --
--- > type MyApi = "books" :> Capture "isbn" Text :> Get Book
+-- > type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book
 -- >
 -- > server :: Server MyApi
 -- > server = getBook
@@ -265,10 +267,12 @@ instance HasServer Delete where
 -- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left'
 -- 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
   type Server (Get ctypes a) = EitherT (Int, String) IO a
   route Proxy action request respond
@@ -301,7 +305,7 @@ instance ( AllCTRender ctypes a, ToJSON a
 -- >   deriving (Eq, Show, FromText, ToText)
 -- >
 -- >            -- 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 = viewReferer
@@ -327,10 +331,12 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
 -- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left'
 -- 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
+-- list.
+instance ( AllCTRender ctypes a
          ) => HasServer (Post ctypes a) where
   type Server (Post ctypes a) = EitherT (Int, String) IO a
 
@@ -358,10 +364,12 @@ instance ( AllCTRender ctypes a, ToJSON a
 -- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left'
 -- 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
   type Server (Put ctypes a) = EitherT (Int, String) IO a
 
@@ -423,7 +431,7 @@ instance (Typeable a, ToJSON a) => HasServer (Patch a) where
 --
 -- Example:
 --
--- > type MyApi = "books" :> QueryParam "author" Text :> Get [Book]
+-- > type MyApi = "books" :> QueryParam "author" Text :> Get '[JSON] [Book]
 -- >
 -- > server :: Server MyApi
 -- > server = getBooksBy
@@ -462,7 +470,7 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
 --
 -- Example:
 --
--- > type MyApi = "books" :> QueryParams "authors" Text :> Get [Book]
+-- > type MyApi = "books" :> QueryParams "authors" Text :> Get '[JSON] [Book]
 -- >
 -- > server :: Server MyApi
 -- > server = getBooksBy
@@ -495,7 +503,7 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
 --
 -- Example:
 --
--- > type MyApi = "books" :> QueryFlag "published" :> Get [Book]
+-- > type MyApi = "books" :> QueryFlag "published" :> Get '[JSON] [Book]
 -- >
 -- > server :: Server MyApi
 -- > server = getBooks
@@ -654,27 +662,38 @@ instance HasServer Raw where
 -- | If you use 'ReqBody' in one of the endpoints for your API,
 -- this automatically requires your server-side handler to be a function
 -- 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
 -- it into a value of the type you specify.
 --
+--
 -- All it asks is for a 'FromJSON' instance.
 --
 -- Example:
 --
--- > type MyApi = "books" :> ReqBody Book :> Post Book
+-- > type MyApi = "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book
 -- >
 -- > server :: Server MyApi
 -- > server = postBook
 -- >   where postBook :: Book -> EitherT (Int, String) IO Book
 -- >         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
 
   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
       Left e -> respond . failWith $ InvalidBody e
       Right v  -> route (Proxy :: Proxy sublayout) (subserver v) request respond

test/Servant/ServerSpec.hs

@@ -16,11 +16,13 @@ import Data.Proxy (Proxy(Proxy))
 import Data.String (fromString)
 import Data.String.Conversions (cs)
 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.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.Capture (Capture)
@@ -171,6 +173,7 @@ queryParamSpec = do
               name = "john"
              }
 
+
       it "allows to retrieve value-less GET parameters" $
         (flip runSession) (serve queryParamApi qpServer) $ do
           let params3 = "?capitalize"
@@ -290,8 +293,8 @@ matrixParamSpec = do
              }
 
 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
 
@@ -299,23 +302,26 @@ postSpec :: Spec
 postSpec = do
   describe "Servant.API.Post and .ReqBody" $ 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
-        post "/" (encode alice) `shouldRespondWith` "42"{
+        post' "/" (encode alice) `shouldRespondWith` "42"{
           matchStatus = 201
          }
 
       it "allows alternative routes if all have request bodies" $ do
-        post "/bla" (encode alice) `shouldRespondWith` "42"{
+        post' "/bla" (encode alice) `shouldRespondWith` "42"{
           matchStatus = 201
          }
 
       it "handles trailing '/' gracefully" $ do
-        post "/bla/" (encode alice) `shouldRespondWith` "42"{
+        post' "/bla/" (encode alice) `shouldRespondWith` "42"{
           matchStatus = 201
          }
 
       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