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 =