Merge pull request #461 from kosmikus/accept-check

Do the accept check before the body check.

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`