@@ -1,98 +1,16 @@
2−{-# LANGUAGE DeriveFunctor #-}
3−{-# LANGUAGE FlexibleInstances #-}
5−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6−{-# LANGUAGE MultiParamTypeClasses #-}
7−{-# LANGUAGE RecordWildCards #-}
8−{-# LANGUAGE TypeFamilies #-}
9−{-# LANGUAGE TypeOperators #-}
10−{-# LANGUAGE UndecidableInstances #-}
11module Servant.Server.Internal.RoutingApplication where
1module Servant.Server.Internal.RoutingApplication where
15−import Control.Monad.Base
17−import Control.Monad.Catch
19−import Control.Monad.Reader
20− (MonadReader (..), ReaderT (..), runReaderT)
21−import Control.Monad.Trans
22− (MonadIO (..), MonadTrans (..))
23−import Control.Monad.Trans.Control
24− (ComposeSt, MonadBaseControl (..), MonadTransControl (..),
25− defaultLiftBaseWith, defaultRestoreM)
26−import Control.Monad.Trans.Resource
27− (MonadResource (..), ResourceT, runInternalState,
28− runResourceT, transResourceT, withInternalState)
29import Network.Wai
3import Network.Wai
30 (Application, Request, Response, ResponseReceived)
4 (Application, Request, Response, ResponseReceived)
31import Prelude ()
5import Prelude ()
32import Prelude.Compat
6import Prelude.Compat
33−import Servant.Server.Internal.Handler
7+import Servant.Server.Internal.RouteResult
34import Servant.Server.Internal.ServerError
8import Servant.Server.Internal.ServerError
36type RoutingApplication =
10type RoutingApplication =
37 Request -- ^ the request, the field 'pathInfo' may be modified by url routing
11 Request -- ^ the request, the field 'pathInfo' may be modified by url routing
38 -> (RouteResult Response -> IO ResponseReceived) -> IO ResponseReceived
12 -> (RouteResult Response -> IO ResponseReceived) -> IO ResponseReceived
40−-- | The result of matching against a path in the route tree.
42− Fail ServerError -- ^ Keep trying other paths. The @ServantErr@
43− -- should only be 404, 405 or 406.
44− | FailFatal !ServerError -- ^ Don't try other paths.
46− deriving (Eq, Show, Read, Functor)
48−instance Applicative RouteResult where
52−instance Monad RouteResult where
55− Fail e >>= _ = Fail e
56− FailFatal e >>= _ = FailFatal e
58−newtype RouteResultT m a = RouteResultT { runRouteResultT :: m (RouteResult a) }
61−instance MonadTrans RouteResultT where
62− lift = RouteResultT . liftM Route
64−instance (Functor m, Monad m) => Applicative (RouteResultT m) where
68−instance Monad m => Monad (RouteResultT m) where
69− return = RouteResultT . return . Route
70− m >>= k = RouteResultT $ do
71− a <- runRouteResultT m
73− Fail e -> return $ Fail e
74− FailFatal e -> return $ FailFatal e
75− Route b -> runRouteResultT (k b)
77−instance MonadIO m => MonadIO (RouteResultT m) where
78− liftIO = lift . liftIO
80−instance MonadBase b m => MonadBase b (RouteResultT m) where
81− liftBase = lift . liftBase
83−instance MonadBaseControl b m => MonadBaseControl b (RouteResultT m) where
84− type StM (RouteResultT m) a = ComposeSt RouteResultT m a
85− liftBaseWith = defaultLiftBaseWith
86− restoreM = defaultRestoreM
88−instance MonadTransControl RouteResultT where
89− type StT RouteResultT a = RouteResult a
90− liftWith f = RouteResultT $ liftM return $ f runRouteResultT
91− restoreT = RouteResultT
93−instance MonadThrow m => MonadThrow (RouteResultT m) where
94− throwM = lift . throwM
96toApplication :: RoutingApplication -> Application
14toApplication :: RoutingApplication -> Application
97toApplication ra request respond = ra request routingRespond
15toApplication ra request respond = ra request routingRespond
@@ -100,300 +18,3 @@ toApplication ra request respond = ra request routingRespond
100 routingRespond (Fail err) = respond $ responseServerError err
18 routingRespond (Fail err) = respond $ responseServerError err
101 routingRespond (FailFatal err) = respond $ responseServerError err
19 routingRespond (FailFatal err) = respond $ responseServerError err
102 routingRespond (Route v) = respond v
20 routingRespond (Route v) = respond v
104−-- | A 'Delayed' is a representation of a handler with scheduled
105−-- delayed checks that can trigger errors.
107−-- Why would we want to delay checks?
109−-- There are two reasons:
111−-- 1. In a straight-forward implementation, the order in which we
112−-- perform checks will determine the error we generate. This is
113−-- because once an error occurs, we would abort and not perform
114−-- any subsequent checks, but rather return the current error.
116−-- This is not a necessity: we could continue doing other checks,
117−-- and choose the preferred error. However, that would in general
118−-- mean more checking, which leads us to the other reason.
120−-- 2. We really want to avoid doing certain checks too early. For
121−-- example, captures involve parsing, and are much more costly
122−-- than static route matches. In particular, if several paths
123−-- contain the "same" capture, we'd like as much as possible to
124−-- avoid trying the same parse many times. Also tricky is the
125−-- request body. Again, this involves parsing, but also, WAI makes
126−-- obtaining the request body a side-effecting operation. We
127−-- could/can work around this by manually caching the request body,
128−-- but we'd rather keep the number of times we actually try to
129−-- decode the request body to an absolute minimum.
131−-- We prefer to have the following relative priorities of error
137−-- 401 (unauthorized)
138−-- 415 (unsupported media type)
139−-- 406 (not acceptable)
143−-- Therefore, while routing, we delay most checks so that they
144−-- will ultimately occur in the right order.
146−-- A 'Delayed' contains many delayed blocks of tests, and
147−-- the actual handler:
149−-- 1. Delayed captures. These can actually cause 404, and
150−-- while they're costly, they should be done first among the
151−-- delayed checks (at least as long as we do not decouple the
152−-- check order from the error reporting, see above). Delayed
153−-- captures can provide inputs to the actual handler.
155−-- 2. Method check(s). This can cause a 405. On success,
156−-- it does not provide an input for the handler. Method checks
157−-- are comparatively cheap.
159−-- 3. Authentication checks. This can cause 401.
161−-- 4. Accept and content type header checks. These checks
162−-- can cause 415 and 406 errors.
164−-- 5. Query parameter checks. They require parsing and can cause 400 if the
165−-- parsing fails. Query parameter checks provide inputs to the handler
167−-- 6. Header Checks. They also require parsing and can cause 400 if parsing fails.
169−-- 7. Body check. The request body check can cause 400.
171−data Delayed env c where
172− Delayed :: { capturesD :: env -> DelayedIO captures
173− , methodD :: DelayedIO ()
174− , authD :: DelayedIO auth
175− , acceptD :: DelayedIO ()
176− , contentD :: DelayedIO contentType
177− , paramsD :: DelayedIO params
178− , headersD :: DelayedIO headers
179− , bodyD :: contentType -> DelayedIO body
180− , serverD :: captures
189−instance Functor (Delayed env) where
190− fmap f Delayed{..} =
192− { serverD = \ c p h a b req -> f <$> serverD c p h a b req
194− } -- Note [Existential Record Update]
196−-- | Computations used in a 'Delayed' can depend on the
197−-- incoming 'Request', may perform 'IO, and result in a
198−-- 'RouteResult, meaning they can either suceed, fail
199−-- (with the possibility to recover), or fail fatally.
201−newtype DelayedIO a = DelayedIO { runDelayedIO' :: ReaderT Request (ResourceT (RouteResultT IO)) a }
203− ( Functor, Applicative, Monad
204− , MonadIO, MonadReader Request
209−instance MonadBase IO DelayedIO where
212−liftRouteResult :: RouteResult a -> DelayedIO a
213−liftRouteResult x = DelayedIO $ lift . lift $ RouteResultT . return $ x
215−instance MonadBaseControl IO DelayedIO where
216− -- type StM DelayedIO a = StM (ReaderT Request (ResourceT (RouteResultT IO))) a
217− -- liftBaseWith f = DelayedIO $ liftBaseWith $ \g -> f (g . runDelayedIO')
218− -- restoreM = DelayedIO . restoreM
220− type StM DelayedIO a = RouteResult a
221− liftBaseWith f = DelayedIO $ ReaderT $ \req -> withInternalState $ \s ->
222− liftBaseWith $ \runInBase -> f $ \x ->
223− runInBase (runInternalState (runReaderT (runDelayedIO' x) req) s)
224− restoreM = DelayedIO . lift . withInternalState . const . restoreM
227−runDelayedIO :: DelayedIO a -> Request -> ResourceT IO (RouteResult a)
228−runDelayedIO m req = transResourceT runRouteResultT $ runReaderT (runDelayedIO' m) req
230−-- | A 'Delayed' without any stored checks.
231−emptyDelayed :: RouteResult a -> Delayed env a
232−emptyDelayed result =
233− Delayed (const r) r r r r r r (const r) (\ _ _ _ _ _ _ -> result)
237−-- | Fail with the option to recover.
238−delayedFail :: ServerError -> DelayedIO a
239−delayedFail err = liftRouteResult $ Fail err
241−-- | Fail fatally, i.e., without any option to recover.
242−delayedFailFatal :: ServerError -> DelayedIO a
243−delayedFailFatal err = liftRouteResult $ FailFatal err
245−-- | Gain access to the incoming request.
246−withRequest :: (Request -> DelayedIO a) -> DelayedIO a
251−-- | Add a capture to the end of the capture block.
252−addCapture :: Delayed env (a -> b)
253− -> (captured -> DelayedIO a)
254− -> Delayed (captured, env) b
255−addCapture Delayed{..} new =
257− { capturesD = \ (txt, env) -> (,) <$> capturesD env <*> new txt
258− , serverD = \ (x, v) p h a b req -> ($ v) <$> serverD x p h a b req
260− } -- Note [Existential Record Update]
262−-- | Add a parameter check to the end of the params block
263−addParameterCheck :: Delayed env (a -> b)
266−addParameterCheck Delayed {..} new =
268− { paramsD = (,) <$> paramsD <*> new
269− , serverD = \c (p, pNew) h a b req -> ($ pNew) <$> serverD c p h a b req
273−-- | Add a parameter check to the end of the params block
274−addHeaderCheck :: Delayed env (a -> b)
277−addHeaderCheck Delayed {..} new =
279− { headersD = (,) <$> headersD <*> new
280− , serverD = \c p (h, hNew) a b req -> ($ hNew) <$> serverD c p h a b req
284−-- | Add a method check to the end of the method block.
285−addMethodCheck :: Delayed env a
288−addMethodCheck Delayed{..} new =
290− { methodD = methodD <* new
292− } -- Note [Existential Record Update]
294−-- | Add an auth check to the end of the auth block.
295−addAuthCheck :: Delayed env (a -> b)
298−addAuthCheck Delayed{..} new =
300− { authD = (,) <$> authD <*> new
301− , serverD = \ c p h (y, v) b req -> ($ v) <$> serverD c p h y b req
303− } -- Note [Existential Record Update]
305−-- | Add a content type and body checks around parameter checks.
307−-- We'll report failed content type check (415), before trying to parse
308−-- query parameters (400). Which, in turn, happens before request body parsing.
309−addBodyCheck :: Delayed env (a -> b)
310− -> DelayedIO c -- ^ content type check
311− -> (c -> DelayedIO a) -- ^ body check
313−addBodyCheck Delayed{..} newContentD newBodyD =
315− { contentD = (,) <$> contentD <*> newContentD
316− , bodyD = \(content, c) -> (,) <$> bodyD content <*> newBodyD c
317− , serverD = \ c p h a (z, v) req -> ($ v) <$> serverD c p h a z req
319− } -- Note [Existential Record Update]
322−-- | Add an accept header check before handling parameters.
323−-- In principle, we'd like
324−-- to take a bad body (400) response take precedence over a
325−-- failed accept check (406). BUT to allow streaming the body,
326−-- we cannot run the body check and then still backtrack.
327−-- We therefore do the accept check before the body check,
328−-- when we can still backtrack. There are other solutions to
329−-- this, but they'd be more complicated (such as delaying the
330−-- body check further so that it can still be run in a situation
331−-- where we'd otherwise report 406).
332−addAcceptCheck :: Delayed env a
335−addAcceptCheck Delayed{..} new =
337− { acceptD = acceptD *> new
339− } -- Note [Existential Record Update]
341−-- | Many combinators extract information that is passed to
342−-- the handler without the possibility of failure. In such a
343−-- case, 'passToServer' can be used.
344−passToServer :: Delayed env (a -> b) -> (Request -> a) -> Delayed env b
345−passToServer Delayed{..} x =
347− { serverD = \ c p h a b req -> ($ x req) <$> serverD c p h a b req
349− } -- Note [Existential Record Update]
351−-- | Run a delayed server. Performs all scheduled operations
352−-- in order, and passes the results from the capture and body
353−-- blocks on to the actual handler.
355−-- This should only be called once per request; otherwise the guarantees about
356−-- effect and HTTP error ordering break down.
357−runDelayed :: Delayed env a
360− -> ResourceT IO (RouteResult a)
361−runDelayed Delayed{..} env = runDelayedIO $ do
368− p <- paramsD -- Has to be before body parsing, but after content-type checks
371− liftRouteResult (serverD c p h a b r)
373−-- | Runs a delayed server and the resulting action.
374−-- Takes a continuation that lets us send a response.
375−-- Also takes a continuation for how to turn the
376−-- result of the delayed server into a response.
377−runAction :: Delayed env (Handler a)
380− -> (RouteResult Response -> IO r)
381− -> (a -> RouteResult Response)
383−runAction action env req respond k = runResourceT $
384− runDelayed action env req >>= go >>= liftIO . respond
386− go (Fail e) = return $ Fail e
387− go (FailFatal e) = return $ FailFatal e
388− go (Route a) = liftIO $ do
391− Left err -> return . Route $ responseServerError err
392− Right x -> return $! k x
394−{- Note [Existential Record Update]
395−~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
397−Due to GHC issue <https://ghc.haskell.org/trac/ghc/ticket/2595 2595>, we cannot
398−do the more succint thing - just update the records we actually change.