Merge pull request #38 from haskell-servant/jkarni/fix-406

Don't succeedWith when response content-type is unacceptable.

src/Servant/Server/Internal.hs

@@ -273,14 +273,14 @@ 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) ->
+          Left (status, message) -> succeedWith $
             responseLBS (mkStatus status (cs message)) [] (cs message)
     | pathIsEmpty request && requestMethod request /= methodGet =
         respond $ failWith WrongMethod
@@ -351,14 +351,14 @@ 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) ->
+          Left (status, message) -> succeedWith $
             responseLBS (mkStatus status (cs message)) [] (cs message)
     | pathIsEmpty request && requestMethod request /= methodPost =
         respond $ failWith WrongMethod
@@ -397,14 +397,14 @@ 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) ->
+          Left (status, message) -> succeedWith $
             responseLBS (mkStatus status (cs message)) [] (cs message)
     | pathIsEmpty request && requestMethod request /= methodPut =
         respond $ failWith WrongMethod
@@ -441,14 +441,14 @@ instance ( AllCTRender ctypes a
   route Proxy action request respond
     | pathIsEmpty request && requestMethod request == methodPatch = 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) ->
+          Left (status, message) -> succeedWith $
             responseLBS (mkStatus status (cs message)) [] (cs message)
     | pathIsEmpty request && requestMethod request /= methodPatch =
         respond $ failWith WrongMethod

test/Servant/ServerSpec.hs

@@ -15,8 +15,10 @@ import           Data.Monoid                ((<>))
 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         (hContentType, methodDelete,
+import           Network.HTTP.Types         (hAccept, hContentType,
+                                             methodDelete, methodGet,
                                              methodPatch, methodPost, methodPut,
                                              ok200, parseQuery, status409)
 import           Network.Wai                (Application, Request, pathInfo,
@@ -31,8 +33,9 @@ import           Test.Hspec.Wai             (get, liftIO, matchStatus, post,
 import           Servant.API                ((:<|>) (..), (:>), Capture, Delete,
                                              Get, Header, JSON, MatrixFlag,
                                              MatrixParam, MatrixParams, Patch,
-                                             Post, Put, QueryFlag, QueryParam,
+                                             PlainText, Post, Put, QueryFlag,
-                                             QueryParams, Raw, ReqBody)
+                                             QueryParam, QueryParams, Raw,
+                                             ReqBody)
 import           Servant.Server             (Server, serve)
 import           Servant.Server.Internal    (RouteMismatch (..))
 
@@ -41,7 +44,7 @@ import           Servant.Server.Internal    (RouteMismatch (..))
 
 data Person = Person {
   name :: String,
-  age :: Integer
+  age  :: Integer
  }
   deriving (Eq, Show, Generic)
 
@@ -52,7 +55,7 @@ alice :: Person
 alice = Person "Alice" 42
 
 data Animal = Animal {
-  species :: String,
+  species      :: String,
   numberOfLegs :: Integer
  }
   deriving (Eq, Show, Generic)
@@ -97,10 +100,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))
@@ -120,18 +126,23 @@ getSpec = do
   describe "Servant.API.Get" $ 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
@@ -483,6 +494,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
 
@@ -490,11 +505,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
@@ -505,6 +525,12 @@ 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
+
 -- | Test server error functionality.
 errorsSpec :: Spec
 errorsSpec = do