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 ()
import Prelude.Compat import Prelude.Compat
import Data.Function
(on)
import Data.Map import Data.Map
(Map) (Map)
import qualified Data.Map as M import qualified Data.Map as M
@ -208,7 +210,14 @@ runChoice ls =
-- Priority on HTTP codes. -- 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 :: 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,6 +30,7 @@ spec = describe "Servant.Server.Internal.Router" $ do
routerSpec :: Spec routerSpec :: Spec
routerSpec = do routerSpec = do
describe "tweakResponse" $ do
let app' :: Application let app' :: Application
app' = toApplication $ runRouter router' 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 (ResponseBuilder (Status i s) hs b) = ResponseBuilder (Status (i + 1) s) hs b
twk b = b twk b = b
describe "tweakResponse" . with (return app') $ do with (return app') $ do
it "calls f on route result" $ do it "calls f on route result" $ do
get "" `shouldRespondWith` 202 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 :: Spec
distributivitySpec = distributivitySpec =
describe "choice" $ do describe "choice" $ do