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

@@ -35,24 +35,24 @@ library
     Servant.Server.Internal
     Servant.Utils.StaticFiles
   build-depends:
-      base >=4.7 && <5
-    , aeson
-    , attoparsec
-    , bytestring
-    , either >= 4.3
-    , http-types
-    , network-uri >= 2.6
-    , http-media == 0.4.*
-    , safe
-    , servant >= 0.2.2
-    , split
-    , string-conversions
-    , system-filepath
-    , text
-    , transformers
-    , wai
-    , wai-app-static >= 3.0.0.6
-    , warp
+        base               >= 4.7  && < 5
+      , aeson              >= 0.7  && < 0.9
+      , attoparsec         >= 0.12 && < 0.13
+      , bytestring         >= 0.10 && < 0.11
+      , either             >= 4.3  && < 4.4
+      , http-media         >= 0.4  && < 0.5
+      , http-types         >= 0.8  && < 0.9
+      , network-uri        >= 2.6  && < 2.7
+      , safe               >= 0.3  && < 0.4
+      , servant            >= 0.2  && < 0.4
+      , split              >= 0.2  && < 0.3
+      , string-conversions >= 0.3  && < 0.4
+      , system-filepath    >= 0.4  && < 0.5
+      , text               >= 1.2  && < 1.3
+      , transformers       >= 0.3  && < 0.5
+      , wai                >= 3.0  && < 3.1
+      , wai-app-static     >= 3.0  && < 3.1
+      , 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
--- >         :<|> "books" :> ReqBody Book :> Post Book -- POST /books
+-- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books
+-- >         :<|> "books" :> ReqBody Book :> Post '[JSON] Book -- POST /books
 -- >
 -- > server :: Server MyApi
 -- > server = listAllBooks :<|> postBook

src/Servant/Server/ContentTypes.hs

@@ -9,51 +9,81 @@
 {-# 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
 -- @Content-Type@ header of the response
 --
 -- Example:
 --
---   instance Accept HTML where
---      contentType _ = "text" // "html"
+-- > instance Accept HTML where
+-- >    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
-    toByteString _ = encode
+-- | @decode@
+instance FromJSON a => MimeUnrender JSON a where
+    fromByteString _ = decode
 
-instance Show a => MimeRender PlainText a where
-    toByteString _ = encode . show
+-- | @Text.decodeUtf8'@
+instance MimeUnrender PlainText Text.Text where
+    fromByteString _ = either (const Nothing) Just . Text.decodeUtf8'
 
-instance MimeRender PlainText String where
-    toByteString _ = encode