Move more Content-type logic back to servant.

src/Servant/Server.hs

@@ -10,16 +10,13 @@ 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(..))
+import Servant.Server.ContentTypes ()
 
 
 -- * Implementing Servers

src/Servant/Server/ContentTypes.hs

@@ -11,7 +11,8 @@
 module Servant.Server.ContentTypes where
 
 import Control.Monad (join)
-import Data.Aeson (ToJSON(..), FromJSON(..), encode, decode)
+import Control.Arrow (left)
+import Data.Aeson (ToJSON(..), FromJSON(..), encode, eitherDecode)
 import Data.ByteString.Lazy (ByteString)
 import qualified Data.ByteString as BS
 import Data.Proxy (Proxy(..))
@@ -23,86 +24,7 @@ import qualified Network.HTTP.Media as M
 
 
 import Servant.API ( XML, HTML, JSON, JavaScript, CSS, PlainText
-                   , OctetStream)
+                   , OctetStream, MimeRender(..), MimeUnrender(..) )
-
--- * 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"
---
-class Accept ctype where
-    contentType   :: Proxy ctype -> M.MediaType
-
--- | @text/html;charset=utf-8@
-instance Accept HTML where
-    contentType _ = "text" M.// "html" M./: ("charset", "utf-8")
-
--- | @application/json;charset=utf-8@
-instance Accept JSON where
-    contentType _ = "application" M.// "json" M./: ("charset", "utf-8")
-
--- | @application/xml;charset=utf-8@
-instance Accept XML where
-    contentType _ = "application" M.// "xml" M./: ("charset", "utf-8")
-
--- | @application/javascript;charset=utf-8@
-instance Accept JavaScript where
-    contentType _ = "application" M.// "javascript" M./: ("charset", "utf-8")
-
--- | @text/css;charset=utf-8@
-instance Accept CSS where
-    contentType _ = "text" M.// "css" M./: ("charset", "utf-8")
-
--- | @text/plain;charset=utf-8@
-instance Accept PlainText where
-    contentType _ = "text" M.// "plain" M./: ("charset", "utf-8")
-
--- | @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
-
-class AllCTRender list a where
-    -- If the Accept header can be matched, returns (Just) a tuple of the
-    -- Content-Type and response (serialization of @a@ into the appropriate
-    -- mimetype).
-    handleAcceptH :: Proxy list -> AcceptHeader -> a -> Maybe (ByteString, ByteString)
-
-instance ( AllMimeRender ctyps a, IsNonEmpty ctyps
-         ) => AllCTRender ctyps a where
-    handleAcceptH _ (AcceptHeader accept) val = M.mapAcceptMedia lkup accept
-      where pctyps = Proxy :: Proxy ctyps
-            amrs = amr pctyps val
-            lkup = zip (map fst amrs) $ map (\(a,b) -> (cs $ show a, b)) amrs
-
-
 
 
 --------------------------------------------------------------------------
@@ -116,86 +38,14 @@ instance ToJSON a => MimeRender JSON a where
 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, IsNonEmpty ctyps
