08786aa · typeable/servant

git.iko.soy/typeable/servant

Check for parse errors in HasServer Header instance

commit08786aadbec639b2f769ca7059b5a429ee447251 authorPhilipp Balzarek <p.balzarek@googlemail.com> dateThu 6 Apr 2017, 13:59 (10 years ago) parent86ad89b

4 files changed+55−17

compare with master

unifiedsplit

servant-server/src/Servant/Server/Internal.hs+21−7 servant-server/src/Servant/Server/Internal/RoutingApplication.hs+25−9 servant-server/test/Servant/Server/Internal/RoutingApplicationSpec.hs+2−1 servant-server/test/Servant/ServerSpec.hs+7

servant-server/src/Servant/Server/Internal.hs+21−7

@@ -46,7 +46,7 @@ import Network.Wai (Application, Request, Response,

4646 responseLBS, vault)

4747import Prelude ()

4848import Prelude.Compat

49−import Web.HttpApiData (FromHttpApiData, parseHeaderMaybe,

49+import Web.HttpApiData (FromHttpApiData, parseHeader,

5050 parseQueryParam,

5151 parseUrlPieceMaybe,

5252 parseUrlPieces)

@@ -280,10 +280,21 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)

280280 type ServerT (Header sym a :> api) m =

281281 Maybe a -> ServerT api m

282282

283− route Proxy context subserver =

284− let mheader req = parseHeaderMaybe =<< lookup str (requestHeaders req)

285− in route (Proxy :: Proxy api) context (passToServer subserver mheader)

286− where str = fromString $ symbolVal (Proxy :: Proxy sym)

283+ route Proxy context subserver = route (Proxy :: Proxy api) context $

284+ subserver `addHeaderCheck` withRequest headerCheck

285+ where

286+ headerName = symbolVal (Proxy :: Proxy sym)

287+ headerCheck req =

288+ case lookup (fromString headerName) (requestHeaders req) of

289+ Nothing -> return Nothing

290+ Just txt ->

291+ case parseHeader txt of

292+ Left e -> delayedFailFatal err400

293+ { errBody = cs $ "Error parsing header "

294+ <> fromString headerName

295+ <> " failed: " <> e

296+ }

297+ Right header -> return $ Just header

287298

288299-- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API,

289300-- this automatically requires your server-side handler to be a function

@@ -321,7 +332,8 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)

321332 Just (Just v) ->

322333 case parseQueryParam v of

323334 Left e -> delayedFailFatal err400

324− { errBody = cs $ "Error parsing query parameter " <> paramname <> " failed: " <> e

335+ { errBody = cs $ "Error parsing query parameter "

336+ <> paramname <> " failed: " <> e

325337 }

326338

327339 Right param -> return $ Just param

@@ -364,7 +376,9 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)

364376 case partitionEithers $ fmap parseQueryParam params of

365377 ([], parsed) -> return parsed

366378 (errs, _) -> delayedFailFatal err400

