From 3a0cbdd0f6c305cb489a44a0868ecc27b8cc9ba1 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Mon, 12 Dec 2016 15:17:06 +0100 Subject: [PATCH] throw 400 on query parameter parse failure --- servant-server/src/Servant/Server/Internal.hs | 46 ++++++++++----- .../Server/Internal/RoutingApplication.hs | 58 ++++++++++++------- .../test/Servant/Server/ErrorSpec.hs | 18 +++--- .../Server/Internal/RoutingApplicationSpec.hs | 3 +- servant-server/test/Servant/ServerSpec.hs | 57 +++++++++++++++++- 5 files changed, 139 insertions(+), 43 deletions(-) diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 62b92612..60c0a044 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -28,7 +28,8 @@ import Control.Monad.Trans.Resource (runResourceT) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC8 import qualified Data.ByteString.Lazy as BL -import Data.Maybe (fromMaybe, mapMaybe) +import Data.Either (partitionEithers) +import Data.Maybe (fromMaybe) import Data.String (fromString) import Data.String.Conversions (cs, (<>)) import Data.Typeable @@ -45,7 +46,7 @@ import Network.Wai (Application, Request, Response, import Prelude () import Prelude.Compat import Web.HttpApiData (FromHttpApiData, parseHeaderMaybe, - parseQueryParamMaybe, + parseQueryParam, parseUrlPieceMaybe, parseUrlPieces) import Servant.API ((:<|>) (..), (:>), BasicAuth, Capture, @@ -311,14 +312,23 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer api context) Maybe a -> ServerT api m route Proxy context subserver = - let querytext r = parseQueryText $ rawQueryString r - param r = - case lookup paramname (querytext r) of - Nothing -> Nothing -- param absent from the query string - Just Nothing -> Nothing -- param present with no value -> Nothing - Just (Just v) -> parseQueryParamMaybe v -- if present, we try to convert to - -- the right type - in route (Proxy :: Proxy api) context (passToServer subserver param) + let querytext req = parseQueryText $ rawQueryString req + parseParam req = + case lookup paramname (querytext req) of + Nothing -> return Nothing -- param absent from the query string + Just Nothing -> return Nothing -- param present with no value -> Nothing + Just (Just v) -> + case parseQueryParam v of + -- TODO: This should set an error description (including + -- paramname) + Left _e -> delayedFailFatal err400 -- parsing the request + -- paramter failed + + Right param -> return $ Just param + delayed = addParameterCheck subserver . withRequest $ \req -> + parseParam req + + in route (Proxy :: Proxy api) context delayed where paramname = cs $ symbolVal (Proxy :: Proxy sym) -- | If you use @'QueryParams' "authors" Text@ in one of the endpoints for your API, @@ -352,12 +362,20 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer api context) -- named "foo" or "foo[]" and call parseQueryParam on the -- corresponding values parameters r = filter looksLikeParam (querytext r) - values r = mapMaybe (convert . snd) (parameters r) - in route (Proxy :: Proxy api) context (passToServer subserver values) + parseParam (paramName, paramTxt) = + case parseQueryParam (fromMaybe "" paramTxt) of + Left _e -> Left paramName -- On error, remember name of parameter + Right paramVal -> Right paramVal + parseParams req = + case partitionEithers $ parseParam <$> parameters req of + ([], params) -> return params -- No errors + -- TODO: This should set an error description + (_errors, _) -> delayedFailFatal err400 + delayed = addParameterCheck subserver . withRequest $ \req -> + parseParams req + in route (Proxy :: Proxy api) context delayed where paramname = cs $ symbolVal (Proxy :: Proxy sym) looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]") - convert Nothing = Nothing - convert (Just v) = parseQueryParamMaybe v -- | If you use @'QueryFlag' "published"@ in one of the endpoints for your API, -- this automatically requires your server-side handler to be a function diff --git a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs index f5c6ca8c..3cee450b 100644 --- a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs +++ b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs @@ -139,7 +139,7 @@ toApplication ra request respond = ra request routingRespond -- Therefore, while routing, we delay most checks so that they -- will ultimately occur in the right order. -- --- A 'Delayed' contains three delayed blocks of tests, and +-- A 'Delayed' contains four delayed blocks of tests, and -- the actual handler: -- -- 1. Delayed captures. These can actually cause 404, and @@ -148,27 +148,36 @@ toApplication ra request respond = ra request routingRespond -- check order from the error reporting, see above). Delayed -- captures can provide inputs to the actual handler. -- --- 2. Method check(s). This can cause a 405. On success, +-- 2. Query parameter checks. They require parsing and can cause 400 if the +-- parsing fails. Query parameter checks provide inputs to the handler +-- +-- 3. Method check(s). This can cause a 405. On success, -- it does not provide an input for the handler. Method checks -- are comparatively cheap. -- --- 3. Body and accept header checks. The request body check can +-- 4. Body and accept header checks. The request body check can -- cause both 400 and 415. This provides an input to the handler. -- The accept header check can be performed as the final -- computation in this block. It can cause a 406. -- data Delayed env c where Delayed :: { capturesD :: env -> DelayedIO captures + , paramsD :: DelayedIO params , methodD :: DelayedIO () , authD :: DelayedIO auth , bodyD :: DelayedIO body - , serverD :: captures -> auth -> body -> Request -> RouteResult c + , serverD :: captures + -> params + -> auth + -> body + -> Request + -> RouteResult c } -> Delayed env c instance Functor (Delayed env) where fmap f Delayed{..} = Delayed - { serverD = \ c a b req -> f <$> serverD c a b req + { serverD = \ c p a b req -> f <$> serverD c p a b req , .. } -- Note [Existential Record Update] @@ -200,7 +209,7 @@ runDelayedIO m req = transResourceT runRouteResultT $ runReaderT (runDelayedIO' -- | A 'Delayed' without any stored checks. emptyDelayed :: RouteResult a -> Delayed env a emptyDelayed result = - Delayed (const r) r r r (\ _ _ _ _ -> result) + Delayed (const r) r r r r (\ _ _ _ _ _ -> result) where r = return () @@ -225,10 +234,21 @@ addCapture :: Delayed env (a -> b) addCapture Delayed{..} new = Delayed { capturesD = \ (txt, env) -> (,) <$> capturesD env <*> new txt - , serverD = \ (x, v) a b req -> ($ v) <$> serverD x a b req + , serverD = \ (x, v) p a b req -> ($ v) <$> serverD x p a b req , .. } -- Note [Existential Record Update] +-- | Add a parameter check to the end of the params block +addParameterCheck :: Delayed env (a -> b) + -> DelayedIO a + -> Delayed env b +addParameterCheck Delayed {..} new = + Delayed + { paramsD = (,) <$> paramsD <*> new + , serverD = \c (p, pNew) a b req -> ($ pNew) <$> serverD c p a b req + , .. + } + -- | Add a method check to the end of the method block. addMethodCheck :: Delayed env a -> DelayedIO () @@ -246,7 +266,7 @@ addAuthCheck :: Delayed env (a -> b) addAuthCheck Delayed{..} new = Delayed { authD = (,) <$> authD <*> new - , serverD = \ c (y, v) b req -> ($ v) <$> serverD c y b req + , serverD = \ c p (y, v) b req -> ($ v) <$> serverD c p y b req , .. } -- Note [Existential Record Update] @@ -257,7 +277,7 @@ addBodyCheck :: Delayed env (a -> b) addBodyCheck Delayed{..} new = Delayed { bodyD = (,) <$> bodyD <*> new - , serverD = \ c a (z, v) req -> ($ v) <$> serverD c a z req + , serverD = \ c p a (z, v) req -> ($ v) <$> serverD c p a z req , .. } -- Note [Existential Record Update] @@ -287,7 +307,7 @@ addAcceptCheck Delayed{..} new = passToServer :: Delayed env (a -> b) -> (Request -> a) -> Delayed env b passToServer Delayed{..} x = Delayed - { serverD = \ c a b req -> ($ x req) <$> serverD c a b req + { serverD = \ c p a b req -> ($ x req) <$> serverD c p a b req , .. } -- Note [Existential Record Update] @@ -301,16 +321,14 @@ runDelayed :: Delayed env a -> env -> Request -> ResourceT IO (RouteResult a) -runDelayed Delayed{..} env req = - runDelayedIO - (do c <- capturesD env - methodD - a <- authD - b <- bodyD - r <- ask - liftRouteResult (serverD c a b r) - ) - req +runDelayed Delayed{..} env = runDelayedIO $ do + c <- capturesD env + methodD + a <- authD + b <- bodyD + r <- ask + p <- paramsD -- Has to be after body to respect the relative error order + liftRouteResult (serverD c p a b r) -- | Runs a delayed server and the resulting action. -- Takes a continuation that lets us send a response. diff --git a/servant-server/test/Servant/Server/ErrorSpec.hs b/servant-server/test/Servant/Server/ErrorSpec.hs index 18c49461..5efb7051 100644 --- a/servant-server/test/Servant/Server/ErrorSpec.hs +++ b/servant-server/test/Servant/Server/ErrorSpec.hs @@ -9,6 +9,7 @@ module Servant.Server.ErrorSpec (spec) where import Data.Aeson (encode) import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Lazy.Char8 as BCL +import Data.Monoid ((<>)) import Data.Proxy import Network.HTTP.Types (hAccept, hAuthorization, hContentType, methodGet, @@ -44,13 +45,14 @@ type ErrorOrderApi = "home" :> BasicAuth "error-realm" () :> ReqBody '[JSON] Int :> Capture "t" Int + :> QueryParam "param" Int :> Post '[JSON] Int errorOrderApi :: Proxy ErrorOrderApi errorOrderApi = Proxy errorOrderServer :: Server ErrorOrderApi -errorOrderServer = \_ _ _ -> throwError err402 +errorOrderServer = \_ _ _ _ -> throwError err402 -- On error priorities: -- @@ -85,7 +87,8 @@ errorOrderSpec = goodContentType = (hContentType, "application/json") goodAccept = (hAccept, "application/json") goodMethod = methodPost - goodUrl = "home/2" + goodUrl = "home/2?param=55" + badParams = goodUrl <> "?param=foo" goodBody = encode (5 :: Int) -- username:password = servant:server goodAuth = (hAuthorization, "Basic c2VydmFudDpzZXJ2ZXI=") @@ -95,22 +98,24 @@ errorOrderSpec = `shouldRespondWith` 404 it "has 405 as its second highest priority error" $ do - request badMethod goodUrl [badAuth, badContentType, badAccept] badBody + request badMethod badParams [badAuth, badContentType, badAccept] badBody `shouldRespondWith` 405 it "has 401 as its third highest priority error (auth)" $ do - request goodMethod goodUrl [badAuth, badContentType, badAccept] badBody + request goodMethod badParams [badAuth, badContentType, badAccept] badBody `shouldRespondWith` 401 it "has 406 as its fourth highest priority error" $ do - request goodMethod goodUrl [goodAuth, badContentType, badAccept] badBody + request goodMethod badParams [goodAuth, badContentType, badAccept] badBody `shouldRespondWith` 406 it "has 415 as its fifth highest priority error" $ do - request goodMethod goodUrl [goodAuth, badContentType, goodAccept] badBody + request goodMethod badParams [goodAuth, badContentType, goodAccept] badBody `shouldRespondWith` 415 it "has 400 as its sixth highest priority error" $ do + request goodMethod badParams [goodAuth, goodContentType, goodAccept] goodBody + `shouldRespondWith` 400 request goodMethod goodUrl [goodAuth, goodContentType, goodAccept] badBody `shouldRespondWith` 400 @@ -221,7 +226,6 @@ errorRetrySpec = then Nothing else Just "body not correct\n" - -- }}} ------------------------------------------------------------------------------ -- * Error Choice {{{ diff --git a/servant-server/test/Servant/Server/Internal/RoutingApplicationSpec.hs b/servant-server/test/Servant/Server/Internal/RoutingApplicationSpec.hs index 776eca1d..c4b72fbf 100644 --- a/servant-server/test/Servant/Server/Internal/RoutingApplicationSpec.hs +++ b/servant-server/test/Servant/Server/Internal/RoutingApplicationSpec.hs @@ -59,11 +59,12 @@ delayed body srv = Delayed { capturesD = \_ -> return () , methodD = return () , authD = return () + , paramsD = return () , bodyD = do liftIO (writeTestResource"hia" >> putStrLn "garbage created") _ <- register (freeTestResource >> putStrLn "garbage collected") body - , serverD = \() () _body _req -> srv + , serverD = \() () () _body _req -> srv } simpleRun :: Delayed () (Handler ()) diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index 17c2f7d1..c0042f44 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -275,12 +275,14 @@ captureAllSpec = do type QueryParamApi = QueryParam "name" String :> Get '[JSON] Person :<|> "a" :> QueryParams "names" String :> Get '[JSON] Person :<|> "b" :> QueryFlag "capitalize" :> Get '[JSON] Person + :<|> "param" :> QueryParam "age" Integer :> Get '[JSON] Person + :<|> "multiparam" :> QueryParams "ages" Integer :> Get '[JSON] Person queryParamApi :: Proxy QueryParamApi queryParamApi = Proxy qpServer :: Server QueryParamApi -qpServer = queryParamServer :<|> qpNames :<|> qpCapitalize +qpServer = queryParamServer :<|> qpNames :<|> qpCapitalize :<|> qpAge :<|> qpAges where qpNames (_:name2:_) = return alice { name = name2 } qpNames _ = return alice @@ -288,6 +290,11 @@ qpServer = queryParamServer :<|> qpNames :<|> qpCapitalize qpCapitalize False = return alice qpCapitalize True = return alice { name = map toUpper (name alice) } + qpAge Nothing = return alice + qpAge (Just age') = return alice{ age = age'} + + qpAges ages = return alice{ age = sum ages} + queryParamServer (Just name_) = return alice{name = name_} queryParamServer Nothing = return alice @@ -319,6 +326,54 @@ queryParamSpec = do name = "john" } + it "parses a query parameter" $ + (flip runSession) (serve queryParamApi qpServer) $ do + let params = "?age=55" + response <- Network.Wai.Test.request defaultRequest{ + rawQueryString = params, + queryString = parseQuery params, + pathInfo = ["param"] + } + liftIO $ + decode' (simpleBody response) `shouldBe` Just alice{ + age = 55 + } + + it "generates an error on query parameter parse failure" $ + (flip runSession) (serve queryParamApi qpServer) $ do + let params = "?age=foo" + response <- Network.Wai.Test.request defaultRequest{ + rawQueryString = params, + queryString = parseQuery params, + pathInfo = ["param"] + } + liftIO $ statusCode (simpleStatus response) `shouldBe` 400 + return () + + it "parses multiple query parameters" $ + (flip runSession) (serve queryParamApi qpServer) $ do + let params = "?ages=10&ages=22" + response <- Network.Wai.Test.request defaultRequest{ + rawQueryString = params, + queryString = parseQuery params, + pathInfo = ["multiparam"] + } + liftIO $ + decode' (simpleBody response) `shouldBe` Just alice{ + age = 32 + } + + it "generates an error on parse failures of multiple parameters" $ + (flip runSession) (serve queryParamApi qpServer) $ do + let params = "?ages=2&ages=foo" + response <- Network.Wai.Test.request defaultRequest{ + rawQueryString = params, + queryString = parseQuery params, + pathInfo = ["multiparam"] + } + liftIO $ statusCode (simpleStatus response) `shouldBe` 400 + return () + it "allows retrieving value-less GET parameters" $ (flip runSession) (serve queryParamApi qpServer) $ do