Merge pull request #1139 from phadej/servant-server-modules

Split RouteApplication mega-module

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)
 

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

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
 

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
 

servant-server/src/Servant/Server/Internal/BasicAuth.hs

@@ -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

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 <https://ghc.haskell.org/trac/ghc/ticket/2595 2595>, we cannot
+do the more succint thing - just update the records we actually change.
+-}

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

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

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

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 <https://ghc.haskell.org/trac/ghc/ticket/2595 2595>, we cannot
-do the more succint thing - just update the records we actually change.
--}

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)

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