git.iko.soy/servant
on master help sign in
Don't succeedWith when response content-type is unacceptable.
622c772Julian K. Arni
src/Servant/Server/Internal.hs+20−20
compare with master
unifiedsplit
@@ -273,14 +273,14 @@ instance ( AllCTRender ctypes a
273 route Proxy action request respond
273 route Proxy action request respond
274 | pathIsEmpty request && requestMethod request == methodGet = do
274 | pathIsEmpty request && requestMethod request == methodGet = do
275 e <- runEitherT action
275 e <- runEitherT action
276− respond . succeedWith $ case e of
276+ respond $ case e of
277 Right output -> do
277 Right output -> do
278 let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
278 let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
279 case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
279 case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
280− Nothing -> responseLBS (mkStatus 406 "Not Acceptable") [] ""
280+ Nothing -> failWith UnsupportedMediaType
281+ Just (contentT, body) -> succeedWith $
281− Just (contentT, body) -> responseLBS ok200 [ ("Content-Type"
282+ responseLBS ok200 [ ("Content-Type" , cs contentT)] body
282− , cs contentT)] body
283− Left (status, message) ->
283+ Left (status, message) -> succeedWith $
284 responseLBS (mkStatus status (cs message)) [] (cs message)
284 responseLBS (mkStatus status (cs message)) [] (cs message)
285 | pathIsEmpty request && requestMethod request /= methodGet =
285 | pathIsEmpty request && requestMethod request /= methodGet =
286 respond $ failWith WrongMethod
286 respond $ failWith WrongMethod
@@ -351,14 +351,14 @@ instance ( AllCTRender ctypes a
351 route Proxy action request respond
351 route Proxy action request respond
352 | pathIsEmpty request && requestMethod request == methodPost = do
352 | pathIsEmpty request && requestMethod request == methodPost = do
353 e <- runEitherT action
353 e <- runEitherT action
354− respond . succeedWith $ case e of
354+ respond $ case e of
355 Right output -> do
355 Right output -> do
356 let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
356 let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
357 case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
357 case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
358− Nothing -> responseLBS (mkStatus 406 "") [] ""
358+ Nothing -> failWith UnsupportedMediaType
359+ Just (contentT, body) -> succeedWith $
359− Just (contentT, body) -> responseLBS status201 [ ("Content-Type"
360+ responseLBS status201 [ ("Content-Type" , cs contentT)] body
360− , cs contentT)] body
361− Left (status, message) ->
361+ Left (status, message) -> succeedWith $
362 responseLBS (mkStatus status (cs message)) [] (cs message)
362 responseLBS (mkStatus status (cs message)) [] (cs message)
363 | pathIsEmpty request && requestMethod request /= methodPost =
363 | pathIsEmpty request && requestMethod request /= methodPost =
364 respond $ failWith WrongMethod
364 respond $ failWith WrongMethod
@@ -397,14 +397,14 @@ instance ( AllCTRender ctypes a
397 route Proxy action request respond
397 route Proxy action request respond
398 | pathIsEmpty request && requestMethod request == methodPut = do
398 | pathIsEmpty request && requestMethod request == methodPut = do
399 e <- runEitherT action
399 e <- runEitherT action
400− respond . succeedWith $ case e of
400+ respond $ case e of
401 Right output -> do
401 Right output -> do
402 let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
402 let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
403 case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
403 case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
404− Nothing -> responseLBS (mkStatus 406 "") [] ""
404+ Nothing -> failWith UnsupportedMediaType
405+ Just (contentT, body) -> succeedWith $
405− Just (contentT, body) -> responseLBS status200 [ ("Content-Type"
406+ responseLBS status200 [ ("Content-Type" , cs contentT)] body
406− , cs contentT)] body
407− Left (status, message) ->
407+ Left (status, message) -> succeedWith $
408 responseLBS (mkStatus status (cs message)) [] (cs message)
408 responseLBS (mkStatus status (cs message)) [] (cs message)
409 | pathIsEmpty request && requestMethod request /= methodPut =
409 | pathIsEmpty request && requestMethod request /= methodPut =
410 respond $ failWith WrongMethod
410 respond $ failWith WrongMethod
@@ -441,14 +441,14 @@ instance ( AllCTRender ctypes a
441 route Proxy action request respond
441 route Proxy action request respond
442 | pathIsEmpty request && requestMethod request == methodPatch = do
442 | pathIsEmpty request && requestMethod request == methodPatch = do
443 e <- runEitherT action
443 e <- runEitherT action
444− respond . succeedWith $ case e of
444+ respond $ case e of
445 Right output -> do
445 Right output -> do
446 let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
446 let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
447 case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
447 case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
448− Nothing -> responseLBS (mkStatus 406 "") [] ""
448+ Nothing -> failWith UnsupportedMediaType
449+ Just (contentT, body) -> succeedWith $
449− Just (contentT, body) -> responseLBS status200 [ ("Content-Type"
450+ responseLBS status200 [ ("Content-Type" , cs contentT)] body
450− , cs contentT)] body
451− Left (status, message) ->
451+ Left (status, message) -> succeedWith $
452 responseLBS (mkStatus status (cs message)) [] (cs message)
452 responseLBS (mkStatus status (cs message)) [] (cs message)
453 | pathIsEmpty request && requestMethod request /= methodPatch =
453 | pathIsEmpty request && requestMethod request /= methodPatch =
454 respond $ failWith WrongMethod
454 respond $ failWith WrongMethod
test/Servant/ServerSpec.hs+8−2
@@ -15,6 +15,7 @@ import Data.Monoid ((<>))
15import Data.Proxy (Proxy (Proxy))
15import Data.Proxy (Proxy (Proxy))
16import Data.String (fromString)
16import Data.String (fromString)
17import Data.String.Conversions (cs)
17import Data.String.Conversions (cs)
18+import qualified Data.Text as T
18import GHC.Generics (Generic)
19import GHC.Generics (Generic)
19import Network.HTTP.Types (hContentType, methodDelete,
20import Network.HTTP.Types (hContentType, methodDelete,
20 methodPatch, methodPost, methodPut,
21 methodPatch, methodPost, methodPut,
@@ -31,8 +32,9 @@ import Test.Hspec.Wai (get, liftIO, matchStatus, post,
31import Servant.API ((:<|>) (..), (:>), Capture, Delete,
32import Servant.API ((:<|>) (..), (:>), Capture, Delete,
32 Get, Header, JSON, MatrixFlag,
33 Get, Header, JSON, MatrixFlag,
33 MatrixParam, MatrixParams, Patch,
34 MatrixParam, MatrixParams, Patch,
34− Post, Put, QueryFlag, QueryParam,
35+ PlainText, Post, Put, QueryFlag,
35− QueryParams, Raw, ReqBody)
36+ QueryParam, QueryParams, Raw,
37+ ReqBody)
36import Servant.Server (Server, serve)
38import Servant.Server (Server, serve)
37import Servant.Server.Internal (RouteMismatch (..))
39import Servant.Server.Internal (RouteMismatch (..))
38
40
@@ -483,6 +485,7 @@ rawSpec = do
483type AlternativeApi =
485type AlternativeApi =
484 "foo" :> Get '[JSON] Person
486 "foo" :> Get '[JSON] Person
485 :<|> "bar" :> Get '[JSON] Animal
487 :<|> "bar" :> Get '[JSON] Animal
488+ :<|> "foo" :> Get '[PlainText] T.Text
486unionApi :: Proxy AlternativeApi
489unionApi :: Proxy AlternativeApi
487unionApi = Proxy
490unionApi = Proxy
488
491
@@ -490,6 +493,7 @@ unionServer :: Server AlternativeApi
490unionServer =
493unionServer =
491 return alice
494 return alice
492 :<|> return jerry
495 :<|> return jerry
496+ :<|> return "a string"
493
497
494unionSpec :: Spec
498unionSpec :: Spec
495unionSpec = do
499unionSpec = do
@@ -504,6 +508,8 @@ unionSpec = do
504 liftIO $ do
508 liftIO $ do
505 decode' (simpleBody response_) `shouldBe`
509 decode' (simpleBody response_) `shouldBe`
506 Just jerry
510 Just jerry
511+ it "checks all endpoints before returning 406" $ do
512+ get "/foo" `shouldRespondWith` 200
507
513
508-- | Test server error functionality.
514-- | Test server error functionality.
509errorsSpec :: Spec
515errorsSpec :: Spec