Merge pull request #461 from kosmikus/accept-check

Do the accept check before the body check.
This commit is contained in:
Andres Löh 2016-04-15 11:20:13 +02:00
commit d876031e7b
5 changed files with 57 additions and 13 deletions

View file

@ -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

View file

@ -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

View file

@ -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]

View file

@ -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

View file

@ -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`