@@ -1,98 +1,16 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE DeriveFunctor #-}
3−{-# LANGUAGE FlexibleInstances #-}
4−{-# LANGUAGE GADTs #-}
5−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6−{-# LANGUAGE MultiParamTypeClasses #-}
7−{-# LANGUAGE RecordWildCards #-}
8−{-# LANGUAGE TypeFamilies #-}
9−{-# LANGUAGE TypeOperators #-}
10−{-# LANGUAGE UndecidableInstances #-}
111module Servant.Server.Internal.RoutingApplication where
122
13−import Control.Monad
14− (ap, liftM)
15−import Control.Monad.Base
16− (MonadBase (..))
17−import Control.Monad.Catch
18− (MonadThrow (..))
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)
293import Network.Wai
304 (Application, Request, Response, ResponseReceived)
315import Prelude ()
326import Prelude.Compat
33−import Servant.Server.Internal.Handler
7+import Servant.Server.Internal.RouteResult
348import Servant.Server.Internal.ServerError
359
3610type RoutingApplication =
3711 Request -- ^ the request, the field 'pathInfo' may be modified by url routing
3812 -> (RouteResult Response -> IO ResponseReceived) -> IO ResponseReceived
3913
40−-- | The result of matching against a path in the route tree.
41−data RouteResult a =
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.
45− | Route !a
46− deriving (Eq, Show, Read, Functor)
47−
48−instance Applicative RouteResult where
49− pure = return
50− (<*>) = ap
51−
52−instance Monad RouteResult where
53− return = Route
54− Route a >>= f = f a
55− Fail e >>= _ = Fail e
56− FailFatal e >>= _ = FailFatal e
57−
58−newtype RouteResultT m a = RouteResultT { runRouteResultT :: m (RouteResult a) }
59− deriving (Functor)
60−
61−instance MonadTrans RouteResultT where
62− lift = RouteResultT . liftM Route
63−
64−instance (Functor m, Monad m) => Applicative (RouteResultT m) where
65− pure = return
66− (<*>) = ap
67−
68−instance Monad m => Monad (RouteResultT m) where
69− return = RouteResultT . return . Route
70− m >>= k = RouteResultT $ do
71− a <- runRouteResultT m
72− case a of
73− Fail e -> return $ Fail e
74− FailFatal e -> return $ FailFatal e
75− Route b -> runRouteResultT (k b)
76−
77−instance MonadIO m => MonadIO (RouteResultT m) where
78− liftIO = lift . liftIO
79−
80−instance MonadBase b m => MonadBase b (RouteResultT m) where
81− liftBase = lift . liftBase
82−
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
87−
88−instance MonadTransControl RouteResultT where
89− type StT RouteResultT a = RouteResult a
90− liftWith f = RouteResultT $ liftM return $ f runRouteResultT
91− restoreT = RouteResultT
92−
93−instance MonadThrow m => MonadThrow (RouteResultT m) where
94− throwM = lift . throwM
95−
9614toApplication :: RoutingApplication -> Application
9715toApplication ra request respond = ra request routingRespond
9816 where
@@ -100,300 +18,3 @@ toApplication ra request respond = ra request routingRespond
10018 routingRespond (Fail err) = respond $ responseServerError err
10119 routingRespond (FailFatal err) = respond $ responseServerError err
10220 routingRespond (Route v) = respond v
103−
104−-- | A 'Delayed' is a representation of a handler with scheduled
105−-- delayed checks that can trigger errors.
106−--
107−-- Why would we want to delay checks?
108−--
109−-- There are two reasons:
110−--
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.
115−--
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.
119−--
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.
130−--
131−-- We prefer to have the following relative priorities of error
132−-- codes:
133−--
134−-- @
135−-- 404
136−-- 405 (bad method)
137−-- 401 (unauthorized)
138−-- 415 (unsupported media type)
139−-- 406 (not acceptable)
140−-- 400 (bad request)
141−-- @
142−--
143−-- Therefore, while routing, we delay most checks so that they
144−-- will ultimately occur in the right order.
145−--
146−-- A 'Delayed' contains many delayed blocks of tests, and
147−-- the actual handler:
148−--
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.
154−--
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.
158−--
159−-- 3. Authentication checks. This can cause 401.
160−--
161−-- 4. Accept and content type header checks. These checks
162−-- can cause 415 and 406 errors.
163−--
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
166−--
167−-- 6. Header Checks. They also require parsing and can cause 400 if parsing fails.
168−--
169−-- 7. Body check. The request body check can cause 400.
170−--
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
181− -> params
182− -> headers
183− -> auth
184− -> body
185− -> Request
186− -> RouteResult c
187− } -> Delayed env c
188−
189−instance Functor (Delayed env) where
190− fmap f Delayed{..} =
191− Delayed
192− { serverD = \ c p h a b req -> f <$> serverD c p h a b req
193− , ..
194− } -- Note [Existential Record Update]
195−
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.
200−--
201−newtype DelayedIO a = DelayedIO { runDelayedIO' :: ReaderT Request (ResourceT (RouteResultT IO)) a }
202− deriving
203− ( Functor, Applicative, Monad
204− , MonadIO, MonadReader Request
205− , MonadThrow
206− , MonadResource
207− )
208−
209−instance MonadBase IO DelayedIO where
210− liftBase = liftIO
211−
212−liftRouteResult :: RouteResult a -> DelayedIO a
213−liftRouteResult x = DelayedIO $ lift . lift $ RouteResultT . return $ x
214−
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
219−
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
225−
226−
227−runDelayedIO :: DelayedIO a -> Request -> ResourceT IO (RouteResult a)
228−runDelayedIO m req = transResourceT runRouteResultT $ runReaderT (runDelayedIO' m) req
229−
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)
234− where
235− r = return ()
236−
237−-- | Fail with the option to recover.
238−delayedFail :: ServerError -> DelayedIO a
239−delayedFail err = liftRouteResult $ Fail err
240−
241−-- | Fail fatally, i.e., without any option to recover.
242−delayedFailFatal :: ServerError -> DelayedIO a
243−delayedFailFatal err = liftRouteResult $ FailFatal err
244−
245−-- | Gain access to the incoming request.
246−withRequest :: (Request -> DelayedIO a) -> DelayedIO a
247−withRequest f = do
248− req <- ask
249− f req
250−
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 =
256− Delayed
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
259− , ..
260− } -- Note [Existential Record Update]
261−
262−-- | Add a parameter check to the end of the params block
263−addParameterCheck :: Delayed env (a -> b)
264− -> DelayedIO a
265− -> Delayed env b
266−addParameterCheck Delayed {..} new =
267− Delayed
268− { paramsD = (,) <$> paramsD <*> new
269− , serverD = \c (p, pNew) h a b req -> ($ pNew) <$> serverD c p h a b req
270− , ..
271− }
272−
273−-- | Add a parameter check to the end of the params block
274−addHeaderCheck :: Delayed env (a -> b)
275− -> DelayedIO a
276− -> Delayed env b
277−addHeaderCheck Delayed {..} new =
278− Delayed
279− { headersD = (,) <$> headersD <*> new
280− , serverD = \c p (h, hNew) a b req -> ($ hNew) <$> serverD c p h a b req
281− , ..
282− }
283−
284−-- | Add a method check to the end of the method block.
285−addMethodCheck :: Delayed env a
286− -> DelayedIO ()
287− -> Delayed env a
288−addMethodCheck Delayed{..} new =
289− Delayed
290− { methodD = methodD <* new
291− , ..
292− } -- Note [Existential Record Update]
293−
294−-- | Add an auth check to the end of the auth block.
295−addAuthCheck :: Delayed env (a -> b)
296− -> DelayedIO a
297− -> Delayed env b
298−addAuthCheck Delayed{..} new =
299− Delayed
300− { authD = (,) <$> authD <*> new
301− , serverD = \ c p h (y, v) b req -> ($ v) <$> serverD c p h y b req
302− , ..
303− } -- Note [Existential Record Update]
304−
305−-- | Add a content type and body checks around parameter checks.
306−--
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
312− -> Delayed env b
313−addBodyCheck Delayed{..} newContentD newBodyD =
314− Delayed
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
318− , ..
319− } -- Note [Existential Record Update]
320−
321−
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
333− -> DelayedIO ()
334− -> Delayed env a
335−addAcceptCheck Delayed{..} new =
336− Delayed
337− { acceptD = acceptD *> new
338− , ..
339− } -- Note [Existential Record Update]
340−
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 =
346− Delayed
347− { serverD = \ c p h a b req -> ($ x req) <$> serverD c p h a b req
348− , ..
349− } -- Note [Existential Record Update]
350−
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.
354−--
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
358− -> env
359− -> Request
360− -> ResourceT IO (RouteResult a)
361−runDelayed Delayed{..} env = runDelayedIO $ do
362− r <- ask
363− c <- capturesD env
364− methodD
365− a <- authD
366− acceptD
367− content <- contentD
368− p <- paramsD -- Has to be before body parsing, but after content-type checks
369− h <- headersD
370− b <- bodyD content
371− liftRouteResult (serverD c p h a b r)
372−
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)
378− -> env
379− -> Request
380− -> (RouteResult Response -> IO r)
381− -> (a -> RouteResult Response)
382− -> IO r
383−runAction action env req respond k = runResourceT $
384− runDelayed action env req >>= go >>= liftIO . respond
385− where
386− go (Fail e) = return $ Fail e
387− go (FailFatal e) = return $ FailFatal e
388− go (Route a) = liftIO $ do
389− e <- runHandler a
390− case e of
391− Left err -> return . Route $ responseServerError err
392− Right x -> return $! k x
393−
394−{- Note [Existential Record Update]
395−~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
396−
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.
399−-}