git.iko.soy/typeable/servant
on master help sign in
throw 400 on query parameter parse failure
commit3a0cbdd0f6c305cb489a44a0868ecc27b8cc9ba1 authorPhilipp Balzarek <p.balzarek@googlemail.com> dateMon 12 Dec 2016, 15:17 (10 years ago) parent8c32913
5 files changed+139−43
compare with master
unifiedsplit
servant-server/src/Servant/Server/Internal.hs+32−14 servant-server/src/Servant/Server/Internal/RoutingApplication.hs+38−20 servant-server/test/Servant/Server/ErrorSpec.hs+11−7 servant-server/test/Servant/Server/Internal/RoutingApplicationSpec.hs+2−1 servant-server/test/Servant/ServerSpec.hs+56−1
servant-server/src/Servant/Server/Internal.hs+32−14
@@ -28,7 +28,8 @@ import Control.Monad.Trans.Resource (runResourceT)
2828import qualified Data.ByteString as B
2929import qualified Data.ByteString.Char8 as BC8
3030import qualified Data.ByteString.Lazy as BL
31−import Data.Maybe (fromMaybe, mapMaybe)
31+import Data.Either (partitionEithers)
32+import Data.Maybe (fromMaybe)
3233import Data.String (fromString)
3334import Data.String.Conversions (cs, (<>))
3435import Data.Typeable
@@ -45,7 +46,7 @@ import Network.Wai (Application, Request, Response,
4546import Prelude ()
4647import Prelude.Compat
4748import Web.HttpApiData (FromHttpApiData, parseHeaderMaybe,
48− parseQueryParamMaybe,
49+ parseQueryParam,
4950 parseUrlPieceMaybe,
5051 parseUrlPieces)
5152import Servant.API ((:<|>) (..), (:>), BasicAuth, Capture,
@@ -311,14 +312,23 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)
311312 Maybe a -> ServerT api m
312313
313314 route Proxy context subserver =
314− let querytext r = parseQueryText $ rawQueryString r
315− param r =
316− case lookup paramname (querytext r) of
317− Nothing -> Nothing -- param absent from the query string
318− Just Nothing -> Nothing -- param present with no value -> Nothing
319− Just (Just v) -> parseQueryParamMaybe v -- if present, we try to convert to
320− -- the right type
321− in route (Proxy :: Proxy api) context (passToServer subserver param)
315+ let querytext req = parseQueryText $ rawQueryString req
316+ parseParam req =
317+ case lookup paramname (querytext req) of
318+ Nothing -> return Nothing -- param absent from the query string
319+ Just Nothing -> return Nothing -- param present with no value -> Nothing
320+ Just (Just v) ->
321+ case parseQueryParam v of
322+ -- TODO: This should set an error description (including
323+ -- paramname)
324+ Left _e -> delayedFailFatal err400 -- parsing the request
325+ -- paramter failed
326+
327+ Right param -> return $ Just param
328+ delayed = addParameterCheck subserver . withRequest $ \req ->
329+ parseParam req
330+
331+ in route (Proxy :: Proxy api) context delayed
322332 where paramname = cs $ symbolVal (Proxy :: Proxy sym)
323333
324334-- | 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)
352362 -- named "foo" or "foo[]" and call parseQueryParam on the
353363 -- corresponding values
354364 parameters r = filter looksLikeParam (querytext r)
355− values r = mapMaybe (convert . snd) (parameters r)
356− in route (Proxy :: Proxy api) context (passToServer subserver values)
365+ parseParam (paramName, paramTxt) =
366+ case parseQueryParam (fromMaybe "" paramTxt) of
367+ Left _e -> Left paramName -- On error, remember name of parameter
368+ Right paramVal -> Right paramVal
369+ parseParams req =
370+ case partitionEithers $ parseParam <$> parameters req of
371+ ([], params) -> return params -- No errors
372+ -- TODO: This should set an error description
373+ (_errors, _) -> delayedFailFatal err400
374+ delayed = addParameterCheck subserver . withRequest $ \req ->
375+ parseParams req
376+ in route (Proxy :: Proxy api) context delayed
357377 where paramname = cs $ symbolVal (Proxy :: Proxy sym)
358378 looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]")
359− convert Nothing = Nothing
360− convert (Just v) = parseQueryParamMaybe v
361379
362380-- | If you use @'QueryFlag' "published"@ in one of the endpoints for your API,
363381-- this automatically requires your server-side handler to be a function
servant-server/src/Servant/Server/Internal/RoutingApplication.hs+38−20
@@ -139,7 +139,7 @@ toApplication ra request respond = ra request routingRespond
139139-- Therefore, while routing, we delay most checks so that they
140140-- will ultimately occur in the right order.
141141--
142−-- A 'Delayed' contains three delayed blocks of tests, and
142+-- A 'Delayed' contains four delayed blocks of tests, and
143143-- the actual handler:
144144--
145145-- 1. Delayed captures. These can actually cause 404, and
@@ -148,27 +148,36 @@ toApplication ra request respond = ra request routingRespond
148148-- check order from the error reporting, see above). Delayed
149149-- captures can provide inputs to the actual handler.
150150--
151−-- 2. Method check(s). This can cause a 405. On success,
151+-- 2. Query parameter checks. They require parsing and can cause 400 if the
152+-- parsing fails. Query parameter checks provide inputs to the handler
153+--
154+-- 3. Method check(s). This can cause a 405. On success,
152155-- it does not provide an input for the handler. Method checks
153156-- are comparatively cheap.
154157--
155−-- 3. Body and accept header checks. The request body check can
158+-- 4. Body and accept header checks. The request body check can
156159-- cause both 400 and 415. This provides an input to the handler.
157160-- The accept header check can be performed as the final
158161-- computation in this block. It can cause a 406.
159162--
160163data Delayed env c where
161164 Delayed :: { capturesD :: env -> DelayedIO captures
165+ , paramsD :: DelayedIO params
162166 , methodD :: DelayedIO ()
163167 , authD :: DelayedIO auth
164168 , bodyD :: DelayedIO body
165− , serverD :: captures -> auth -> body -> Request -> RouteResult c
169+ , serverD :: captures
170+ -> params
171+ -> auth
172+ -> body
173+ -> Request
174+ -> RouteResult c
166175 } -> Delayed env c
167176
168177instance Functor (Delayed env) where
169178 fmap f Delayed{..} =
170179 Delayed
171− { serverD = \ c a b req -> f <$> serverD c a b req
180+ { serverD = \ c p a b req -> f <$> serverD c p a b req
172181 , ..
173182 } -- Note [Existential Record Update]
174183
@@ -200,7 +209,7 @@ runDelayedIO m req = transResourceT runRouteResultT $ runReaderT (runDelayedIO'
200209-- | A 'Delayed' without any stored checks.
201210emptyDelayed :: RouteResult a -> Delayed env a
202211emptyDelayed result =
203− Delayed (const r) r r r (\ _ _ _ _ -> result)
212+ Delayed (const r) r r r r (\ _ _ _ _ _ -> result)
204213 where
205214 r = return ()
206215
@@ -225,10 +234,21 @@ addCapture :: Delayed env (a -> b)
225234addCapture Delayed{..} new =
226235 Delayed
227236 { capturesD = \ (txt, env) -> (,) <$> capturesD env <*> new txt
228− , serverD = \ (x, v) a b req -> ($ v) <$> serverD x a b req
237+ , serverD = \ (x, v) p a b req -> ($ v) <$> serverD x p a b req
229238 , ..
230239 } -- Note [Existential Record Update]
231240
241+-- | Add a parameter check to the end of the params block
242+addParameterCheck :: Delayed env (a -> b)
243+ -> DelayedIO a
244+ -> Delayed env b
245+addParameterCheck Delayed {..} new =
246+ Delayed
247+ { paramsD = (,) <$> paramsD <*> new
248+ , serverD = \c (p, pNew) a b req -> ($ pNew) <$> serverD c p a b req
249+ , ..
250+ }
251+
232252-- | Add a method check to the end of the method block.
233253addMethodCheck :: Delayed env a
234254 -> DelayedIO ()
@@ -246,7 +266,7 @@ addAuthCheck :: Delayed env (a -> b)
246266addAuthCheck Delayed{..} new =
247267 Delayed
248268 { authD = (,) <$> authD <*> new
249− , serverD = \ c (y, v) b req -> ($ v) <$> serverD c y b req
269+ , serverD = \ c p (y, v) b req -> ($ v) <$> serverD c p y b req
250270 , ..
251271 } -- Note [Existential Record Update]
252272
@@ -257,7 +277,7 @@ addBodyCheck :: Delayed env (a -> b)
257277addBodyCheck Delayed{..} new =
258278 Delayed
259279 { bodyD = (,) <$> bodyD <*> new
260− , serverD = \ c a (z, v) req -> ($ v) <$> serverD c a z req
280+ , serverD = \ c p a (z, v) req -> ($ v) <$> serverD c p a z req
261281 , ..
262282 } -- Note [Existential Record Update]
263283
@@ -287,7 +307,7 @@ addAcceptCheck Delayed{..} new =
287307passToServer :: Delayed env (a -> b) -> (Request -> a) -> Delayed env b
288308passToServer Delayed{..} x =
289309 Delayed
290− { serverD = \ c a b req -> ($ x req) <$> serverD c a b req
310+ { serverD = \ c p a b req -> ($ x req) <$> serverD c p a b req
291311 , ..
292312 } -- Note [Existential Record Update]
293313
@@ -301,16 +321,14 @@ runDelayed :: Delayed env a
301321 -> env
302322 -> Request
303323 -> ResourceT IO (RouteResult a)
304−runDelayed Delayed{..} env req =
305− runDelayedIO
306− (do c <- capturesD env
307− methodD
308− a <- authD
309− b <- bodyD
310− r <- ask
311− liftRouteResult (serverD c a b r)
312− )
313− req
324+runDelayed Delayed{..} env = runDelayedIO $ do
325+ c <- capturesD env
326+ methodD
327+ a <- authD
328+ b <- bodyD
329+ r <- ask
330+ p <- paramsD -- Has to be after body to respect the relative error order
331+ liftRouteResult (serverD c p a b r)
314332
315333-- | Runs a delayed server and the resulting action.
316334-- Takes a continuation that lets us send a response.
servant-server/test/Servant/Server/ErrorSpec.hs+11−7
@@ -9,6 +9,7 @@ module Servant.Server.ErrorSpec (spec) where
99import Data.Aeson (encode)
1010import qualified Data.ByteString.Char8 as BC
1111import qualified Data.ByteString.Lazy.Char8 as BCL
12+import Data.Monoid ((<>))
1213import Data.Proxy
1314import Network.HTTP.Types (hAccept, hAuthorization,
1415 hContentType, methodGet,
@@ -44,13 +45,14 @@ type ErrorOrderApi = "home"
4445 :> BasicAuth "error-realm" ()
4546 :> ReqBody '[JSON] Int
4647 :> Capture "t" Int
48+ :> QueryParam "param" Int
4749 :> Post '[JSON] Int
4850
4951errorOrderApi :: Proxy ErrorOrderApi
5052errorOrderApi = Proxy
5153
5254errorOrderServer :: Server ErrorOrderApi
53−errorOrderServer = \_ _ _ -> throwError err402
55+errorOrderServer = \_ _ _ _ -> throwError err402
5456
5557-- On error priorities:
5658--
@@ -85,7 +87,8 @@ errorOrderSpec =
8587 goodContentType = (hContentType, "application/json")
8688 goodAccept = (hAccept, "application/json")
8789 goodMethod = methodPost
88− goodUrl = "home/2"
90+ goodUrl = "home/2?param=55"
91+ badParams = goodUrl <> "?param=foo"
8992 goodBody = encode (5 :: Int)
9093 -- username:password = servant:server
9194 goodAuth = (hAuthorization, "Basic c2VydmFudDpzZXJ2ZXI=")
@@ -95,22 +98,24 @@ errorOrderSpec =
9598 `shouldRespondWith` 404
9699
97100 it "has 405 as its second highest priority error" $ do
98− request badMethod goodUrl [badAuth, badContentType, badAccept] badBody
101+ request badMethod badParams [badAuth, badContentType, badAccept] badBody
99102 `shouldRespondWith` 405
100103
101104 it "has 401 as its third highest priority error (auth)" $ do
102− request goodMethod goodUrl [badAuth, badContentType, badAccept] badBody
105+ request goodMethod badParams [badAuth, badContentType, badAccept] badBody
103106 `shouldRespondWith` 401
104107
105108 it "has 406 as its fourth highest priority error" $ do
106− request goodMethod goodUrl [goodAuth, badContentType, badAccept] badBody
109+ request goodMethod badParams [goodAuth, badContentType, badAccept] badBody
107110 `shouldRespondWith` 406
108111
109112 it "has 415 as its fifth highest priority error" $ do
110− request goodMethod goodUrl [goodAuth, badContentType, goodAccept] badBody
113+ request goodMethod badParams [goodAuth, badContentType, goodAccept] badBody
111114 `shouldRespondWith` 415
112115
113116 it "has 400 as its sixth highest priority error" $ do
117+ request goodMethod badParams [goodAuth, goodContentType, goodAccept] goodBody
118+ `shouldRespondWith` 400
114119 request goodMethod goodUrl [goodAuth, goodContentType, goodAccept] badBody
115120 `shouldRespondWith` 400
116121
@@ -221,7 +226,6 @@ errorRetrySpec =
221226 then Nothing
222227 else Just "body not correct\n"
223228
224−
225229-- }}}
226230------------------------------------------------------------------------------
227231-- * Error Choice {{{
servant-server/test/Servant/Server/Internal/RoutingApplicationSpec.hs+2−1
@@ -59,11 +59,12 @@ delayed body srv = Delayed
5959 { capturesD = \_ -> return ()
6060 , methodD = return ()
6161 , authD = return ()
62+ , paramsD = return ()
6263 , bodyD = do
6364 liftIO (writeTestResource"hia" >> putStrLn "garbage created")
6465 _ <- register (freeTestResource >> putStrLn "garbage collected")
6566 body
66− , serverD = \() () _body _req -> srv
67+ , serverD = \() () () _body _req -> srv
6768 }
6869
6970simpleRun :: Delayed () (Handler ())
servant-server/test/Servant/ServerSpec.hs+56−1
@@ -275,12 +275,14 @@ captureAllSpec = do
275275type QueryParamApi = QueryParam "name" String :> Get '[JSON] Person
276276 :<|> "a" :> QueryParams "names" String :> Get '[JSON] Person
277277 :<|> "b" :> QueryFlag "capitalize" :> Get '[JSON] Person
278+ :<|> "param" :> QueryParam "age" Integer :> Get '[JSON] Person
279+ :<|> "multiparam" :> QueryParams "ages" Integer :> Get '[JSON] Person
278280
279281queryParamApi :: Proxy QueryParamApi
280282queryParamApi = Proxy
281283
282284qpServer :: Server QueryParamApi
283−qpServer = queryParamServer :<|> qpNames :<|> qpCapitalize
285+qpServer = queryParamServer :<|> qpNames :<|> qpCapitalize :<|> qpAge :<|> qpAges
284286
285287 where qpNames (_:name2:_) = return alice { name = name2 }
286288 qpNames _ = return alice
@@ -288,6 +290,11 @@ qpServer = queryParamServer :<|> qpNames :<|> qpCapitalize
288290 qpCapitalize False = return alice
289291 qpCapitalize True = return alice { name = map toUpper (name alice) }
290292
293+ qpAge Nothing = return alice
294+ qpAge (Just age') = return alice{ age = age'}
295+
296+ qpAges ages = return alice{ age = sum ages}
297+
291298 queryParamServer (Just name_) = return alice{name = name_}
292299 queryParamServer Nothing = return alice
293300
@@ -319,6 +326,54 @@ queryParamSpec = do
319326 name = "john"
320327 }
321328
329+ it "parses a query parameter" $
330+ (flip runSession) (serve queryParamApi qpServer) $ do
331+ let params = "?age=55"
332+ response <- Network.Wai.Test.request defaultRequest{
333+ rawQueryString = params,
334+ queryString = parseQuery params,
335+ pathInfo = ["param"]
336+ }
337+ liftIO $
338+ decode' (simpleBody response) `shouldBe` Just alice{
339+ age = 55
340+ }
341+
342+ it "generates an error on query parameter parse failure" $
343+ (flip runSession) (serve queryParamApi qpServer) $ do
344+ let params = "?age=foo"
345+ response <- Network.Wai.Test.request defaultRequest{
346+ rawQueryString = params,
347+ queryString = parseQuery params,
348+ pathInfo = ["param"]
349+ }
350+ liftIO $ statusCode (simpleStatus response) `shouldBe` 400
351+ return ()
352+
353+ it "parses multiple query parameters" $
354+ (flip runSession) (serve queryParamApi qpServer) $ do
355+ let params = "?ages=10&ages=22"
356+ response <- Network.Wai.Test.request defaultRequest{
357+ rawQueryString = params,
358+ queryString = parseQuery params,
359+ pathInfo = ["multiparam"]
360+ }
361+ liftIO $
362+ decode' (simpleBody response) `shouldBe` Just alice{
363+ age = 32
364+ }
365+
366+ it "generates an error on parse failures of multiple parameters" $
367+ (flip runSession) (serve queryParamApi qpServer) $ do
368+ let params = "?ages=2&ages=foo"
369+ response <- Network.Wai.Test.request defaultRequest{
370+ rawQueryString = params,
371+ queryString = parseQuery params,
372+ pathInfo = ["multiparam"]
373+ }
374+ liftIO $ statusCode (simpleStatus response) `shouldBe` 400
375+ return ()
376+
322377
323378 it "allows retrieving value-less GET parameters" $
324379 (flip runSession) (serve queryParamApi qpServer) $ do