Merge pull request #13 from haskell-servant/jkarni/content-types

Jkarni/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
 -----

default.nix

@@ -0,0 +1,15 @@
+{ pkgs ? import <nixpkgs> { config.allowUnfree = true; }
+, src ?  builtins.filterSource (path: type:
+    type != "unknown" &&
+    baseNameOf path != ".git" &&
+    baseNameOf path != "result" &&
+    baseNameOf path != "dist") ./.
+, servant ? import ../servant {}
+}:
+pkgs.haskellPackages.buildLocalCabalWithArgs {
+  name = "servant-server";
+  inherit src;
+  args = {
+      inherit servant;
+  };
+}

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

@@ -34,23 +34,23 @@ library
     Servant.Server.Internal
     Servant.Utils.StaticFiles
   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-types         >= 0.8  && < 0.9
-    , network-uri >= 2.6
+      , 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.hs

@@ -8,7 +8,6 @@ module Servant (
   -- | Using your types in request paths and query string parameters
   module Servant.Common.Text,
   -- | Utilities on top of the servant core
-  module Servant.QQ,
   module Servant.Utils.Links,
   module Servant.Utils.StaticFiles,
   -- | Useful re-exports
@@ -19,6 +18,5 @@ import Data.Proxy
 import Servant.API
 import Servant.Common.Text
 import Servant.Server
-import Servant.QQ
 import Servant.Utils.Links
 import Servant.Utils.StaticFiles

src/Servant/Server.hs

@@ -9,6 +9,7 @@ module Servant.Server
 
   , -- * Handlers for all standard combinators
     HasServer(..)
+
   ) where
 
 import Data.Proxy (Proxy)
@@ -23,8 +24,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/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)
@@ -24,12 +24,18 @@ import qualified Data.Text as T
 import Data.Typeable
 import GHC.TypeLits (KnownSymbol, symbolVal)
 import Network.HTTP.Types hiding (Header)
