|
| 1 | +{-# LANGUAGE CPP #-} |
| 2 | +{-# LANGUAGE FlexibleInstances #-} |
| 3 | +{-# LANGUAGE GADTs #-} |
| 4 | +{-# LANGUAGE MultiParamTypeClasses #-} |
| 5 | +{-# LANGUAGE RecordWildCards #-} |
| 6 | +{-# LANGUAGE TypeFamilies #-} |
| 7 | +{-# LANGUAGE TypeOperators #-} |
| 8 | +{-# LANGUAGE UndecidableInstances #-} |
| 9 | +module Servant.Server.Internal.Delayed where |
| 10 | + |
| 11 | +import Control.Monad.IO.Class |
| 12 | + (MonadIO (..)) |
| 13 | +import Control.Monad.Reader |
| 14 | + (ask) |
| 15 | +import Control.Monad.Trans.Resource |
| 16 | + (ResourceT, runResourceT) |
| 17 | +import Network.Wai |
| 18 | + (Request, Response) |
| 19 | + |
| 20 | +import Servant.Server.Internal.DelayedIO |
| 21 | +import Servant.Server.Internal.Handler |
| 22 | +import Servant.Server.Internal.RouteResult |
| 23 | +import Servant.Server.Internal.ServerError |
| 24 | + |
| 25 | +-- | A 'Delayed' is a representation of a handler with scheduled |
| 26 | +-- delayed checks that can trigger errors. |
| 27 | +-- |
| 28 | +-- Why would we want to delay checks? |
| 29 | +-- |
| 30 | +-- There are two reasons: |
| 31 | +-- |
| 32 | +-- 1. In a straight-forward implementation, the order in which we |
| 33 | +-- perform checks will determine the error we generate. This is |
| 34 | +-- because once an error occurs, we would abort and not perform |
| 35 | +-- any subsequent checks, but rather return the current error. |
| 36 | +-- |
| 37 | +-- This is not a necessity: we could continue doing other checks, |
| 38 | +-- and choose the preferred error. However, that would in general |
| 39 | +-- mean more checking, which leads us to the other reason. |
| 40 | +-- |
| 41 | +-- 2. We really want to avoid doing certain checks too early. For |
| 42 | +-- example, captures involve parsing, and are much more costly |
| 43 | +-- than static route matches. In particular, if several paths |
| 44 | +-- contain the "same" capture, we'd like as much as possible to |
| 45 | +-- avoid trying the same parse many times. Also tricky is the |
| 46 | +-- request body. Again, this involves parsing, but also, WAI makes |
| 47 | +-- obtaining the request body a side-effecting operation. We |
| 48 | +-- could/can work around this by manually caching the request body, |
| 49 | +-- but we'd rather keep the number of times we actually try to |
| 50 | +-- decode the request body to an absolute minimum. |
| 51 | +-- |
| 52 | +-- We prefer to have the following relative priorities of error |
| 53 | +-- codes: |
| 54 | +-- |
| 55 | +-- @ |
| 56 | +-- 404 |
| 57 | +-- 405 (bad method) |
| 58 | +-- 401 (unauthorized) |
| 59 | +-- 415 (unsupported media type) |
| 60 | +-- 406 (not acceptable) |
| 61 | +-- 400 (bad request) |
| 62 | +-- @ |
| 63 | +-- |
| 64 | +-- Therefore, while routing, we delay most checks so that they |
| 65 | +-- will ultimately occur in the right order. |
| 66 | +-- |
| 67 | +-- A 'Delayed' contains many delayed blocks of tests, and |
| 68 | +-- the actual handler: |
| 69 | +-- |
| 70 | +-- 1. Delayed captures. These can actually cause 404, and |
| 71 | +-- while they're costly, they should be done first among the |
| 72 | +-- delayed checks (at least as long as we do not decouple the |
| 73 | +-- check order from the error reporting, see above). Delayed |
| 74 | +-- captures can provide inputs to the actual handler. |
| 75 | +-- |
| 76 | +-- 2. Method check(s). This can cause a 405. On success, |
| 77 | +-- it does not provide an input for the handler. Method checks |
| 78 | +-- are comparatively cheap. |
| 79 | +-- |
| 80 | +-- 3. Authentication checks. This can cause 401. |
| 81 | +-- |
| 82 | +-- 4. Accept and content type header checks. These checks |
| 83 | +-- can cause 415 and 406 errors. |
| 84 | +-- |
| 85 | +-- 5. Query parameter checks. They require parsing and can cause 400 if the |
| 86 | +-- parsing fails. Query parameter checks provide inputs to the handler |
| 87 | +-- |
| 88 | +-- 6. Header Checks. They also require parsing and can cause 400 if parsing fails. |
| 89 | +-- |
| 90 | +-- 7. Body check. The request body check can cause 400. |
| 91 | +-- |
| 92 | +data Delayed env c where |
| 93 | + Delayed :: { capturesD :: env -> DelayedIO captures |
| 94 | + , methodD :: DelayedIO () |
| 95 | + , authD :: DelayedIO auth |
| 96 | + , acceptD :: DelayedIO () |
| 97 | + , contentD :: DelayedIO contentType |
| 98 | + , paramsD :: DelayedIO params |
| 99 | + , headersD :: DelayedIO headers |
| 100 | + , bodyD :: contentType -> DelayedIO body |
| 101 | + , serverD :: captures |
| 102 | + -> params |
| 103 | + -> headers |
| 104 | + -> auth |
| 105 | + -> body |
| 106 | + -> Request |
| 107 | + -> RouteResult c |
| 108 | + } -> Delayed env c |
| 109 | + |
| 110 | +instance Functor (Delayed env) where |
| 111 | + fmap f Delayed{..} = |
| 112 | + Delayed |
| 113 | + { serverD = \ c p h a b req -> f <$> serverD c p h a b req |
| 114 | + , .. |
| 115 | + } -- Note [Existential Record Update] |
| 116 | + |
| 117 | +-- | A 'Delayed' without any stored checks. |
| 118 | +emptyDelayed :: RouteResult a -> Delayed env a |
| 119 | +emptyDelayed result = |
| 120 | + Delayed (const r) r r r r r r (const r) (\ _ _ _ _ _ _ -> result) |
| 121 | + where |
| 122 | + r = return () |
| 123 | + |
| 124 | +-- | Add a capture to the end of the capture block. |
| 125 | +addCapture :: Delayed env (a -> b) |
| 126 | + -> (captured -> DelayedIO a) |
| 127 | + -> Delayed (captured, env) b |
| 128 | +addCapture Delayed{..} new = |
| 129 | + Delayed |
| 130 | + { capturesD = \ (txt, env) -> (,) <$> capturesD env <*> new txt |
| 131 | + , serverD = \ (x, v) p h a b req -> ($ v) <$> serverD x p h a b req |
| 132 | + , .. |
| 133 | + } -- Note [Existential Record Update] |
| 134 | + |
| 135 | +-- | Add a parameter check to the end of the params block |
| 136 | +addParameterCheck :: Delayed env (a -> b) |
| 137 | + -> DelayedIO a |
| 138 | + -> Delayed env b |
| 139 | +addParameterCheck Delayed {..} new = |
| 140 | + Delayed |
| 141 | + { paramsD = (,) <$> paramsD <*> new |
| 142 | + , serverD = \c (p, pNew) h a b req -> ($ pNew) <$> serverD c p h a b req |
| 143 | + , .. |
| 144 | + } |
| 145 | + |
| 146 | +-- | Add a parameter check to the end of the params block |
| 147 | +addHeaderCheck :: Delayed env (a -> b) |
| 148 | + -> DelayedIO a |
| 149 | + -> Delayed env b |
| 150 | +addHeaderCheck Delayed {..} new = |
| 151 | + Delayed |
| 152 | + { headersD = (,) <$> headersD <*> new |
| 153 | + , serverD = \c p (h, hNew) a b req -> ($ hNew) <$> serverD c p h a b req |
| 154 | + , .. |
| 155 | + } |
| 156 | + |
| 157 | +-- | Add a method check to the end of the method block. |
| 158 | +addMethodCheck :: Delayed env a |
| 159 | + -> DelayedIO () |
| 160 | + -> Delayed env a |
| 161 | +addMethodCheck Delayed{..} new = |
| 162 | + Delayed |
| 163 | + { methodD = methodD <* new |
| 164 | + , .. |
| 165 | + } -- Note [Existential Record Update] |
| 166 | + |
| 167 | +-- | Add an auth check to the end of the auth block. |
| 168 | +addAuthCheck :: Delayed env (a -> b) |
| 169 | + -> DelayedIO a |
| 170 | + -> Delayed env b |
| 171 | +addAuthCheck Delayed{..} new = |
| 172 | + Delayed |
| 173 | + { authD = (,) <$> authD <*> new |
| 174 | + , serverD = \ c p h (y, v) b req -> ($ v) <$> serverD c p h y b req |
| 175 | + , .. |
| 176 | + } -- Note [Existential Record Update] |
| 177 | + |
| 178 | +-- | Add a content type and body checks around parameter checks. |
| 179 | +-- |
| 180 | +-- We'll report failed content type check (415), before trying to parse |
| 181 | +-- query parameters (400). Which, in turn, happens before request body parsing. |
| 182 | +addBodyCheck :: Delayed env (a -> b) |
| 183 | + -> DelayedIO c -- ^ content type check |
| 184 | + -> (c -> DelayedIO a) -- ^ body check |
| 185 | + -> Delayed env b |
| 186 | +addBodyCheck Delayed{..} newContentD newBodyD = |
| 187 | + Delayed |
| 188 | + { contentD = (,) <$> contentD <*> newContentD |
| 189 | + , bodyD = \(content, c) -> (,) <$> bodyD content <*> newBodyD c |
| 190 | + , serverD = \ c p h a (z, v) req -> ($ v) <$> serverD c p h a z req |
| 191 | + , .. |
| 192 | + } -- Note [Existential Record Update] |
| 193 | + |
| 194 | + |
| 195 | +-- | Add an accept header check before handling parameters. |
| 196 | +-- In principle, we'd like |
| 197 | +-- to take a bad body (400) response take precedence over a |
| 198 | +-- failed accept check (406). BUT to allow streaming the body, |
| 199 | +-- we cannot run the body check and then still backtrack. |
| 200 | +-- We therefore do the accept check before the body check, |
| 201 | +-- when we can still backtrack. There are other solutions to |
| 202 | +-- this, but they'd be more complicated (such as delaying the |
| 203 | +-- body check further so that it can still be run in a situation |
| 204 | +-- where we'd otherwise report 406). |
| 205 | +addAcceptCheck :: Delayed env a |
| 206 | + -> DelayedIO () |
| 207 | + -> Delayed env a |
| 208 | +addAcceptCheck Delayed{..} new = |
| 209 | + Delayed |
| 210 | + { acceptD = acceptD *> new |
| 211 | + , .. |
| 212 | + } -- Note [Existential Record Update] |
| 213 | + |
| 214 | +-- | Many combinators extract information that is passed to |
| 215 | +-- the handler without the possibility of failure. In such a |
| 216 | +-- case, 'passToServer' can be used. |
| 217 | +passToServer :: Delayed env (a -> b) -> (Request -> a) -> Delayed env b |
| 218 | +passToServer Delayed{..} x = |
| 219 | + Delayed |
| 220 | + { serverD = \ c p h a b req -> ($ x req) <$> serverD c p h a b req |
| 221 | + , .. |
| 222 | + } -- Note [Existential Record Update] |
| 223 | + |
| 224 | +-- | Run a delayed server. Performs all scheduled operations |
| 225 | +-- in order, and passes the results from the capture and body |
| 226 | +-- blocks on to the actual handler. |
| 227 | +-- |
| 228 | +-- This should only be called once per request; otherwise the guarantees about |
| 229 | +-- effect and HTTP error ordering break down. |
| 230 | +runDelayed :: Delayed env a |
| 231 | + -> env |
| 232 | + -> Request |
| 233 | + -> ResourceT IO (RouteResult a) |
| 234 | +runDelayed Delayed{..} env = runDelayedIO $ do |
| 235 | + r <- ask |
| 236 | + c <- capturesD env |
| 237 | + methodD |
| 238 | + a <- authD |
| 239 | + acceptD |
| 240 | + content <- contentD |
| 241 | + p <- paramsD -- Has to be before body parsing, but after content-type checks |
| 242 | + h <- headersD |
| 243 | + b <- bodyD content |
| 244 | + liftRouteResult (serverD c p h a b r) |
| 245 | + |
| 246 | +-- | Runs a delayed server and the resulting action. |
| 247 | +-- Takes a continuation that lets us send a response. |
| 248 | +-- Also takes a continuation for how to turn the |
| 249 | +-- result of the delayed server into a response. |
| 250 | +runAction :: Delayed env (Handler a) |
| 251 | + -> env |
| 252 | + -> Request |
| 253 | + -> (RouteResult Response -> IO r) |
| 254 | + -> (a -> RouteResult Response) |
| 255 | + -> IO r |
| 256 | +runAction action env req respond k = runResourceT $ |
| 257 | + runDelayed action env req >>= go >>= liftIO . respond |
| 258 | + where |
| 259 | + go (Fail e) = return $ Fail e |
| 260 | + go (FailFatal e) = return $ FailFatal e |
| 261 | + go (Route a) = liftIO $ do |
| 262 | + e <- runHandler a |
| 263 | + case e of |
| 264 | + Left err -> return . Route $ responseServerError err |
| 265 | + Right x -> return $! k x |
| 266 | + |
| 267 | +{- Note [Existential Record Update] |
| 268 | +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
| 269 | +
|
| 270 | +Due to GHC issue <https://ghc.haskell.org/trac/ghc/ticket/2595 2595>, we cannot |
| 271 | +do the more succint thing - just update the records we actually change. |
| 272 | +-} |
0 commit comments