Check for parse errors in HasServer Header instance

This commit is contained in:
Philipp Balzarek 2017-04-06 13:59:16 +02:00
parent 86ad89b15c
commit 08786aadbe
4 changed files with 55 additions and 17 deletions

View file

@ -46,7 +46,7 @@ import Network.Wai (Application, Request, Response,
responseLBS, vault) responseLBS, vault)
import Prelude () import Prelude ()
import Prelude.Compat import Prelude.Compat
import Web.HttpApiData (FromHttpApiData, parseHeaderMaybe, import Web.HttpApiData (FromHttpApiData, parseHeader,
parseQueryParam, parseQueryParam,
parseUrlPieceMaybe, parseUrlPieceMaybe,
parseUrlPieces) parseUrlPieces)
@ -280,10 +280,21 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)
type ServerT (Header sym a :> api) m = type ServerT (Header sym a :> api) m =
Maybe a -> ServerT api m Maybe a -> ServerT api m
route Proxy context subserver = route Proxy context subserver = route (Proxy :: Proxy api) context $
let mheader req = parseHeaderMaybe =<< lookup str (requestHeaders req) subserver `addHeaderCheck` withRequest headerCheck
in route (Proxy :: Proxy api) context (passToServer subserver mheader) where
where str = fromString $ symbolVal (Proxy :: Proxy sym) headerName = symbolVal (Proxy :: Proxy sym)
headerCheck req =
case lookup (fromString headerName) (requestHeaders req) of
Nothing -> return Nothing
Just txt ->
case parseHeader txt of
Left e -> delayedFailFatal err400
{ errBody = cs $ "Error parsing header "
<> fromString headerName
<> " failed: " <> e
}
Right header -> return $ Just header
-- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API, -- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API,
-- this automatically requires your server-side handler to be a function -- this automatically requires your server-side handler to be a function
@ -321,7 +332,8 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)
Just (Just v) -> Just (Just v) ->
case parseQueryParam v of case parseQueryParam v of
Left e -> delayedFailFatal err400 Left e -> delayedFailFatal err400
{ errBody = cs $ "Error parsing query parameter " <> paramname <> " failed: " <> e { errBody = cs $ "Error parsing query parameter "
<> paramname <> " failed: " <> e
} }
Right param -> return $ Just param Right param -> return $ Just param
@ -364,7 +376,9 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)
case partitionEithers $ fmap parseQueryParam params of case partitionEithers $ fmap parseQueryParam params of
([], parsed) -> return parsed ([], parsed) -> return parsed
(errs, _) -> delayedFailFatal err400 (errs, _) -> delayedFailFatal err400
{ errBody = cs $ "Error parsing query parameter(s) " <> paramname <> " failed: " <> T.intercalate ", " errs { errBody = cs $ "Error parsing query parameter(s) "
<> paramname <> " failed: "
<> T.intercalate ", " errs
} }
where where
params :: [T.Text] params :: [T.Text]

View file

