Split RouteApplication mega-module
This commit is contained in:
Oleg Grenrus
parent
f17a468872
commit
48c5cc96a2
12 changed files with 441 additions and 388 deletions
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
272
servant-server/src/Servant/Server/Internal/Delayed.hs
Normal file
272
servant-server/src/Servant/Server/Internal/Delayed.hs
Normal file
|
|
@ -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 <https://ghc.haskell.org/trac/ghc/ticket/2595 2595>, we cannot
|
||||
do the more succint thing - just update the records we actually change.
|
||||
-}
|
||||
72
servant-server/src/Servant/Server/Internal/DelayedIO.hs
Normal file
72
servant-server/src/Servant/Server/Internal/DelayedIO.hs
Normal file
|
|
@ -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
|
||||
76
servant-server/src/Servant/Server/Internal/RouteResult.hs
Normal file
76
servant-server/src/Servant/Server/Internal/RouteResult.hs
Normal file
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 <https://ghc.haskell.org/trac/ghc/ticket/2595 2595>, we cannot
|
||||
do the more succint thing - just update the records we actually change.
|
||||
-}
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in a new issue