Merge branch 'master' into canonical-types

Conflicts:
	CHANGELOG.md
	src/Servant/Server/Internal.hs

CHANGELOG.md

@@ -6,6 +6,8 @@
 * Export `toApplication` from `Servant.Server` (https://github.com/haskell-servant/servant-server/pull/29)
 * Support other Monads than just `EitherT (Int, String) IO` (https://github.com/haskell-servant/servant-server/pull/21)
 * Canonicalize API types before generating the handler types with `Server`
+* Make methods return status code 204 if they return () (https://github.com/haskell-servant/servant-server/issues/28)
+* Add server support for response headers
 
 0.2.4
 -----

servant-server.cabal

@@ -80,6 +80,7 @@ test-suite spec
       base == 4.*
     , aeson
     , bytestring
+    , bytestring-conversion
     , directory
     , either
     , exceptions

src/Servant/Server/Internal.hs

@@ -1,46 +1,53 @@
 {-# LANGUAGE DataKinds            #-}
+{-# LANGUAGE FlexibleContexts     #-}
+{-# LANGUAGE FlexibleInstances    #-}
+{-# LANGUAGE OverlappingInstances #-}
+{-# LANGUAGE OverloadedStrings    #-}
 {-# LANGUAGE PolyKinds            #-}
+{-# LANGUAGE ScopedTypeVariables  #-}
 {-# LANGUAGE TypeFamilies         #-}
 {-# LANGUAGE TypeOperators        #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
 module Servant.Server.Internal where
 
 import           Control.Applicative         ((<$>))
 import           Control.Monad.Trans.Either  (EitherT, runEitherT)
-import Data.Aeson (ToJSON)
 import qualified Data.ByteString             as B
 import qualified Data.ByteString.Lazy        as BL
 import           Data.IORef                  (newIORef, readIORef, writeIORef)
 import           Data.List                   (unfoldr)
 import           Data.Maybe                  (catMaybes, fromMaybe)
-import Data.Monoid (Monoid, mempty, mappend)
+import           Data.Monoid                 (Monoid, mappend, mempty)
 import           Data.String                 (fromString)
 import           Data.String.Conversions     (cs, (<>))
-import Data.Text.Encoding (decodeUtf8, encodeUtf8)
 import           Data.Text                   (Text)
 import qualified Data.Text                   as T
+import           Data.Text.Encoding          (decodeUtf8, encodeUtf8)
 import           Data.Typeable
 import           GHC.TypeLits                (KnownSymbol, symbolVal)
-import Network.HTTP.Types hiding (Header)
+import           Network.HTTP.Types          hiding (Header, ResponseHeaders)
-import Network.Wai ( Response, Request, ResponseReceived, Application
+import           Network.Wai                 (Application, Request, Response,
-                   , pathInfo, requestBody, strictRequestBody
+                                              ResponseReceived, lazyRequestBody,
-                   , lazyRequestBody, requestHeaders, requestMethod,
+                                              pathInfo, rawQueryString,
-                    rawQueryString, responseLBS)
+                                              requestBody, requestHeaders,
-import Servant.API ( QueryParams, QueryParam, QueryFlag, ReqBody, Header
+                                              requestMethod, responseLBS,
-                   , MatrixParams, MatrixParam, MatrixFlag
+                                              strictRequestBody)
-                   , Capture, Get, Delete, Put, Post, Patch, Raw, (:>), (:<|>)(..)
+import           Servant.API                 ((:<|>) (..), (:>), Capture,
-                   , Canonicalize)
+                                              Canonicalize, Delete, Get, Header,
-import Servant.API.ContentTypes ( AllCTRender(..), AcceptHeader(..)
+                                              MatrixFlag, MatrixParam, MatrixParams,
-                                   , AllCTUnrender(..),)
+                                              Patch, Post, Put, QueryFlag,
+                                              QueryParam, QueryParams, Raw,
+                                              ReqBody)
+import           Servant.API.ContentTypes    (AcceptHeader (..),
+                                              AllCTRender (..),
+                                              AllCTUnrender (..))
+import           Servant.API.ResponseHeaders (Headers, getResponse, getHeaders)
 import           Servant.Common.Text         (FromText, fromText)
 
-
 data ReqBodyState = Uncalled
                   | Called !B.ByteString
                   | Done !B.ByteString
 
+
 toApplication :: RoutingApplication -> Application
 toApplication ra request respond = do
   reqBodyRef <- newIORef Uncalled
@@ -281,19 +288,53 @@ instance ( AllCTRender ctypes a
   route Proxy action request respond
     | pathIsEmpty request && requestMethod request == methodGet = do
         e <- runEitherT action
-        respond . succeedWith $ case e of
+        respond $ case e of
           Right output -> do
             let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
             case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
-              Nothing -> responseLBS (mkStatus 406 "Not Acceptable") [] ""
+              Nothing -> failWith UnsupportedMediaType
-              Just (contentT, body) -> responseLBS ok200 [ ("Content-Type"
+              Just (contentT, body) -> succeedWith $
-                                                         , cs contentT)] body
+                responseLBS ok200 [ ("Content-Type" , cs contentT)] body
+          Left (status, message) -> succeedWith $
+            responseLBS (mkStatus status (cs message)) [] (cs message)
+    | pathIsEmpty request && requestMethod request /= methodGet =
+        respond $ failWith WrongMethod
+    | otherwise = respond $ failWith NotFound
+
+-- '()' ==> 204 No Content
+instance HasServer (Get ctypes ()) where
+  type ServerT (Get ctypes ()) m = m ()
+  route Proxy action request respond
+    | pathIsEmpty request && requestMethod request == methodGet = do
+        e <- runEitherT action
+        respond . succeedWith $ case e of
+          Right () -> responseLBS noContent204 [] ""
           Left (status, message) ->
             responseLBS (mkStatus status (cs message)) [] (cs message)
     | pathIsEmpty request && requestMethod request /= methodGet =
         respond $ failWith WrongMethod
     | otherwise = respond $ failWith NotFound
 
+-- Add response headers
+instance ( AllCTRender ctypes v ) => HasServer (Get ctypes (Headers h v)) where
+  type ServerT (Get ctypes (Headers h v)) m = m (Headers h v)
+  route Proxy action request respond
+    | pathIsEmpty request && requestMethod request == methodGet = do
+      e <- runEitherT action
+      respond $ case e of
+        Right output -> do
+          let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
+              headers = getHeaders output
+          case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of
+            Nothing -> failWith UnsupportedMediaType
+            Just (contentT, body) -> succeedWith $
+              responseLBS ok200 ( ("Content-Type" , cs contentT) : headers) body
+        Left (status, message) -> succeedWith $
+          responseLBS (mkStatus status (cs message)) [] (cs message)
+    | pathIsEmpty request && requestMethod request /= methodGet =
+        respond $ failWith WrongMethod
+    | otherwise = respond $ failWith NotFound
+
 -- | If you use 'Header' 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 'Header'.
@@ -347,19 +388,52 @@ instance ( AllCTRender ctypes a
   route Proxy action request respond
     | pathIsEmpty request && requestMethod request == methodPost = do
         e <- runEitherT action
-        respond . succeedWith $ case e of
+        respond $ case e of
           Right output -> do
             let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
             case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
-              Nothing -> responseLBS (mkStatus 406 "") [] ""
+              Nothing -> failWith UnsupportedMediaType
-              Just (contentT, body) -> responseLBS status201 [ ("Content-Type"
+              Just (contentT, body) -> succeedWith $
-                                                             , cs contentT)] body
+                responseLBS status201 [ ("Content-Type" , cs contentT)] body
+          Left (status, message) -> succeedWith $
+            responseLBS (mkStatus status (cs message)) [] (cs message)
+    | pathIsEmpty request && requestMethod request /= methodPost =
+        respond $ failWith WrongMethod
+    | otherwise = respond $ failWith NotFound
+
+instance HasServer (Post ctypes ()) where
+  type ServerT (Post ctypes ()) m = m ()
+  route Proxy action request respond
+    | pathIsEmpty request && requestMethod request == methodPost = do
+        e <- runEitherT action
+        respond . succeedWith $ case e of
+          Right () -> responseLBS noContent204 [] ""
           Left (status, message) ->
             responseLBS (mkStatus status (cs message)) [] (cs message)
     | pathIsEmpty request && requestMethod request /= methodPost =
         respond $ failWith WrongMethod
     | otherwise = respond $ failWith NotFound
 
+-- Add response headers
+instance ( AllCTRender ctypes v ) => HasServer (Post ctypes (Headers h v)) where
+  type ServerT (Post ctypes (Headers h v)) m = m (Headers h v)
+  route Proxy action request respond
+    | pathIsEmpty request && requestMethod request == methodPost = do
+      e <- runEitherT action
+      respond $ case e of
+        Right output -> do
+          let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
+              headers = getHeaders output
+          case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of
+            Nothing -> failWith UnsupportedMediaType
+            Just (contentT, body) -> succeedWith $
+              responseLBS status201 ( ("Content-Type" , cs contentT) : headers) body
+        Left (status, message) -> succeedWith $
+          responseLBS (mkStatus status (cs message)) [] (cs message)
+    | pathIsEmpty request && requestMethod request /= methodPost =
+        respond $ failWith WrongMethod
+    | otherwise = respond $ failWith NotFound
+
 -- | When implementing the handler for a 'Put' endpoint,
 -- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'
 -- and 'Servant.API.Post.Post', the handler code runs in the
@@ -370,7 +444,7 @@ instance ( AllCTRender ctypes a
 --
 -- If successfully returning a value, we use the type-level list, combined
 -- with the request's @Accept@ header, to encode the value for you
--- (returning a status code of 201). If there was no @Accept@ header or it
+-- (returning a status code of 200). If there was no @Accept@ header or it
 -- was @*/*@, we return encode using the first @Content-Type@ type on the
 -- list.
 instance ( AllCTRender ctypes a
@@ -381,18 +455,50 @@ instance ( AllCTRender ctypes a
   route Proxy action request respond
     | pathIsEmpty request && requestMethod request == methodPut = do
         e <- runEitherT action
-        respond . succeedWith $ case e of
+        respond $ case e of
           Right output -> do
             let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
             case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
-              Nothing -> responseLBS (mkStatus 406 "") [] ""
+              Nothing -> failWith UnsupportedMediaType
-              Just (contentT, body) -> responseLBS status200 [ ("Content-Type"
+              Just (contentT, body) -> succeedWith $
-                                                             , cs contentT)] body
+                responseLBS status200 [ ("Content-Type" , cs contentT)] body
+          Left (status, message) -> succeedWith $
+            responseLBS (mkStatus status (cs message)) [] (cs message)
+    | pathIsEmpty request && requestMethod request /= methodPut =
+        respond $ failWith WrongMethod
+    | otherwise = respond $ failWith NotFound
+
+instance HasServer (Put ctypes ()) where
+  type ServerT (Put ctypes ()) m = m ()
+  route Proxy action request respond
+    | pathIsEmpty request && requestMethod request == methodPut = do
+        e <- runEitherT action
+        respond . succeedWith $ case e of
+          Right () -> responseLBS noContent204 [] ""
           Left (status, message) ->
             responseLBS (mkStatus status (cs message)) [] (cs message)
     | pathIsEmpty request && requestMethod request /= methodPut =
         respond $ failWith WrongMethod
+    | otherwise = respond $ failWith NotFound
 
+-- Add response headers
+instance ( AllCTRender ctypes v ) => HasServer (Put ctypes (Headers h v)) where
+  type ServerT (Put ctypes (Headers h v)) m = m (Headers h v)
+  route Proxy action request respond
+    | pathIsEmpty request && requestMethod request == methodPut = do
+      e <- runEitherT action
+      respond $ case e of
+        Right output -> do
+          let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
+              headers = getHeaders output
+          case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of
+            Nothing -> failWith UnsupportedMediaType
+            Just (contentT, body) -> succeedWith $
+              responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body
+        Left (status, message) -> succeedWith $
+          responseLBS (mkStatus status (cs message)) [] (cs message)
+    | pathIsEmpty request && requestMethod request /= methodPut =
+        respond $ failWith WrongMethod
     | otherwise = respond $ failWith NotFound
 
 -- | When implementing the handler for a 'Patch' endpoint,
@@ -405,28 +511,57 @@ 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.
+-- yielding status code 200 along the way.
 instance ( AllCTRender ctypes a
-         , Typeable a
+         ) => HasServer (Patch ctypes a) where
-         , ToJSON a) => HasServer (Patch ctypes a) where
-
   type ServerT' (Patch ctypes a) m = m a
 
   route Proxy action request respond
-    | pathIsEmpty request && requestMethod request == methodPost = do
+    | pathIsEmpty request && requestMethod request == methodPatch = do
+        e <- runEitherT action
+        respond $ case e of
+          Right output -> do
+            let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
+            case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
+              Nothing -> failWith UnsupportedMediaType
+              Just (contentT, body) -> succeedWith $
+                responseLBS status200 [ ("Content-Type" , cs contentT)] body
+          Left (status, message) -> succeedWith $
+            responseLBS (mkStatus status (cs message)) [] (cs message)
+    | pathIsEmpty request && requestMethod request /= methodPatch =
+        respond $ failWith WrongMethod
+    | otherwise = respond $ failWith NotFound
+
+instance HasServer (Patch ctypes ()) where
+  type ServerT (Patch ctypes ()) m = m ()
+  route Proxy action request respond
+    | pathIsEmpty request && requestMethod request == methodPatch = do
         e <- runEitherT action
         respond . succeedWith $ case e of
-          Right out -> case cast out of
+          Right () -> responseLBS noContent204 [] ""
-              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)
-    | pathIsEmpty request && requestMethod request /= methodPost =
+    | pathIsEmpty request && requestMethod request /= methodPatch =
+        respond $ failWith WrongMethod
+    | otherwise = respond $ failWith NotFound
+
+-- Add response headers
+instance ( AllCTRender ctypes v ) => HasServer (Patch ctypes (Headers h v)) where
+  type ServerT (Patch ctypes (Headers h v)) m = m (Headers h v)
+  route Proxy action request respond
+    | pathIsEmpty request && requestMethod request == methodPatch = do
+      e <- runEitherT action
+      respond $ case e of
+        Right outpatch -> do
+          let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
+              headers = getHeaders outpatch
+          case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse outpatch) of
+            Nothing -> failWith UnsupportedMediaType
+            Just (contentT, body) -> succeedWith $
+              responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body
+        Left (status, message) -> succeedWith $
+          responseLBS (mkStatus status (cs message)) [] (cs message)
+    | pathIsEmpty request && requestMethod request /= methodPatch =
         respond $ failWith WrongMethod
     | otherwise = respond $ failWith NotFound
 

test/Servant/ServerSpec.hs

@@ -1,36 +1,48 @@
 {-# LANGUAGE DataKinds           #-}
 {-# LANGUAGE DeriveGeneric       #-}
 {-# LANGUAGE OverloadedStrings   #-}
-{-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeOperators       #-}
+{-# LANGUAGE TypeSynonymInstances       #-}
+{-# LANGUAGE FlexibleInstances       #-}
 
 module Servant.ServerSpec where
 
 
-import Control.Monad (when)
+import           Control.Monad              (forM_, when)
 import           Control.Monad.Trans.Either (EitherT, left)
-import Data.Aeson (ToJSON, FromJSON, encode, decode')
+import           Data.Aeson                 (FromJSON, ToJSON, decode', encode)
+import           Data.ByteString.Conversion ()
 import           Data.Char                  (toUpper)
 import           Data.Monoid                ((<>))
-import Data.Proxy (Proxy(Proxy))
+import           Data.Proxy                 (Proxy (Proxy))
 import           Data.String                (fromString)
 import           Data.String.Conversions    (cs)
+import qualified Data.Text                  as T
 import           GHC.Generics               (Generic)
-import Network.HTTP.Types ( parseQuery, ok200, status409, methodPost
+import           Network.HTTP.Types         (hAccept, hContentType,
-                          , methodDelete, hContentType)
+                                             methodDelete, methodGet,
-import Network.Wai ( Application, Request, responseLBS, pathInfo
+                                             methodPatch, methodPost, methodPut,
-                   , queryString, rawQueryString )
+                                             ok200, parseQuery, status409)
-import Network.Wai.Test (runSession, defaultRequest, simpleBody, request)
+import           Network.Wai                (Application, Request, pathInfo,
+                                             queryString, rawQueryString,
+                                             responseLBS)
+import           Network.Wai.Test           (defaultRequest, request,
+                                             runSession, simpleBody)
 import           Test.Hspec                 (Spec, describe, it, shouldBe)
-import Test.Hspec.Wai ( liftIO, with, get, post, shouldRespondWith
+import           Test.Hspec.Wai             (get, liftIO, matchHeaders,
-                      , matchStatus, request )
+                                             matchStatus, post, request,
+                                             shouldRespondWith, with, (<:>))
 
-import Servant.API (JSON, Capture, Get, ReqBody, Post, QueryParam
+import           Servant.API                ((:<|>) (..), (:>),
-                   , QueryParams, QueryFlag, MatrixParam, MatrixParams
+                                             AddHeader (addHeader), Capture,
-                   , MatrixFlag, Raw, (:>), (:<|>)(..), Header, Delete )
+                                             Delete, Get, Header (..), Headers,
+                                             JSON, MatrixFlag, MatrixParam,
+                                             MatrixParams, Patch, PlainText,
+                                             Post, Put, QueryFlag, QueryParam,
+                                             QueryParams, Raw, ReqBody)
 import           Servant.Server             (Server, serve)
-import Servant.Server.Internal (RouteMismatch(..))
+import           Servant.Server.Internal    (RouteMismatch (..))
 
 
 -- * test data types
@@ -69,13 +81,16 @@ spec :: Spec
 spec = do
   captureSpec
   getSpec
+  postSpec
+  putSpec
+  patchSpec
   queryParamSpec
   matrixParamSpec
-  postSpec
   headerSpec
   rawSpec
   unionSpec
   errorsSpec
+  responseHeadersSpec
 
 
 type CaptureApi = Capture "legs" Integer :> Get '[JSON] Animal
@@ -91,10 +106,13 @@ captureSpec :: Spec
 captureSpec = do
   describe "Servant.API.Capture" $ do
     with (return (serve captureApi captureServer)) $ do
+
       it "can capture parts of the 'pathInfo'" $ do
         response <- get "/2"
-        liftIO $ do
+        liftIO $ decode' (simpleBody response) `shouldBe` Just tweety
-          decode' (simpleBody response) `shouldBe` Just tweety
+
+      it "returns 404 if the decoding fails" $ do
+        get "/notAnInt" `shouldRespondWith` 404
 
     with (return (serve
         (Proxy :: Proxy (Capture "captured" String :> Raw))
@@ -105,21 +123,32 @@ captureSpec = do
 
 
 type GetApi = Get '[JSON] Person
+        :<|> "empty" :> Get '[] ()
 getApi :: Proxy GetApi
 getApi = Proxy
 
 getSpec :: Spec
 getSpec = do
   describe "Servant.API.Get" $ do
-    with (return (serve getApi (return alice))) $ do
+    let server = return alice :<|> return ()
+    with (return $ serve getApi server) $ do
+
       it "allows to GET a Person" $ do
         response <- get "/"
         return response `shouldRespondWith` 200
-        liftIO $ do
+        liftIO $ decode' (simpleBody response) `shouldBe` Just alice
-          decode' (simpleBody response) `shouldBe` Just alice
 
       it "throws 405 (wrong method) on POSTs" $ do
         post "/" "" `shouldRespondWith` 405
+        post "/empty" "" `shouldRespondWith` 405
+
+      it "returns 204 if the type is '()'" $ do
+        get "empty" `shouldRespondWith` ""{ matchStatus = 204 }
+
+      it "returns 415 if the Accept header is not supported" $ do
+        Test.Hspec.Wai.request methodGet "" [(hAccept, "crazy/mime")] ""
+          `shouldRespondWith` 415
+
 
 
 type QueryParamApi = QueryParam "name" String :> Get '[JSON] Person
@@ -291,13 +320,16 @@ matrixParamSpec = do
 type PostApi =
        ReqBody '[JSON] Person :> Post '[JSON] Integer
   :<|> "bla" :> ReqBody '[JSON] Person :> Post '[JSON] Integer
+  :<|> "empty" :> Post '[] ()
+
 postApi :: Proxy PostApi
 postApi = Proxy
 
 postSpec :: Spec
 postSpec = do
   describe "Servant.API.Post and .ReqBody" $ do
-    with (return (serve postApi (return . age :<|> return . age))) $ do
+    let server = return . age :<|> return . age :<|> return ()
+    with (return $ serve postApi server) $ do
       let post' x = Test.Hspec.Wai.request methodPost x [(hContentType
                                                         , "application/json;charset=utf-8")]
 
@@ -319,11 +351,98 @@ postSpec = do
       it "correctly rejects invalid request bodies with status 400" $ do
         post' "/" "some invalid body" `shouldRespondWith` 400
 
+      it "returns 204 if the type is '()'" $ do
+        post' "empty" "" `shouldRespondWith` ""{ matchStatus = 204 }
+
       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 PutApi =
+       ReqBody '[JSON] Person :> Put '[JSON] Integer
+  :<|> "bla" :> ReqBody '[JSON] Person :> Put '[JSON] Integer
+  :<|> "empty" :> Put '[] ()
+
+putApi :: Proxy PutApi
+putApi = Proxy
+
+putSpec :: Spec
+putSpec = do
+  describe "Servant.API.Put and .ReqBody" $ do
+    let server = return . age :<|> return . age :<|> return ()
+    with (return $ serve putApi server) $ do
+      let put' x = Test.Hspec.Wai.request methodPut x [(hContentType
+                                                        , "application/json;charset=utf-8")]
+
+      it "allows to put a Person" $ do
+        put' "/" (encode alice) `shouldRespondWith` "42"{
+          matchStatus = 200
+         }
+
+      it "allows alternative routes if all have request bodies" $ do
+        put' "/bla" (encode alice) `shouldRespondWith` "42"{
+          matchStatus = 200
+         }
+
+      it "handles trailing '/' gracefully" $ do
+        put' "/bla/" (encode alice) `shouldRespondWith` "42"{
+          matchStatus = 200
+         }
+
+      it "correctly rejects invalid request bodies with status 400" $ do
+        put' "/" "some invalid body" `shouldRespondWith` 400
+
+      it "returns 204 if the type is '()'" $ do
+        put' "empty" "" `shouldRespondWith` ""{ matchStatus = 204 }
+
+      it "responds with 415 if the requested media type is unsupported" $ do
+        let put'' x = Test.Hspec.Wai.request methodPut x [(hContentType
+                                                            , "application/nonsense")]
+        put'' "/" "anything at all" `shouldRespondWith` 415
+
+type PatchApi =
+       ReqBody '[JSON] Person :> Patch '[JSON] Integer
+  :<|> "bla" :> ReqBody '[JSON] Person :> Patch '[JSON] Integer
+  :<|> "empty" :> Patch '[] ()
+
+patchApi :: Proxy PatchApi
+patchApi = Proxy
+
+patchSpec :: Spec
+patchSpec = do
+  describe "Servant.API.Patch and .ReqBody" $ do
+    let server = return . age :<|> return . age :<|> return ()
+    with (return $ serve patchApi server) $ do
+      let patch' x = Test.Hspec.Wai.request methodPatch x [(hContentType
+                                                        , "application/json;charset=utf-8")]
+
+      it "allows to patch a Person" $ do
+        patch' "/" (encode alice) `shouldRespondWith` "42"{
+          matchStatus = 200
+         }
+
+      it "allows alternative routes if all have request bodies" $ do
+        patch' "/bla" (encode alice) `shouldRespondWith` "42"{
+          matchStatus = 200
+         }
+
+      it "handles trailing '/' gracefully" $ do
+        patch' "/bla/" (encode alice) `shouldRespondWith` "42"{
+          matchStatus = 200
+         }
+
+      it "correctly rejects invalid request bodies with status 400" $ do
+        patch' "/" "some invalid body" `shouldRespondWith` 400
+
+      it "returns 204 if the type is '()'" $ do
+        patch' "empty" "" `shouldRespondWith` ""{ matchStatus = 204 }
+
+      it "responds with 415 if the requested media type is unsupported" $ do
+        let patch'' x = Test.Hspec.Wai.request methodPatch x [(hContentType
+                                                            , "application/nonsense")]
+        patch'' "/" "anything at all" `shouldRespondWith` 415
+
 type HeaderApi a = Header "MyHeader" a :> Delete
 headerApi :: Proxy (HeaderApi a)
 headerApi = Proxy
@@ -381,6 +500,10 @@ rawSpec = do
 type AlternativeApi =
        "foo" :> Get '[JSON] Person
   :<|> "bar" :> Get '[JSON] Animal
+  :<|> "foo" :> Get '[PlainText] T.Text
+  :<|> "bar" :> Post '[JSON] Animal
+  :<|> "bar" :> Put '[JSON] Animal
+  :<|> "bar" :> Delete
 unionApi :: Proxy AlternativeApi
 unionApi = Proxy
 
@@ -388,11 +511,16 @@ unionServer :: Server AlternativeApi
 unionServer =
        return alice
   :<|> return jerry
+  :<|> return "a string"
+  :<|> return jerry
+  :<|> return jerry
+  :<|> return ()
 
 unionSpec :: Spec
 unionSpec = do
   describe "Servant.API.Alternative" $ do
     with (return $ serve unionApi unionServer) $ do
+
       it "unions endpoints" $ do
         response <- get "/foo"
         liftIO $ do
@@ -403,6 +531,48 @@ unionSpec = do
           decode' (simpleBody response_) `shouldBe`
             Just jerry
 
+      it "checks all endpoints before returning 415" $ do
+        get "/foo" `shouldRespondWith` 200
+
+      it "returns 404 if the path does not exist" $ do
+        get "/nonexistent" `shouldRespondWith` 404
+
+type ResponseHeadersApi =
+       Get   '[JSON] (Headers '[Header "H1" Int, Header "H2" String] String)
+  :<|> Post  '[JSON] (Headers '[Header "H1" Int, Header "H2" String] String)
+  :<|> Put   '[JSON] (Headers '[Header "H1" Int, Header "H2" String] String)
+  :<|> Patch '[JSON] (Headers '[Header "H1" Int, Header "H2" String] String)
+
+
+responseHeadersServer :: Server ResponseHeadersApi
+responseHeadersServer = let h = return $ addHeader 5 $ addHeader "kilroy" "hi"
+  in h :<|> h :<|> h :<|> h
+
+
+responseHeadersSpec :: Spec
+responseHeadersSpec = describe "ResponseHeaders" $ do
+  with (return $ serve (Proxy :: Proxy ResponseHeadersApi) responseHeadersServer) $ do
+
+    let methods = [(methodGet, 200), (methodPost, 201), (methodPut, 200), (methodPatch, 200)]
+
+    it "includes the headers in the response" $
+      forM_ methods $ \(method, expected) ->
+        Test.Hspec.Wai.request method "/" [] ""
+          `shouldRespondWith` "\"hi\""{ matchHeaders = ["H1" <:> "5", "H2" <:> "kilroy"]
+                                      , matchStatus  = expected
+                                      }
+
+    it "responds with not found for non-existent endpoints" $
+      forM_ methods $ \(method,_) ->
+        Test.Hspec.Wai.request method "blahblah" [] ""
+          `shouldRespondWith` 404
+
+    it "returns 415 if the Accept header is not supported" $
+      forM_ methods $ \(method,_) ->
+        Test.Hspec.Wai.request method "" [(hAccept, "crazy/mime")] ""
+          `shouldRespondWith` 415
+
+
 -- | Test server error functionality.
 errorsSpec :: Spec
 errorsSpec = do