From 622c77251e2613a3fd9b1e3bfde2ac3337c5a6ee Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Mon, 6 Apr 2015 16:12:28 +0200 Subject: [PATCH] Don't succeedWith when response content-type is unacceptable. --- src/Servant/Server/Internal.hs | 40 +++++++++++++++++----------------- test/Servant/ServerSpec.hs | 10 +++++++-- 2 files changed, 28 insertions(+), 22 deletions(-) diff --git a/src/Servant/Server/Internal.hs b/src/Servant/Server/Internal.hs index b92036c6..064eddab 100644 --- a/src/Servant/Server/Internal.hs +++ b/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") [] "" - Just (contentT, body) -> responseLBS ok200 [ ("Content-Type" - , cs contentT)] body - Left (status, message) -> + Nothing -> failWith UnsupportedMediaType + Just (contentT, body) -> succeedWith $ + 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 @@ -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 "") [] "" - Just (contentT, body) -> responseLBS status201 [ ("Content-Type" - , cs contentT)] body - Left (status, message) -> + Nothing -> failWith UnsupportedMediaType + Just (contentT, body) -> succeedWith $ + 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 @@ -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 "") [] "" - Just (contentT, body) -> responseLBS status200 [ ("Content-Type" - , cs contentT)] body - Left (status, message) -> + 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 /= 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 "") [] "" - Just (contentT, body) -> responseLBS status200 [ ("Content-Type" - , cs contentT)] body - Left (status, message) -> + 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 diff --git a/test/Servant/ServerSpec.hs b/test/Servant/ServerSpec.hs index 6b44e409..03c7463c 100644 --- a/test/Servant/ServerSpec.hs +++ b/test/Servant/ServerSpec.hs @@ -15,6 +15,7 @@ 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, methodPatch, methodPost, methodPut, @@ -31,8 +32,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, - QueryParams, Raw, ReqBody) + PlainText, Post, Put, QueryFlag, + QueryParam, QueryParams, Raw, + ReqBody) import Servant.Server (Server, serve) import Servant.Server.Internal (RouteMismatch (..)) @@ -483,6 +485,7 @@ rawSpec = do type AlternativeApi = "foo" :> Get '[JSON] Person :<|> "bar" :> Get '[JSON] Animal + :<|> "foo" :> Get '[PlainText] T.Text unionApi :: Proxy AlternativeApi unionApi = Proxy @@ -490,6 +493,7 @@ unionServer :: Server AlternativeApi unionServer = return alice :<|> return jerry + :<|> return "a string" unionSpec :: Spec unionSpec = do @@ -504,6 +508,8 @@ unionSpec = do liftIO $ do decode' (simpleBody response_) `shouldBe` Just jerry + it "checks all endpoints before returning 406" $ do + get "/foo" `shouldRespondWith` 200 -- | Test server error functionality. errorsSpec :: Spec