{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} module Servant.Server.Internal.Delayed where import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Reader (ask) import Control.Monad.Trans.Resource (ResourceT, runResourceT) import Network.Wai (Request, Response) import Servant.Server.Internal.DelayedIO import Servant.Server.Internal.Handler import Servant.Server.Internal.RouteResult import Servant.Server.Internal.ServerError -- | A 'Delayed' is a representation of a handler with scheduled -- delayed checks that can trigger errors. -- -- Why would we want to delay checks? -- -- There are two reasons: -- -- 1. In a straight-forward implementation, the order in which we -- perform checks will determine the error we generate. This is -- because once an error occurs, we would abort and not perform -- any subsequent checks, but rather return the current error. -- -- This is not a necessity: we could continue doing other checks, -- and choose the preferred error. However, that would in general -- mean more checking, which leads us to the other reason. -- -- 2. We really want to avoid doing certain checks too early. For -- example, captures involve parsing, and are much more costly -- than static route matches. In particular, if several paths -- contain the "same" capture, we'd like as much as possible to -- avoid trying the same parse many times. Also tricky is the -- request body. Again, this involves parsing, but also, WAI makes -- obtaining the request body a side-effecting operation. We -- could/can work around this by manually caching the request body, -- but we'd rather keep the number of times we actually try to -- decode the request body to an absolute minimum. -- -- We prefer to have the following relative priorities of error -- codes: -- -- @ -- 404 -- 405 (bad method) -- 401 (unauthorized) -- 415 (unsupported media type) -- 406 (not acceptable) -- 400 (bad request) -- @ -- -- Therefore, while routing, we delay most checks so that they -- will ultimately occur in the right order. -- -- A 'Delayed' contains many delayed blocks of tests, and -- the actual handler: -- -- 1. Delayed captures. These can actually cause 404, and -- while they're costly, they should be done first among the -- delayed checks (at least as long as we do not decouple the -- check order from the error reporting, see above). Delayed -- captures can provide inputs to the actual handler. -- -- 2. Method check(s). This can cause a 405. On success, -- it does not provide an input for the handler. Method checks -- are comparatively cheap. -- -- 3. Authentication checks. This can cause 401. -- -- 4. Accept and content type header checks. These checks -- can cause 415 and 406 errors. -- -- 5. Query parameter checks. They require parsing and can cause 400 if the -- parsing fails. Query parameter checks provide inputs to the handler -- -- 6. Header Checks. They also require parsing and can cause 400 if parsing fails. -- -- 7. Body check. The request body check can cause 400. -- data Delayed env c where Delayed :: { () capturesD :: env -> DelayedIO captures , forall env c. Delayed env c -> DelayedIO () methodD :: DelayedIO () , () authD :: DelayedIO auth , forall env c. Delayed env c -> DelayedIO () acceptD :: DelayedIO () , () contentD :: DelayedIO contentType , () paramsD :: DelayedIO params , () headersD :: DelayedIO headers , () bodyD :: contentType -> DelayedIO body , () serverD :: captures -> params -> headers -> auth -> body -> Request -> RouteResult c } -> Delayed env c instance Functor (Delayed env) where fmap :: forall a b. (a -> b) -> Delayed env a -> Delayed env b fmap a -> b f Delayed{DelayedIO auth DelayedIO contentType DelayedIO params DelayedIO headers DelayedIO () env -> DelayedIO captures captures -> params -> headers -> auth -> body -> Request -> RouteResult a contentType -> DelayedIO body serverD :: captures -> params -> headers -> auth -> body -> Request -> RouteResult a bodyD :: contentType -> DelayedIO body headersD :: DelayedIO headers paramsD :: DelayedIO params contentD :: DelayedIO contentType acceptD :: DelayedIO () authD :: DelayedIO auth methodD :: DelayedIO () capturesD :: env -> DelayedIO captures serverD :: () bodyD :: () headersD :: () paramsD :: () contentD :: () acceptD :: forall env c. Delayed env c -> DelayedIO () authD :: () methodD :: forall env c. Delayed env c -> DelayedIO () capturesD :: () ..} = Delayed { serverD :: captures -> params -> headers -> auth -> body -> Request -> RouteResult b serverD = \ captures c params p headers h auth a body b Request req -> a -> b f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> captures -> params -> headers -> auth -> body -> Request -> RouteResult a serverD captures c params p headers h auth a body b Request req , DelayedIO auth DelayedIO contentType DelayedIO params DelayedIO headers DelayedIO () env -> DelayedIO captures contentType -> DelayedIO body bodyD :: contentType -> DelayedIO body headersD :: DelayedIO headers paramsD :: DelayedIO params contentD :: DelayedIO contentType acceptD :: DelayedIO () authD :: DelayedIO auth methodD :: DelayedIO () capturesD :: env -> DelayedIO captures bodyD :: contentType -> DelayedIO body headersD :: DelayedIO headers paramsD :: DelayedIO params contentD :: DelayedIO contentType acceptD :: DelayedIO () authD :: DelayedIO auth methodD :: DelayedIO () capturesD :: env -> DelayedIO captures .. } -- Note [Existential Record Update] -- | A 'Delayed' without any stored checks. emptyDelayed :: RouteResult a -> Delayed env a emptyDelayed :: forall a env. RouteResult a -> Delayed env a emptyDelayed RouteResult a result = forall env captures auth contentType params headers body c. (env -> DelayedIO captures) -> DelayedIO () -> DelayedIO auth -> DelayedIO () -> DelayedIO contentType -> DelayedIO params -> DelayedIO headers -> (contentType -> DelayedIO body) -> (captures -> params -> headers -> auth -> body -> Request -> RouteResult c) -> Delayed env c Delayed (forall a b. a -> b -> a const DelayedIO () r) DelayedIO () r DelayedIO () r DelayedIO () r DelayedIO () r DelayedIO () r DelayedIO () r (forall a b. a -> b -> a const DelayedIO () r) (\ () _ () _ () _ () _ () _ Request _ -> RouteResult a result) where r :: DelayedIO () r = forall (m :: * -> *) a. Monad m => a -> m a return () -- | Add a capture to the end of the capture block. addCapture :: Delayed env (a -> b) -> (captured -> DelayedIO a) -> Delayed (captured, env) b addCapture :: forall env a b captured. Delayed env (a -> b) -> (captured -> DelayedIO a) -> Delayed (captured, env) b addCapture Delayed{DelayedIO auth DelayedIO contentType DelayedIO params DelayedIO headers DelayedIO () env -> DelayedIO captures captures -> params -> headers -> auth -> body -> Request -> RouteResult (a -> b) contentType -> DelayedIO body serverD :: captures -> params -> headers -> auth -> body -> Request -> RouteResult (a -> b) bodyD :: contentType -> DelayedIO body headersD :: DelayedIO headers paramsD :: DelayedIO params contentD :: DelayedIO contentType acceptD :: DelayedIO () authD :: DelayedIO auth methodD :: DelayedIO () capturesD :: env -> DelayedIO captures serverD :: () bodyD :: () headersD :: () paramsD :: () contentD :: () acceptD :: forall env c. Delayed env c -> DelayedIO () authD :: () methodD :: forall env c. Delayed env c -> DelayedIO () capturesD :: () ..} captured -> DelayedIO a new = Delayed { capturesD :: (captured, env) -> DelayedIO (captures, a) capturesD = \ (captured txt, env env) -> (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> env -> DelayedIO captures capturesD env env forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> captured -> DelayedIO a new captured txt , serverD :: (captures, a) -> params -> headers -> auth -> body -> Request -> RouteResult b serverD = \ (captures x, a v) params p headers h auth a body b Request req -> (forall a b. (a -> b) -> a -> b $ a v) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> captures -> params -> headers -> auth -> body -> Request -> RouteResult (a -> b) serverD captures x params p headers h auth a body b Request req , DelayedIO auth DelayedIO contentType DelayedIO params DelayedIO headers DelayedIO () contentType -> DelayedIO body bodyD :: contentType -> DelayedIO body headersD :: DelayedIO headers paramsD :: DelayedIO params contentD :: DelayedIO contentType acceptD :: DelayedIO () authD :: DelayedIO auth methodD :: DelayedIO () bodyD :: contentType -> DelayedIO body headersD :: DelayedIO headers paramsD :: DelayedIO params contentD :: DelayedIO contentType acceptD :: DelayedIO () authD :: DelayedIO auth methodD :: DelayedIO () .. } -- Note [Existential Record Update] -- | Add a parameter check to the end of the params block addParameterCheck :: Delayed env (a -> b) -> DelayedIO a -> Delayed env b addParameterCheck :: forall env a b. Delayed env (a -> b) -> DelayedIO a -> Delayed env b addParameterCheck Delayed {DelayedIO auth DelayedIO contentType DelayedIO params DelayedIO headers DelayedIO () env -> DelayedIO captures captures -> params -> headers -> auth -> body -> Request -> RouteResult (a -> b) contentType -> DelayedIO body serverD :: captures -> params -> headers -> auth -> body -> Request -> RouteResult (a -> b) bodyD :: contentType -> DelayedIO body headersD :: DelayedIO headers paramsD :: DelayedIO params contentD :: DelayedIO contentType acceptD :: DelayedIO () authD :: DelayedIO auth methodD :: DelayedIO () capturesD :: env -> DelayedIO captures serverD :: () bodyD :: () headersD :: () paramsD :: () contentD :: () acceptD :: forall env c. Delayed env c -> DelayedIO () authD :: () methodD :: forall env c. Delayed env c -> DelayedIO () capturesD :: () ..} DelayedIO a new = Delayed { paramsD :: DelayedIO (params, a) paramsD = (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> DelayedIO params paramsD forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> DelayedIO a new , serverD :: captures -> (params, a) -> headers -> auth -> body -> Request -> RouteResult b serverD = \captures c (params p, a pNew) headers h auth a body b Request req -> (forall a b. (a -> b) -> a -> b $ a pNew) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> captures -> params -> headers -> auth -> body -> Request -> RouteResult (a -> b) serverD captures c params p headers h auth a body b Request req , DelayedIO auth DelayedIO contentType DelayedIO headers DelayedIO () env -> DelayedIO captures contentType -> DelayedIO body bodyD :: contentType -> DelayedIO body headersD :: DelayedIO headers contentD :: DelayedIO contentType acceptD :: DelayedIO () authD :: DelayedIO auth methodD :: DelayedIO () capturesD :: env -> DelayedIO captures bodyD :: contentType -> DelayedIO body headersD :: DelayedIO headers contentD :: DelayedIO contentType acceptD :: DelayedIO () authD :: DelayedIO auth methodD :: DelayedIO () capturesD :: env -> DelayedIO captures .. } -- | Add a parameter check to the end of the params block addHeaderCheck :: Delayed env (a -> b) -> DelayedIO a -> Delayed env b addHeaderCheck :: forall env a b. Delayed env (a -> b) -> DelayedIO a -> Delayed env b addHeaderCheck Delayed {DelayedIO auth DelayedIO contentType DelayedIO params DelayedIO headers DelayedIO () env -> DelayedIO captures captures -> params -> headers -> auth -> body -> Request -> RouteResult (a -> b) contentType -> DelayedIO body serverD :: captures -> params -> headers -> auth -> body -> Request -> RouteResult (a -> b) bodyD :: contentType -> DelayedIO body headersD :: DelayedIO headers paramsD :: DelayedIO params contentD :: DelayedIO contentType acceptD :: DelayedIO () authD :: DelayedIO auth methodD :: DelayedIO () capturesD :: env -> DelayedIO captures serverD :: () bodyD :: () headersD :: () paramsD :: () contentD :: () acceptD :: forall env c. Delayed env c -> DelayedIO () authD :: () methodD :: forall env c. Delayed env c -> DelayedIO () capturesD :: () ..} DelayedIO a new = Delayed { headersD :: DelayedIO (headers, a) headersD = (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> DelayedIO headers headersD forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> DelayedIO a new , serverD :: captures -> params -> (headers, a) -> auth -> body -> Request -> RouteResult b serverD = \captures c params p (headers h, a hNew) auth a body b Request req -> (forall a b. (a -> b) -> a -> b $ a hNew) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> captures -> params -> headers -> auth -> body -> Request -> RouteResult (a -> b) serverD captures c params p headers h auth a body b Request req , DelayedIO auth DelayedIO contentType DelayedIO params DelayedIO () env -> DelayedIO captures contentType -> DelayedIO body bodyD :: contentType -> DelayedIO body paramsD :: DelayedIO params contentD :: DelayedIO contentType acceptD :: DelayedIO () authD :: DelayedIO auth methodD :: DelayedIO () capturesD :: env -> DelayedIO captures bodyD :: contentType -> DelayedIO body paramsD :: DelayedIO params contentD :: DelayedIO contentType acceptD :: DelayedIO () authD :: DelayedIO auth methodD :: DelayedIO () capturesD :: env -> DelayedIO captures .. } -- | Add a method check to the end of the method block. addMethodCheck :: Delayed env a -> DelayedIO () -> Delayed env a addMethodCheck :: forall env a. Delayed env a -> DelayedIO () -> Delayed env a addMethodCheck Delayed{DelayedIO auth DelayedIO contentType DelayedIO params DelayedIO headers DelayedIO () env -> DelayedIO captures captures -> params -> headers -> auth -> body -> Request -> RouteResult a contentType -> DelayedIO body serverD :: captures -> params -> headers -> auth -> body -> Request -> RouteResult a bodyD :: contentType -> DelayedIO body headersD :: DelayedIO headers paramsD :: DelayedIO params contentD :: DelayedIO contentType acceptD :: DelayedIO () authD :: DelayedIO auth methodD :: DelayedIO () capturesD :: env -> DelayedIO captures serverD :: () bodyD :: () headersD :: () paramsD :: () contentD :: () acceptD :: forall env c. Delayed env c -> DelayedIO () authD :: () methodD :: forall env c. Delayed env c -> DelayedIO () capturesD :: () ..} DelayedIO () new = Delayed { methodD :: DelayedIO () methodD = DelayedIO () methodD forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a <* DelayedIO () new , DelayedIO auth DelayedIO contentType DelayedIO params DelayedIO headers DelayedIO () env -> DelayedIO captures captures -> params -> headers -> auth -> body -> Request -> RouteResult a contentType -> DelayedIO body serverD :: captures -> params -> headers -> auth -> body -> Request -> RouteResult a bodyD :: contentType -> DelayedIO body headersD :: DelayedIO headers paramsD :: DelayedIO params contentD :: DelayedIO contentType acceptD :: DelayedIO () authD :: DelayedIO auth capturesD :: env -> DelayedIO captures serverD :: captures -> params -> headers -> auth -> body -> Request -> RouteResult a bodyD :: contentType -> DelayedIO body headersD :: DelayedIO headers paramsD :: DelayedIO params contentD :: DelayedIO contentType acceptD :: DelayedIO () authD :: DelayedIO auth capturesD :: env -> DelayedIO captures .. } -- Note [Existential Record Update] -- | Add an auth check to the end of the auth block. addAuthCheck :: Delayed env (a -> b) -> DelayedIO a -> Delayed env b addAuthCheck :: forall env a b. Delayed env (a -> b) -> DelayedIO a -> Delayed env b addAuthCheck Delayed{DelayedIO auth DelayedIO contentType DelayedIO params DelayedIO headers DelayedIO () env -> DelayedIO captures captures -> params -> headers -> auth -> body -> Request -> RouteResult (a -> b) contentType -> DelayedIO body serverD :: captures -> params -> headers -> auth -> body -> Request -> RouteResult (a -> b) bodyD :: contentType -> DelayedIO body headersD :: DelayedIO headers paramsD :: DelayedIO params contentD :: DelayedIO contentType acceptD :: DelayedIO () authD :: DelayedIO auth methodD :: DelayedIO () capturesD :: env -> DelayedIO captures serverD :: () bodyD :: () headersD :: () paramsD :: () contentD :: () acceptD :: forall env c. Delayed env c -> DelayedIO () authD :: () methodD :: forall env c. Delayed env c -> DelayedIO () capturesD :: () ..} DelayedIO a new = Delayed { authD :: DelayedIO (auth, a) authD = (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> DelayedIO auth authD forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> DelayedIO a new , serverD :: captures -> params -> headers -> (auth, a) -> body -> Request -> RouteResult b serverD = \ captures c params p headers h (auth y, a v) body b Request req -> (forall a b. (a -> b) -> a -> b $ a v) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> captures -> params -> headers -> auth -> body -> Request -> RouteResult (a -> b) serverD captures c params p headers h auth y body b Request req , DelayedIO contentType DelayedIO params DelayedIO headers DelayedIO () env -> DelayedIO captures contentType -> DelayedIO body bodyD :: contentType -> DelayedIO body headersD :: DelayedIO headers paramsD :: DelayedIO params contentD :: DelayedIO contentType acceptD :: DelayedIO () methodD :: DelayedIO () capturesD :: env -> DelayedIO captures bodyD :: contentType -> DelayedIO body headersD :: DelayedIO headers paramsD :: DelayedIO params contentD :: DelayedIO contentType acceptD :: DelayedIO () methodD :: DelayedIO () capturesD :: env -> DelayedIO captures .. } -- Note [Existential Record Update] -- | Add a content type and body checks around parameter checks. -- -- We'll report failed content type check (415), before trying to parse -- query parameters (400). Which, in turn, happens before request body parsing. addBodyCheck :: Delayed env (a -> b) -> DelayedIO c -- ^ content type check -> (c -> DelayedIO a) -- ^ body check -> Delayed env b addBodyCheck :: forall env a b c. Delayed env (a -> b) -> DelayedIO c -> (c -> DelayedIO a) -> Delayed env b addBodyCheck Delayed{DelayedIO auth DelayedIO contentType DelayedIO params DelayedIO headers DelayedIO () env -> DelayedIO captures captures -> params -> headers -> auth -> body -> Request -> RouteResult (a -> b) contentType -> DelayedIO body serverD :: captures -> params -> headers -> auth -> body -> Request -> RouteResult (a -> b) bodyD :: contentType -> DelayedIO body headersD :: DelayedIO headers paramsD :: DelayedIO params contentD :: DelayedIO contentType acceptD :: DelayedIO () authD :: DelayedIO auth methodD :: DelayedIO () capturesD :: env -> DelayedIO captures serverD :: () bodyD :: () headersD :: () paramsD :: () contentD :: () acceptD :: forall env c. Delayed env c -> DelayedIO () authD :: () methodD :: forall env c. Delayed env c -> DelayedIO () capturesD :: () ..} DelayedIO c newContentD c -> DelayedIO a newBodyD = Delayed { contentD :: DelayedIO (contentType, c) contentD = (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> DelayedIO contentType contentD forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> DelayedIO c newContentD , bodyD :: (contentType, c) -> DelayedIO (body, a) bodyD = \(contentType content, c c) -> (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> contentType -> DelayedIO body bodyD contentType content forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> c -> DelayedIO a newBodyD c c , serverD :: captures -> params -> headers -> auth -> (body, a) -> Request -> RouteResult b serverD = \ captures c params p headers h auth a (body z, a v) Request req -> (forall a b. (a -> b) -> a -> b $ a v) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> captures -> params -> headers -> auth -> body -> Request -> RouteResult (a -> b) serverD captures c params p headers h auth a body z Request req , DelayedIO auth DelayedIO params DelayedIO headers DelayedIO () env -> DelayedIO captures headersD :: DelayedIO headers paramsD :: DelayedIO params acceptD :: DelayedIO () authD :: DelayedIO auth methodD :: DelayedIO () capturesD :: env -> DelayedIO captures headersD :: DelayedIO headers paramsD :: DelayedIO params acceptD :: DelayedIO () authD :: DelayedIO auth methodD :: DelayedIO () capturesD :: env -> DelayedIO captures .. } -- Note [Existential Record Update] -- | Add an accept header check before handling parameters. -- In principle, we'd like -- to take a bad body (400) response take precedence over a -- failed accept check (406). BUT to allow streaming the body, -- we cannot run the body check and then still backtrack. -- We therefore do the accept check before the body check, -- when we can still backtrack. There are other solutions to -- this, but they'd be more complicated (such as delaying the -- body check further so that it can still be run in a situation -- where we'd otherwise report 406). addAcceptCheck :: Delayed env a -> DelayedIO () -> Delayed env a addAcceptCheck :: forall env a. Delayed env a -> DelayedIO () -> Delayed env a addAcceptCheck Delayed{DelayedIO auth DelayedIO contentType DelayedIO params DelayedIO headers DelayedIO () env -> DelayedIO captures captures -> params -> headers -> auth -> body -> Request -> RouteResult a contentType -> DelayedIO body serverD :: captures -> params -> headers -> auth -> body -> Request -> RouteResult a bodyD :: contentType -> DelayedIO body headersD :: DelayedIO headers paramsD :: DelayedIO params contentD :: DelayedIO contentType acceptD :: DelayedIO () authD :: DelayedIO auth methodD :: DelayedIO () capturesD :: env -> DelayedIO captures serverD :: () bodyD :: () headersD :: () paramsD :: () contentD :: () acceptD :: forall env c. Delayed env c -> DelayedIO () authD :: () methodD :: forall env c. Delayed env c -> DelayedIO () capturesD :: () ..} DelayedIO () new = Delayed { acceptD :: DelayedIO () acceptD = DelayedIO () acceptD forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b *> DelayedIO () new , DelayedIO auth DelayedIO contentType DelayedIO params DelayedIO headers DelayedIO () env -> DelayedIO captures captures -> params -> headers -> auth -> body -> Request -> RouteResult a contentType -> DelayedIO body serverD :: captures -> params -> headers -> auth -> body -> Request -> RouteResult a bodyD :: contentType -> DelayedIO body headersD :: DelayedIO headers paramsD :: DelayedIO params contentD :: DelayedIO contentType authD :: DelayedIO auth methodD :: DelayedIO () capturesD :: env -> DelayedIO captures serverD :: captures -> params -> headers -> auth -> body -> Request -> RouteResult a bodyD :: contentType -> DelayedIO body headersD :: DelayedIO headers paramsD :: DelayedIO params contentD :: DelayedIO contentType authD :: DelayedIO auth methodD :: DelayedIO () capturesD :: env -> DelayedIO captures .. } -- Note [Existential Record Update] -- | Many combinators extract information that is passed to -- the handler without the possibility of failure. In such a -- case, 'passToServer' can be used. passToServer :: Delayed env (a -> b) -> (Request -> a) -> Delayed env b passToServer :: forall env a b. Delayed env (a -> b) -> (Request -> a) -> Delayed env b passToServer Delayed{DelayedIO auth DelayedIO contentType DelayedIO params DelayedIO headers DelayedIO () env -> DelayedIO captures captures -> params -> headers -> auth -> body -> Request -> RouteResult (a -> b) contentType -> DelayedIO body serverD :: captures -> params -> headers -> auth -> body -> Request -> RouteResult (a -> b) bodyD :: contentType -> DelayedIO body headersD :: DelayedIO headers paramsD :: DelayedIO params contentD :: DelayedIO contentType acceptD :: DelayedIO () authD :: DelayedIO auth methodD :: DelayedIO () capturesD :: env -> DelayedIO captures serverD :: () bodyD :: () headersD :: () paramsD :: () contentD :: () acceptD :: forall env c. Delayed env c -> DelayedIO () authD :: () methodD :: forall env c. Delayed env c -> DelayedIO () capturesD :: () ..} Request -> a x = Delayed { serverD :: captures -> params -> headers -> auth -> body -> Request -> RouteResult b serverD = \ captures c params p headers h auth a body b Request req -> (forall a b. (a -> b) -> a -> b $ Request -> a x Request req) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> captures -> params -> headers -> auth -> body -> Request -> RouteResult (a -> b) serverD captures c params p headers h auth a body b Request req , DelayedIO auth DelayedIO contentType DelayedIO params DelayedIO headers DelayedIO () env -> DelayedIO captures contentType -> DelayedIO body bodyD :: contentType -> DelayedIO body headersD :: DelayedIO headers paramsD :: DelayedIO params contentD :: DelayedIO contentType acceptD :: DelayedIO () authD :: DelayedIO auth methodD :: DelayedIO () capturesD :: env -> DelayedIO captures bodyD :: contentType -> DelayedIO body headersD :: DelayedIO headers paramsD :: DelayedIO params contentD :: DelayedIO contentType acceptD :: DelayedIO () authD :: DelayedIO auth methodD :: DelayedIO () capturesD :: env -> DelayedIO captures .. } -- Note [Existential Record Update] -- | Run a delayed server. Performs all scheduled operations -- in order, and passes the results from the capture and body -- blocks on to the actual handler. -- -- This should only be called once per request; otherwise the guarantees about -- effect and HTTP error ordering break down. runDelayed :: Delayed env a -> env -> Request -> ResourceT IO (RouteResult a) runDelayed :: forall env a. Delayed env a -> env -> Request -> ResourceT IO (RouteResult a) runDelayed Delayed{DelayedIO auth DelayedIO contentType DelayedIO params DelayedIO headers DelayedIO () env -> DelayedIO captures captures -> params -> headers -> auth -> body -> Request -> RouteResult a contentType -> DelayedIO body serverD :: captures -> params -> headers -> auth -> body -> Request -> RouteResult a bodyD :: contentType -> DelayedIO body headersD :: DelayedIO headers paramsD :: DelayedIO params contentD :: DelayedIO contentType acceptD :: DelayedIO () authD :: DelayedIO auth methodD :: DelayedIO () capturesD :: env -> DelayedIO captures serverD :: () bodyD :: () headersD :: () paramsD :: () contentD :: () acceptD :: forall env c. Delayed env c -> DelayedIO () authD :: () methodD :: forall env c. Delayed env c -> DelayedIO () capturesD :: () ..} env env = forall a. DelayedIO a -> Request -> ResourceT IO (RouteResult a) runDelayedIO forall a b. (a -> b) -> a -> b $ do Request r <- forall r (m :: * -> *). MonadReader r m => m r ask captures c <- env -> DelayedIO captures capturesD env env DelayedIO () methodD auth a <- DelayedIO auth authD DelayedIO () acceptD contentType content <- DelayedIO contentType contentD params p <- DelayedIO params paramsD -- Has to be before body parsing, but after content-type checks headers h <- DelayedIO headers headersD body b <- contentType -> DelayedIO body bodyD contentType content forall a. RouteResult a -> DelayedIO a liftRouteResult (captures -> params -> headers -> auth -> body -> Request -> RouteResult a serverD captures c params p headers h auth a body b Request r) -- | Runs a delayed server and the resulting action. -- Takes a continuation that lets us send a response. -- Also takes a continuation for how to turn the -- result of the delayed server into a response. runAction :: Delayed env (Handler a) -> env -> Request -> (RouteResult Response -> IO r) -> (a -> RouteResult Response) -> IO r runAction :: forall env a r. Delayed env (Handler a) -> env -> Request -> (RouteResult Response -> IO r) -> (a -> RouteResult Response) -> IO r runAction Delayed env (Handler a) action env env Request req RouteResult Response -> IO r respond a -> RouteResult Response k = forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a runResourceT forall a b. (a -> b) -> a -> b $ forall env a. Delayed env a -> env -> Request -> ResourceT IO (RouteResult a) runDelayed Delayed env (Handler a) action env env Request req forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= RouteResult (Handler a) -> ResourceT IO (RouteResult Response) go forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c . RouteResult Response -> IO r respond where go :: RouteResult (Handler a) -> ResourceT IO (RouteResult Response) go (Fail ServerError e) = forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ forall a. ServerError -> RouteResult a Fail ServerError e go (FailFatal ServerError e) = forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ forall a. ServerError -> RouteResult a FailFatal ServerError e go (Route Handler a a) = forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO forall a b. (a -> b) -> a -> b $ do Either ServerError a e <- forall a. Handler a -> IO (Either ServerError a) runHandler Handler a a case Either ServerError a e of Left ServerError err -> forall (m :: * -> *) a. Monad m => a -> m a return forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. a -> RouteResult a Route forall a b. (a -> b) -> a -> b $ ServerError -> Response responseServerError ServerError err Right a x -> forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $! a -> RouteResult Response k a x {- Note [Existential Record Update] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Due to GHC issue <https://ghc.haskell.org/trac/ghc/ticket/2595 2595>, we cannot do the more succinct thing - just update the records we actually change. -}