-import Network.Wai (Response, Request, ResponseReceived, Application, pathInfo, requestBody,
+import Network.Wai ( Response, Request, ResponseReceived, Application
-                    strictRequestBody, lazyRequestBody, requestHeaders, requestMethod,
+                   , pathInfo, requestBody, strictRequestBody
+                   , lazyRequestBody, requestHeaders, requestMethod,
                     rawQueryString, responseLBS)
-import Servant.API (QueryParams, QueryParam, QueryFlag, MatrixParams, MatrixParam, MatrixFlag, ReqBody, Header, Capture, Get, Delete, Put, Post, Patch, Raw, (:>), (:<|>)(..))
+import Servant.API ( QueryParams, QueryParam, QueryFlag, ReqBody, Header
+                   , MatrixParams, MatrixParam, MatrixFlag
+                   , Capture, Get, Delete, Put, Post, Patch, Raw, (:>), (:<|>)(..))
+import Servant.API.ContentTypes ( AllCTRender(..), AcceptHeader(..)
+                                   , AllCTUnrender(..),)
 import Servant.Common.Text (FromText, fromText)
 
+
 data ReqBodyState = Uncalled
                   | Called !B.ByteString
                   | Done !B.ByteString
@@ -66,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 =
@@ -171,8 +171,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
@@ -203,7 +203,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
@@ -225,7 +225,7 @@ instance (KnownSymbol capture, FromText a, HasServer sublayout)
     _ -> respond $ failWith NotFound
 
     where captureProxy = Proxy :: Proxy (Capture capture a)
-           
+
 
 -- | If you have a 'Delete' endpoint in your API,
 -- the handler for this endpoint is meant to delete
@@ -261,17 +261,24 @@ 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 ToJSON result => HasServer (Get result) where
+-- was @*/*@, we return encode using the first @Content-Type@ type on the
-  type Server (Get result) = EitherT (Int, String) IO result
+-- 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
     | pathIsEmpty request && requestMethod request == methodGet = do
         e <- runEitherT action
         respond . succeedWith $ case e of
-          Right output ->
+          Right output -> do
-            responseLBS ok200 [("Content-Type", "application/json")] (encode output)
+            let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
+            case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
+              Nothing -> responseLBS (mkStatus 406 "Not Acceptable") [] ""
+              Just (contentT, body) -> responseLBS ok200 [ ("Content-Type"
+                                                         , cs contentT)] body
           Left (status, message) ->
             responseLBS (mkStatus status (cs message)) [] (cs message)
     | pathIsEmpty request && requestMethod request /= methodGet =
@@ -292,7 +299,7 @@ instance ToJSON result => HasServer (Get result) where
 -- >   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
@@ -318,18 +325,25 @@ 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 ToJSON a => HasServer (Post a) where
+-- was @*/*@, we return encode using the first @Content-Type@ type on the
-  type Server (Post a) = EitherT (Int, String) IO a
+-- list.
+instance ( AllCTRender ctypes a
+         ) => HasServer (Post ctypes a) where
+  type Server (Post 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 ->
+          Right output -> do
-            responseLBS status201 [("Content-Type", "application/json")] (encode out)
+            let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
+            case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
+              Nothing -> responseLBS (mkStatus 406 "") [] ""
+              Just (contentT, body) -> responseLBS status201 [ ("Content-Type"
+                                                             , cs contentT)] body
           Left (status, message) ->
             responseLBS (mkStatus status (cs message)) [] (cs message)
     | pathIsEmpty request && requestMethod request /= methodPost =
@@ -344,18 +358,25 @@ instance ToJSON a => HasServer (Post a) 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 201). If there was no @Accept@ header or it
-instance ToJSON a => HasServer (Put a) where
+-- was @*/*@, we return encode using the first @Content-Type@ type on the
-  type Server (Put a) = EitherT (Int, String) IO a
+-- list.
+instance ( AllCTRender ctypes a
+         ) => HasServer (Put ctypes a) where
+  type Server (Put ctypes a) = EitherT (Int, String) IO a
 
   route Proxy action request respond
     | pathIsEmpty request && requestMethod request == methodPut = do
         e <- runEitherT action
         respond . succeedWith $ case e of
-          Right out ->
+          Right output -> do
-            responseLBS ok200 [("Content-Type", "application/json")] (encode out)
+            let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
+            case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
+              Nothing -> responseLBS (mkStatus 406 "") [] ""
+              Just (contentT, body) -> responseLBS status200 [ ("Content-Type"
+                                                             , cs contentT)] body
           Left (status, message) ->
             responseLBS (mkStatus status (cs message)) [] (cs message)
     | pathIsEmpty request && requestMethod request /= methodPut =
@@ -374,15 +395,22 @@ instance ToJSON a => HasServer (Put a) where
 -- 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)
@@ -404,7 +432,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
@@ -443,7 +471,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
@@ -476,7 +504,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
@@ -635,30 +663,42 @@ 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
+      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/ServerSpec.hs

@@ -8,6 +8,7 @@
 module Servant.ServerSpec where
 
 
+import Control.Monad (when)
 import Control.Monad.Trans.Either (EitherT, left)
 import Data.Aeson (ToJSON, FromJSON, encode, decode')
 import Data.Char (toUpper)
@@ -16,21 +17,18 @@ 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
-import Network.Wai (Application, Request, responseLBS, pathInfo, queryString, rawQueryString)
+                          , methodDelete, hContentType)
-import Network.Wai.Test (runSession, request, defaultRequest, simpleBody)
+import Network.Wai ( Application, Request, responseLBS, pathInfo
+                   , 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.Capture (Capture)
+import Servant.API (JSON, Capture, Get, ReqBody, Post, QueryParam
-import Servant.API.Get (Get)
+                   , QueryParams, QueryFlag, MatrixParam, MatrixParams
-import Servant.API.ReqBody (ReqBody)
+                   , MatrixFlag, Raw, (:>), (:<|>)(..), Header, Delete )
-import Servant.API.Post (Post)
-import Servant.API.QueryParam (QueryParam, QueryParams, QueryFlag)
-import Servant.API.MatrixParam (MatrixParam, MatrixParams, MatrixFlag)
-import Servant.API.Raw (Raw)
-import Servant.API.Sub ((:>))
-import Servant.API.Alternative ((:<|>)((:<|>)))
 import Servant.Server (Server, serve)
 import Servant.Server.Internal (RouteMismatch(..))
 
@@ -74,12 +72,13 @@ spec = do
   queryParamSpec
   matrixParamSpec
   postSpec
+  headerSpec
   rawSpec
   unionSpec
   errorsSpec
 
 
-type CaptureApi = Capture "legs" Integer :> Get Animal
+type CaptureApi = Capture "legs" Integer :> Get '[JSON] Animal
 captureApi :: Proxy CaptureApi
 captureApi = Proxy
 captureServer :: Integer -> EitherT (Int, String) IO Animal
@@ -105,7 +104,7 @@ captureSpec = do
         get "/captured/foo" `shouldRespondWith` (fromString (show ["foo" :: String]))
 
 
-type GetApi = Get Person
+type GetApi = Get '[JSON] Person
 getApi :: Proxy GetApi
 getApi = Proxy
 
@@ -123,9 +122,9 @@ getSpec = do
         post "/" "" `shouldRespondWith` 405
 
 
-type QueryParamApi = QueryParam "name" String :> Get Person
+type QueryParamApi = QueryParam "name" String :> Get '[JSON] Person
-                :<|> "a" :> QueryParams "names" String :> Get Person
+                :<|> "a" :> QueryParams "names" String :> Get '[JSON] Person
-                :<|> "b" :> QueryFlag "capitalize" :> Get Person
+                :<|> "b" :> QueryFlag "capitalize" :> Get '[JSON] Person
 
 queryParamApi :: Proxy QueryParamApi
 queryParamApi = Proxy
@@ -170,6 +169,7 @@ queryParamSpec = do
               name = "john"
              }
 
+
       it "allows to retrieve value-less GET parameters" $
         (flip runSession) (serve queryParamApi qpServer) $ do
           let params3 = "?capitalize"
@@ -205,10 +205,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
@@ -289,8 +289,8 @@ matrixParamSpec = do
              }
 
 type PostApi =
-       ReqBody Person :> Post Integer
+       ReqBody '[JSON] Person :> Post '[JSON] Integer
-  :<|> "bla" :> ReqBody Person :> Post Integer
+  :<|> "bla" :> ReqBody '[JSON] Person :> Post '[JSON] Integer
 postApi :: Proxy PostApi
 postApi = Proxy
 
@@ -298,23 +298,58 @@ 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;charset=utf-8")]
+
       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
+
+      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 HeaderApi a = Header "MyHeader" a :> Delete
+headerApi :: Proxy (HeaderApi a)
+headerApi = Proxy
+
+headerSpec :: Spec
+headerSpec = describe "Servant.API.Header" $ do
+
+    let expectsInt :: Maybe Int -> EitherT (Int,String) IO ()
+        expectsInt (Just x) = when (x /= 5) $ error "Expected 5"
+        expectsInt Nothing  = error "Expected an int"
+
+    let expectsString :: Maybe String -> EitherT (Int,String) IO ()
+        expectsString (Just x) = when (x /= "more from you") $ error "Expected more from you"
+        expectsString Nothing  = error "Expected a string"
+
+    with (return (serve headerApi expectsInt)) $ do
+        let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader" ,"5")]
+
+        it "passes the header to the handler (Int)" $
+            delete' "/" "" `shouldRespondWith` 204
+
+    with (return (serve headerApi expectsString)) $ do
+        let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader" ,"more from you")]
+
+        it "passes the header to the handler (String)" $
+            delete' "/" "" `shouldRespondWith` 204
 
 
 type RawApi = "foo" :> Raw
@@ -344,8 +379,8 @@ rawSpec = do
 
 
 type AlternativeApi =
-       "foo" :> Get Person
+       "foo" :> Get '[JSON] Person
-  :<|> "bar" :> Get Animal
+  :<|> "bar" :> Get '[JSON] Animal
 unionApi :: Proxy AlternativeApi
 unionApi = Proxy
 
@@ -375,7 +410,7 @@ errorsSpec = do
   let ib = InvalidBody "The body is invalid"
   let wm = WrongMethod
   let nf = NotFound
-  
+
   describe "Servant.Server.Internal.RouteMismatch" $ do
     it "HttpError > *" $ do
       ib <> he `shouldBe` he

test/Servant/Utils/StaticFilesSpec.hs

@@ -13,6 +13,7 @@ import System.IO.Temp (withSystemTempDirectory)
 import Test.Hspec (Spec, describe, it, around_)
 import Test.Hspec.Wai (with, get, shouldRespondWith)
 
+import Servant.API (JSON)
 import Servant.API.Alternative ((:<|>)((:<|>)))
 import Servant.API.Capture (Capture)
 import Servant.API.Get (Get)
@@ -23,7 +24,7 @@ import Servant.ServerSpec (Person(Person))
 import Servant.Utils.StaticFiles (serveDirectory)
 
 type Api =
-       "dummy_api" :> Capture "person_name" String :> Get Person
+       "dummy_api" :> Capture "person_name" String :> Get '[JSON] Person
   :<|> "static" :> Raw