WIP: Introduce Redirect combinator

changelog.d/1561

@@ -0,0 +1,33 @@
+synopsis: New combinator to return routed path in response headers
+prs: #1561
+issues: #1553
+
+description: {
+
+This commit introduces a new type-level combinator, `WithRoutingHeader`.
+It modifies the behaviour of the following sub-API, such that all endpoints of said API return an additional routing header in their response.
+
+A routing header is a header that specifies which endpoint the incoming request was routed to.
+Endpoint are designated by their path, in which `Capture'` and `CaptureAll` combinators are replaced by a capture hint.
+
+This header can be used by downstream middlewares to gather information about individual endpoints, since in most cases
+a routing header uniquely identifies a single endpoint.
+
+Example:
+
+```haskell
+type MyApi =
+  WithRoutingHeader :> "by-id" :> Capture "id" Int :> Get '[JSON] Foo
+-- GET /by-id/1234 will return a response with the following header:
+--   ("Servant-Routed-Path", "/by-id/<id::Int>")
+```
+
+To achieve this, two refactorings were necessary:
+
+* Introduce a type `RouterEnv env` to encapsulate the `env` type (as in `Router env a`), which contains a tuple-encoded list of url pieces parsed from the incoming request. This type makes it possible to pass more information throughout the routing process, and the computation of the `Delayed env c` associated with each request.
+* Introduce a new kind of router, which only modifies the `RouterEnv`, and doesn't affect the routing process otherwise: `EnvRouter (RouterEnv env -> RouterEnv env) (Router' env a)`.
+  This new router is used when encountering the `WithRoutingHeader` combinator in an API, to notify the endpoints of the sub-API that they must produce a routing header (this behaviour is disabled by default).
+
+This PR also introduces `Spec` tests for the `WithRoutingHeader` combinator, which showcase some of its possible uses.
+
+}

servant-server/servant-server.cabal

@@ -46,6 +46,8 @@ library
     Servant.Server.Internal.DelayedIO
     Servant.Server.Internal.ErrorFormatter
     Servant.Server.Internal.Handler
+    Servant.Server.Internal.Redirect
+    Servant.Server.Internal.RouterEnv
     Servant.Server.Internal.RouteResult
     Servant.Server.Internal.Router
     Servant.Server.Internal.RoutingApplication
@@ -142,6 +144,7 @@ test-suite spec
     , base-compat
     , base64-bytestring
     , bytestring
+    , containers
     , http-types
     , mtl
     , resourcet

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

@@ -26,6 +26,7 @@ module Servant.Server.Internal
   , module Servant.Server.Internal.ErrorFormatter
   , module Servant.Server.Internal.Handler
   , module Servant.Server.Internal.Router
+  , module Servant.Server.Internal.RouterEnv
   , module Servant.Server.Internal.RouteResult
   , module Servant.Server.Internal.RoutingApplication
   , module Servant.Server.Internal.ServerError
@@ -73,10 +74,10 @@ import           Servant.API
                  CaptureAll, Description, EmptyAPI, Fragment,
                  FramingRender (..), FramingUnrender (..), FromSourceIO (..),
                  Header', If, IsSecure (..), NoContentVerb, QueryFlag,
-                 QueryParam', QueryParams, Raw, ReflectMethod (reflectMethod),
+                 QueryParam', QueryParams, Raw, Redirect, ReflectMethod (reflectMethod),
                  RemoteHost, ReqBody', SBool (..), SBoolI (..), SourceIO,
                  Stream, StreamBody', Summary, ToSourceIO (..), Vault, Verb,
-                 WithNamedContext, NamedRoutes)
+                 WithNamedContext, WithRoutingHeader, NamedRoutes)
 import           Servant.API.Generic (GenericMode(..), ToServant, ToServantApi, GServantProduct, toServant, fromServant)
 import           Servant.API.ContentTypes
                  (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..),
@@ -88,7 +89,7 @@ import           Servant.API.Modifiers
 import           Servant.API.ResponseHeaders
                  (GetHeaders, Headers, getHeaders, getResponse)
 import           Servant.API.Status
-                 (statusFromNat)
+                 (Redirection, statusFromNat)
 import qualified Servant.Types.SourceT                      as S
 import           Servant.API.TypeErrors
 import           Web.HttpApiData
@@ -101,8 +102,10 @@ import           Servant.Server.Internal.Delayed
 import           Servant.Server.Internal.DelayedIO
 import           Servant.Server.Internal.ErrorFormatter
 import           Servant.Server.Internal.Handler
+import           Servant.Server.Internal.Redirect
 import           Servant.Server.Internal.Router
 import           Servant.Server.Internal.RouteResult
+import           Servant.Server.Internal.RouterEnv
 import           Servant.Server.Internal.RoutingApplication
 import           Servant.Server.Internal.ServerError
 
@@ -241,6 +244,40 @@ instance (KnownSymbol capture, FromHttpApiData a, Typeable a
       formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
       hint = CaptureHint (T.pack $ symbolVal $ Proxy @capture) (typeRep (Proxy :: Proxy [a]))
 
+-- | Using 'WithRoutingHeaders' in one of the endpoints for your API,
+-- will automatically add routing headers to the response generated by the server.
+--
+-- @since 0.20
+--
+instance ( HasServer api context
+         , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
+         )
+      => HasServer (WithRoutingHeader :> api) context where
+
+  type ServerT (WithRoutingHeader :> api) m = ServerT api m
+
+  hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt s
+
+  route _ context d =
+      EnvRouter enableRoutingHeaders $ route (Proxy :: Proxy api) context d
+
+-- | TODO: Documentation
+instance ( HasServer api context
+         , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
+         , KnownSymbol location
+         , AllStatusesInClass Redirection api
+         )
+      => HasServer (Redirect location :> api) context where
+
+  type ServerT (Redirect location :> api) m = ServerT api m
+
+  hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt s
+
+  route _ context d =
+      EnvRouter
+        (withLocationHeader $ symbolVal $ Proxy @location)
+        (route (Proxy :: Proxy api) context d)
+
 allowedMethodHead :: Method -> Request -> Bool
 allowedMethodHead method request = method == methodGet && requestMethod request == methodHead
 
@@ -292,7 +329,10 @@ noContentRouter method status action = leafRouter route'
     route' env request respond =
           runAction (action `addMethodCheck` methodCheck method request)
                     env request respond $ \ _output ->
-                      Route $ responseLBS status [] ""
+                      let headers = if (shouldReturnRoutedPath env)
+                            then [(hRoutedPathHeader, cs $ routedPathRepr env)]
+                            else []
+                      in Route $ responseLBS status headers ""
 
 instance {-# OVERLAPPABLE #-}
          ( AllCTRender ctypes a, ReflectMethod method, KnownNat status

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

@@ -14,11 +14,15 @@ import           Control.Monad.Reader
                  (ask)
 import           Control.Monad.Trans.Resource
                  (ResourceT, runResourceT)
+import           Data.String.Conversions
+                 (cs)
 import           Network.Wai
-                 (Request, Response)
+                 (Request, Response, mapResponseHeaders)
 
 import           Servant.Server.Internal.DelayedIO
 import           Servant.Server.Internal.Handler
+import           Servant.Server.Internal.RouterEnv
+                 (RouterEnv (..), hLocationHeader, hRoutedPathHeader, routedPathRepr)
 import           Servant.Server.Internal.RouteResult
 import           Servant.Server.Internal.ServerError
 
@@ -228,12 +232,12 @@ passToServer Delayed{..} x =
 -- This should only be called once per request; otherwise the guarantees about
 -- effect and HTTP error ordering break down.
 runDelayed :: Delayed env a
-           -> env
+           -> RouterEnv env
            -> Request
            -> ResourceT IO (RouteResult a)
 runDelayed Delayed{..} env = runDelayedIO $ do
     r <- ask
-    c <- capturesD env
+    c <- capturesD $ routerEnv env
     methodD
     a <- authD
     acceptD
@@ -248,7 +252,7 @@ runDelayed Delayed{..} env = runDelayedIO $ do
 -- Also takes a continuation for how to turn the
 -- result of the delayed server into a response.
 runAction :: Delayed env (Handler a)
-          -> env
+          -> RouterEnv env
           -> Request
           -> (RouteResult Response -> IO r)
           -> (a -> RouteResult Response)
@@ -261,8 +265,18 @@ runAction action env req respond k = runResourceT $
     go (Route a)     = liftIO $ do
       e <- runHandler a
       case e of
-        Left err -> return . Route $ responseServerError err
-        Right x  -> return $! k x
+        Left err -> return . Route . withRoutingHeaders $ responseServerError err
+        Right x  -> return $! withHeaders <$> k x
+    withRoutingHeaders :: Response -> Response
+    withRoutingHeaders = if shouldReturnRoutedPath env
+      then mapResponseHeaders ((hRoutedPathHeader, cs $ routedPathRepr env) :)
+      else id
+    withLocationHeader :: Response -> Response
+    withLocationHeader = case locationHeader env of
+      Nothing -> id
+      Just location -> mapResponseHeaders ((hLocationHeader, cs location) :)
+    withHeaders :: Response -> Response
+    withHeaders = withLocationHeader . withRoutingHeaders
 
 {- Note [Existential Record Update]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

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

@@ -0,0 +1,53 @@
+{-# LANGUAGE DataKinds              #-}
+{-# LANGUAGE FlexibleInstances      #-}          
+{-# LANGUAGE MultiParamTypeClasses  #-}
+{-# LANGUAGE PolyKinds              #-}
+{-# LANGUAGE TypeFamilies           #-}
+{-# LANGUAGE TypeOperators          #-}
+{-# LANGUAGE UndecidableInstances   #-}
+
+module Servant.Server.Internal.Redirect where
+
+import           Data.SOP.Constraint
+                 (All)
+import           GHC.TypeLits
+                 (Nat, ErrorMessage(..), TypeError)
+import           Servant.API
+                 ((:>), (:<|>), Raw, Statuses, Stream, UVerb, Verb)
+import           Servant.API.Status
+                 (HasStatusClass, KnownStatusClass)
+
+type family (as :: [k]) ++ (bs :: [k]) :: [k] where
+  '[] ++ bs = bs
+  (a ': as) ++ bs = a ': (as ++ bs)
+
+-- | A type class to gather all statically declared HTTP status codes of an api
+class HasApiStatuses a where
+  type ApiStatuses a :: [Nat]
+
+instance HasApiStatuses (Verb method status ctypes a) where
+  type ApiStatuses (Verb _ status _ _) = '[status]
+
+instance HasApiStatuses (Stream method status framing ctypes a) where
+  type ApiStatuses (Stream _ status _ _ _) = '[status]
+
+instance HasApiStatuses (UVerb method ctypes as) where
+  type ApiStatuses (UVerb _ _ as) = Statuses as
+
+instance HasApiStatuses Raw where
+  type ApiStatuses Raw = TypeError ('Text "cannot observe the HTTP statuses of a Raw API")
+
+instance (HasApiStatuses api) => HasApiStatuses (api' :> api) where
+  type ApiStatuses (_ :> api) = ApiStatuses api
+
+instance (HasApiStatuses api1, HasApiStatuses api2) => HasApiStatuses (api1 :<|> api2) where
+  type ApiStatuses (api1 :<|> api2) = (ApiStatuses api1) ++ (ApiStatuses api2)
+
+-- | A type class to check that all statically declared HTTP status codes of an api
+-- belong to the same status class, as defined by @KnownStatusClass@.
+class AllStatusesInClass c api
+
+instance ( HasApiStatuses api
+         , KnownStatusClass c
+         , All (HasStatusClass c) (ApiStatuses api)
+         ) => AllStatusesInClass c api

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

@@ -2,6 +2,7 @@
 {-# LANGUAGE DeriveFunctor     #-}
 {-# LANGUAGE GADTs             #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections     #-}
 module Servant.Server.Internal.Router where
 
 import           Prelude ()
@@ -17,29 +18,16 @@ import qualified Data.Map                                   as M
 import           Data.Text
                  (Text)
 import qualified Data.Text                                  as T
-import           Data.Typeable
-                 (TypeRep)
 import           Network.Wai
                  (Response, pathInfo)
 import           Servant.Server.Internal.ErrorFormatter
+import           Servant.Server.Internal.RouterEnv
 import           Servant.Server.Internal.RouteResult
 import           Servant.Server.Internal.RoutingApplication
 import           Servant.Server.Internal.ServerError
 
 type Router env = Router' env RoutingApplication
 
-data CaptureHint = CaptureHint
-  { captureName :: Text
-  , captureType :: TypeRep
-  }
-  deriving (Show, Eq)
-
-toCaptureTag :: CaptureHint -> Text
-toCaptureTag hint = captureName hint <> "::" <> (T.pack . show) (captureType hint)
-
-toCaptureTags :: [CaptureHint] -> Text
-toCaptureTags hints = "<" <> T.intercalate "|" (map toCaptureTag hints) <> ">"
-
 -- | Internal representation of a router.
 --
 -- The first argument describes an environment type that is
@@ -48,7 +36,7 @@ toCaptureTags hints = "<" <> T.intercalate "|" (map toCaptureTag hints) <> ">"
 -- components that can be used to process captures.
 --
 data Router' env a =
-    StaticRouter  (Map Text (Router' env a)) [env -> a]
+    StaticRouter  (Map Text (Router' env a)) [RouterEnv env -> a]
       -- ^ the map contains routers for subpaths (first path component used
       --   for lookup and removed afterwards), the list contains handlers
       --   for the empty path, to be tried in order
@@ -58,10 +46,13 @@ data Router' env a =
   | CaptureAllRouter [CaptureHint] (Router' ([Text], env) a)
       -- ^ all path components are passed to the child router in its
       --   environment and are removed afterwards
-  | RawRouter     (env -> a)
+  | RawRouter     (RouterEnv env -> a)
       -- ^ to be used for routes we do not know anything about
   | Choice        (Router' env a) (Router' env a)
       -- ^ left-biased choice between two routers
+  | EnvRouter     (RouterEnv env -> RouterEnv env) (Router' env a)
+      -- ^ modifies the environment, and passes it to the child router
+      -- @since 0.20
   deriving Functor
 
 -- | Smart constructor for a single static path component.
@@ -71,7 +62,7 @@ pathRouter t r = StaticRouter (M.singleton t r) []
 -- | Smart constructor for a leaf, i.e., a router that expects
 -- the empty path.
 --
-leafRouter :: (env -> a) -> Router' env a
+leafRouter :: (RouterEnv env -> a) -> Router' env a
 leafRouter l = StaticRouter M.empty [l]
 
 -- | Smart constructor for the choice between routers.
@@ -126,6 +117,7 @@ routerStructure (Choice r1 r2) =
   ChoiceStructure
     (routerStructure r1)
     (routerStructure r2)
+routerStructure (EnvRouter _ r) = routerStructure r
 
 -- | Compare the structure of two routers.
 --
@@ -172,9 +164,9 @@ tweakResponse f = fmap (\a -> \req cont -> a req (cont . f))
 
 -- | Interpret a router as an application.
 runRouter :: NotFoundErrorFormatter -> Router () -> RoutingApplication
-runRouter fmt r = runRouterEnv fmt r ()
+runRouter fmt r = runRouterEnv fmt r $ emptyEnv ()
 
-runRouterEnv :: NotFoundErrorFormatter -> Router env -> env -> RoutingApplication
+runRouterEnv :: NotFoundErrorFormatter -> Router env -> RouterEnv env -> RoutingApplication
 runRouterEnv fmt router env request respond  =
   case router of
     StaticRouter table ls ->
@@ -184,24 +176,31 @@ runRouterEnv fmt router env request respond  =
         [""] -> runChoice fmt ls env request respond
         first : rest | Just router' <- M.lookup first table
           -> let request' = request { pathInfo = rest }
-             in  runRouterEnv fmt router' env request' respond
+                 newEnv = appendPathPiece (StaticPiece first) env
+             in  runRouterEnv fmt router' newEnv request' respond
         _ -> respond $ Fail $ fmt request
-    CaptureRouter _ router' ->
+    CaptureRouter hints router' ->
       case pathInfo request of
         []   -> respond $ Fail $ fmt request
         -- This case is to handle trailing slashes.
         [""] -> respond $ Fail $ fmt request
         first : rest
           -> let request' = request { pathInfo = rest }
-             in  runRouterEnv fmt router' (first, env) request' respond
-    CaptureAllRouter _ router' ->
+                 newEnv = appendPathPiece (CapturePiece hints) env
+                 newEnv' = ((first,) <$> newEnv)
+             in  runRouterEnv fmt router' newEnv' request' respond
+    CaptureAllRouter hints router' ->
       let segments = pathInfo request
           request' = request { pathInfo = [] }
-      in runRouterEnv fmt router' (segments, env) request' respond
+          newEnv = appendPathPiece (CapturePiece hints) env
+          newEnv' = ((segments,) <$> newEnv)
+      in runRouterEnv fmt router' newEnv' request' respond
     RawRouter app ->
       app env request respond
     Choice r1 r2 ->
       runChoice fmt [runRouterEnv fmt r1, runRouterEnv fmt r2] env request respond
+    EnvRouter f router' ->
+      runRouterEnv fmt router' (f env) request respond
 
 -- | Try a list of routing applications in order.
 -- We stop as soon as one fails fatally or succeeds.