diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 65b71a63..d289482c 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -603,7 +603,7 @@ instance ( AllCTUnrender list a, HasServer api context, SBoolI (FoldLenient mods let contentTypeH = fromMaybe "application/octet-stream" $ lookup hContentType $ requestHeaders request case canHandleCTypeH (Proxy :: Proxy list) (cs contentTypeH) :: Maybe (BL.ByteString -> Either String a) of - Nothing -> delayedFailFatal err415 + Nothing -> delayedFail err415 Just f -> return f -- Body check, we get a body parsing functions as the first argument. diff --git a/servant-server/test/Servant/Server/ErrorSpec.hs b/servant-server/test/Servant/Server/ErrorSpec.hs index 787185da..0de8bef8 100644 --- a/servant-server/test/Servant/Server/ErrorSpec.hs +++ b/servant-server/test/Servant/Server/ErrorSpec.hs @@ -247,6 +247,8 @@ type ErrorChoiceApi :<|> "path3" :> ReqBody '[JSON] Int :> Post '[PlainText] Int -- 3 :<|> "path4" :> (ReqBody '[PlainText] Int :> Post '[PlainText] Int -- 4 :<|> ReqBody '[PlainText] Int :> Post '[JSON] Int) -- 5 + :<|> "path5" :> (ReqBody '[JSON] Int :> Post '[PlainText] Int -- 6 + :<|> ReqBody '[PlainText] Int :> Post '[PlainText] Int) -- 7 errorChoiceApi :: Proxy ErrorChoiceApi errorChoiceApi = Proxy @@ -256,8 +258,8 @@ errorChoiceServer = return 0 :<|> return 1 :<|> return 2 :<|> (\_ -> return 3) - :<|> (\_ -> return 4) - :<|> (\_ -> return 5) + :<|> ((\_ -> return 4) :<|> (\_ -> return 5)) + :<|> ((\_ -> return 6) :<|> (\_ -> return 7)) errorChoiceSpec :: Spec @@ -278,6 +280,13 @@ errorChoiceSpec = describe "Multiple handlers return errors" request methodPost "path4" [(hContentType, "text/plain;charset=utf-8"), (hAccept, "blah")] "5" `shouldRespondWith` 406 + it "should respond with 415 only if none of the subservers supports the request's content type" $ do + request methodPost "path5" [(hContentType, "text/plain;charset=utf-8")] "1" + `shouldRespondWith` 200 + request methodPost "path5" [(hContentType, "application/json")] "1" + `shouldRespondWith` 200 + request methodPost "path5" [(hContentType, "application/not-supported")] "" + `shouldRespondWith` 415 -- }}}