git.iko.soy/typeable/servant
on master help sign in
Merge pull request #1103 from tstat/capture-parse-failure-fix

Set http failure code priority explicitly

commitdf6e992675d64497de1fee2dec221206b0b4483b authorOleg Grenrus <oleg.grenrus@iki.fi> dateSat 2 Feb 2019, 10:23 (8 years ago) parent28ac8c09d8a811
2 files changed+51−17
compare with master
unifiedsplit
servant-server/src/Servant/Server/Internal/Router.hs+12−3 servant-server/test/Servant/Server/RouterSpec.hs+39−14
servant-server/src/Servant/Server/Internal/Router.hs+12−3
@@ -7,6 +7,8 @@ module Servant.Server.Internal.Router where
77import Prelude ()
88import Prelude.Compat
99
10+import Data.Function
11+ (on)
1012import Data.Map
1113 (Map)
1214import qualified Data.Map as M
@@ -208,7 +210,14 @@ runChoice ls =
208210
209211-- Priority on HTTP codes.
210212--
211−-- It just so happens that 404 < 405 < 406 as far as
212−-- we are concerned here, so we can use (<).
213213worseHTTPCode :: Int -> Int -> Bool
214−worseHTTPCode = (<)
214+worseHTTPCode = on (<) toPriority
215+ where
216+ toPriority :: Int -> Int
217+ toPriority 404 = 0 -- not found
218+ toPriority 405 = 1 -- method not allowed
219+ toPriority 401 = 2 -- unauthorized
220+ toPriority 415 = 3 -- unsupported media type
221+ toPriority 406 = 4 -- not acceptable
222+ toPriority 400 = 6 -- bad request
223+ toPriority _ = 5
servant-server/test/Servant/Server/RouterSpec.hs+39−14
@@ -30,20 +30,45 @@ spec = describe "Servant.Server.Internal.Router" $ do
3030
3131routerSpec :: Spec
3232routerSpec = do
33− let app' :: Application
34− app' = toApplication $ runRouter router'
35−
36− router', router :: Router ()
37− router' = tweakResponse (fmap twk) router
38− router = leafRouter $ \_ _ cont -> cont (Route $ responseBuilder (Status 201 "") [] "")
39−
40− twk :: Response -> Response
41− twk (ResponseBuilder (Status i s) hs b) = ResponseBuilder (Status (i + 1) s) hs b
42− twk b = b
43−
44− describe "tweakResponse" . with (return app') $ do
45− it "calls f on route result" $ do
46− get "" `shouldRespondWith` 202
33+ describe "tweakResponse" $ do
34+ let app' :: Application
35+ app' = toApplication $ runRouter router'
36+
37+ router', router :: Router ()
38+ router' = tweakResponse (fmap twk) router
39+ router = leafRouter $ \_ _ cont -> cont (Route $ responseBuilder (Status 201 "") [] "")
40+
41+ twk :: Response -> Response
42+ twk (ResponseBuilder (Status i s) hs b) = ResponseBuilder (Status (i + 1) s) hs b
43+ twk b = b
44+
45+ with (return app') $ do
46+ it "calls f on route result" $ do
47+ get "" `shouldRespondWith` 202
48+
49+ describe "runRouter" $ do
50+ let toApp :: Router () -> Application
51+ toApp = toApplication . runRouter
52+
53+ cap :: Router ()
54+ cap = CaptureRouter $
55+ let delayed = addCapture (emptyDelayed $ Route pure) (const $ delayedFail err400)
56+ in leafRouter
57+ $ \env req res ->
58+ runAction delayed env req res
59+ . const
60+ $ Route success
61+
62+ router :: Router ()
63+ router = leafRouter (\_ _ res -> res $ Route success)
64+ `Choice` cap
65+
66+ success :: Response
67+ success = responseBuilder (Status 200 "") [] ""
68+
69+ with (pure $ toApp router) $ do
70+ it "capture failure returns a 400 response" $ do
71+ get "/badcapture" `shouldRespondWith` 400
4772
4873distributivitySpec :: Spec
4974distributivitySpec =