eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

Merge pull request #670 from phadej/pull-649

Browse source 
Throw error on param parse failure.
This commit is contained in:
Oleg Grenrus 2017-01-19 11:44:03 +02:00 committed by GitHub
commit 22b4d1301d
7 changed files with 219 additions and 85 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
servant-server/CHANGELOG.md
View file

@ -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))

81
servant-server/src/Servant/Server/Internal.hs
View file

@ -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@.

91
servant-server/src/Servant/Server/Internal/RoutingApplication.hs
View file

@ -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.

32
servant-server/test/Servant/Server/ErrorSpec.hs
View file

@ -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 {{{

18
servant-server/test/Servant/Server/Internal/RoutingApplicationSpec.hs
View file

@ -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

57
servant-server/test/Servant/ServerSpec.hs
View file

@ -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

21
servant/src/Servant/API/ContentTypes.hs
View file

@ -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