Merge 801f075d7d into 8f081bd9ad

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,7 @@ library
     Servant.Server.Internal.DelayedIO
     Servant.Server.Internal.ErrorFormatter
     Servant.Server.Internal.Handler
+    Servant.Server.Internal.RouterEnv
     Servant.Server.Internal.RouteResult
     Servant.Server.Internal.Router
     Servant.Server.Internal.RoutingApplication
@@ -142,6 +143,7 @@ test-suite spec
     , base-compat
     , base64-bytestring
     , bytestring
+    , containers
     , http-types
     , mtl
     , resourcet

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

@@ -27,6 +27,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
@@ -77,7 +78,7 @@ import           Servant.API
                  QueryParam', QueryParams, Raw, 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 (..),
@@ -106,6 +107,7 @@ import           Servant.Server.Internal.ErrorFormatter
 import           Servant.Server.Internal.Handler
 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
 
@@ -244,6 +246,23 @@ 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
+
 allowedMethodHead :: Method -> Request -> Bool
 allowedMethodHead method request = method == methodGet && requestMethod request == methodHead
 
@@ -295,7 +314,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 (..), 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,12 @@ runAction action env req respond k = runResourceT $
     go (Route a)     = liftIO $ do
       e <- runHandler a
       case e of
-        Left err -> return . Route $ responseServerError err
+        Left err -> return . Route . withRoutingHeaders $ responseServerError err
-        Right x  -> return $! k x
+        Right x  -> return $! withRoutingHeaders <$> k x
+    withRoutingHeaders :: Response -> Response
+    withRoutingHeaders = if shouldReturnRoutedPath env
+      then mapResponseHeaders ((hRoutedPathHeader, cs $ routedPathRepr env) :)
+      else id
 
 {- Note [Existential Record Update]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

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
+                 newEnv = appendPathPiece (CapturePiece hints) env
-    CaptureAllRouter _ router' ->
+                 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.

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

@@ -0,0 +1,65 @@
+{-# LANGUAGE DeriveFunctor     #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards   #-}
+-- | This module contains the `RouterEnv env` type and associated functions.
+-- `RouterEnv env` encapsulates the `env` type (as in `Router env a`),
+-- which contains a tuple-encoded list of url pieces parsed from the incoming request.
+-- The encapsulation makes it possible to pass more information throughout
+-- the routing process, and ultimately to the computation of the `Delayed env c`
+-- associated with each request.
+-- The type and functions have been designed to be extensible: it should remain easy
+-- to add a new field to the record and manipulate it.
+--
+-- @since 0.20
+--
+module Servant.Server.Internal.RouterEnv where
+
+import           Data.Text
+                 (Text)
+import qualified Data.Text                                  as T
+import           Data.Typeable
+                 (TypeRep)
+import           Network.HTTP.Types.Header
+                 (HeaderName)
+
+data RouterEnv env = RouterEnv
+  { routedPath :: [PathPiece]
+  , shouldReturnRoutedPath :: Bool
+  , routerEnv :: env
+  }
+  deriving Functor
+
+emptyEnv :: a -> RouterEnv a
+emptyEnv v = RouterEnv [] False v
+
+enableRoutingHeaders :: RouterEnv env -> RouterEnv env
+enableRoutingHeaders env = env { shouldReturnRoutedPath = True }
+
+routedPathRepr :: RouterEnv env -> Text
+routedPathRepr RouterEnv{routedPath = path} =
+    "/" <> T.intercalate "/" (map go $ reverse path)
+  where
+    go (StaticPiece p) = p
+    go (CapturePiece p) = toCaptureTags p
+
+data PathPiece
+  = StaticPiece Text
+  | CapturePiece [CaptureHint]
+
+appendPathPiece :: PathPiece -> RouterEnv a -> RouterEnv a
+appendPathPiece p env@RouterEnv{..} = env { routedPath = p:routedPath }
+
+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) <> ">"
+
+hRoutedPathHeader :: HeaderName
+hRoutedPathHeader = "Servant-Routed-Path"

servant-server/test/Servant/Server/Internal/RoutingApplicationSpec.hs

@@ -80,7 +80,7 @@ delayed body srv = Delayed
 simpleRun :: Delayed () (Handler ())
           -> IO ()
 simpleRun d = fmap (either ignoreE id) . try $
-  runAction d () defaultRequest (\_ -> return ()) (\_ -> FailFatal err500)
+  runAction d (emptyEnv ()) defaultRequest (\_ -> return ()) (\_ -> FailFatal err500)
 
   where ignoreE :: SomeException -> ()
         ignoreE = const ()

servant-server/test/Servant/ServerSpec.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE DeriveGeneric       #-}
 {-# LANGUAGE FlexibleContexts    #-}
 {-# LANGUAGE FlexibleInstances   #-}
+{-# LANGUAGE LambdaCase          #-}
 {-# LANGUAGE OverloadedStrings   #-}
 {-# LANGUAGE PolyKinds           #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -25,6 +26,8 @@ import qualified Data.ByteString                   as BS
 import qualified Data.ByteString.Base64            as Base64
 import           Data.Char
                  (toUpper)
+import           Data.Map
+                 (fromList, notMember)
 import           Data.Maybe
                  (fromMaybe)
 import           Data.Proxy
@@ -49,20 +52,21 @@ import           Network.Wai.Test
 import           Servant.API
                  ((:<|>) (..), (:>), AuthProtect, BasicAuth,
                  BasicAuthData (BasicAuthData), Capture, Capture', CaptureAll,
-                 Delete, EmptyAPI, Fragment, Get, HasStatus (StatusOf), Header,
+                 Delete, EmptyAPI, Fragment, Get, GetNoContent,
-                 Headers, HttpVersion, IsSecure (..), JSON, Lenient,
+                 HasStatus (StatusOf), Header, Headers, HttpVersion,
-                 NoContent (..), NoContentVerb, NoFraming, OctetStream, Patch,
+                 IsSecure (..), JSON, Lenient, NoContent (..), NoContentVerb,
-                 PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, Raw,
+                 NoFraming, OctetStream, Patch, PlainText, Post, Put,
-                 RemoteHost, ReqBody, SourceIO, StdMethod (..), Stream, Strict,
+                 QueryFlag, QueryParam, QueryParams, Raw, RemoteHost, ReqBody,
-                 UVerb, Union, Verb, WithStatus (..), addHeader)
+                 SourceIO, StdMethod (..), Stream, StreamGet, Strict, UVerb,
+                 Union, Verb, WithRoutingHeader, WithStatus (..), addHeader)
 import           Servant.Server
                  (Context ((:.), EmptyContext), Handler, Server, Tagged (..),
-                 emptyServer, err401, err403, err404, respond, serve,
+                 emptyServer, err401, err403, err404, err500, respond, serve,
                  serveWithContext)
 import           Servant.Test.ComprehensiveAPI
 import qualified Servant.Types.SourceT             as S
 import           Test.Hspec
-                 (Spec, context, describe, it, shouldBe, shouldContain)
+                 (Spec, context, describe, it, shouldBe, shouldContain, shouldSatisfy)
 import           Test.Hspec.Wai
                  (get, liftIO, matchHeaders, matchStatus, shouldRespondWith,
                  with, (<:>))
@@ -103,6 +107,7 @@ spec = do
   miscCombinatorSpec
   basicAuthSpec
   genAuthSpec
+  routedPathHeadersSpec
 
 ------------------------------------------------------------------------------
 -- * verbSpec {{{
@@ -842,6 +847,102 @@ genAuthSpec = do
         it "plays nice with subsequent Raw endpoints" $ do
           get "/foo" `shouldRespondWith` 418
 
+-- }}}
+------------------------------------------------------------------------------
+-- * Routed path response headers {{{
+------------------------------------------------------------------------------
+
+type RoutedPathApi = WithRoutingHeader :>
+  (    "content"   :> Get '[JSON] Person
+  :<|> "noContent" :> GetNoContent
+  :<|> "header"    :> Get '[JSON] (Headers '[Header "H" Int] Person)
+  :<|> "stream"    :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString)
+  :<|> "animal"    :> (    Capture "legs" Int :> Get '[JSON] Animal
+                      :<|> CaptureAll "legs" Int :> Get '[JSON] Animal
+                      :<|> Capture "name" String :> Get '[JSON] Animal
+                      )
+  ) :<|> "withoutHeader" :> Get '[JSON] Person
+
+routedPathApi :: Proxy RoutedPathApi
+routedPathApi = Proxy
+
+routedPathServer :: Server RoutedPathApi
+routedPathServer =
+  (    return alice
+  :<|> return NoContent
+  :<|> return (addHeader 5 alice)
+  :<|> return (S.source ["bytestring"])
+  :<|> ((     \case
+                2 -> return tweety
+                4 -> return jerry
+                _ -> throwError err500
+       ):<|>( \ legs -> case sum legs of
+                2 -> return tweety
+                4 -> return jerry
+                _ -> throwError err500
+       ):<|>( \case
+                "tweety" -> return tweety
+                "jerry" -> return jerry
+                "bob" -> return beholder
+                _ -> throwError err404
+       ))
+  ) :<|> return alice
+
+routedPathHeadersSpec :: Spec
+routedPathHeadersSpec = do
+  describe "Server routing header" $ do
+    with (return $ serve routedPathApi routedPathServer) $ do
+      it "returns the routed path on verbs" $ do
+        response <- THW.request methodGet "/content" [] ""
+        liftIO $ simpleHeaders response `shouldContain`
+          [("Servant-Routed-Path", "/content")]
+
+      it "returns the routed path on noContent verbs" $ do
+        response <- THW.request methodGet "/noContent" [] ""
+        liftIO $ simpleHeaders response `shouldContain`
+          [("Servant-Routed-Path", "/noContent")]
+
+      it "returns the routed path on streams" $ do
+        response <- THW.request methodGet "/stream" [] ""
+        liftIO $ simpleHeaders response `shouldContain`
+          [("Servant-Routed-Path", "/stream")]
+
+      it "plays nice with manually added headers" $ do
+        response <- THW.request methodGet "/header" [] ""
+        liftIO $ do
+          simpleHeaders response `shouldContain` [("Servant-Routed-Path", "/header")]
+          simpleHeaders response `shouldContain` [("H", "5")]
+
+      it "abstracts captured values" $ do
+        response <- THW.request methodGet "/animal/4" [] ""
+        liftIO $ simpleHeaders response `shouldContain`
+          [("Servant-Routed-Path", "/animal/<legs::Int>")]
+
+      it "abstracts captured lists" $ do
+        response <- THW.request methodGet "/animal/1/1/0" [] ""
+        liftIO $ simpleHeaders response `shouldContain`
+          [("Servant-Routed-Path", "/animal/<legs::[Int]>")]
+
+      it "supports backtracking on routing errors" $ do
+        response <- THW.request methodGet "/animal/jerry" [] ""
+        liftIO $ simpleHeaders response `shouldContain`
+          [("Servant-Routed-Path", "/animal/<name::[Char]>")]
+
+      it "returns the routed path on a failing route" $ do
+        response <- THW.request methodGet "/animal/0" [] ""
+        liftIO $ simpleHeaders response `shouldContain`
+          [("Servant-Routed-Path", "/animal/<legs::Int>")]
+
+      it "is missing when no route matches" $ do
+        response <- THW.request methodGet "/wrongPath" [] ""
+        liftIO $ simpleHeaders response `shouldSatisfy`
+          (notMember "Servant-Routed-Path") . fromList
+
+      it "is missing when WithRoutingHeader is missing" $ do
+        response <- THW.request methodGet "/withoutHeader" [] ""
+        liftIO $ simpleHeaders response `shouldSatisfy`
+          (notMember "Servant-Routed-Path") . fromList
+
 -- }}}
 ------------------------------------------------------------------------------
 -- * UVerb {{{

servant/servant.cabal

@@ -38,6 +38,7 @@ library
     Servant.API.Capture
     Servant.API.ContentTypes
     Servant.API.Description
+    Servant.API.Environment
     Servant.API.Empty
     Servant.API.Experimental.Auth
     Servant.API.Fragment

servant/src/Servant/API.hs

@@ -7,6 +7,8 @@ module Servant.API (
   -- | Type-level combinator for alternative endpoints: @':<|>'@
   module Servant.API.Empty,
   -- | Type-level combinator for an empty API: @'EmptyAPI'@
+  module Servant.API.Environment,
+  -- | Type-level combinators to modify the routing environment: @'WithRoutingHeader'@
   module Servant.API.Modifiers,
   -- | Type-level modifiers for 'QueryParam', 'Header' and 'ReqBody'.
 
@@ -97,6 +99,8 @@ import           Servant.API.Description
                  (Description, Summary)
 import           Servant.API.Empty
                  (EmptyAPI (..))
+import           Servant.API.Environment
+                 (WithRoutingHeader)
 import           Servant.API.Experimental.Auth
                  (AuthProtect)
 import           Servant.API.Fragment

servant/src/Servant/API/Environment.hs

@@ -0,0 +1,29 @@
+{-# OPTIONS_HADDOCK not-home    #-}
+-- | Define API combinator that modify the behaviour of the routing environment.
+module Servant.API.Environment (WithRoutingHeader) where
+
+-- | Modify the behaviour of the following sub-API, such that all endpoint 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@ 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:
+--
+-- >>> 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>")
+--
+-- @since 0.20
+--
+data WithRoutingHeader
+
+-- $setup
+-- >>> import Servant.API
+-- >>> import Data.Aeson
+-- >>> import Data.Text
+-- >>> data Foo
+-- >>> instance ToJSON Foo where { toJSON = undefined }

servant/src/Servant/API/TypeLevel.hs

@@ -57,6 +57,8 @@ import           Servant.API.Alternative
                  (type (:<|>))
 import           Servant.API.Capture
                  (Capture, CaptureAll)
+import           Servant.API.Environment
+                 (WithRoutingHeader)
 import           Servant.API.Fragment
 import           Servant.API.Header
                  (Header)
@@ -130,6 +132,7 @@ type family IsElem endpoint api :: Constraint where
   IsElem e (sa :<|> sb)                   = Or (IsElem e sa) (IsElem e sb)
   IsElem (e :> sa) (e :> sb)              = IsElem sa sb
   IsElem sa (Header sym x :> sb)          = IsElem sa sb
+  IsElem sa (WithRoutingHeader :> sb)     = IsElem sa sb
   IsElem sa (ReqBody y x :> sb)           = IsElem sa sb
   IsElem (CaptureAll z y :> sa) (CaptureAll x y :> sb)
                                           = IsElem sa sb