@ -160,7 +160,9 @@ toApplication ra request respond = ra request routingRespond
-- 5. Query parameter checks. They require parsing and can cause 400 if the -- 5. Query parameter checks. They require parsing and can cause 400 if the
-- parsing fails. Query parameter checks provide inputs to the handler -- parsing fails. Query parameter checks provide inputs to the handler
-- --
-- 6. Body check. The request body check can cause 400. -- 6. Header Checks. They also require parsing and can cause 400 if parsing fails.
--
-- 7. Body check. The request body check can cause 400.
-- --
data Delayed env c where data Delayed env c where
Delayed :: { capturesD :: env -> DelayedIO captures Delayed :: { capturesD :: env -> DelayedIO captures
@ -169,9 +171,11 @@ data Delayed env c where
, acceptD :: DelayedIO () , acceptD :: DelayedIO ()
, contentD :: DelayedIO contentType , contentD :: DelayedIO contentType
, paramsD :: DelayedIO params , paramsD :: DelayedIO params
, headersD :: DelayedIO headers
, bodyD :: contentType -> DelayedIO body , bodyD :: contentType -> DelayedIO body
, serverD :: captures , serverD :: captures
-> params -> params
-> headers
-> auth -> auth
-> body -> body
-> Request -> Request
@ -181,7 +185,7 @@ data Delayed env c where
instance Functor (Delayed env) where instance Functor (Delayed env) where
fmap f Delayed{..} = fmap f Delayed{..} =
Delayed Delayed
{ serverD = \ c p a b req -> f <$> serverD c p a b req { serverD = \ c p h a b req -> f <$> serverD c p h a b req
, .. , ..
} -- Note [Existential Record Update] } -- Note [Existential Record Update]
@ -213,7 +217,7 @@ runDelayedIO m req = transResourceT runRouteResultT $ runReaderT (runDelayedIO'
-- | A 'Delayed' without any stored checks. -- | A 'Delayed' without any stored checks.
emptyDelayed :: RouteResult a -> Delayed env a emptyDelayed :: RouteResult a -> Delayed env a
emptyDelayed result = emptyDelayed result =
Delayed (const r) r r r r r (const r) (\ _ _ _ _ _ -> result) Delayed (const r) r r r r r r (const r) (\ _ _ _ _ _ _ -> result)
where where
r = return () r = return ()
@ -238,7 +242,7 @@ addCapture :: Delayed env (a -> b)
addCapture Delayed{..} new = addCapture Delayed{..} new =
Delayed Delayed
{ capturesD = \ (txt, env) -> (,) <$> capturesD env <*> new txt { capturesD = \ (txt, env) -> (,) <$> capturesD env <*> new txt
, serverD = \ (x, v) p a b req -> ($ v) <$> serverD x p a b req , serverD = \ (x, v) p h a b req -> ($ v) <$> serverD x p h a b req
, .. , ..
} -- Note [Existential Record Update] } -- Note [Existential Record Update]
@ -249,7 +253,18 @@ addParameterCheck :: Delayed env (a -> b)
addParameterCheck Delayed {..} new = addParameterCheck Delayed {..} new =
Delayed Delayed
{ paramsD = (,) <$> paramsD <*> new { paramsD = (,) <$> paramsD <*> new
, serverD = \c (p, pNew) a b req -> ($ pNew) <$> serverD c p a b req , serverD = \c (p, pNew) h a b req -> ($ pNew) <$> serverD c p h a b req
, ..
}
-- | Add a parameter check to the end of the params block
addHeaderCheck :: Delayed env (a -> b)
-> DelayedIO a
-> Delayed env b
addHeaderCheck Delayed {..} new =
Delayed
{ headersD = (,) <$> headersD <*> new
, serverD = \c p (h, hNew) a b req -> ($ hNew) <$> serverD c p h a b req
, .. , ..
} }
@ -270,7 +285,7 @@ addAuthCheck :: Delayed env (a -> b)
addAuthCheck Delayed{..} new = addAuthCheck Delayed{..} new =
Delayed Delayed
{ authD = (,) <$> authD <*> new { authD = (,) <$> authD <*> new
, serverD = \ c p (y, v) b req -> ($ v) <$> serverD c p y b req , serverD = \ c p h (y, v) b req -> ($ v) <$> serverD c p h y b req
, .. , ..
} -- Note [Existential Record Update] } -- Note [Existential Record Update]
@ -286,7 +301,7 @@ addBodyCheck Delayed{..} newContentD newBodyD =
Delayed Delayed
{ contentD = (,) <$> contentD <*> newContentD { contentD = (,) <$> contentD <*> newContentD
, bodyD = \(content, c) -> (,) <$> bodyD content <*> newBodyD c , bodyD = \(content, c) -> (,) <$> bodyD content <*> newBodyD c
, serverD = \ c p a (z, v) req -> ($ v) <$> serverD c p a z req , serverD = \ c p h a (z, v) req -> ($ v) <$> serverD c p h a z req
, .. , ..
} -- Note [Existential Record Update] } -- Note [Existential Record Update]
@ -316,7 +331,7 @@ addAcceptCheck Delayed{..} new =
passToServer :: Delayed env (a -> b) -> (Request -> a) -> Delayed env b passToServer :: Delayed env (a -> b) -> (Request -> a) -> Delayed env b
passToServer Delayed{..} x = passToServer Delayed{..} x =
Delayed Delayed
{ serverD = \ c p a b req -> ($ x req) <$> serverD c p a b req { serverD = \ c p h a b req -> ($ x req) <$> serverD c p h a b req
, .. , ..
} -- Note [Existential Record Update] } -- Note [Existential Record Update]
@ -338,8 +353,9 @@ runDelayed Delayed{..} env = runDelayedIO $ do
acceptD acceptD
content <- contentD content <- contentD
p <- paramsD -- Has to be before body parsing, but after content-type checks p <- paramsD -- Has to be before body parsing, but after content-type checks
h <- headersD
b <- bodyD content b <- bodyD content
liftRouteResult (serverD c p a b r) liftRouteResult (serverD c p h a b r)
-- | Runs a delayed server and the resulting action. -- | Runs a delayed server and the resulting action.
-- Takes a continuation that lets us send a response. -- Takes a continuation that lets us send a response.

View file

@ -63,11 +63,12 @@ delayed body srv = Delayed
, acceptD = return () , acceptD = return ()
, contentD = return () , contentD = return ()
, paramsD = return () , paramsD = return ()
, headersD = return ()
, bodyD = \() -> do , bodyD = \() -> do
liftIO (writeTestResource "hia" >> putStrLn "garbage created") liftIO (writeTestResource "hia" >> putStrLn "garbage created")
_ <- register (freeTestResource >> putStrLn "garbage collected") _ <- register (freeTestResource >> putStrLn "garbage collected")
body body
, serverD = \() () () _body _req -> srv , serverD = \() () () () _body _req -> srv
} }
simpleRun :: Delayed () (Handler ()) simpleRun :: Delayed () (Handler ())

View file

@ -477,6 +477,13 @@ headerSpec = describe "Servant.API.Header" $ do
it "passes the header to the handler (String)" $ it "passes the header to the handler (String)" $
delete' "/" "" `shouldRespondWith` 200 delete' "/" "" `shouldRespondWith` 200
with (return (serve headerApi expectsInt)) $ do
let delete' x = THW.request methodDelete x [("MyHeader", "not a number")]
it "checks for parse errors" $
delete' "/" "" `shouldRespondWith` 400
-- }}} -- }}}
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
-- * rawSpec {{{ -- * rawSpec {{{