Do the accept check before the body check.

This is a reasonably simple attempt at fixing #460.
By moving the accept check to a place before the body check,
we can make it recoverable (the body check is irreversible,
so everything done after the body check has to fail fatally).

The advantage is that we can now specify routes offering
different content types modularly. Failure to match one
is not fatal, and will result in subsequent routes being
tried.

The disadvantage is that we hereby bump the error priority
of the 406 status code. If a request contains a bad accept
header and a bad body, we now get 406 rather than 400. This
deviates from the HTTP decision diagram we try to follow,
but seems like an acceptable compromise for now.

Author: kosmikus

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
 

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

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]
 

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

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`