From 48c5cc96a2a986732d2690bc53aeea2a968bdeab Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Wed, 27 Feb 2019 13:04:33 +0200 Subject: [PATCH] Split RouteApplication mega-module --- servant-server/CHANGELOG.md | 2 + servant-server/servant-server.cabal | 3 + .../src/Servant/Server/Experimental/Auth.hs | 8 +- servant-server/src/Servant/Server/Internal.hs | 6 + .../src/Servant/Server/Internal/BasicAuth.hs | 4 +- .../src/Servant/Server/Internal/Delayed.hs | 272 +++++++++++++ .../src/Servant/Server/Internal/DelayedIO.hs | 72 ++++ .../Servant/Server/Internal/RouteResult.hs | 76 ++++ .../src/Servant/Server/Internal/Router.hs | 1 + .../Server/Internal/RoutingApplication.hs | 381 +----------------- .../Server/Internal/RoutingApplicationSpec.hs | 2 +- servant/CHANGELOG.md | 2 + 12 files changed, 441 insertions(+), 388 deletions(-) create mode 100644 servant-server/src/Servant/Server/Internal/Delayed.hs create mode 100644 servant-server/src/Servant/Server/Internal/DelayedIO.hs create mode 100644 servant-server/src/Servant/Server/Internal/RouteResult.hs diff --git a/servant-server/CHANGELOG.md b/servant-server/CHANGELOG.md index 4d73d998..1d963104 100644 --- a/servant-server/CHANGELOG.md +++ b/servant-server/CHANGELOG.md @@ -8,6 +8,8 @@ [#1131](https://github.com/haskell-servant/pull/1131) - *servant-server* Reorder HTTP failure code priorities [#1103](https://github.com/haskell-servant/servant/pull/1103) +- *servant-server* Re-organise internal modules + [#1139](https://github.com/haskell-servant/servant/pull/1139) - Allow `network-3.0` [#1107](https://github.com/haskell-servant/pull/1107) diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index eb7f2140..7166100c 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -52,8 +52,11 @@ library Servant.Server.Internal Servant.Server.Internal.BasicAuth Servant.Server.Internal.Context + Servant.Server.Internal.Delayed + Servant.Server.Internal.DelayedIO Servant.Server.Internal.Handler Servant.Server.Internal.Router + Servant.Server.Internal.RouteResult Servant.Server.Internal.RoutingApplication Servant.Server.Internal.ServerError Servant.Server.StaticFiles diff --git a/servant-server/src/Servant/Server/Experimental/Auth.hs b/servant-server/src/Servant/Server/Experimental/Auth.hs index 43e8a633..20463903 100644 --- a/servant-server/src/Servant/Server/Experimental/Auth.hs +++ b/servant-server/src/Servant/Server/Experimental/Auth.hs @@ -27,11 +27,9 @@ import Servant ((:>)) import Servant.API.Experimental.Auth import Servant.Server.Internal - (HasContextEntry, HasServer (..), getContextEntry) -import Servant.Server.Internal.Handler - (Handler, runHandler) -import Servant.Server.Internal.RoutingApplication - (DelayedIO, addAuthCheck, delayedFailFatal, withRequest) + (DelayedIO, Handler, HasContextEntry, HasServer (..), + addAuthCheck, delayedFailFatal, getContextEntry, runHandler, + withRequest) -- * General Auth diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 27000054..6405e3dc 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -22,8 +22,11 @@ module Servant.Server.Internal ( module Servant.Server.Internal , module Servant.Server.Internal.BasicAuth , module Servant.Server.Internal.Context + , module Servant.Server.Internal.Delayed + , module Servant.Server.Internal.DelayedIO , module Servant.Server.Internal.Handler , module Servant.Server.Internal.Router + , module Servant.Server.Internal.RouteResult , module Servant.Server.Internal.RoutingApplication , module Servant.Server.Internal.ServerError ) where @@ -88,8 +91,11 @@ import Web.HttpApiData import Servant.Server.Internal.BasicAuth import Servant.Server.Internal.Context +import Servant.Server.Internal.Delayed +import Servant.Server.Internal.DelayedIO import Servant.Server.Internal.Handler import Servant.Server.Internal.Router +import Servant.Server.Internal.RouteResult import Servant.Server.Internal.RoutingApplication import Servant.Server.Internal.ServerError diff --git a/servant-server/src/Servant/Server/Internal/BasicAuth.hs b/servant-server/src/Servant/Server/Internal/BasicAuth.hs index 19e62c6d..8b5e06ae 100644 --- a/servant-server/src/Servant/Server/Internal/BasicAuth.hs +++ b/servant-server/src/Servant/Server/Internal/BasicAuth.hs @@ -9,7 +9,7 @@ import Control.Monad (guard) import Control.Monad.Trans (liftIO) -import qualified Data.ByteString as BS +import qualified Data.ByteString as BS import Data.ByteString.Base64 (decodeLenient) import Data.Monoid @@ -26,7 +26,7 @@ import Network.Wai import Servant.API.BasicAuth (BasicAuthData (BasicAuthData)) -import Servant.Server.Internal.RoutingApplication +import Servant.Server.Internal.DelayedIO import Servant.Server.Internal.ServerError -- * Basic Auth diff --git a/servant-server/src/Servant/Server/Internal/Delayed.hs b/servant-server/src/Servant/Server/Internal/Delayed.hs new file mode 100644 index 00000000..1e580cf6 --- /dev/null +++ b/servant-server/src/Servant/Server/Internal/Delayed.hs @@ -0,0 +1,272 @@ +{-# 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 + , methodD :: DelayedIO () + , authD :: DelayedIO auth + , 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 f Delayed{..} = + Delayed + { serverD = \ c p h a b req -> f <$> serverD c p h a b req + , .. + } -- Note [Existential Record Update] + +-- | A 'Delayed' without any stored checks. +emptyDelayed :: RouteResult a -> Delayed env a +emptyDelayed result = + Delayed (const r) r r r r r r (const r) (\ _ _ _ _ _ _ -> result) + where + r = return () + +-- | Add a capture to the end of the capture block. +addCapture :: Delayed env (a -> b) + -> (captured -> DelayedIO a) + -> Delayed (captured, env) b +addCapture Delayed{..} new = + Delayed + { capturesD = \ (txt, env) -> (,) <$> capturesD env <*> new txt + , serverD = \ (x, v) p h a b req -> ($ v) <$> serverD x p h a b req + , .. + } -- 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 Delayed {..} new = + Delayed + { paramsD = (,) <$> paramsD <*> new + , serverD = \c (p, pNew) h a b req -> ($ pNew) <$> serverD c p h a b req + , .. + } + +-- | Add a parameter check to the end of the params block +addHeaderCheck :: Delayed env (a -> b) + -> DelayedIO a + -> Delayed env b +addHeaderCheck Delayed {..} new = + Delayed + { headersD = (,) <$> headersD <*> new + , serverD = \c p (h, hNew) a b req -> ($ hNew) <$> serverD c p h a b req + , .. + } + +-- | Add a method check to the end of the method block. +addMethodCheck :: Delayed env a + -> DelayedIO () + -> Delayed env a +addMethodCheck Delayed{..} new = + Delayed + { methodD = methodD <* new + , .. + } -- 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 Delayed{..} new = + Delayed + { authD = (,) <$> authD <*> new + , serverD = \ c p h (y, v) b req -> ($ v) <$> serverD c p h y b req + , .. + } -- 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 Delayed{..} newContentD newBodyD = + Delayed + { contentD = (,) <$> contentD <*> newContentD + , bodyD = \(content, c) -> (,) <$> bodyD content <*> newBodyD c + , serverD = \ c p h a (z, v) req -> ($ v) <$> serverD c p h a z req + , .. + } -- 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 Delayed{..} new = + Delayed + { acceptD = acceptD *> new + , .. + } -- 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 Delayed{..} x = + Delayed + { serverD = \ c p h a b req -> ($ x req) <$> serverD c p h a b req + , .. + } -- 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 Delayed{..} env = runDelayedIO $ do + r <- ask + c <- capturesD env + methodD + a <- authD + acceptD + content <- contentD + p <- paramsD -- Has to be before body parsing, but after content-type checks + h <- headersD + b <- bodyD content + liftRouteResult (serverD c p h a b 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 action env req respond k = runResourceT $ + runDelayed action env req >>= go >>= liftIO . respond + where + go (Fail e) = return $ Fail e + go (FailFatal e) = return $ FailFatal e + go (Route a) = liftIO $ do + e <- runHandler a + case e of + Left err -> return . Route $ responseServerError err + Right x -> return $! k x + +{- Note [Existential Record Update] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Due to GHC issue , we cannot +do the more succint thing - just update the records we actually change. +-} diff --git a/servant-server/src/Servant/Server/Internal/DelayedIO.hs b/servant-server/src/Servant/Server/Internal/DelayedIO.hs new file mode 100644 index 00000000..52b6aff5 --- /dev/null +++ b/servant-server/src/Servant/Server/Internal/DelayedIO.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +module Servant.Server.Internal.DelayedIO where + +import Control.Monad.Base + (MonadBase (..)) +import Control.Monad.Catch + (MonadThrow (..)) +import Control.Monad.Reader + (MonadReader (..), ReaderT (..), runReaderT) +import Control.Monad.Trans + (MonadIO (..), MonadTrans (..)) +import Control.Monad.Trans.Control + (ComposeSt, MonadBaseControl (..), MonadTransControl (..), + defaultLiftBaseWith, defaultRestoreM) +import Control.Monad.Trans.Resource + (MonadResource (..), ResourceT, runInternalState, + runResourceT, transResourceT, withInternalState) +import Network.Wai + (Application, Request, Response, ResponseReceived) + +import Servant.Server.Internal.RouteResult +import Servant.Server.Internal.ServerError + +-- | Computations used in a 'Delayed' can depend on the +-- incoming 'Request', may perform 'IO', and result in a +-- 'RouteResult', meaning they can either suceed, fail +-- (with the possibility to recover), or fail fatally. +-- +newtype DelayedIO a = DelayedIO { runDelayedIO' :: ReaderT Request (ResourceT (RouteResultT IO)) a } + deriving + ( Functor, Applicative, Monad + , MonadIO, MonadReader Request + , MonadThrow + , MonadResource + ) + +instance MonadBase IO DelayedIO where + liftBase = liftIO + +liftRouteResult :: RouteResult a -> DelayedIO a +liftRouteResult x = DelayedIO $ lift . lift $ RouteResultT . return $ x + +instance MonadBaseControl IO DelayedIO where + -- type StM DelayedIO a = StM (ReaderT Request (ResourceT (RouteResultT IO))) a + -- liftBaseWith f = DelayedIO $ liftBaseWith $ \g -> f (g . runDelayedIO') + -- restoreM = DelayedIO . restoreM + + type StM DelayedIO a = RouteResult a + liftBaseWith f = DelayedIO $ ReaderT $ \req -> withInternalState $ \s -> + liftBaseWith $ \runInBase -> f $ \x -> + runInBase (runInternalState (runReaderT (runDelayedIO' x) req) s) + restoreM = DelayedIO . lift . withInternalState . const . restoreM + + +runDelayedIO :: DelayedIO a -> Request -> ResourceT IO (RouteResult a) +runDelayedIO m req = transResourceT runRouteResultT $ runReaderT (runDelayedIO' m) req + +-- | Fail with the option to recover. +delayedFail :: ServerError -> DelayedIO a +delayedFail err = liftRouteResult $ Fail err + +-- | Fail fatally, i.e., without any option to recover. +delayedFailFatal :: ServerError -> DelayedIO a +delayedFailFatal err = liftRouteResult $ FailFatal err + +-- | Gain access to the incoming request. +withRequest :: (Request -> DelayedIO a) -> DelayedIO a +withRequest f = do + req <- ask + f req diff --git a/servant-server/src/Servant/Server/Internal/RouteResult.hs b/servant-server/src/Servant/Server/Internal/RouteResult.hs new file mode 100644 index 00000000..399e487f --- /dev/null +++ b/servant-server/src/Servant/Server/Internal/RouteResult.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +module Servant.Server.Internal.RouteResult where + +import Control.Monad + (ap, liftM) +import Control.Monad.Base + (MonadBase (..)) +import Control.Monad.Catch + (MonadThrow (..)) +import Control.Monad.Trans + (MonadIO (..), MonadTrans (..)) +import Control.Monad.Trans.Control + (ComposeSt, MonadBaseControl (..), MonadTransControl (..), + defaultLiftBaseWith, defaultRestoreM) + +import Servant.Server.Internal.ServerError + +-- | The result of matching against a path in the route tree. +data RouteResult a = + Fail ServerError -- ^ Keep trying other paths. + -- The 'ServantError' should only be 404, 405 or 406. + | FailFatal !ServerError -- ^ Don't try other paths. + | Route !a + deriving (Eq, Show, Read, Functor) + +instance Applicative RouteResult where + pure = return + (<*>) = ap + +instance Monad RouteResult where + return = Route + Route a >>= f = f a + Fail e >>= _ = Fail e + FailFatal e >>= _ = FailFatal e + +newtype RouteResultT m a = RouteResultT { runRouteResultT :: m (RouteResult a) } + deriving (Functor) + +instance MonadTrans RouteResultT where + lift = RouteResultT . liftM Route + +instance (Functor m, Monad m) => Applicative (RouteResultT m) where + pure = return + (<*>) = ap + +instance Monad m => Monad (RouteResultT m) where + return = RouteResultT . return . Route + m >>= k = RouteResultT $ do + a <- runRouteResultT m + case a of + Fail e -> return $ Fail e + FailFatal e -> return $ FailFatal e + Route b -> runRouteResultT (k b) + +instance MonadIO m => MonadIO (RouteResultT m) where + liftIO = lift . liftIO + +instance MonadBase b m => MonadBase b (RouteResultT m) where + liftBase = lift . liftBase + +instance MonadBaseControl b m => MonadBaseControl b (RouteResultT m) where + type StM (RouteResultT m) a = ComposeSt RouteResultT m a + liftBaseWith = defaultLiftBaseWith + restoreM = defaultRestoreM + +instance MonadTransControl RouteResultT where + type StT RouteResultT a = RouteResult a + liftWith f = RouteResultT $ liftM return $ f runRouteResultT + restoreT = RouteResultT + +instance MonadThrow m => MonadThrow (RouteResultT m) where + throwM = lift . throwM diff --git a/servant-server/src/Servant/Server/Internal/Router.hs b/servant-server/src/Servant/Server/Internal/Router.hs index ccfdb159..d6735c9e 100644 --- a/servant-server/src/Servant/Server/Internal/Router.hs +++ b/servant-server/src/Servant/Server/Internal/Router.hs @@ -18,6 +18,7 @@ import qualified Data.Text as T import Network.Wai (Response, pathInfo) import Servant.Server.Internal.RoutingApplication +import Servant.Server.Internal.RouteResult import Servant.Server.Internal.ServerError type Router env = Router' env RoutingApplication diff --git a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs index ef88fd37..fd28c1e0 100644 --- a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs +++ b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs @@ -1,98 +1,16 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} module Servant.Server.Internal.RoutingApplication where -import Control.Monad - (ap, liftM) -import Control.Monad.Base - (MonadBase (..)) -import Control.Monad.Catch - (MonadThrow (..)) -import Control.Monad.Reader - (MonadReader (..), ReaderT (..), runReaderT) -import Control.Monad.Trans - (MonadIO (..), MonadTrans (..)) -import Control.Monad.Trans.Control - (ComposeSt, MonadBaseControl (..), MonadTransControl (..), - defaultLiftBaseWith, defaultRestoreM) -import Control.Monad.Trans.Resource - (MonadResource (..), ResourceT, runInternalState, - runResourceT, transResourceT, withInternalState) import Network.Wai (Application, Request, Response, ResponseReceived) import Prelude () import Prelude.Compat -import Servant.Server.Internal.Handler +import Servant.Server.Internal.RouteResult import Servant.Server.Internal.ServerError type RoutingApplication = Request -- ^ the request, the field 'pathInfo' may be modified by url routing -> (RouteResult Response -> IO ResponseReceived) -> IO ResponseReceived --- | The result of matching against a path in the route tree. -data RouteResult a = - Fail ServerError -- ^ Keep trying other paths. The @ServantErr@ - -- should only be 404, 405 or 406. - | FailFatal !ServerError -- ^ Don't try other paths. - | Route !a - deriving (Eq, Show, Read, Functor) - -instance Applicative RouteResult where - pure = return - (<*>) = ap - -instance Monad RouteResult where - return = Route - Route a >>= f = f a - Fail e >>= _ = Fail e - FailFatal e >>= _ = FailFatal e - -newtype RouteResultT m a = RouteResultT { runRouteResultT :: m (RouteResult a) } - deriving (Functor) - -instance MonadTrans RouteResultT where - lift = RouteResultT . liftM Route - -instance (Functor m, Monad m) => Applicative (RouteResultT m) where - pure = return - (<*>) = ap - -instance Monad m => Monad (RouteResultT m) where - return = RouteResultT . return . Route - m >>= k = RouteResultT $ do - a <- runRouteResultT m - case a of - Fail e -> return $ Fail e - FailFatal e -> return $ FailFatal e - Route b -> runRouteResultT (k b) - -instance MonadIO m => MonadIO (RouteResultT m) where - liftIO = lift . liftIO - -instance MonadBase b m => MonadBase b (RouteResultT m) where - liftBase = lift . liftBase - -instance MonadBaseControl b m => MonadBaseControl b (RouteResultT m) where - type StM (RouteResultT m) a = ComposeSt RouteResultT m a - liftBaseWith = defaultLiftBaseWith - restoreM = defaultRestoreM - -instance MonadTransControl RouteResultT where - type StT RouteResultT a = RouteResult a - liftWith f = RouteResultT $ liftM return $ f runRouteResultT - restoreT = RouteResultT - -instance MonadThrow m => MonadThrow (RouteResultT m) where - throwM = lift . throwM - toApplication :: RoutingApplication -> Application toApplication ra request respond = ra request routingRespond where @@ -100,300 +18,3 @@ toApplication ra request respond = ra request routingRespond routingRespond (Fail err) = respond $ responseServerError err routingRespond (FailFatal err) = respond $ responseServerError err routingRespond (Route v) = respond v - --- | 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 - , methodD :: DelayedIO () - , authD :: DelayedIO auth - , 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 f Delayed{..} = - Delayed - { serverD = \ c p h a b req -> f <$> serverD c p h a b req - , .. - } -- Note [Existential Record Update] - --- | Computations used in a 'Delayed' can depend on the --- incoming 'Request', may perform 'IO, and result in a --- 'RouteResult, meaning they can either suceed, fail --- (with the possibility to recover), or fail fatally. --- -newtype DelayedIO a = DelayedIO { runDelayedIO' :: ReaderT Request (ResourceT (RouteResultT IO)) a } - deriving - ( Functor, Applicative, Monad - , MonadIO, MonadReader Request - , MonadThrow - , MonadResource - ) - -instance MonadBase IO DelayedIO where - liftBase = liftIO - -liftRouteResult :: RouteResult a -> DelayedIO a -liftRouteResult x = DelayedIO $ lift . lift $ RouteResultT . return $ x - -instance MonadBaseControl IO DelayedIO where - -- type StM DelayedIO a = StM (ReaderT Request (ResourceT (RouteResultT IO))) a - -- liftBaseWith f = DelayedIO $ liftBaseWith $ \g -> f (g . runDelayedIO') - -- restoreM = DelayedIO . restoreM - - type StM DelayedIO a = RouteResult a - liftBaseWith f = DelayedIO $ ReaderT $ \req -> withInternalState $ \s -> - liftBaseWith $ \runInBase -> f $ \x -> - runInBase (runInternalState (runReaderT (runDelayedIO' x) req) s) - restoreM = DelayedIO . lift . withInternalState . const . restoreM - - -runDelayedIO :: DelayedIO a -> Request -> ResourceT IO (RouteResult a) -runDelayedIO m req = transResourceT runRouteResultT $ runReaderT (runDelayedIO' m) req - --- | A 'Delayed' without any stored checks. -emptyDelayed :: RouteResult a -> Delayed env a -emptyDelayed result = - Delayed (const r) r r r r r r (const r) (\ _ _ _ _ _ _ -> result) - where - r = return () - --- | Fail with the option to recover. -delayedFail :: ServerError -> DelayedIO a -delayedFail err = liftRouteResult $ Fail err - --- | Fail fatally, i.e., without any option to recover. -delayedFailFatal :: ServerError -> DelayedIO a -delayedFailFatal err = liftRouteResult $ FailFatal err - --- | Gain access to the incoming request. -withRequest :: (Request -> DelayedIO a) -> DelayedIO a -withRequest f = do - req <- ask - f req - --- | Add a capture to the end of the capture block. -addCapture :: Delayed env (a -> b) - -> (captured -> DelayedIO a) - -> Delayed (captured, env) b -addCapture Delayed{..} new = - Delayed - { capturesD = \ (txt, env) -> (,) <$> capturesD env <*> new txt - , serverD = \ (x, v) p h a b req -> ($ v) <$> serverD x p h a b req - , .. - } -- 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 Delayed {..} new = - Delayed - { paramsD = (,) <$> paramsD <*> new - , serverD = \c (p, pNew) h a b req -> ($ pNew) <$> serverD c p h a b req - , .. - } - --- | Add a parameter check to the end of the params block -addHeaderCheck :: Delayed env (a -> b) - -> DelayedIO a - -> Delayed env b -addHeaderCheck Delayed {..} new = - Delayed - { headersD = (,) <$> headersD <*> new - , serverD = \c p (h, hNew) a b req -> ($ hNew) <$> serverD c p h a b req - , .. - } - --- | Add a method check to the end of the method block. -addMethodCheck :: Delayed env a - -> DelayedIO () - -> Delayed env a -addMethodCheck Delayed{..} new = - Delayed - { methodD = methodD <* new - , .. - } -- 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 Delayed{..} new = - Delayed - { authD = (,) <$> authD <*> new - , serverD = \ c p h (y, v) b req -> ($ v) <$> serverD c p h y b req - , .. - } -- 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 Delayed{..} newContentD newBodyD = - Delayed - { contentD = (,) <$> contentD <*> newContentD - , bodyD = \(content, c) -> (,) <$> bodyD content <*> newBodyD c - , serverD = \ c p h a (z, v) req -> ($ v) <$> serverD c p h a z req - , .. - } -- 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 Delayed{..} new = - Delayed - { acceptD = acceptD *> new - , .. - } -- 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 Delayed{..} x = - Delayed - { serverD = \ c p h a b req -> ($ x req) <$> serverD c p h a b req - , .. - } -- 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 Delayed{..} env = runDelayedIO $ do - r <- ask - c <- capturesD env - methodD - a <- authD - acceptD - content <- contentD - p <- paramsD -- Has to be before body parsing, but after content-type checks - h <- headersD - b <- bodyD content - liftRouteResult (serverD c p h a b 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 action env req respond k = runResourceT $ - runDelayed action env req >>= go >>= liftIO . respond - where - go (Fail e) = return $ Fail e - go (FailFatal e) = return $ FailFatal e - go (Route a) = liftIO $ do - e <- runHandler a - case e of - Left err -> return . Route $ responseServerError err - Right x -> return $! k x - -{- Note [Existential Record Update] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Due to GHC issue , we cannot -do the more succint thing - just update the records we actually change. --} diff --git a/servant-server/test/Servant/Server/Internal/RoutingApplicationSpec.hs b/servant-server/test/Servant/Server/Internal/RoutingApplicationSpec.hs index c32e1b37..80210495 100644 --- a/servant-server/test/Servant/Server/Internal/RoutingApplicationSpec.hs +++ b/servant-server/test/Servant/Server/Internal/RoutingApplicationSpec.hs @@ -23,7 +23,7 @@ import GHC.TypeLits import Network.Wai (defaultRequest) import Servant -import Servant.Server.Internal.RoutingApplication +import Servant.Server.Internal import Test.Hspec import Test.Hspec.Wai (request, shouldRespondWith, with) diff --git a/servant/CHANGELOG.md b/servant/CHANGELOG.md index 34ba68e1..727a7cdd 100644 --- a/servant/CHANGELOG.md +++ b/servant/CHANGELOG.md @@ -53,6 +53,8 @@ [#1104](https://github.com/haskell-servant/servant/pull/1104) - *servant-server* Reorder HTTP failure code priorities [#1103](https://github.com/haskell-servant/servant/pull/1103) +- *servant-server* Re-organise internal modules + [#1139](https://github.com/haskell-servant/servant/pull/1139) - Allow `network-3.0` [#1107](https://github.com/haskell-servant/servant/pull/1107) - Add `NFData NoContent` instance