From 404bfdd89cc5d5949021341ad25d6126dcfdf39a Mon Sep 17 00:00:00 2001
From: Andres Loeh <andres@well-typed.com>
Date: Mon, 1 Jun 2015 10:24:09 +0200
Subject: [PATCH] Add test cases for the priority of error codes.

Due to the delayed treatment of checks during the server interpretation,
we now have the ability to produce "better" error codes for certain
APIs. This change introduces test cases for some of these situations and
their new, desired results. These tests would mostly fail with the old
approach to routing.
---
 servant-server/test/Servant/ServerSpec.hs | 49 +++++++++++++++++++++++
 1 file changed, 49 insertions(+)

diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs
index 2689a4e2..ca604ae7 100644
--- a/servant-server/test/Servant/ServerSpec.hs
+++ b/servant-server/test/Servant/ServerSpec.hs
@@ -89,6 +89,7 @@ spec = do
   headerSpec
   rawSpec
   unionSpec
+  prioErrorsSpec
   errorsSpec
   responseHeadersSpec
 
@@ -572,6 +573,54 @@ responseHeadersSpec = describe "ResponseHeaders" $ do
         Test.Hspec.Wai.request method "" [(hAccept, "crazy/mime")] ""
           `shouldRespondWith` 415
 
+type PrioErrorsApi = ReqBody '[JSON] Person :> "foo" :> Get '[JSON] Integer
+
+prioErrorsApi :: Proxy PrioErrorsApi
+prioErrorsApi = Proxy
+
+-- | Test the relative priority of error responses from the server.
+--
+-- In particular, we check whether matching continues even if a 'ReqBody'
+-- or similar construct is encountered early in a path. We don't want to
+-- see a complaint about the request body unless the path actually matches.
+--
+prioErrorsSpec :: Spec
+prioErrorsSpec = describe "PrioErrors" $ do
+  let server = return . age
+  with (return $ serve prioErrorsApi server) $ do
+    let check (mdescr, method) path (cdescr, ctype, body) resp =
+          it fulldescr $
+            Test.Hspec.Wai.request method path [(hContentType, ctype)] body
+              `shouldRespondWith` resp
+          where
+            fulldescr = "returns " ++ show (matchStatus resp) ++ " on " ++ mdescr
+                     ++ " " ++ cs path ++ " (" ++ cdescr ++ ")"
+
+        get' = ("GET", methodGet)
+        put' = ("PUT", methodPut)
+
+        txt   = ("text"        , "text/plain;charset=utf8"      , "42"        )
+        ijson = ("invalid json", "application/json;charset=utf8", "invalid"   )
+        vjson = ("valid json"  , "application/json;charset=utf8", encode alice)
+
+    check get' "/"    txt   404
+    check get' "/bar" txt   404
+    check get' "/foo" txt   415
+    check put' "/"    txt   404
+    check put' "/bar" txt   404
+    check put' "/foo" txt   405
+    check get' "/"    ijson 404
+    check get' "/bar" ijson 404
+    check get' "/foo" ijson 400
+    check put' "/"    ijson 404
+    check put' "/bar" ijson 404
+    check put' "/foo" ijson 405
+    check get' "/"    vjson 404
+    check get' "/bar" vjson 404
+    check get' "/foo" vjson 200
+    check put' "/"    vjson 404
+    check put' "/bar" vjson 404
+    check put' "/foo" vjson 405
 
 -- | Test server error functionality.
 errorsSpec :: Spec