@@ -132,14 +132,14 @@ toApplication ra request respond = ra request routingRespond
132-- 405 (bad method)
132-- 405 (bad method)
133-- 401 (unauthorized)
133-- 401 (unauthorized)
134-- 415 (unsupported media type)
134-- 415 (unsupported media type)
136-- 406 (not acceptable)
135-- 406 (not acceptable)
139-- Therefore, while routing, we delay most checks so that they
139-- Therefore, while routing, we delay most checks so that they
140-- will ultimately occur in the right order.
140-- will ultimately occur in the right order.
142−-- A 'Delayed' contains three delayed blocks of tests, and
142+-- A 'Delayed' contains many delayed blocks of tests, and
143-- the actual handler:
143-- the actual handler:
145-- 1. Delayed captures. These can actually cause 404, and
145-- 1. Delayed captures. These can actually cause 404, and
@@ -152,23 +152,36 @@ toApplication ra request respond = ra request routingRespond
152-- it does not provide an input for the handler. Method checks
152-- it does not provide an input for the handler. Method checks
153-- are comparatively cheap.
153-- are comparatively cheap.
155+-- 3. Authentication checks. This can cause 401.
157+-- 4. Accept and content type header checks. These checks
158+-- can cause 415 and 406 errors.
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
155−-- 3. Body and accept header checks. The request body check can
163+-- 6. Body check. The request body check can cause 400.
156−-- cause both 400 and 415. This provides an input to the handler.
157−-- The accept header check can be performed as the final
158−-- computation in this block. It can cause a 406.
160data Delayed env c where
165data Delayed env c where
161 Delayed :: { capturesD :: env -> DelayedIO captures
166 Delayed :: { capturesD :: env -> DelayedIO captures
162 , methodD :: DelayedIO ()
167 , methodD :: DelayedIO ()
163 , authD :: DelayedIO auth
168 , authD :: DelayedIO auth
169+ , acceptD :: DelayedIO ()
170+ , contentD :: DelayedIO contentType
171+ , paramsD :: DelayedIO params
164− , bodyD :: DelayedIO body
172+ , bodyD :: contentType -> DelayedIO body
165− , serverD :: captures -> auth -> body -> Request -> RouteResult c
173+ , serverD :: captures
166 } -> Delayed env c
179 } -> Delayed env c
168instance Functor (Delayed env) where
181instance Functor (Delayed env) where
169 fmap f Delayed{..} =
182 fmap f Delayed{..} =
171− { serverD = \ c a b req -> f <$> serverD c a b req
184+ { serverD = \ c p a b req -> f <$> serverD c p a b req
173 } -- Note [Existential Record Update]
186 } -- Note [Existential Record Update]
@@ -200,7 +213,7 @@ runDelayedIO m req = transResourceT runRouteResultT $ runReaderT (runDelayedIO'
200-- | A 'Delayed' without any stored checks.
213-- | A 'Delayed' without any stored checks.
201emptyDelayed :: RouteResult a -> Delayed env a
214emptyDelayed :: RouteResult a -> Delayed env a
202emptyDelayed result =
215emptyDelayed result =
203− Delayed (const r) r r r (\ _ _ _ _ -> result)
216+ Delayed (const r) r r r r r (const r) (\ _ _ _ _ _ -> result)
205 r = return ()
218 r = return ()
@@ -225,10 +238,21 @@ addCapture :: Delayed env (a -> b)
225addCapture Delayed{..} new =
238addCapture Delayed{..} new =
227 { capturesD = \ (txt, env) -> (,) <$> capturesD env <*> new txt
240 { capturesD = \ (txt, env) -> (,) <$> capturesD env <*> new txt
228− , serverD = \ (x, v) a b req -> ($ v) <$> serverD x a b req
241+ , serverD = \ (x, v) p a b req -> ($ v) <$> serverD x p a b req
230 } -- Note [Existential Record Update]
243 } -- Note [Existential Record Update]
245+-- | Add a parameter check to the end of the params block
246+addParameterCheck :: Delayed env (a -> b)
249+addParameterCheck Delayed {..} new =
251+ { paramsD = (,) <$> paramsD <*> new
252+ , serverD = \c (p, pNew) a b req -> ($ pNew) <$> serverD c p a b req
232-- | Add a method check to the end of the method block.
256-- | Add a method check to the end of the method block.
233addMethodCheck :: Delayed env a
257addMethodCheck :: Delayed env a
234 -> DelayedIO ()
258 -> DelayedIO ()
@@ -246,24 +270,29 @@ addAuthCheck :: Delayed env (a -> b)
246addAuthCheck Delayed{..} new =
270addAuthCheck Delayed{..} new =
248 { authD = (,) <$> authD <*> new
272 { authD = (,) <$> authD <*> new
249− , serverD = \ c (y, v) b req -> ($ v) <$> serverD c y b req
273+ , serverD = \ c p (y, v) b req -> ($ v) <$> serverD c p y b req
251 } -- Note [Existential Record Update]
275 } -- Note [Existential Record Update]
253−-- | Add a body check to the end of the body block.
277+-- | Add a content type and body checks around parameter checks.
279+-- We'll report failed content type check (415), before trying to parse
280+-- query parameters (400). Which, in turn, happens before request body parsing.
254addBodyCheck :: Delayed env (a -> b)
281addBodyCheck :: Delayed env (a -> b)
255− -> DelayedIO a
282+ -> DelayedIO c -- ^ content type check
283+ -> (c -> DelayedIO a) -- ^ body check
256 -> Delayed env b
284 -> Delayed env b
257−addBodyCheck Delayed{..} new =
285+addBodyCheck Delayed{..} newContentD newBodyD =
287+ { contentD = (,) <$> contentD <*> newContentD
259− { bodyD = (,) <$> bodyD <*> new
288+ , bodyD = \(content, c) -> (,) <$> bodyD content <*> newBodyD c
260− , serverD = \ c a (z, v) req -> ($ v) <$> serverD c a z req
289+ , serverD = \ c p a (z, v) req -> ($ v) <$> serverD c p a z req
262 } -- Note [Existential Record Update]
291 } -- Note [Existential Record Update]
265−-- | Add an accept header check to the beginning of the body
294+-- | Add an accept header check before handling parameters.
266−-- block. There is a tradeoff here. In principle, we'd like
295+-- In principle, we'd like
267-- to take a bad body (400) response take precedence over a
296-- to take a bad body (400) response take precedence over a
268-- failed accept check (406). BUT to allow streaming the body,
297-- failed accept check (406). BUT to allow streaming the body,
269-- we cannot run the body check and then still backtrack.
298-- we cannot run the body check and then still backtrack.
@@ -277,7 +306,7 @@ addAcceptCheck :: Delayed env a
277 -> Delayed env a
306 -> Delayed env a
278addAcceptCheck Delayed{..} new =
307addAcceptCheck Delayed{..} new =
280− { bodyD = new *> bodyD
309+ { acceptD = acceptD *> new
282 } -- Note [Existential Record Update]
311 } -- Note [Existential Record Update]
@@ -287,7 +316,7 @@ addAcceptCheck Delayed{..} new =
287passToServer :: Delayed env (a -> b) -> (Request -> a) -> Delayed env b
316passToServer :: Delayed env (a -> b) -> (Request -> a) -> Delayed env b
288passToServer Delayed{..} x =
317passToServer Delayed{..} x =
290− { serverD = \ c a b req -> ($ x req) <$> serverD c a b req
319+ { serverD = \ c p a b req -> ($ x req) <$> serverD c p a b req
292 } -- Note [Existential Record Update]
321 } -- Note [Existential Record Update]
@@ -301,16 +330,16 @@ runDelayed :: Delayed env a
302 -> Request
331 -> Request
303 -> ResourceT IO (RouteResult a)
332 -> ResourceT IO (RouteResult a)
304−runDelayed Delayed{..} env req =
333+runDelayed Delayed{..} env = runDelayedIO $ do
305− runDelayedIO
334+ r <- ask
306− (do c <- capturesD env
335+ c <- capturesD env
308− a <- authD
337+ a <- authD
340+ p <- paramsD -- Has to be before body parsing, but after content-type checks
309− b <- bodyD
341+ b <- bodyD content
311− liftRouteResult (serverD c a b r)
342+ liftRouteResult (serverD c p a b r)
315-- | Runs a delayed server and the resulting action.
344-- | Runs a delayed server and the resulting action.
316-- Takes a continuation that lets us send a response.
345-- Takes a continuation that lets us send a response.