From 9d8a8118b81ba43dba5950a2a5d3a06c115772c9 Mon Sep 17 00:00:00 2001
From: Travis Staton <hello@travisstaton.com>
Date: Sun, 6 Jan 2019 09:44:48 -0500
Subject: [PATCH] Set http failure code priority explicitly

---
 .../src/Servant/Server/Internal/Router.hs     | 15 ++++--
 .../test/Servant/Server/RouterSpec.hs         | 47 ++++++++++++++-----
 2 files changed, 48 insertions(+), 14 deletions(-)

diff --git a/servant-server/src/Servant/Server/Internal/Router.hs b/servant-server/src/Servant/Server/Internal/Router.hs
index c73d76d8..36d7205c 100644
--- a/servant-server/src/Servant/Server/Internal/Router.hs
+++ b/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
diff --git a/servant-server/test/Servant/Server/RouterSpec.hs b/servant-server/test/Servant/Server/RouterSpec.hs
index 24e920a4..472dfecc 100644
--- a/servant-server/test/Servant/Server/RouterSpec.hs
+++ b/servant-server/test/Servant/Server/RouterSpec.hs
@@ -30,20 +30,45 @@ spec = describe "Servant.Server.Internal.Router" $ do
 
 routerSpec :: Spec
 routerSpec = do
-  let app' :: Application
-      app' = toApplication $ runRouter router'
+  describe "tweakResponse" $ do
+    let app' :: Application
+        app' = toApplication $ runRouter router'
 
-      router', router :: Router ()
-      router' = tweakResponse (fmap twk) router
-      router = leafRouter $ \_ _ cont -> cont (Route $ responseBuilder (Status 201 "") [] "")
+        router', router :: Router ()
+        router' = tweakResponse (fmap twk) router
+        router = leafRouter $ \_ _ cont -> cont (Route $ responseBuilder (Status 201 "") [] "")
 
-      twk :: Response -> Response
-      twk (ResponseBuilder (Status i s) hs b) = ResponseBuilder (Status (i + 1) s) hs b
-      twk b = b
+        twk :: Response -> Response
+        twk (ResponseBuilder (Status i s) hs b) = ResponseBuilder (Status (i + 1) s) hs b
+        twk b = b
 
-  describe "tweakResponse" . with (return app') $ do
-    it "calls f on route result" $ do
-      get "" `shouldRespondWith` 202
+    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 =