Display capture hints in router layout

This commit introduces a `CaptureHint` type, which is passed as an extra
argument to the `CaptureRouter` and `CaptureAllRouter` constructors for
the `Router'` type.
`CaptureHint` values are then used in `routerLayout`, to display the
name and "type" of captured values (single or list), instead of just
"<capture>" previously.

N.B.:
Because the `choice` smart constructor for routers can aggregate
`Capture` combinators with different capture hints, the `Capture*Router`
constructors actually take a *list* of `CaptureHint`, instead of a
single one.

Author: nbacquey

servant-server/src/Servant/Server.hs

@@ -235,7 +235,7 @@ hoistServer p = hoistServerWithContext p (Proxy :: Proxy '[])
 -- > │  └─ e/
 -- > │     └─•
 -- > ├─ b/
--- > │  └─ <capture>/
+-- > │  └─ <x::CaptureSingle>/
 -- > │     ├─•
 -- > │     ┆
 -- > │     └─•
@@ -252,7 +252,8 @@ hoistServer p = hoistServerWithContext p (Proxy :: Proxy '[])
 --
 -- [@─•@] Leaves reflect endpoints.
 --
--- [@\<capture\>/@] This is a delayed capture of a path component.
+-- [@\<x::CaptureSingle\>/@] This is a delayed capture of a single
+-- path component named @x@.
 --
 -- [@\<raw\>@] This is a part of the API we do not know anything about.
 --

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

@@ -185,7 +185,7 @@ instance (KnownSymbol capture, FromHttpApiData a
   hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
 
   route Proxy context d =
-    CaptureRouter $
+    CaptureRouter [hint] $
         route (Proxy :: Proxy api)
               context
               (addCapture d $ \ txt -> withRequest $ \ request ->
@@ -197,6 +197,7 @@ instance (KnownSymbol capture, FromHttpApiData a
     where
       rep = typeRep (Proxy :: Proxy Capture')
       formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
+      hint = CaptureHint (T.pack $ symbolVal $ Proxy @capture) CaptureSingle
 
 -- | If you use 'CaptureAll' in one of the endpoints for your API,
 -- this automatically requires your server-side handler to be a
@@ -227,7 +228,7 @@ instance (KnownSymbol capture, FromHttpApiData a
   hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
 
   route Proxy context d =
-    CaptureAllRouter $
+    CaptureAllRouter [hint] $
         route (Proxy :: Proxy api)
               context
               (addCapture d $ \ txts -> withRequest $ \ request ->
@@ -238,6 +239,7 @@ instance (KnownSymbol capture, FromHttpApiData a
     where
       rep = typeRep (Proxy :: Proxy CaptureAll)
       formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
+      hint = CaptureHint (T.pack $ symbolVal $ Proxy @capture) CaptureList
 
 allowedMethodHead :: Method -> Request -> Bool
 allowedMethodHead method request = method == methodGet && requestMethod request == methodHead

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

@@ -9,6 +9,8 @@ import           Prelude.Compat
 
 import           Data.Function
                  (on)
+import           Data.List
+                 (nub)
 import           Data.Map
                  (Map)
 import qualified Data.Map                                   as M
@@ -24,6 +26,21 @@ import           Servant.Server.Internal.ServerError
 
 type Router env = Router' env RoutingApplication
 
+data CaptureHint = CaptureHint
+  { captureName :: Text
+  , captureType :: CaptureType
+  }
+  deriving (Show, Eq)
+
+data CaptureType = CaptureList | CaptureSingle
+  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
@@ -36,10 +53,10 @@ data Router' 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
-  | CaptureRouter (Router' (Text, env) a)
+  | CaptureRouter [CaptureHint] (Router' (Text, env) a)
       -- ^ first path component is passed to the child router in its
       --   environment and removed afterwards
-  | CaptureAllRouter (Router' ([Text], 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)
@@ -69,8 +86,8 @@ leafRouter l = StaticRouter M.empty [l]
 choice :: Router' env a -> Router' env a -> Router' env a
 choice (StaticRouter table1 ls1) (StaticRouter table2 ls2) =
   StaticRouter (M.unionWith choice table1 table2) (ls1 ++ ls2)
-choice (CaptureRouter router1)   (CaptureRouter router2)   =
-  CaptureRouter (choice router1 router2)
+choice (CaptureRouter hints1 router1)   (CaptureRouter hints2 router2)   =
+  CaptureRouter (nub $ hints1 ++ hints2) (choice router1 router2)
 choice router1 (Choice router2 router3) = Choice (choice router1 router2) router3
 choice router1 router2 = Choice router1 router2
 
@@ -84,7 +101,7 @@ choice router1 router2 = Choice router1 router2
 --
 data RouterStructure =
     StaticRouterStructure  (Map Text RouterStructure) Int
-  | CaptureRouterStructure RouterStructure
+  | CaptureRouterStructure [CaptureHint] RouterStructure
   | RawRouterStructure
   | ChoiceStructure        RouterStructure RouterStructure
   deriving (Eq, Show)
@@ -98,11 +115,11 @@ data RouterStructure =
 routerStructure :: Router' env a -> RouterStructure
 routerStructure (StaticRouter m ls) =
   StaticRouterStructure (fmap routerStructure m) (length ls)
-routerStructure (CaptureRouter router) =
-  CaptureRouterStructure $
+routerStructure (CaptureRouter hints router) =
+  CaptureRouterStructure hints $
     routerStructure router
-routerStructure (CaptureAllRouter router) =
-  CaptureRouterStructure $
+routerStructure (CaptureAllRouter hints router) =
+  CaptureRouterStructure hints $
     routerStructure router
 routerStructure (RawRouter _) =
   RawRouterStructure
@@ -111,11 +128,21 @@ routerStructure (Choice r1 r2) =
     (routerStructure r1)
     (routerStructure r2)
 
--- | Compare the structure of two routers.
+-- | Compare the structure of two routers. Ignores capture hints.
 --
 sameStructure :: Router' env a -> Router' env b -> Bool
-sameStructure r1 r2 =
-  routerStructure r1 == routerStructure r2
+sameStructure router1 router2 =
+    routerStructure router1 `almostEq` routerStructure router2
+  where
+    almostEq :: RouterStructure -> RouterStructure -> Bool
+    almostEq (StaticRouterStructure m1 l1) (StaticRouterStructure m2 l2) =
+      l1 == l2 && M.isSubmapOfBy almostEq m1 m2 && M.isSubmapOfBy almostEq m2 m1
+    almostEq (CaptureRouterStructure _ r1) (CaptureRouterStructure _ r2) =
+      r1 `almostEq` r2
+    almostEq RawRouterStructure RawRouterStructure = True
+    almostEq (ChoiceStructure r1 r1') (ChoiceStructure r2 r2') =
+      r1 `almostEq` r2 && r1' `almostEq` r2'
+    almostEq _ _ = False
 
 -- | Provide a textual representation of the
 -- structure of a router.
@@ -126,7 +153,8 @@ routerLayout router =
   where
     mkRouterLayout :: Bool -> RouterStructure -> [Text]
     mkRouterLayout c (StaticRouterStructure m n) = mkSubTrees c (M.toList m) n
-    mkRouterLayout c (CaptureRouterStructure r)  = mkSubTree c "<capture>" (mkRouterLayout False r)
+    mkRouterLayout c (CaptureRouterStructure hints r) =
+      mkSubTree c (toCaptureTags hints) (mkRouterLayout False r)
     mkRouterLayout c  RawRouterStructure         =
       if c then ["├─ <raw>"] else ["└─ <raw>"]
     mkRouterLayout c (ChoiceStructure r1 r2)     =
@@ -169,15 +197,15 @@ runRouterEnv fmt router env request respond  =
           -> let request' = request { pathInfo = rest }
              in  runRouterEnv fmt router' env request' respond
         _ -> respond $ Fail $ fmt request
-    CaptureRouter router' ->
+    CaptureRouter _ 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' ->
+    CaptureAllRouter _ router' ->
       let segments = pathInfo request
           request' = request { pathInfo = [] }
       in runRouterEnv fmt router' (segments, env) request' respond

servant-server/test/Servant/Server/RouterSpec.hs

@@ -9,7 +9,7 @@ import           Control.Monad
 import           Data.Proxy
                  (Proxy (..))
 import           Data.Text
-                 (unpack)
+                 (Text, unpack)
 import           Network.HTTP.Types
                  (Status (..))
 import           Network.Wai
@@ -51,14 +51,17 @@ routerSpec = do
         toApp = toApplication . runRouter (const err404)
 
         cap :: Router ()
-        cap = CaptureRouter $
+        cap = CaptureRouter [hint] $
           let delayed = addCapture (emptyDelayed $ Route pure) (const $ delayedFail err400)
           in leafRouter
              $ \env req res ->
                  runAction delayed env req res
                  . const
                  $ Route success
 
+        hint :: CaptureHint
+        hint = CaptureHint "anything" $ CaptureSingle
+
         router :: Router ()
         router = leafRouter (\_ _ res -> res $ Route success)
           `Choice` cap