08786aa · typeable/servant

git.iko.soy/typeable/servant

on master help sign in

Check for parse errors in HasServer Header instance

08786aaPhilipp Balzarek10 years ago

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

compare with master

unifiedsplit

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

46 responseLBS, vault)

47import Prelude ()

48import Prelude.Compat

49−import Web.HttpApiData (FromHttpApiData, parseHeaderMaybe,

49+import Web.HttpApiData (FromHttpApiData, parseHeader,

50 parseQueryParam,

51 parseUrlPieceMaybe,

52 parseUrlPieces)

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

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

281 Maybe a -> ServerT api m

282

283− route Proxy context subserver =

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

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

284+ subserver `addHeaderCheck` withRequest headerCheck

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

285+ where

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

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

287

298

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

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

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

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

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

321 Just (Just v) ->

332 Just (Just v) ->

322 case parseQueryParam v of

333 case parseQueryParam v of

323 Left e -> delayedFailFatal err400

334 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

325 }

337 }

326

338

327 Right param -> return $ Just param

339 Right param -> return $ Just param

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

364 case partitionEithers $ fmap parseQueryParam params of

376 case partitionEithers $ fmap parseQueryParam params of

365 ([], parsed) -> return parsed

377 ([], parsed) -> return parsed

366 (errs, _) -> delayedFailFatal err400

378 (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

368 }

382 }

369 where

383 where

370 params :: [T.Text]

384 params :: [T.Text]

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

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

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. Header Checks. They also require parsing and can cause 400 if parsing fails.

164+--

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

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

164--

166--

165data Delayed env c where

167data Delayed env c where

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

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

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

169 , acceptD :: DelayedIO ()

171 , acceptD :: DelayedIO ()

170 , contentD :: DelayedIO contentType

172 , contentD :: DelayedIO contentType

171 , paramsD :: DelayedIO params

173 , paramsD :: DelayedIO params

174+ , headersD :: DelayedIO headers

172 , bodyD :: contentType -> DelayedIO body

175 , bodyD :: contentType -> DelayedIO body

173 , serverD :: captures

176 , serverD :: captures

174 -> params

177 -> params

178+ -> headers

175 -> auth

179 -> auth

176 -> body

180 -> body

177 -> Request

181 -> Request

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

181instance Functor (Delayed env) where

185instance Functor (Delayed env) where

182 fmap f Delayed{..} =

186 fmap f Delayed{..} =

183 Delayed

187 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

185 , ..

189 , ..

186 } -- Note [Existential Record Update]

190 } -- Note [Existential Record Update]

187

191

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

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

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

214emptyDelayed :: RouteResult a -> Delayed env a

218emptyDelayed :: RouteResult a -> Delayed env a

215emptyDelayed result =

219emptyDelayed 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)

217 where

221 where

218 r = return ()

222 r = return ()

219

223

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

238addCapture Delayed{..} new =

242addCapture Delayed{..} new =

239 Delayed

243 Delayed

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

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

242 , ..

246 , ..

243 } -- Note [Existential Record Update]

247 } -- Note [Existential Record Update]

244

248

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

249addParameterCheck Delayed {..} new =

253addParameterCheck Delayed {..} new =

250 Delayed

254 Delayed

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

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

253 , ..

268 , ..

254 }

269 }

255

270

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

270addAuthCheck Delayed{..} new =

285addAuthCheck Delayed{..} new =

271 Delayed

286 Delayed

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

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

274 , ..

289 , ..

275 } -- Note [Existential Record Update]

290 } -- Note [Existential Record Update]

276

291

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

286 Delayed

301 Delayed

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

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

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

303 , 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

290 , ..

305 , ..

291 } -- Note [Existential Record Update]

306 } -- Note [Existential Record Update]

292

307

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

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

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

317passToServer Delayed{..} x =

332passToServer Delayed{..} x =

318 Delayed

333 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

320 , ..

335 , ..

321 } -- Note [Existential Record Update]

336 } -- Note [Existential Record Update]

322

337

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

338 acceptD

353 acceptD

339 content <- contentD

354 content <- contentD

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

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

356+ h <- headersD

341 b <- bodyD content

357 b <- bodyD content

342− liftRouteResult (serverD c p a b r)

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

343

359

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

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

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

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

63 , acceptD = return ()

64 , contentD = return ()

65 , paramsD = return ()

66+ , headersD = return ()

66 , bodyD = \() -> do

67 , bodyD = \() -> do

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

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

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

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

69 body

70 body

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

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

71 }

72 }

73simpleRun :: Delayed () (Handler ())

74simpleRun :: Delayed () (Handler ())

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

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

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

478 delete' "/" "" `shouldRespondWith` 200

479

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+

480-- }}}

487-- }}}

481------------------------------------------------------------------------------

488------------------------------------------------------------------------------

482-- * rawSpec {{{

489-- * rawSpec {{{