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

Set http failure code priority explicitly
This commit is contained in:
Oleg Grenrus 2019-02-02 10:23:55 +02:00 committed by GitHub
commit df6e992675
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
2 changed files with 48 additions and 14 deletions

View file

@ -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

View file

@ -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 =