diff --git a/servant-server/CHANGELOG.md b/servant-server/CHANGELOG.md index a3815bdb..98c840a8 100644 --- a/servant-server/CHANGELOG.md +++ b/servant-server/CHANGELOG.md @@ -3,6 +3,10 @@ * Add `err422` Unprocessable Entity ([#646](https://github.com/haskell-servant/servant/pull/646)) +* Changed `HasServer` instances for `QueryParam` and `QueryParam` to throw 400 + when parsing fails + ([#649](6e77453b67dc164e5381fb867e5e6475302619a3)) +* Added `paramD` block to `Delayed` * `Handler` is now an abstract datatype. Migration hint: change `throwE` to `throwError`. ([#641](https://github.com/haskell-servant/servant/issues/641)) diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 62b92612..686cf59d 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -29,8 +29,10 @@ 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.String (fromString) import Data.String.Conversions (cs, (<>)) +import qualified Data.Text as T import Data.Typeable import GHC.TypeLits (KnownNat, KnownSymbol, natVal, symbolVal) @@ -45,7 +47,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 +313,22 @@ 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 + Left e -> delayedFailFatal err400 + { errBody = cs $ "Error parsing query parameter " <> paramname <> " failed: " <> e + } + + 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, @@ -346,18 +356,25 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer api context) type ServerT (QueryParams sym a :> api) m = [a] -> ServerT api m - route Proxy context subserver = - let querytext r = parseQueryText $ rawQueryString r - -- if sym is "foo", we look for query string parameters - -- 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) - where paramname = cs $ symbolVal (Proxy :: Proxy sym) - looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]") - convert Nothing = Nothing - convert (Just v) = parseQueryParamMaybe v + route Proxy context subserver = route (Proxy :: Proxy api) context $ + subserver `addParameterCheck` withRequest paramsCheck + where + paramname = cs $ symbolVal (Proxy :: Proxy sym) + paramsCheck req = + case partitionEithers $ fmap parseQueryParam params of + ([], parsed) -> return parsed + (errs, _) -> delayedFailFatal err400 + { errBody = cs $ "Error parsing query parameter(s) " <> paramname <> " failed: " <> T.intercalate ", " errs + } + where + params :: [T.Text] + params = mapMaybe snd + . filter (looksLikeParam . fst) + . parseQueryText + . rawQueryString + $ req + + looksLikeParam name = name == paramname || name == (paramname <> "[]") -- | If you use @'QueryFlag' "published"@ in one of the endpoints for your API, -- this automatically requires your server-side handler to be a function @@ -439,22 +456,28 @@ instance ( AllCTUnrender list a, HasServer api context type ServerT (ReqBody list a :> api) m = a -> ServerT api m - route Proxy context subserver = - route (Proxy :: Proxy api) context (addBodyCheck subserver bodyCheck) + route Proxy context subserver + = route (Proxy :: Proxy api) context $ + addBodyCheck subserver ctCheck bodyCheck where - bodyCheck = withRequest $ \ request -> do + -- Content-Type check, we only lookup we can try to parse the request body + ctCheck = withRequest $ \ request -> do -- See HTTP RFC 2616, section 7.2.1 -- http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1 -- See also "W3C Internet Media Type registration, consistency of use" -- http://www.w3.org/2001/tag/2002/0129-mime let contentTypeH = fromMaybe "application/octet-stream" $ lookup hContentType $ requestHeaders request - mrqbody <- handleCTypeH (Proxy :: Proxy list) (cs contentTypeH) - <$> liftIO (lazyRequestBody request) + case canHandleCTypeH (Proxy :: Proxy list) (cs contentTypeH) :: Maybe (BL.ByteString -> Either String a) of + Nothing -> delayedFailFatal err415 + Just f -> return f + + -- Body check, we get a body parsing functions as the first argument. + bodyCheck f = withRequest $ \ request -> do + mrqbody <- f <$> liftIO (lazyRequestBody request) case mrqbody of - Nothing -> delayedFailFatal err415 - Just (Left e) -> delayedFailFatal err400 { errBody = cs e } - Just (Right v) -> return v + Left e -> delayedFailFatal err400 { errBody = cs e } + Right v -> return v -- | Make sure the incoming request starts with @"/path"@, strip it and -- pass the rest of the request path to @api@. diff --git a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs index f5c6ca8c..9c8a411c 100644 --- a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs +++ b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs @@ -132,14 +132,14 @@ toApplication ra request respond = ra request routingRespond -- 405 (bad method) -- 401 (unauthorized) -- 415 (unsupported media type) --- 400 (bad request) -- 406 (not acceptable) +-- 400 (bad request) -- @ -- -- 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 many delayed blocks of tests, and -- the actual handler: -- -- 1. Delayed captures. These can actually cause 404, and @@ -152,23 +152,36 @@ toApplication ra request respond = ra request routingRespond -- 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 --- 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. +-- 3. Authentication checks. This can cause 401. +-- +-- 4. Accept and content type header checks. These checks +-- can cause 415 and 406 errors. +-- +-- 5. Query parameter checks. They require parsing and can cause 400 if the +-- parsing fails. Query parameter checks provide inputs to the handler +-- +-- 6. Body check. The request body check can cause 400. -- data Delayed env c where Delayed :: { capturesD :: env -> DelayedIO captures , methodD :: DelayedIO () , authD :: DelayedIO auth - , bodyD :: DelayedIO body - , serverD :: captures -> auth -> body -> Request -> RouteResult c + , acceptD :: DelayedIO () + , contentD :: DelayedIO contentType + , paramsD :: DelayedIO params + , bodyD :: contentType -> DelayedIO body + , 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 +213,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 r (const r) (\ _ _ _ _ _ -> result) where r = return () @@ -225,10 +238,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,24 +270,29 @@ 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] --- | Add a body check to the end of the body block. +-- | Add a content type and body checks around parameter checks. +-- +-- We'll report failed content type check (415), before trying to parse +-- query parameters (400). Which, in turn, happens before request body parsing. addBodyCheck :: Delayed env (a -> b) - -> DelayedIO a + -> DelayedIO c -- ^ content type check + -> (c -> DelayedIO a) -- ^ body check -> Delayed env b -addBodyCheck Delayed{..} new = +addBodyCheck Delayed{..} newContentD newBodyD = Delayed - { bodyD = (,) <$> bodyD <*> new - , serverD = \ c a (z, v) req -> ($ v) <$> serverD c a z req + { contentD = (,) <$> contentD <*> newContentD + , bodyD = \(content, c) -> (,) <$> bodyD content <*> newBodyD c + , serverD = \ c p a (z, v) req -> ($ v) <$> serverD c p a z req , .. } -- Note [Existential Record Update] --- | Add an accept header check to the beginning of the body --- block. There is a tradeoff here. In principle, we'd like +-- | Add an accept header check before handling parameters. +-- In principle, we'd like -- to take a bad body (400) response take precedence over a -- failed accept check (406). BUT to allow streaming the body, -- we cannot run the body check and then still backtrack. @@ -277,7 +306,7 @@ addAcceptCheck :: Delayed env a -> Delayed env a addAcceptCheck Delayed{..} new = Delayed - { bodyD = new *> bodyD + { acceptD = acceptD *> new , .. } -- Note [Existential Record Update] @@ -287,7 +316,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 +330,16 @@ 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 + r <- ask + c <- capturesD env + methodD + a <- authD + acceptD + content <- contentD + p <- paramsD -- Has to be before body parsing, but after content-type checks + b <- bodyD content + 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..787185da 100644 --- a/servant-server/test/Servant/Server/ErrorSpec.hs +++ b/servant-server/test/Servant/Server/ErrorSpec.hs @@ -6,9 +6,11 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Servant.Server.ErrorSpec (spec) where +import Control.Monad (when) 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 +46,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 +88,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,24 +99,35 @@ 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 goodUrl [goodAuth, goodContentType, goodAccept] badBody - `shouldRespondWith` 400 + badParamsRes <- request goodMethod badParams [goodAuth, goodContentType, goodAccept] goodBody + badBodyRes <- request goodMethod goodUrl [goodAuth, goodContentType, goodAccept] badBody + + -- Both bad body and bad params result in 400 + return badParamsRes `shouldRespondWith` 400 + return badBodyRes `shouldRespondWith` 400 + + -- Param check should occur before body checks + both <- request goodMethod badParams [goodAuth, goodContentType, goodAccept ] badBody + when (both /= badParamsRes) $ liftIO $ + expectationFailure $ "badParams + badBody /= badParams: " ++ show both ++ ", " ++ show badParamsRes + when (both == badBodyRes) $ liftIO $ + expectationFailure $ "badParams + badBody == badBody: " ++ show both it "has handler-level errors as last priority" $ do request goodMethod goodUrl [goodAuth, goodContentType, goodAccept] goodBody @@ -221,7 +236,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..a3be12f5 100644 --- a/servant-server/test/Servant/Server/Internal/RoutingApplicationSpec.hs +++ b/servant-server/test/Servant/Server/Internal/RoutingApplicationSpec.hs @@ -19,6 +19,7 @@ import Data.Proxy import GHC.TypeLits (Symbol, KnownSymbol, symbolVal) import Servant import Servant.Server.Internal.RoutingApplication +import Network.Wai (defaultRequest) import Test.Hspec import Test.Hspec.Wai (request, shouldRespondWith, with) @@ -56,20 +57,23 @@ freeTestResource = modifyIORef delayedTestRef $ \r -> case r of delayed :: DelayedIO () -> RouteResult (Handler ()) -> Delayed () (Handler ()) delayed body srv = Delayed - { capturesD = \_ -> return () + { capturesD = \() -> return () , methodD = return () , authD = return () - , bodyD = do - liftIO (writeTestResource"hia" >> putStrLn "garbage created") + , acceptD = return () + , contentD = 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 ()) -> IO () simpleRun d = fmap (either ignoreE id) . try $ - runAction d () undefined (\_ -> return ()) (\_ -> FailFatal err500) + runAction d () defaultRequest (\_ -> return ()) (\_ -> FailFatal err500) where ignoreE :: SomeException -> () ignoreE = const () @@ -84,10 +88,10 @@ data Res (sym :: Symbol) instance (KnownSymbol sym, HasServer api ctx) => HasServer (Res sym :> api) ctx where type ServerT (Res sym :> api) m = IORef (TestResource String) -> ServerT api m route Proxy ctx server = route (Proxy :: Proxy api) ctx $ - server `addBodyCheck` check + addBodyCheck server (return ()) check where sym = symbolVal (Proxy :: Proxy sym) - check = do + check () = do liftIO $ writeTestResource sym _ <- register freeTestResource return delayedTestRef 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 diff --git a/servant/src/Servant/API/ContentTypes.hs b/servant/src/Servant/API/ContentTypes.hs index d13d9951..d5967e2a 100644 --- a/servant/src/Servant/API/ContentTypes.hs +++ b/servant/src/Servant/API/ContentTypes.hs @@ -220,14 +220,20 @@ class Accept ctype => MimeUnrender ctype a where {-# MINIMAL mimeUnrender | mimeUnrenderWithType #-} class AllCTUnrender (list :: [*]) a where + canHandleCTypeH + :: Proxy list + -> ByteString -- Content-Type header + -> Maybe (ByteString -> Either String a) + handleCTypeH :: Proxy list -> ByteString -- Content-Type header -> ByteString -- Request body -> Maybe (Either String a) + handleCTypeH p ctypeH body = ($ body) `fmap` canHandleCTypeH p ctypeH instance ( AllMimeUnrender ctyps a ) => AllCTUnrender ctyps a where - handleCTypeH _ ctypeH body = M.mapContentMedia lkup (cs ctypeH) - where lkup = allMimeUnrender (Proxy :: Proxy ctyps) body + canHandleCTypeH p ctypeH = + M.mapContentMedia (allMimeUnrender p) (cs ctypeH) -------------------------------------------------------------------------- -- * Utils (Internal) @@ -292,20 +298,19 @@ instance OVERLAPPING_ -------------------------------------------------------------------------- class (AllMime list) => AllMimeUnrender (list :: [*]) a where allMimeUnrender :: Proxy list - -> ByteString - -> [(M.MediaType, Either String a)] + -> [(M.MediaType, ByteString -> Either String a)] instance AllMimeUnrender '[] a where - allMimeUnrender _ _ = [] + allMimeUnrender _ = [] instance ( MimeUnrender ctyp a , AllMimeUnrender ctyps a ) => AllMimeUnrender (ctyp ': ctyps) a where - allMimeUnrender _ bs = + allMimeUnrender _ = (map mk $ NE.toList $ contentTypes pctyp) - ++ allMimeUnrender pctyps bs + ++ allMimeUnrender pctyps where - mk ct = (ct, mimeUnrenderWithType pctyp ct bs) + mk ct = (ct, \bs -> mimeUnrenderWithType pctyp ct bs) pctyp = Proxy :: Proxy ctyp pctyps = Proxy :: Proxy ctyps