git.iko.soy/servant
on master help sign in
Merge pull request #670 from phadej/pull-649

Throw error on param parse failure.

commit22b4d1301d78c58833dc3debb4c37bd1806cf226 authorOleg Grenrus <oleg.grenrus@iki.fi> dateThu 19 Jan 2017, 11:44 (10 years ago) parent8c3291358e931f
7 files changed+219−85
compare with master
unifiedsplit
servant-server/CHANGELOG.md+4 servant-server/src/Servant/Server/Internal.hs+52−29 servant-server/src/Servant/Server/Internal/RoutingApplication.hs+60−31 servant-server/test/Servant/Server/ErrorSpec.hs+23−9 servant-server/test/Servant/Server/Internal/RoutingApplicationSpec.hs+11−7 servant-server/test/Servant/ServerSpec.hs+56−1 servant/src/Servant/API/ContentTypes.hs+13−8
servant-server/CHANGELOG.md+4
@@ -3,6 +3,10 @@
33
44* Add `err422` Unprocessable Entity
55 ([#646](https://github.com/haskell-servant/servant/pull/646))
6+* Changed `HasServer` instances for `QueryParam` and `QueryParam` to throw 400
7+ when parsing fails
8+ ([#649](6e77453b67dc164e5381fb867e5e6475302619a3))
9+* Added `paramD` block to `Delayed`
610
711* `Handler` is now an abstract datatype. Migration hint: change `throwE` to `throwError`.
812 ([#641](https://github.com/haskell-servant/servant/issues/641))
servant-server/src/Servant/Server/Internal.hs+52−29
@@ -29,8 +29,10 @@ import qualified Data.ByteString as B
2929import qualified Data.ByteString.Char8 as BC8
3030import qualified Data.ByteString.Lazy as BL
3131import Data.Maybe (fromMaybe, mapMaybe)
32+import Data.Either (partitionEithers)
3233import Data.String (fromString)
3334import Data.String.Conversions (cs, (<>))
35+import qualified Data.Text as T
3436import Data.Typeable
3537import GHC.TypeLits (KnownNat, KnownSymbol, natVal,
3638 symbolVal)
@@ -45,7 +47,7 @@ import Network.Wai (Application, Request, Response,
4547import Prelude ()
4648import Prelude.Compat
4749import Web.HttpApiData (FromHttpApiData, parseHeaderMaybe,
48− parseQueryParamMaybe,
50+ parseQueryParam,
4951 parseUrlPieceMaybe,
5052 parseUrlPieces)
5153import Servant.API ((:<|>) (..), (:>), BasicAuth, Capture,
@@ -311,14 +313,22 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)
311313 Maybe a -> ServerT api m
312314
313315 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)
316+ let querytext req = parseQueryText $ rawQueryString req
317+ parseParam req =
318+ case lookup paramname (querytext req) of
319+ Nothing -> return Nothing -- param absent from the query string
320+ Just Nothing -> return Nothing -- param present with no value -> Nothing
321+ Just (Just v) ->
322+ case parseQueryParam v of
323+ Left e -> delayedFailFatal err400
324+ { errBody = cs $ "Error parsing query parameter " <> paramname <> " failed: " <> e
325+ }
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,
@@ -346,18 +356,25 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)
346356 type ServerT (QueryParams sym a :> api) m =
347357 [a] -> ServerT api m
348358
349− route Proxy context subserver =
350− let querytext r = parseQueryText $ rawQueryString r
351− -- if sym is "foo", we look for query string parameters
352− -- named "foo" or "foo[]" and call parseQueryParam on the
353− -- corresponding values
354− parameters r = filter looksLikeParam (querytext r)
355− values r = mapMaybe (convert . snd) (parameters r)
356− in route (Proxy :: Proxy api) context (passToServer subserver values)
357− where paramname = cs $ symbolVal (Proxy :: Proxy sym)
358− looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]")
359− convert Nothing = Nothing
360− convert (Just v) = parseQueryParamMaybe v
359+ route Proxy context subserver = route (Proxy :: Proxy api) context $
360+ subserver `addParameterCheck` withRequest paramsCheck
361+ where
362+ paramname = cs $ symbolVal (Proxy :: Proxy sym)
363+ paramsCheck req =
364+ case partitionEithers $ fmap parseQueryParam params of
365+ ([], parsed) -> return parsed
366+ (errs, _) -> delayedFailFatal err400
367+ { errBody = cs $ "Error parsing query parameter(s) " <> paramname <> " failed: " <> T.intercalate ", " errs
368+ }
369+ where
370+ params :: [T.Text]
371+ params = mapMaybe snd
372+ . filter (looksLikeParam . fst)
373+ . parseQueryText
374+ . rawQueryString
375+ $ req
376+
377+ looksLikeParam name = name == paramname || name == (paramname <> "[]")
361378
362379-- | If you use @'QueryFlag' "published"@ in one of the endpoints for your API,
363380-- this automatically requires your server-side handler to be a function
@@ -439,22 +456,28 @@ instance ( AllCTUnrender list a, HasServer api context
439456 type ServerT (ReqBody list a :> api) m =
440457 a -> ServerT api m
441458
442− route Proxy context subserver =
443− route (Proxy :: Proxy api) context (addBodyCheck subserver bodyCheck)
459+ route Proxy context subserver
460+ = route (Proxy :: Proxy api) context $
461+ addBodyCheck subserver ctCheck bodyCheck
444462 where
445− bodyCheck = withRequest $ \ request -> do
463+ -- Content-Type check, we only lookup we can try to parse the request body
464+ ctCheck = withRequest $ \ request -> do
446465 -- See HTTP RFC 2616, section 7.2.1
447466 -- http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1
448467 -- See also "W3C Internet Media Type registration, consistency of use"
449468 -- http://www.w3.org/2001/tag/2002/0129-mime
450469 let contentTypeH = fromMaybe "application/octet-stream"
451470 $ lookup hContentType $ requestHeaders request
452− mrqbody <- handleCTypeH (Proxy :: Proxy list) (cs contentTypeH)
453− <$> liftIO (lazyRequestBody request)
471+ case canHandleCTypeH (Proxy :: Proxy list) (cs contentTypeH) :: Maybe (BL.ByteString -> Either String a) of
472+ Nothing -> delayedFailFatal err415
473+ Just f -> return f
474+
475+ -- Body check, we get a body parsing functions as the first argument.
476+ bodyCheck f = withRequest $ \ request -> do
477+ mrqbody <- f <$> liftIO (lazyRequestBody request)
454478 case mrqbody of
455− Nothing -> delayedFailFatal err415
456− Just (Left e) -> delayedFailFatal err400 { errBody = cs e }
457− Just (Right v) -> return v
479+ Left e -> delayedFailFatal err400 { errBody = cs e }
480+ Right v -> return v
458481
459482-- | Make sure the incoming request starts with @"/path"@, strip it and
460483-- pass the rest of the request path to @api@.
servant-server/src/Servant/Server/Internal/RoutingApplication.hs+60−31
@@ -132,14 +132,14 @@ toApplication ra request respond = ra request routingRespond
132132-- 405 (bad method)
133133-- 401 (unauthorized)
134134-- 415 (unsupported media type)
135−-- 400 (bad request)
136135-- 406 (not acceptable)
136+-- 400 (bad request)
137137-- @
138138--
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 many delayed blocks of tests, and
143143-- the actual handler:
144144--
145145-- 1. Delayed captures. These can actually cause 404, and
@@ -152,23 +152,36 @@ toApplication ra request respond = ra request routingRespond
152152-- it does not provide an input for the handler. Method checks
153153-- are comparatively cheap.
154154--
155−-- 3. Body and accept header checks. The request body check can
156−-- cause both 400 and 415. This provides an input to the handler.
157−-- The accept header check can be performed as the final
158−-- computation in this block. It can cause a 406.
155+-- 3. Authentication checks. This can cause 401.
156+--
157+-- 4. Accept and content type header checks. These checks
158+-- can cause 415 and 406 errors.
159+--
160+-- 5. Query parameter checks. They require parsing and can cause 400 if the
161+-- parsing fails. Query parameter checks provide inputs to the handler
162+--
163+-- 6. Body check. The request body check can cause 400.
159164--
160165data Delayed env c where
161166 Delayed :: { capturesD :: env -> DelayedIO captures
162167 , methodD :: DelayedIO ()
163168 , authD :: DelayedIO auth
164− , bodyD :: DelayedIO body
165− , serverD :: captures -> auth -> body -> Request -> RouteResult c
169+ , acceptD :: DelayedIO ()
170+ , contentD :: DelayedIO contentType
171+ , paramsD :: DelayedIO params
172+ , bodyD :: contentType -> DelayedIO body
173+ , serverD :: captures
174+ -> params
175+ -> auth
176+ -> body
177+ -> Request
178+ -> RouteResult c
166179 } -> Delayed env c
167180
168181instance Functor (Delayed env) where
169182 fmap f Delayed{..} =
170183 Delayed
171− { serverD = \ c a b req -> f <$> serverD c a b req
184+ { serverD = \ c p a b req -> f <$> serverD c p a b req
172185 , ..
173186 } -- Note [Existential Record Update]
174187
@@ -200,7 +213,7 @@ runDelayedIO m req = transResourceT runRouteResultT $ runReaderT (runDelayedIO'
200213-- | A 'Delayed' without any stored checks.
201214emptyDelayed :: RouteResult a -> Delayed env a
202215emptyDelayed result =
203− Delayed (const r) r r r (\ _ _ _ _ -> result)
216+ Delayed (const r) r r r r r (const r) (\ _ _ _ _ _ -> result)
204217 where
205218 r = return ()
206219
@@ -225,10 +238,21 @@ addCapture :: Delayed env (a -> b)
225238addCapture Delayed{..} new =
226239 Delayed
227240 { capturesD = \ (txt, env) -> (,) <$> capturesD env <*> new txt
228− , serverD = \ (x, v) a b req -> ($ v) <$> serverD x a b req
241+ , serverD = \ (x, v) p a b req -> ($ v) <$> serverD x p a b req
229242 , ..
230243 } -- Note [Existential Record Update]
231244
245+-- | Add a parameter check to the end of the params block
246+addParameterCheck :: Delayed env (a -> b)
247+ -> DelayedIO a
248+ -> Delayed env b
249+addParameterCheck Delayed {..} new =
250+ Delayed
251+ { paramsD = (,) <$> paramsD <*> new
252+ , serverD = \c (p, pNew) a b req -> ($ pNew) <$> serverD c p a b req
253+ , ..
254+ }
255+
232256-- | Add a method check to the end of the method block.
233257addMethodCheck :: Delayed env a
234258 -> DelayedIO ()
@@ -246,24 +270,29 @@ addAuthCheck :: Delayed env (a -> b)
246270addAuthCheck Delayed{..} new =
247271 Delayed
248272 { authD = (,) <$> authD <*> new
249− , serverD = \ c (y, v) b req -> ($ v) <$> serverD c y b req
273+ , serverD = \ c p (y, v) b req -> ($ v) <$> serverD c p y b req
250274 , ..
251275 } -- Note [Existential Record Update]
252276
253−-- | Add a body check to the end of the body block.
277+-- | Add a content type and body checks around parameter checks.
278+--
279+-- We'll report failed content type check (415), before trying to parse
280+-- query parameters (400). Which, in turn, happens before request body parsing.
254281addBodyCheck :: Delayed env (a -> b)
255− -> DelayedIO a
282+ -> DelayedIO c -- ^ content type check
283+ -> (c -> DelayedIO a) -- ^ body check
256284 -> Delayed env b
257−addBodyCheck Delayed{..} new =
285+addBodyCheck Delayed{..} newContentD newBodyD =
258286 Delayed
259− { bodyD = (,) <$> bodyD <*> new
260− , serverD = \ c a (z, v) req -> ($ v) <$> serverD c a z req
287+ { contentD = (,) <$> contentD <*> newContentD
288+ , bodyD = \(content, c) -> (,) <$> bodyD content <*> newBodyD c
289+ , serverD = \ c p a (z, v) req -> ($ v) <$> serverD c p a z req
261290 , ..
262291 } -- Note [Existential Record Update]
263292
264293
265−-- | Add an accept header check to the beginning of the body
266−-- block. There is a tradeoff here. In principle, we'd like
294+-- | Add an accept header check before handling parameters.
295+-- In principle, we'd like
267296-- to take a bad body (400) response take precedence over a
268297-- failed accept check (406). BUT to allow streaming the body,
269298-- we cannot run the body check and then still backtrack.
@@ -277,7 +306,7 @@ addAcceptCheck :: Delayed env a
277306 -> Delayed env a
278307addAcceptCheck Delayed{..} new =
279308 Delayed
280− { bodyD = new *> bodyD
309+ { acceptD = acceptD *> new
281310 , ..
282311 } -- Note [Existential Record Update]
283312
@@ -287,7 +316,7 @@ addAcceptCheck Delayed{..} new =
287316passToServer :: Delayed env (a -> b) -> (Request -> a) -> Delayed env b
288317passToServer Delayed{..} x =
289318 Delayed
290− { serverD = \ c a b req -> ($ x req) <$> serverD c a b req
319+ { serverD = \ c p a b req -> ($ x req) <$> serverD c p a b req
291320 , ..
292321 } -- Note [Existential Record Update]
293322
@@ -301,16 +330,16 @@ runDelayed :: Delayed env a
301330 -> env
302331 -> Request
303332 -> 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
333+runDelayed Delayed{..} env = runDelayedIO $ do
334+ r <- ask
335+ c <- capturesD env
336+ methodD
337+ a <- authD
338+ acceptD
339+ content <- contentD
340+ p <- paramsD -- Has to be before body parsing, but after content-type checks
341+ b <- bodyD content
342+ liftRouteResult (serverD c p a b r)
314343
315344-- | Runs a delayed server and the resulting action.
316345-- Takes a continuation that lets us send a response.
servant-server/test/Servant/Server/ErrorSpec.hs+23−9
@@ -6,9 +6,11 @@
66{-# OPTIONS_GHC -fno-warn-orphans #-}
77module Servant.Server.ErrorSpec (spec) where
88
9+import Control.Monad (when)
910import Data.Aeson (encode)
1011import qualified Data.ByteString.Char8 as BC
1112import qualified Data.ByteString.Lazy.Char8 as BCL
13+import Data.Monoid ((<>))
1214import Data.Proxy
1315import Network.HTTP.Types (hAccept, hAuthorization,
1416 hContentType, methodGet,
@@ -44,13 +46,14 @@ type ErrorOrderApi = "home"
4446 :> BasicAuth "error-realm" ()
4547 :> ReqBody '[JSON] Int
4648 :> Capture "t" Int
49+ :> QueryParam "param" Int
4750 :> Post '[JSON] Int
4851
4952errorOrderApi :: Proxy ErrorOrderApi
5053errorOrderApi = Proxy
5154
5255errorOrderServer :: Server ErrorOrderApi
53−errorOrderServer = \_ _ _ -> throwError err402
56+errorOrderServer = \_ _ _ _ -> throwError err402
5457
5558-- On error priorities:
5659--
@@ -85,7 +88,8 @@ errorOrderSpec =
8588 goodContentType = (hContentType, "application/json")
8689 goodAccept = (hAccept, "application/json")
8790 goodMethod = methodPost
88− goodUrl = "home/2"
91+ goodUrl = "home/2?param=55"
92+ badParams = goodUrl <> "?param=foo"
8993 goodBody = encode (5 :: Int)
9094 -- username:password = servant:server
9195 goodAuth = (hAuthorization, "Basic c2VydmFudDpzZXJ2ZXI=")
@@ -95,24 +99,35 @@ errorOrderSpec =
9599 `shouldRespondWith` 404
96100
97101 it "has 405 as its second highest priority error" $ do
98− request badMethod goodUrl [badAuth, badContentType, badAccept] badBody
102+ request badMethod badParams [badAuth, badContentType, badAccept] badBody
99103 `shouldRespondWith` 405
100104
101105 it "has 401 as its third highest priority error (auth)" $ do
102− request goodMethod goodUrl [badAuth, badContentType, badAccept] badBody
106+ request goodMethod badParams [badAuth, badContentType, badAccept] badBody
103107 `shouldRespondWith` 401
104108
105109 it "has 406 as its fourth highest priority error" $ do
106− request goodMethod goodUrl [goodAuth, badContentType, badAccept] badBody
110+ request goodMethod badParams [goodAuth, badContentType, badAccept] badBody
107111 `shouldRespondWith` 406
108112
109113 it "has 415 as its fifth highest priority error" $ do
110− request goodMethod goodUrl [goodAuth, badContentType, goodAccept] badBody
114+ request goodMethod badParams [goodAuth, badContentType, goodAccept] badBody
111115 `shouldRespondWith` 415
112116
113117 it "has 400 as its sixth highest priority error" $ do
114− request goodMethod goodUrl [goodAuth, goodContentType, goodAccept] badBody
115− `shouldRespondWith` 400
118+ badParamsRes <- request goodMethod badParams [goodAuth, goodContentType, goodAccept] goodBody
119+ badBodyRes <- request goodMethod goodUrl [goodAuth, goodContentType, goodAccept] badBody
120+
121+ -- Both bad body and bad params result in 400
122+ return badParamsRes `shouldRespondWith` 400
123+ return badBodyRes `shouldRespondWith` 400
124+
125+ -- Param check should occur before body checks
126+ both <- request goodMethod badParams [goodAuth, goodContentType, goodAccept ] badBody
127+ when (both /= badParamsRes) $ liftIO $
128+ expectationFailure $ "badParams + badBody /= badParams: " ++ show both ++ ", " ++ show badParamsRes
129+ when (both == badBodyRes) $ liftIO $
130+ expectationFailure $ "badParams + badBody == badBody: " ++ show both
116131
117132 it "has handler-level errors as last priority" $ do
118133 request goodMethod goodUrl [goodAuth, goodContentType, goodAccept] goodBody
@@ -221,7 +236,6 @@ errorRetrySpec =
221236 then Nothing
222237 else Just "body not correct\n"
223238
224−
225239-- }}}
226240------------------------------------------------------------------------------
227241-- * Error Choice {{{
servant-server/test/Servant/Server/Internal/RoutingApplicationSpec.hs+11−7
@@ -19,6 +19,7 @@ import Data.Proxy
1919import GHC.TypeLits (Symbol, KnownSymbol, symbolVal)
2020import Servant
2121import Servant.Server.Internal.RoutingApplication
22+import Network.Wai (defaultRequest)
2223import Test.Hspec
2324import Test.Hspec.Wai (request, shouldRespondWith, with)
2425
@@ -56,20 +57,23 @@ freeTestResource = modifyIORef delayedTestRef $ \r -> case r of
5657
5758delayed :: DelayedIO () -> RouteResult (Handler ()) -> Delayed () (Handler ())
5859delayed body srv = Delayed
59− { capturesD = \_ -> return ()
60+ { capturesD = \() -> return ()
6061 , methodD = return ()
6162 , authD = return ()
62− , bodyD = do
63− liftIO (writeTestResource"hia" >> putStrLn "garbage created")
63+ , acceptD = return ()
64+ , contentD = return ()
65+ , paramsD = return ()
66+ , bodyD = \() -> do
67+ liftIO (writeTestResource "hia" >> putStrLn "garbage created")
6468 _ <- register (freeTestResource >> putStrLn "garbage collected")
6569 body
66− , serverD = \() () _body _req -> srv
70+ , serverD = \() () () _body _req -> srv
6771 }
6872
6973simpleRun :: Delayed () (Handler ())
7074 -> IO ()
7175simpleRun d = fmap (either ignoreE id) . try $
72− runAction d () undefined (\_ -> return ()) (\_ -> FailFatal err500)
76+ runAction d () defaultRequest (\_ -> return ()) (\_ -> FailFatal err500)
7377
7478 where ignoreE :: SomeException -> ()
7579 ignoreE = const ()
@@ -84,10 +88,10 @@ data Res (sym :: Symbol)
8488instance (KnownSymbol sym, HasServer api ctx) => HasServer (Res sym :> api) ctx where
8589 type ServerT (Res sym :> api) m = IORef (TestResource String) -> ServerT api m
8690 route Proxy ctx server = route (Proxy :: Proxy api) ctx $
87− server `addBodyCheck` check
91+ addBodyCheck server (return ()) check
8892 where
8993 sym = symbolVal (Proxy :: Proxy sym)
90− check = do
94+ check () = do
9195 liftIO $ writeTestResource sym
9296 _ <- register freeTestResource
9397 return delayedTestRef
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
servant/src/Servant/API/ContentTypes.hs+13−8
@@ -220,14 +220,20 @@ class Accept ctype => MimeUnrender ctype a where
220220 {-# MINIMAL mimeUnrender | mimeUnrenderWithType #-}
221221
222222class AllCTUnrender (list :: [*]) a where
223+ canHandleCTypeH
224+ :: Proxy list
225+ -> ByteString -- Content-Type header
226+ -> Maybe (ByteString -> Either String a)
227+
223228 handleCTypeH :: Proxy list
224229 -> ByteString -- Content-Type header
225230 -> ByteString -- Request body
226231 -> Maybe (Either String a)
232+ handleCTypeH p ctypeH body = ($ body) `fmap` canHandleCTypeH p ctypeH
227233
228234instance ( AllMimeUnrender ctyps a ) => AllCTUnrender ctyps a where
229− handleCTypeH _ ctypeH body = M.mapContentMedia lkup (cs ctypeH)
230− where lkup = allMimeUnrender (Proxy :: Proxy ctyps) body
235+ canHandleCTypeH p ctypeH =
236+ M.mapContentMedia (allMimeUnrender p) (cs ctypeH)
231237
232238--------------------------------------------------------------------------
233239-- * Utils (Internal)
@@ -292,20 +298,19 @@ instance OVERLAPPING_
292298--------------------------------------------------------------------------
293299class (AllMime list) => AllMimeUnrender (list :: [*]) a where
294300 allMimeUnrender :: Proxy list
295− -> ByteString
296− -> [(M.MediaType, Either String a)]
301+ -> [(M.MediaType, ByteString -> Either String a)]
297302
298303instance AllMimeUnrender '[] a where
299− allMimeUnrender _ _ = []
304+ allMimeUnrender _ = []
300305
301306instance ( MimeUnrender ctyp a
302307 , AllMimeUnrender ctyps a
303308 ) => AllMimeUnrender (ctyp ': ctyps) a where
304− allMimeUnrender _ bs =
309+ allMimeUnrender _ =
305310 (map mk $ NE.toList $ contentTypes pctyp)
306− ++ allMimeUnrender pctyps bs
311+ ++ allMimeUnrender pctyps
307312 where
308− mk ct = (ct, mimeUnrenderWithType pctyp ct bs)
313+ mk ct = (ct, \bs -> mimeUnrenderWithType pctyp ct bs)
309314 pctyp = Proxy :: Proxy ctyp
310315 pctyps = Proxy :: Proxy ctyps
311316