367− { errBody = cs $ "Error parsing query parameter(s) " <> paramname <> " failed: " <> T.intercalate ", " errs

379+ { errBody = cs $ "Error parsing query parameter(s) "

380+ <> paramname <> " failed: "

381+ <> T.intercalate ", " errs

368382 }

369383 where

370384 params :: [T.Text]

servant-server/src/Servant/Server/Internal/RoutingApplication.hs+25−9

@@ -160,7 +160,9 @@ toApplication ra request respond = ra request routingRespond

160160-- 5. Query parameter checks. They require parsing and can cause 400 if the

161161-- parsing fails. Query parameter checks provide inputs to the handler

162162--

163−-- 6. Body check. The request body check can cause 400.

163+-- 6. Header Checks. They also require parsing and can cause 400 if parsing fails.

164+--

165+-- 7. Body check. The request body check can cause 400.

164166--

165167data Delayed env c where

166168 Delayed :: { capturesD :: env -> DelayedIO captures

@@ -169,9 +171,11 @@ data Delayed env c where

169171 , acceptD :: DelayedIO ()

170172 , contentD :: DelayedIO contentType

171173 , paramsD :: DelayedIO params

174+ , headersD :: DelayedIO headers

172175 , bodyD :: contentType -> DelayedIO body

173176 , serverD :: captures

174177 -> params

178+ -> headers

175179 -> auth

176180 -> body

177181 -> Request

@@ -181,7 +185,7 @@ data Delayed env c where

181185instance Functor (Delayed env) where

182186 fmap f Delayed{..} =

183187 Delayed

184− { serverD = \ c p a b req -> f <$> serverD c p a b req

188+ { serverD = \ c p h a b req -> f <$> serverD c p h a b req

185189 , ..

186190 } -- Note [Existential Record Update]

187191

@@ -213,7 +217,7 @@ runDelayedIO m req = transResourceT runRouteResultT $ runReaderT (runDelayedIO'

213217-- | A 'Delayed' without any stored checks.

214218emptyDelayed :: RouteResult a -> Delayed env a

215219emptyDelayed result =

216− Delayed (const r) r r r r r (const r) (\ _ _ _ _ _ -> result)

220+ Delayed (const r) r r r r r r (const r) (\ _ _ _ _ _ _ -> result)

217221 where

218222 r = return ()

219223

@@ -238,7 +242,7 @@ addCapture :: Delayed env (a -> b)

238242addCapture Delayed{..} new =

239243 Delayed

240244 { capturesD = \ (txt, env) -> (,) <$> capturesD env <*> new txt

241− , serverD = \ (x, v) p a b req -> ($ v) <$> serverD x p a b req

245+ , serverD = \ (x, v) p h a b req -> ($ v) <$> serverD x p h a b req

242246 , ..

243247 } -- Note [Existential Record Update]

244248

@@ -249,7 +253,18 @@ addParameterCheck :: Delayed env (a -> b)

249253addParameterCheck Delayed {..} new =

250254 Delayed

251255 { paramsD = (,) <$> paramsD <*> new

252− , serverD = \c (p, pNew) a b req -> ($ pNew) <$> serverD c p a b req

256+ , serverD = \c (p, pNew) h a b req -> ($ pNew) <$> serverD c p h a b req

257+ , ..

258+ }

259+

260+-- | Add a parameter check to the end of the params block

261+addHeaderCheck :: Delayed env (a -> b)

262+ -> DelayedIO a

263+ -> Delayed env b

264+addHeaderCheck Delayed {..} new =

265+ Delayed

266+ { headersD = (,) <$> headersD <*> new

267+ , serverD = \c p (h, hNew) a b req -> ($ hNew) <$> serverD c p h a b req

253268 , ..

254269 }

255270

@@ -270,7 +285,7 @@ addAuthCheck :: Delayed env (a -> b)

270285addAuthCheck Delayed{..} new =

271286 Delayed

272287 { authD = (,) <$> authD <*> new

273− , serverD = \ c p (y, v) b req -> ($ v) <$> serverD c p y b req

288+ , serverD = \ c p h (y, v) b req -> ($ v) <$> serverD c p h y b req

274289 , ..

275290 } -- Note [Existential Record Update]

276291

@@ -286,7 +301,7 @@ addBodyCheck Delayed{..} newContentD newBodyD =

286301 Delayed

287302 { contentD = (,) <$> contentD <*> newContentD

288303 , bodyD = \(content, c) -> (,) <$> bodyD content <*> newBodyD c

289− , serverD = \ c p a (z, v) req -> ($ v) <$> serverD c p a z req

304+ , serverD = \ c p h a (z, v) req -> ($ v) <$> serverD c p h a z req

290305 , ..

291306 } -- Note [Existential Record Update]

292307

@@ -316,7 +331,7 @@ addAcceptCheck Delayed{..} new =

316331passToServer :: Delayed env (a -> b) -> (Request -> a) -> Delayed env b

317332passToServer Delayed{..} x =

318333 Delayed

319− { serverD = \ c p a b req -> ($ x req) <$> serverD c p a b req

334+ { serverD = \ c p h a b req -> ($ x req) <$> serverD c p h a b req

320335 , ..

321336 } -- Note [Existential Record Update]

322337

@@ -338,8 +353,9 @@ runDelayed Delayed{..} env = runDelayedIO $ do

338353 acceptD

339354 content <- contentD

340355 p <- paramsD -- Has to be before body parsing, but after content-type checks

356+ h <- headersD

341357 b <- bodyD content

342− liftRouteResult (serverD c p a b r)

358+ liftRouteResult (serverD c p h a b r)

343359

344360-- | Runs a delayed server and the resulting action.

345361-- Takes a continuation that lets us send a response.

servant-server/test/Servant/Server/Internal/RoutingApplicationSpec.hs+2−1

@@ -63,11 +63,12 @@ delayed body srv = Delayed

6363 , acceptD = return ()

6464 , contentD = return ()

6565 , paramsD = return ()

66+ , headersD = return ()

6667 , bodyD = \() -> do

6768 liftIO (writeTestResource "hia" >> putStrLn "garbage created")

6869 _ <- register (freeTestResource >> putStrLn "garbage collected")

6970 body

70− , serverD = \() () () _body _req -> srv

71+ , serverD = \() () () () _body _req -> srv

7172 }

7273

7374simpleRun :: Delayed () (Handler ())

servant-server/test/Servant/ServerSpec.hs+7

@@ -477,6 +477,13 @@ headerSpec = describe "Servant.API.Header" $ do

477477 it "passes the header to the handler (String)" $

478478 delete' "/" "" `shouldRespondWith` 200

479479

480+ with (return (serve headerApi expectsInt)) $ do

481+ let delete' x = THW.request methodDelete x [("MyHeader", "not a number")]

482+

483+ it "checks for parse errors" $

484+ delete' "/" "" `shouldRespondWith` 400

485+

486+

480487-- }}}

481488------------------------------------------------------------------------------

482489-- * rawSpec {{{