Ignore redundant trailing slashes (with test case).

This commit is contained in:
Matthias Fischmann 2015-01-05 14:27:06 +01:00
parent 0cc4f975cc
commit 9b8d25c838
2 changed files with 21 additions and 8 deletions

View file

@ -104,6 +104,14 @@ isMismatch :: RouteResult a -> Bool
isMismatch (RR (Left _)) = True isMismatch (RR (Left _)) = True
isMismatch _ = False isMismatch _ = False
-- | Like `null . pathInfo`, but works with redundant trailing slashes.
pathIsEmpty :: Request -> Bool
pathIsEmpty = f . pathInfo
where
f [] = True
f [""] = True
f _ = False
-- | If we get a `Right`, it has precedence over everything else. -- | If we get a `Right`, it has precedence over everything else.
-- --
-- This in particular means that if we could get several 'Right's, -- This in particular means that if we could get several 'Right's,
@ -199,14 +207,14 @@ instance HasServer Delete where
type Server Delete = EitherT (Int, String) IO () type Server Delete = EitherT (Int, String) IO ()
route Proxy action request respond route Proxy action request respond
| null (pathInfo request) && requestMethod request == methodDelete = do | pathIsEmpty request && requestMethod request == methodDelete = do
e <- runEitherT action e <- runEitherT action
respond $ succeedWith $ case e of respond $ succeedWith $ case e of
Right () -> Right () ->
responseLBS status204 [] "" responseLBS status204 [] ""
Left (status, message) -> Left (status, message) ->
responseLBS (mkStatus status (cs message)) [] (cs message) responseLBS (mkStatus status (cs message)) [] (cs message)
| null (pathInfo request) && requestMethod request /= methodDelete = | pathIsEmpty request && requestMethod request /= methodDelete =
respond $ failWith WrongMethod respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound | otherwise = respond $ failWith NotFound
@ -224,14 +232,14 @@ instance HasServer Delete where
instance ToJSON result => HasServer (Get result) where instance ToJSON result => HasServer (Get result) where
type Server (Get result) = EitherT (Int, String) IO result type Server (Get result) = EitherT (Int, String) IO result
route Proxy action request respond route Proxy action request respond
| null (pathInfo request) && requestMethod request == methodGet = do | pathIsEmpty request && requestMethod request == methodGet = do
e <- runEitherT action e <- runEitherT action
respond . succeedWith $ case e of respond . succeedWith $ case e of
Right output -> Right output ->
responseLBS ok200 [("Content-Type", "application/json")] (encode output) responseLBS ok200 [("Content-Type", "application/json")] (encode output)
Left (status, message) -> Left (status, message) ->
responseLBS (mkStatus status (cs message)) [] (cs message) responseLBS (mkStatus status (cs message)) [] (cs message)
| null (pathInfo request) && requestMethod request /= methodGet = | pathIsEmpty request && requestMethod request /= methodGet =
respond $ failWith WrongMethod respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound | otherwise = respond $ failWith NotFound
@ -282,14 +290,14 @@ instance ToJSON a => HasServer (Post a) where
type Server (Post a) = EitherT (Int, String) IO a type Server (Post a) = EitherT (Int, String) IO a
route Proxy action request respond route Proxy action request respond
| null (pathInfo request) && requestMethod request == methodPost = do | pathIsEmpty request && requestMethod request == methodPost = do
e <- runEitherT action e <- runEitherT action
respond . succeedWith $ case e of respond . succeedWith $ case e of
Right out -> Right out ->
responseLBS status201 [("Content-Type", "application/json")] (encode out) responseLBS status201 [("Content-Type", "application/json")] (encode out)
Left (status, message) -> Left (status, message) ->
responseLBS (mkStatus status (cs message)) [] (cs message) responseLBS (mkStatus status (cs message)) [] (cs message)
| null (pathInfo request) && requestMethod request /= methodPost = | pathIsEmpty request && requestMethod request /= methodPost =
respond $ failWith WrongMethod respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound | otherwise = respond $ failWith NotFound
@ -308,14 +316,14 @@ instance ToJSON a => HasServer (Put a) where
type Server (Put a) = EitherT (Int, String) IO a type Server (Put a) = EitherT (Int, String) IO a
route Proxy action request respond route Proxy action request respond
| null (pathInfo request) && requestMethod request == methodPut = do | pathIsEmpty request && requestMethod request == methodPut = do
e <- runEitherT action e <- runEitherT action
respond . succeedWith $ case e of respond . succeedWith $ case e of
Right out -> Right out ->
responseLBS ok200 [("Content-Type", "application/json")] (encode out) responseLBS ok200 [("Content-Type", "application/json")] (encode out)
Left (status, message) -> Left (status, message) ->
responseLBS (mkStatus status (cs message)) [] (cs message) responseLBS (mkStatus status (cs message)) [] (cs message)
| null (pathInfo request) && requestMethod request /= methodPut = | pathIsEmpty request && requestMethod request /= methodPut =
respond $ failWith WrongMethod respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound | otherwise = respond $ failWith NotFound

View file

@ -209,6 +209,11 @@ postSpec = do
matchStatus = 201 matchStatus = 201
} }
it "handles trailing '/' gracefully" $ do
post "/bla/" (encode alice) `shouldRespondWith` "42"{
matchStatus = 201
}
it "correctly rejects invalid request bodies with status 400" $ do it "correctly rejects invalid request bodies with status 400" $ do
post "/" "some invalid body" `shouldRespondWith` 400 post "/" "some invalid body" `shouldRespondWith` 400