git.iko.soy/servant
on master help sign in
Don't succeedWith when response content-type is unacceptable.
commit622c77251e2613a3fd9b1e3bfde2ac3337c5a6ee authorJulian K. Arni <jkarni@gmail.com> dateMon 6 Apr 2015, 16:12 (12 years ago) parent25d1e46
2 files changed+28−22
compare with master
unifiedsplit
src/Servant/Server/Internal.hs+20−20 test/Servant/ServerSpec.hs+8−2
src/Servant/Server/Internal.hs+20−20
@@ -273,14 +273,14 @@ instance ( AllCTRender ctypes a
273273 route Proxy action request respond
274274 | pathIsEmpty request && requestMethod request == methodGet = do
275275 e <- runEitherT action
276− respond . succeedWith $ case e of
276+ respond $ case e of
277277 Right output -> do
278278 let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
279279 case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
280− Nothing -> responseLBS (mkStatus 406 "Not Acceptable") [] ""
281− Just (contentT, body) -> responseLBS ok200 [ ("Content-Type"
282− , cs contentT)] body
283− Left (status, message) ->
280+ Nothing -> failWith UnsupportedMediaType
281+ Just (contentT, body) -> succeedWith $
282+ responseLBS ok200 [ ("Content-Type" , cs contentT)] body
283+ Left (status, message) -> succeedWith $
284284 responseLBS (mkStatus status (cs message)) [] (cs message)
285285 | pathIsEmpty request && requestMethod request /= methodGet =
286286 respond $ failWith WrongMethod
@@ -351,14 +351,14 @@ instance ( AllCTRender ctypes a
351351 route Proxy action request respond
352352 | pathIsEmpty request && requestMethod request == methodPost = do
353353 e <- runEitherT action
354− respond . succeedWith $ case e of
354+ respond $ case e of
355355 Right output -> do
356356 let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
357357 case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
358− Nothing -> responseLBS (mkStatus 406 "") [] ""
359− Just (contentT, body) -> responseLBS status201 [ ("Content-Type"
360− , cs contentT)] body
361− Left (status, message) ->
358+ Nothing -> failWith UnsupportedMediaType
359+ Just (contentT, body) -> succeedWith $
360+ responseLBS status201 [ ("Content-Type" , cs contentT)] body
361+ Left (status, message) -> succeedWith $
362362 responseLBS (mkStatus status (cs message)) [] (cs message)
363363 | pathIsEmpty request && requestMethod request /= methodPost =
364364 respond $ failWith WrongMethod
@@ -397,14 +397,14 @@ instance ( AllCTRender ctypes a
397397 route Proxy action request respond
398398 | pathIsEmpty request && requestMethod request == methodPut = do
399399 e <- runEitherT action
400− respond . succeedWith $ case e of
400+ respond $ case e of
401401 Right output -> do
402402 let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
403403 case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
404− Nothing -> responseLBS (mkStatus 406 "") [] ""
405− Just (contentT, body) -> responseLBS status200 [ ("Content-Type"
406− , cs contentT)] body
407− Left (status, message) ->
404+ Nothing -> failWith UnsupportedMediaType
405+ Just (contentT, body) -> succeedWith $
406+ responseLBS status200 [ ("Content-Type" , cs contentT)] body
407+ Left (status, message) -> succeedWith $
408408 responseLBS (mkStatus status (cs message)) [] (cs message)
409409 | pathIsEmpty request && requestMethod request /= methodPut =
410410 respond $ failWith WrongMethod
@@ -441,14 +441,14 @@ instance ( AllCTRender ctypes a
441441 route Proxy action request respond
442442 | pathIsEmpty request && requestMethod request == methodPatch = do
443443 e <- runEitherT action
444− respond . succeedWith $ case e of
444+ respond $ case e of
445445 Right output -> do
446446 let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
447447 case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
448− Nothing -> responseLBS (mkStatus 406 "") [] ""
449− Just (contentT, body) -> responseLBS status200 [ ("Content-Type"
450− , cs contentT)] body
451− Left (status, message) ->
448+ Nothing -> failWith UnsupportedMediaType
449+ Just (contentT, body) -> succeedWith $
450+ responseLBS status200 [ ("Content-Type" , cs contentT)] body
451+ Left (status, message) -> succeedWith $
452452 responseLBS (mkStatus status (cs message)) [] (cs message)
453453 | pathIsEmpty request && requestMethod request /= methodPatch =
454454 respond $ failWith WrongMethod
test/Servant/ServerSpec.hs+8−2
@@ -15,6 +15,7 @@ import Data.Monoid ((<>))
1515import Data.Proxy (Proxy (Proxy))
1616import Data.String (fromString)
1717import Data.String.Conversions (cs)
18+import qualified Data.Text as T
1819import GHC.Generics (Generic)
1920import Network.HTTP.Types (hContentType, methodDelete,
2021 methodPatch, methodPost, methodPut,
@@ -31,8 +32,9 @@ import Test.Hspec.Wai (get, liftIO, matchStatus, post,
3132import Servant.API ((:<|>) (..), (:>), Capture, Delete,
3233 Get, Header, JSON, MatrixFlag,
3334 MatrixParam, MatrixParams, Patch,
34− Post, Put, QueryFlag, QueryParam,
35− QueryParams, Raw, ReqBody)
35+ PlainText, Post, Put, QueryFlag,
36+ QueryParam, QueryParams, Raw,
37+ ReqBody)
3638import Servant.Server (Server, serve)
3739import Servant.Server.Internal (RouteMismatch (..))
3840
@@ -483,6 +485,7 @@ rawSpec = do
483485type AlternativeApi =
484486 "foo" :> Get '[JSON] Person
485487 :<|> "bar" :> Get '[JSON] Animal
488+ :<|> "foo" :> Get '[PlainText] T.Text
486489unionApi :: Proxy AlternativeApi
487490unionApi = Proxy
488491
@@ -490,6 +493,7 @@ unionServer :: Server AlternativeApi
490493unionServer =
491494 return alice
492495 :<|> return jerry
496+ :<|> return "a string"
493497
494498unionSpec :: Spec
495499unionSpec = do
@@ -504,6 +508,8 @@ unionSpec = do
504508 liftIO $ do
505509 decode' (simpleBody response_) `shouldBe`
506510 Just jerry
511+ it "checks all endpoints before returning 406" $ do
512+ get "/foo" `shouldRespondWith` 200
507513
508514-- | Test server error functionality.
509515errorsSpec :: Spec