Merge pull request #1103 from tstat/capture-parse-failure-fix

Set http failure code priority explicitly

servant-server/src/Servant/Server/Internal/Router.hs

@@ -7,6 +7,8 @@ module Servant.Server.Internal.Router where
 import           Prelude ()
 import           Prelude.Compat
 
+import           Data.Function
+                 (on)
 import           Data.Map
                  (Map)
 import qualified Data.Map                                   as M
@@ -208,7 +210,14 @@ runChoice ls =
 
 -- Priority on HTTP codes.
 --
--- It just so happens that 404 < 405 < 406 as far as
--- we are concerned here, so we can use (<).
 worseHTTPCode :: Int -> Int -> Bool
-worseHTTPCode = (<)
+worseHTTPCode = on (<) toPriority
+  where
+    toPriority :: Int -> Int
+    toPriority 404 = 0 -- not found
+    toPriority 405 = 1 -- method not allowed
+    toPriority 401 = 2 -- unauthorized
+    toPriority 415 = 3 -- unsupported media type
+    toPriority 406 = 4 -- not acceptable
+    toPriority 400 = 6 -- bad request
+    toPriority _   = 5

servant-server/test/Servant/Server/RouterSpec.hs

@@ -30,6 +30,7 @@ spec = describe "Servant.Server.Internal.Router" $ do
 
 routerSpec :: Spec
 routerSpec = do
+  describe "tweakResponse" $ do
     let app' :: Application
         app' = toApplication $ runRouter router'
 
@@ -41,10 +42,34 @@ routerSpec = do
         twk (ResponseBuilder (Status i s) hs b) = ResponseBuilder (Status (i + 1) s) hs b
         twk b = b
 
-  describe "tweakResponse" . with (return app') $ do
+    with (return app') $ do
       it "calls f on route result" $ do
         get "" `shouldRespondWith` 202
 
+  describe "runRouter" $ do
+    let toApp :: Router () -> Application
+        toApp = toApplication . runRouter
+
+        cap :: Router ()
+        cap = CaptureRouter $
+          let delayed = addCapture (emptyDelayed $ Route pure) (const $ delayedFail err400)
+          in leafRouter
+             $ \env req res ->
+                 runAction delayed env req res
+                 . const
+                 $ Route success
+
+        router :: Router ()
+        router = leafRouter (\_ _ res -> res $ Route success)
+          `Choice` cap
+
+        success :: Response
+        success = responseBuilder (Status 200 "") [] ""
+
+    with (pure $ toApp router) $ do
+      it "capture failure returns a 400 response" $ do
+        get "/badcapture" `shouldRespondWith` 400
+
 distributivitySpec :: Spec
 distributivitySpec =
   describe "choice" $ do