@@ -89,6 +89,7 @@ spec = do
8989 headerSpec
9090 rawSpec
9191 unionSpec
92+ prioErrorsSpec
9293 errorsSpec
9394 responseHeadersSpec
9495
@@ -572,6 +573,54 @@ responseHeadersSpec = describe "ResponseHeaders" $ do
572573 Test.Hspec.Wai.request method "" [(hAccept, "crazy/mime")] ""
573574 `shouldRespondWith` 415
574575
576+type PrioErrorsApi = ReqBody '[JSON] Person :> "foo" :> Get '[JSON] Integer
577+
578+prioErrorsApi :: Proxy PrioErrorsApi
579+prioErrorsApi = Proxy
580+
581+-- | Test the relative priority of error responses from the server.
582+--
583+-- In particular, we check whether matching continues even if a 'ReqBody'
584+-- or similar construct is encountered early in a path. We don't want to
585+-- see a complaint about the request body unless the path actually matches.
586+--
587+prioErrorsSpec :: Spec
588+prioErrorsSpec = describe "PrioErrors" $ do
589+ let server = return . age
590+ with (return $ serve prioErrorsApi server) $ do
591+ let check (mdescr, method) path (cdescr, ctype, body) resp =
592+ it fulldescr $
593+ Test.Hspec.Wai.request method path [(hContentType, ctype)] body
594+ `shouldRespondWith` resp
595+ where
596+ fulldescr = "returns " ++ show (matchStatus resp) ++ " on " ++ mdescr
597+ ++ " " ++ cs path ++ " (" ++ cdescr ++ ")"
598+
599+ get' = ("GET", methodGet)
600+ put' = ("PUT", methodPut)
601+
602+ txt = ("text" , "text/plain;charset=utf8" , "42" )
603+ ijson = ("invalid json", "application/json;charset=utf8", "invalid" )
604+ vjson = ("valid json" , "application/json;charset=utf8", encode alice)
605+
606+ check get' "/" txt 404
607+ check get' "/bar" txt 404
608+ check get' "/foo" txt 415
609+ check put' "/" txt 404
610+ check put' "/bar" txt 404
611+ check put' "/foo" txt 405
612+ check get' "/" ijson 404
613+ check get' "/bar" ijson 404
614+ check get' "/foo" ijson 400
615+ check put' "/" ijson 404
616+ check put' "/bar" ijson 404
617+ check put' "/foo" ijson 405
618+ check get' "/" vjson 404
619+ check get' "/bar" vjson 404
620+ check get' "/foo" vjson 200
621+ check put' "/" vjson 404
622+ check put' "/bar" vjson 404
623+ check put' "/foo" vjson 405
575624
576625-- | Test server error functionality.
577626errorsSpec :: Spec