diff --git a/servant-server/CHANGELOG.md b/servant-server/CHANGELOG.md index 736c36bd..b4213b6d 100644 --- a/servant-server/CHANGELOG.md +++ b/servant-server/CHANGELOG.md @@ -7,6 +7,10 @@ efficiently. Functions `layout` and `layoutWithContext` have been added to visualize the router layout for debugging purposes. Test cases for expected router layouts have been added. +* If an endpoint is discovered to have a non-matching "accept header", + this is now a recoverable rather than a fatal failure, allowing + different endpoints for the same route, but with different content + types to be specified modularly. * Export `throwError` from module `Servant` * Add `Handler` type synonym diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 2d378c9d..5d02c96d 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -154,10 +154,17 @@ methodCheck method request | allowedMethod method request = return () | otherwise = delayedFail err405 +-- This has switched between using 'Fail' and 'FailFatal' a number of +-- times. If the 'acceptCheck' is run after the body check (which would +-- be morally right), then we have to set this to 'FailFatal', because +-- the body check is not reversible, and therefore backtracking after the +-- body check is no longer an option. However, we now run the accept +-- check before the body check and can therefore afford to make it +-- recoverable. acceptCheck :: (AllMime list) => Proxy list -> B.ByteString -> DelayedIO () acceptCheck proxy accH | canHandleAcceptH proxy (AcceptHeader accH) = return () - | otherwise = delayedFailFatal err406 + | otherwise = delayedFail err406 methodRouter :: (AllCTRender ctypes a) => Method -> Proxy ctypes -> Status diff --git a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs index 5825531e..10bdc461 100644 --- a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs +++ b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs @@ -203,16 +203,22 @@ addBodyCheck Delayed{..} new = } -- Note [Existential Record Update] --- | Add an accept header check to the end of the body block. --- The accept header check should occur after the body check, --- but this will be the case, because the accept header check --- is only scheduled by the method combinators. +-- | Add an accept header check to the beginning of the body +-- block. There is a tradeoff here. In principle, we'd like +-- to take a bad body (400) response take precedence over a +-- failed accept check (406). BUT to allow streaming the body, +-- we cannot run the body check and then still backtrack. +-- We therefore do the accept check before the body check, +-- when we can still backtrack. There are other solutions to +-- this, but they'd be more complicated (such as delaying the +-- body check further so that it can still be run in a situation +-- where we'd otherwise report 406). addAcceptCheck :: Delayed env a -> DelayedIO () -> Delayed env a addAcceptCheck Delayed{..} new = Delayed - { bodyD = bodyD <* new + { bodyD = new *> bodyD , .. } -- Note [Existential Record Update] diff --git a/servant-server/test/Servant/Server/ErrorSpec.hs b/servant-server/test/Servant/Server/ErrorSpec.hs index 94d26d09..39a71721 100644 --- a/servant-server/test/Servant/Server/ErrorSpec.hs +++ b/servant-server/test/Servant/Server/ErrorSpec.hs @@ -53,6 +53,23 @@ errorOrderApi = Proxy errorOrderServer :: Server ErrorOrderApi errorOrderServer = \_ _ _ -> throwE err402 +-- On error priorities: +-- +-- We originally had +-- +-- 404, 405, 401, 415, 400, 406, 402 +-- +-- but we changed this to +-- +-- 404, 405, 401, 406, 415, 400, 402 +-- +-- for servant-0.7. +-- +-- This change is due to the body check being irreversible (to support +-- streaming). Any check done after the body check has to be made fatal, +-- breaking modularity. We've therefore moved the accept check before +-- the body check, to allow it being recoverable and modular, and this +-- goes along with promoting the error priority of 406. errorOrderSpec :: Spec errorOrderSpec = describe "HTTP error order" $ @@ -86,18 +103,18 @@ errorOrderSpec = request goodMethod goodUrl [badAuth, badContentType, badAccept] badBody `shouldRespondWith` 401 - it "has 415 as its fourth highest priority error" $ do + it "has 406 as its fourth highest priority error" $ do request goodMethod goodUrl [goodAuth, badContentType, badAccept] badBody + `shouldRespondWith` 406 + + it "has 415 as its fifth highest priority error" $ do + request goodMethod goodUrl [goodAuth, badContentType, goodAccept] badBody `shouldRespondWith` 415 - it "has 400 as its fifth highest priority error" $ do - request goodMethod goodUrl [goodAuth, goodContentType, badAccept] badBody + it "has 400 as its sixth highest priority error" $ do + request goodMethod goodUrl [goodAuth, goodContentType, goodAccept] badBody `shouldRespondWith` 400 - it "has 406 as its sixth highest priority error" $ do - request goodMethod goodUrl [goodAuth, goodContentType, badAccept] goodBody - `shouldRespondWith` 406 - it "has handler-level errors as last priority" $ do request goodMethod goodUrl [goodAuth, goodContentType, goodAccept] goodBody `shouldRespondWith` 402 diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index fc4eb1df..50113cf3 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -99,6 +99,9 @@ type VerbApi method status :<|> "noContent" :> Verb method status '[JSON] NoContent :<|> "header" :> Verb method status '[JSON] (Headers '[Header "H" Int] Person) :<|> "headerNC" :> Verb method status '[JSON] (Headers '[Header "H" Int] NoContent) + :<|> "accept" :> ( Verb method status '[JSON] Person + :<|> Verb method status '[PlainText] String + ) verbSpec :: Spec verbSpec = describe "Servant.API.Verb" $ do @@ -107,6 +110,7 @@ verbSpec = describe "Servant.API.Verb" $ do :<|> return NoContent :<|> return (addHeader 5 alice) :<|> return (addHeader 10 NoContent) + :<|> (return alice :<|> return "B") get200 = Proxy :: Proxy (VerbApi 'GET 200) post210 = Proxy :: Proxy (VerbApi 'POST 210) put203 = Proxy :: Proxy (VerbApi 'PUT 203) @@ -161,6 +165,12 @@ verbSpec = describe "Servant.API.Verb" $ do [(hAccept, "application/json")] "" liftIO $ statusCode (simpleStatus response) `shouldBe` status + unless (status `elem` [214, 215] || method == methodHead) $ + it "allows modular specification of supported content types" $ do + response <- THW.request method "/accept" [(hAccept, "text/plain")] "" + liftIO $ statusCode (simpleStatus response) `shouldBe` status + liftIO $ simpleBody response `shouldBe` "B" + it "sets the Content-Type header" $ do response <- THW.request method "" [] "" liftIO $ simpleHeaders response `shouldContain`