-         ) => 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                              -- 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        -- at least two elems to avoid overlap
-         , AllMimeRender ctyps a
-         ) => AllMimeRender (ctyp ': ctyp' ': ctyps) a where
-    amr _ a = (contentType pctyp, toByteString pctyp a)
-             :(contentType pctyp', toByteString pctyp' a)
-             :(amr pctyps a)
-        where pctyp = Proxy :: Proxy ctyp
-              pctyps = Proxy :: Proxy ctyps
-              pctyp' = Proxy :: Proxy ctyp'
-
-
-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 IsNonEmpty (ls::[*]) :: Constraint where
-    IsNonEmpty '[] = 'False ~ 'True
-    IsNonEmpty x   = ()
-
 --------------------------------------------------------------------------
 -- * MimeUnrender Instances
 
 -- | @decode@
 instance FromJSON a => MimeUnrender JSON a where
-    fromByteString _ = decode
+    fromByteString _ = eitherDecode
 
 -- | @Text.decodeUtf8'@
 instance MimeUnrender PlainText Text.Text where
-    fromByteString _ = either (const Nothing) Just . Text.decodeUtf8'
+    fromByteString _ = left show . Text.decodeUtf8'
 

src/Servant/Server/Internal.hs

@@ -9,7 +9,7 @@ module Servant.Server.Internal where
 
 import Control.Applicative ((<$>))
 import Control.Monad.Trans.Either (EitherT, runEitherT)
-import Data.Aeson (ToJSON, FromJSON, encode, eitherDecode')
+import Data.Aeson (ToJSON)
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Lazy as BL
 import Data.IORef (newIORef, readIORef, writeIORef)
@@ -29,10 +29,10 @@ import Network.Wai ( Response, Request, ResponseReceived, Application
                    , lazyRequestBody, requestHeaders, requestMethod,
                     rawQueryString, responseLBS)
 import Servant.API ( QueryParams, QueryParam, QueryFlag, ReqBody, Header
-                   , MatrixParams, MatrixParam, MatrixFlag,
+                   , MatrixParams, MatrixParam, MatrixFlag
                    , Capture, Get, Delete, Put, Post, Patch, Raw, (:>), (:<|>)(..))
-import Servant.Server.ContentTypes ( AllCTRender(..), AcceptHeader(..)
+import Servant.API.ContentTypes ( AllCTRender(..), AcceptHeader(..)
-                                   , AllCTUnrender(..) )
+                                   , AllCTUnrender(..),)
 import Servant.Common.Text (FromText, fromText)
 
 
@@ -72,39 +72,33 @@ toApplication ra request respond = do
     respond $ responseLBS methodNotAllowed405 [] "method not allowed"
   routingRespond (Left (InvalidBody err)) =
     respond $ responseLBS badRequest400 [] $ fromString $ "Invalid JSON in request body: " ++ err
+  routingRespond (Left UnsupportedMediaType) =
+    respond $ responseLBS unsupportedMediaType415 [] "unsupported media type"
   routingRespond (Left (HttpError status body)) =
     respond $ responseLBS status [] $ fromMaybe (BL.fromStrict $ statusMessage status) body
   routingRespond (Right response) =
     respond response
 
+-- Note that the ordering of the constructors has great significance! It
+-- determines the Ord instance and, consequently, the monoid instance.
 -- * Route mismatch
 data RouteMismatch =
     NotFound           -- ^ the usual "not found" error
   | WrongMethod        -- ^ a more informative "you just got the HTTP method wrong" error
+  | UnsupportedMediaType -- ^ request body has unsupported media type
   | InvalidBody String -- ^ an even more informative "your json request body wasn't valid" error
   | HttpError Status (Maybe BL.ByteString)  -- ^ an even even more informative arbitrary HTTP response code error.
-  deriving (Eq, Show)
+  deriving (Eq, Ord, Show)
 
--- |
--- @
--- > mempty = NotFound
--- >
--- > _             `mappend` HttpError s b = HttpError s b
--- > HttpError s b `mappend`             _ = HttpError s b
--- > NotFound      `mappend`             x = x
--- > WrongMethod   `mappend` InvalidBody s = InvalidBody s
--- > WrongMethod   `mappend`             _ = WrongMethod
--- > InvalidBody s `mappend`             _ = InvalidBody s
--- @
 instance Monoid RouteMismatch where
   mempty = NotFound
+  -- The following isn't great, since it picks @InvalidBody@ based on
+  -- alphabetical ordering, but any choice would be arbitrary.
+  --
+  -- "As one judge said to the other, 'Be just and if you can't be just, be
+  -- arbitrary'" -- William Burroughs
+  mappend = max
 
-  _             `mappend` HttpError s b = HttpError s b
-  HttpError s b `mappend`             _ = HttpError s b
-  NotFound      `mappend`             x = x
-  WrongMethod   `mappend` InvalidBody s = InvalidBody s
-  WrongMethod   `mappend`             _ = WrongMethod
-  InvalidBody s `mappend`             _ = InvalidBody s
 
 -- | A wrapper around @'Either' 'RouteMismatch' a@.
 newtype RouteResult a =
@@ -401,15 +395,22 @@ instance ( AllCTRender ctypes a
 -- If successfully returning a value, we just require that its type has
 -- a 'ToJSON' instance and servant takes care of encoding it for you,
 -- yielding status code 201 along the way.
-instance (Typeable a, ToJSON a) => HasServer (Patch a) where
+instance ( AllCTRender ctypes a
-  type Server (Patch a) = EitherT (Int, String) IO a
+         , Typeable a
+         , ToJSON a) => HasServer (Patch ctypes a) where
+  type Server (Patch ctypes a) = EitherT (Int, String) IO a
 
   route Proxy action request respond
     | pathIsEmpty request && requestMethod request == methodPost = do
         e <- runEitherT action
         respond . succeedWith $ case e of
           Right out -> case cast out of
-              Nothing -> responseLBS status200 [("Content-Type", "application/json")] (encode out)
+              Nothing -> do
+                  let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
+                  case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) out of
+                    Nothing -> responseLBS (mkStatus 406 "") [] ""
+                    Just (contentT, body) -> responseLBS status200 [ ("Content-Type"
+                                                                   , cs contentT)] body
               Just () -> responseLBS status204 [] ""
           Left (status, message) ->
             responseLBS (mkStatus status (cs message)) [] (cs message)
@@ -695,8 +696,9 @@ instance ( AllCTUnrender list a, HasServer sublayout
     mrqbody <- handleCTypeH (Proxy :: Proxy list) (cs contentTypeH)
            <$> lazyRequestBody request
     case mrqbody of
-      Left e -> respond . failWith $ InvalidBody e
+      Nothing -> respond . failWith $ UnsupportedMediaType
-      Right v  -> route (Proxy :: Proxy sublayout) (subserver v) request respond
+      Just (Left e) -> respond . failWith $ InvalidBody e
+      Just (Right v) -> route (Proxy :: Proxy sublayout) (subserver v) request respond
 
 -- | Make sure the incoming request starts with @"/path"@, strip it and
 -- pass the rest of the request path to @sublayout@.

test/Servant/Server/ContentTypesSpec.hs

@@ -24,8 +24,9 @@ import Test.Hspec
 import Test.QuickCheck
 
 import Servant.API
+import Servant.API.ContentTypes
 import Servant.Server
-import Servant.Server.ContentTypes
+import Servant.Server.ContentTypes ()
 
 
 spec :: Spec

test/Servant/ServerSpec.hs

@@ -209,10 +209,10 @@ queryParamSpec = do
               name = "Alice"
              }
 
-type MatrixParamApi = "a" :> MatrixParam "name" String :> Get Person
+type MatrixParamApi = "a" :> MatrixParam "name" String :> Get '[JSON] Person
-                :<|> "b" :> MatrixParams "names" String :> "bsub" :> MatrixParams "names" String :> Get Person
+                :<|> "b" :> MatrixParams "names" String :> "bsub" :> MatrixParams "names" String :> Get '[JSON] Person
-                :<|> "c" :> MatrixFlag "capitalize" :> Get Person
+                :<|> "c" :> MatrixFlag "capitalize" :> Get '[JSON] Person
-                :<|> "d" :> Capture "foo" Integer :> MatrixParam "name" String :> MatrixFlag "capitalize" :> "dsub" :> Get Person
+                :<|> "d" :> Capture "foo" Integer :> MatrixParam "name" String :> MatrixFlag "capitalize" :> "dsub" :> Get '[JSON] Person
 
 matrixParamApi :: Proxy MatrixParamApi
 matrixParamApi = Proxy
@@ -323,6 +323,11 @@ postSpec = do
       it "correctly rejects invalid request bodies with status 400" $ do
         post' "/" "some invalid body" `shouldRespondWith` 400
 
+      it "responds with 415 if the requested media type is unsupported" $ do
+        let post'' x = Test.Hspec.Wai.request methodPost x [(hContentType
+                                                            , "application/nonsense")]
+        post'' "/" "anything at all" `shouldRespondWith` 415
+
 
 type RawApi = "foo" :> Raw
 rawApi :: Proxy RawApi