2015-06-01 19:38:51 +02:00
|
|
|
{-# LANGUAGE CPP #-}
|
2015-09-10 08:49:19 +02:00
|
|
|
{-# LANGUAGE DeriveFunctor #-}
|
2015-06-01 19:38:51 +02:00
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
{-# LANGUAGE TypeOperators #-}
|
2015-09-16 22:07:55 +02:00
|
|
|
{-# LANGUAGE GADTs #-}
|
|
|
|
{-# LANGUAGE KindSignatures #-}
|
2016-02-17 19:56:15 +01:00
|
|
|
{-# LANGUAGE RecordWildCards #-}
|
2015-09-16 22:07:55 +02:00
|
|
|
{-# LANGUAGE StandaloneDeriving #-}
|
2015-06-01 19:38:51 +02:00
|
|
|
module Servant.Server.Internal.RoutingApplication where
|
|
|
|
|
2015-09-12 14:11:24 +02:00
|
|
|
import Control.Monad.Trans.Except (ExceptT, runExceptT)
|
2015-08-17 23:56:29 +02:00
|
|
|
import Network.Wai (Application, Request,
|
2016-02-18 16:36:24 +01:00
|
|
|
Response, ResponseReceived)
|
2016-03-01 12:41:24 +01:00
|
|
|
import Prelude.Compat
|
2015-06-01 19:38:51 +02:00
|
|
|
import Servant.Server.Internal.ServantErr
|
|
|
|
|
|
|
|
type RoutingApplication =
|
|
|
|
Request -- ^ the request, the field 'pathInfo' may be modified by url routing
|
|
|
|
-> (RouteResult Response -> IO ResponseReceived) -> IO ResponseReceived
|
|
|
|
|
2015-09-16 22:07:55 +02:00
|
|
|
-- | The result of matching against a path in the route tree.
|
2015-09-10 08:49:19 +02:00
|
|
|
data RouteResult a =
|
2015-09-15 11:37:17 +02:00
|
|
|
Fail ServantErr -- ^ Keep trying other paths. The @ServantErr@
|
2015-09-16 22:07:55 +02:00
|
|
|
-- should only be 404, 405 or 406.
|
|
|
|
| FailFatal !ServantErr -- ^ Don't try other paths.
|
|
|
|
| Route !a
|
2015-09-10 08:49:19 +02:00
|
|
|
deriving (Eq, Show, Read, Functor)
|
2015-06-01 19:38:51 +02:00
|
|
|
|
|
|
|
toApplication :: RoutingApplication -> Application
|
2016-01-26 14:43:15 +01:00
|
|
|
toApplication ra request respond = ra request routingRespond
|
2015-06-01 19:38:51 +02:00
|
|
|
where
|
2015-09-10 08:49:19 +02:00
|
|
|
routingRespond :: RouteResult Response -> IO ResponseReceived
|
2015-09-16 22:07:55 +02:00
|
|
|
routingRespond (Fail err) = respond $ responseServantErr err
|
|
|
|
routingRespond (FailFatal err) = respond $ responseServantErr err
|
|
|
|
routingRespond (Route v) = respond v
|
2015-06-01 19:38:51 +02:00
|
|
|
|
2015-09-16 22:07:55 +02:00
|
|
|
-- We currently mix up the order in which we perform checks
|
|
|
|
-- and the priority with which errors are reported.
|
|
|
|
--
|
|
|
|
-- For example, we perform Capture checks prior to method checks,
|
|
|
|
-- and therefore get 404 before 405.
|
|
|
|
--
|
|
|
|
-- However, we also perform body checks prior to method checks
|
|
|
|
-- now, and therefore get 415 before 405, which is wrong.
|
|
|
|
--
|
|
|
|
-- If we delay Captures, but perform method checks eagerly, we
|
2016-01-19 01:06:38 +01:00
|
|
|
-- end up potentially preferring 405 over 404, which is also bad.
|
2015-09-16 22:07:55 +02:00
|
|
|
--
|
|
|
|
-- So in principle, we'd like:
|
|
|
|
--
|
|
|
|
-- static routes (can cause 404)
|
|
|
|
-- delayed captures (can cause 404)
|
|
|
|
-- methods (can cause 405)
|
2016-02-17 19:00:31 +01:00
|
|
|
-- authentication and authorization (can cause 401, 403)
|
2015-09-16 22:07:55 +02:00
|
|
|
-- delayed body (can cause 415, 400)
|
|
|
|
-- accept header (can cause 406)
|
|
|
|
--
|
|
|
|
-- According to the HTTP decision diagram, the priority order
|
|
|
|
-- between HTTP status codes is as follows:
|
|
|
|
--
|
|
|
|
|
|
|
|
-- | 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:
|
|
|
|
--
|
2016-01-28 11:07:36 +01:00
|
|
|
-- 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.
|
2015-09-16 22:07:55 +02:00
|
|
|
--
|
|
|
|
-- 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)
|
|
|
|
-- 400 (bad request)
|
|
|
|
-- 406 (not acceptable)
|
|
|
|
-- @
|
|
|
|
--
|
|
|
|
-- Therefore, while routing, we delay most checks so that they
|
|
|
|
-- will ultimately occur in the right order.
|
|
|
|
--
|
|
|
|
-- A 'Delayed' contains three 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. Body and accept header checks. The request body check can
|
|
|
|
-- cause both 400 and 415. This provides an input to the handler.
|
|
|
|
-- The accept header check can be performed as the final
|
|
|
|
-- computation in this block. It can cause a 406.
|
|
|
|
--
|
2016-02-17 19:00:31 +01:00
|
|
|
data Delayed c where
|
|
|
|
Delayed :: { capturesD :: IO (RouteResult captures)
|
|
|
|
, methodD :: IO (RouteResult ())
|
|
|
|
, authD :: IO (RouteResult auth)
|
|
|
|
, bodyD :: IO (RouteResult body)
|
|
|
|
, serverD :: (captures -> auth -> body -> RouteResult c)
|
|
|
|
} -> Delayed c
|
2015-09-16 22:07:55 +02:00
|
|
|
|
2015-10-13 20:29:14 +02:00
|
|
|
instance Functor Delayed where
|
2016-02-17 19:00:31 +01:00
|
|
|
fmap f Delayed{..}
|
|
|
|
= Delayed { capturesD = capturesD
|
|
|
|
, methodD = methodD
|
|
|
|
, authD = authD
|
|
|
|
, bodyD = bodyD
|
|
|
|
, serverD = (fmap.fmap.fmap.fmap) f serverD
|
|
|
|
} -- Note [Existential Record Update]
|
2015-09-16 22:07:55 +02:00
|
|
|
|
|
|
|
-- | Add a capture to the end of the capture block.
|
|
|
|
addCapture :: Delayed (a -> b)
|
|
|
|
-> IO (RouteResult a)
|
|
|
|
-> Delayed b
|
2016-02-17 19:00:31 +01:00
|
|
|
addCapture Delayed{..} new
|
|
|
|
= Delayed { capturesD = combineRouteResults (,) capturesD new
|
|
|
|
, methodD = methodD
|
|
|
|
, authD = authD
|
|
|
|
, bodyD = bodyD
|
|
|
|
, serverD = \ (x, v) y z -> ($ v) <$> serverD x y z
|
|
|
|
} -- Note [Existential Record Update]
|
2015-09-16 22:07:55 +02:00
|
|
|
|
|
|
|
-- | Add a method check to the end of the method block.
|
|
|
|
addMethodCheck :: Delayed a
|
|
|
|
-> IO (RouteResult ())
|
|
|
|
-> Delayed a
|
2016-02-17 19:00:31 +01:00
|
|
|
addMethodCheck Delayed{..} new
|
|
|
|
= Delayed { capturesD = capturesD
|
|
|
|
, methodD = combineRouteResults const methodD new
|
|
|
|
, authD = authD
|
|
|
|
, bodyD = bodyD
|
|
|
|
, serverD = serverD
|
|
|
|
} -- Note [Existential Record Update]
|
|
|
|
|
|
|
|
-- | Add an auth check to the end of the auth block.
|
|
|
|
addAuthCheck :: Delayed (a -> b)
|
|
|
|
-> IO (RouteResult a)
|
|
|
|
-> Delayed b
|
|
|
|
addAuthCheck Delayed{..} new
|
|
|
|
= Delayed { capturesD = capturesD
|
|
|
|
, methodD = methodD
|
|
|
|
, authD = combineRouteResults (,) authD new
|
|
|
|
, bodyD = bodyD
|
|
|
|
, serverD = \ x (y, v) z -> ($ v) <$> serverD x y z
|
|
|
|
} -- Note [Existential Record Update]
|
2015-09-16 22:07:55 +02:00
|
|
|
|
|
|
|
-- | Add a body check to the end of the body block.
|
|
|
|
addBodyCheck :: Delayed (a -> b)
|
|
|
|
-> IO (RouteResult a)
|
|
|
|
-> Delayed b
|
2016-02-17 19:00:31 +01:00
|
|
|
addBodyCheck Delayed{..} new
|
|
|
|
= Delayed { capturesD = capturesD
|
|
|
|
, methodD = methodD
|
|
|
|
, authD = authD
|
|
|
|
, bodyD = combineRouteResults (,) bodyD new
|
|
|
|
, serverD = \ x y (z, v) -> ($ v) <$> serverD x y z
|
|
|
|
} -- Note [Existential Record Update]
|
|
|
|
|
2015-09-16 22:07:55 +02:00
|
|
|
|
|
|
|
-- | Add an accept header check to the end of the body block.
|
|
|
|
-- The accept header check should occur after the body check,
|
|
|
|
-- but this will be the case, because the accept header check
|
|
|
|
-- is only scheduled by the method combinators.
|
|
|
|
addAcceptCheck :: Delayed a
|
|
|
|
-> IO (RouteResult ())
|
|
|
|
-> Delayed a
|
2016-02-17 19:00:31 +01:00
|
|
|
addAcceptCheck Delayed{..} new
|
|
|
|
= Delayed { capturesD = capturesD
|
|
|
|
, methodD = methodD
|
|
|
|
, authD = authD
|
|
|
|
, bodyD = combineRouteResults const bodyD new
|
|
|
|
, serverD = serverD
|
|
|
|
} -- Note [Existential Record Update]
|
2015-09-16 22:07:55 +02:00
|
|
|
|
|
|
|
-- | 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 (a -> b) -> a -> Delayed b
|
|
|
|
passToServer d x = ($ x) <$> d
|
|
|
|
|
|
|
|
-- | The combination 'IO . RouteResult' is a monad, but we
|
|
|
|
-- don't explicitly wrap it in a newtype in order to make it
|
|
|
|
-- an instance. This is the '>>=' of that monad.
|
|
|
|
--
|
|
|
|
-- We stop on the first error.
|
|
|
|
bindRouteResults :: IO (RouteResult a) -> (a -> IO (RouteResult b)) -> IO (RouteResult b)
|
|
|
|
bindRouteResults m f = do
|
|
|
|
r <- m
|
|
|
|
case r of
|
|
|
|
Fail e -> return $ Fail e
|
|
|
|
FailFatal e -> return $ FailFatal e
|
|
|
|
Route a -> f a
|
|
|
|
|
|
|
|
-- | Common special case of 'bindRouteResults', corresponding
|
|
|
|
-- to 'liftM2'.
|
|
|
|
combineRouteResults :: (a -> b -> c) -> IO (RouteResult a) -> IO (RouteResult b) -> IO (RouteResult c)
|
|
|
|
combineRouteResults f m1 m2 =
|
|
|
|
m1 `bindRouteResults` \ a ->
|
|
|
|
m2 `bindRouteResults` \ b ->
|
|
|
|
return (Route (f a b))
|
|
|
|
|
|
|
|
-- | 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.
|
2016-02-17 19:00:31 +01:00
|
|
|
--
|
|
|
|
-- This should only be called once per request; otherwise the guarantees about
|
|
|
|
-- effect and HTTP error ordering break down.
|
2015-09-16 22:07:55 +02:00
|
|
|
runDelayed :: Delayed a
|
|
|
|
-> IO (RouteResult a)
|
2016-02-17 19:00:31 +01:00
|
|
|
runDelayed Delayed{..} =
|
|
|
|
capturesD `bindRouteResults` \ c ->
|
|
|
|
methodD `bindRouteResults` \ _ ->
|
|
|
|
authD `bindRouteResults` \ a ->
|
|
|
|
bodyD `bindRouteResults` \ b ->
|
|
|
|
return (serverD c a b)
|
2015-09-16 22:07:55 +02:00
|
|
|
|
|
|
|
-- | 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 (ExceptT ServantErr IO a)
|
2015-06-01 19:38:51 +02:00
|
|
|
-> (RouteResult Response -> IO r)
|
|
|
|
-> (a -> RouteResult Response)
|
|
|
|
-> IO r
|
2015-09-16 22:07:55 +02:00
|
|
|
runAction action respond k = runDelayed action >>= go >>= respond
|
2015-06-01 19:38:51 +02:00
|
|
|
where
|
2016-01-28 11:08:22 +01:00
|
|
|
go (Fail e) = return $ Fail e
|
2015-09-15 11:37:17 +02:00
|
|
|
go (FailFatal e) = return $ FailFatal e
|
2016-01-28 11:08:22 +01:00
|
|
|
go (Route a) = do
|
2015-09-12 14:11:24 +02:00
|
|
|
e <- runExceptT a
|
2015-09-10 08:49:19 +02:00
|
|
|
case e of
|
2015-09-15 11:37:17 +02:00
|
|
|
Left err -> return . Route $ responseServantErr err
|
2015-09-10 08:49:19 +02:00
|
|
|
Right x -> return $! k x
|
2016-02-17 19:00:31 +01:00
|
|
|
|
|
|
|
{- Note [Existential Record Update]
|
|
|
|
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
|
|
|
|
|
|
Due to GHC issue <https://ghc.haskell.org/trac/ghc/ticket/2595 2595>, we cannot
|
|
|
|
do the more succint thing - just update the records we actually change.
|
|
|
|
-}
|