Merge pull request #1556 from nbacquey/router_layout_captures

Display capture hints in router layout

changelog.d/1556

@@ -0,0 +1,81 @@
+synopsis: Display capture hints in router layout
+prs: #1556
+
+description: {
+
+This PR enhances the `Servant.Server.layout` function, which produces a textual description of the routing layout of an API. More precisely, it changes `<capture>` blocks, so that they display the name and type of the variable being captured instead.
+
+Example:
+
+For the following API
+```haskell
+type API =
+       "a" :> "d" :> Get '[JSON] NoContent
+  :<|> "b" :> Capture "x" Int :> Get '[JSON] Bool
+  :<|> "a" :> "e" :> Get '[JSON] Int
+```
+
+we previously got the following output:
+
+```
+/
+├─ a/
+│  ├─ d/
+│  │  └─•
+│  └─ e/
+│     └─•
+└─ b/
+   └─ <capture>/
+      ├─•
+      ┆
+      └─•
+```
+
+now we get:
+
+```
+/
+├─ a/
+│  ├─ d/
+│  │  └─•
+│  └─ e/
+│     └─•
+└─ b/
+   └─ <x::Int>/
+      ├─•
+      ┆
+      └─•
+```
+
+This change is achieved by the introduction of 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, 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.
+
+This PR also introduces Spec tests for the routerLayout function.
+
+Warning:
+This change is potentially breaking, because it adds the constraint `Typeable a` to all types that are to be captured. Because all types are typeable since GHC 7.10, this is not as bad as it sounds ; it only break expressions where `a` is quantified in an expression with `Capture a`.
+In those cases, the fix is easy: it suffices to add `Typeable a` to the left-hand side of the quantification constraint.
+
+For instance, the following code will no longer compile:
+```haskell
+type MyAPI a = Capture "foo" a :> Get '[JSON] ()
+
+myServer :: forall a. Server (MyAPI a)
+myServer = const $ return ()
+
+myApi :: forall a. Proxy (MyAPI a)
+myApi = Proxy
+
+app :: forall a. (FromHttpApiData a) => Application
+app = serve (myApi @a) (myServer @a)
+```
+
+Indeed, `app` should be replaced with:
+```haskell
+app :: forall a. (FromHttpApiData a, Typeable a) => Application
+app = serve (myApi @a) (myServer @a)
+```
+}

servant-server/src/Servant/Server.hs

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

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

@@ -173,7 +173,7 @@ instance (HasServer a context, HasServer b context) => HasServer (a :<|> b) cont
 -- > server = getBook
 -- >   where getBook :: Text -> Handler Book
 -- >         getBook isbn = ...
-instance (KnownSymbol capture, FromHttpApiData a
+instance (KnownSymbol capture, FromHttpApiData a, Typeable a
          , HasServer api context, SBoolI (FoldLenient mods)
          , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
          )
@@ -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) (typeRep (Proxy :: Proxy a))
 
 -- | If you use 'CaptureAll' in one of the endpoints for your API,
 -- this automatically requires your server-side handler to be a
@@ -215,7 +216,7 @@ instance (KnownSymbol capture, FromHttpApiData a
 -- > server = getSourceFile
 -- >   where getSourceFile :: [Text] -> Handler Book
 -- >         getSourceFile pathSegments = ...
-instance (KnownSymbol capture, FromHttpApiData a
+instance (KnownSymbol capture, FromHttpApiData a, Typeable a
          , HasServer api context
          , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
          )
@@ -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) (typeRep (Proxy :: Proxy [a]))
 
 allowedMethodHead :: Method -> Request -> Bool
 allowedMethodHead method request = method == methodGet && requestMethod request == methodHead

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

@@ -9,12 +9,16 @@ import           Prelude.Compat
 
 import           Data.Function
                  (on)
+import           Data.List
+                 (nub)
 import           Data.Map
                  (Map)
 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
@@ -24,6 +28,18 @@ 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
@@ -36,10 +52,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 +85,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)   =
+choice (CaptureRouter hints1 router1)   (CaptureRouter hints2 router2)   =
-  CaptureRouter (choice router1 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 +100,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 +114,11 @@ data RouterStructure =
 routerStructure :: Router' env a -> RouterStructure
 routerStructure (StaticRouter m ls) =
   StaticRouterStructure (fmap routerStructure m) (length ls)
-routerStructure (CaptureRouter router) =
+routerStructure (CaptureRouter hints router) =
-  CaptureRouterStructure $
+  CaptureRouterStructure hints $
     routerStructure router
-routerStructure (CaptureAllRouter router) =
+routerStructure (CaptureAllRouter hints router) =
-  CaptureRouterStructure $
+  CaptureRouterStructure hints $
     routerStructure router
 routerStructure (RawRouter _) =
   RawRouterStructure
@@ -114,8 +130,8 @@ routerStructure (Choice r1 r2) =
 -- | Compare the structure of two routers.
 --
 sameStructure :: Router' env a -> Router' env b -> Bool
-sameStructure r1 r2 =
+sameStructure router1 router2 =
-  routerStructure r1 == routerStructure r2
+    routerStructure router1 == routerStructure router2
 
 -- | Provide a textual representation of the
 -- structure of a router.
@@ -126,7 +142,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,7 +186,7 @@ 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.
@@ -177,7 +194,7 @@ runRouterEnv fmt router env request respond  =
         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,9 @@ import           Control.Monad
 import           Data.Proxy
                  (Proxy (..))
 import           Data.Text
-                 (unpack)
+                 (Text, unpack)
+import           Data.Typeable
+                 (typeRep)
 import           Network.HTTP.Types
                  (Status (..))
 import           Network.Wai
@@ -27,6 +29,7 @@ spec :: Spec
 spec = describe "Servant.Server.Internal.Router" $ do
   routerSpec
   distributivitySpec
+  serverLayoutSpec
 
 routerSpec :: Spec
 routerSpec = do
@@ -51,7 +54,7 @@ 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 ->
@@ -59,6 +62,9 @@ routerSpec = do
                  . const
                  $ Route success
 
+        hint :: CaptureHint
+        hint = CaptureHint "anything" $ typeRep (Proxy :: Proxy ())
+
         router :: Router ()
         router = leafRouter (\_ _ res -> res $ Route success)
           `Choice` cap
@@ -98,12 +104,30 @@ distributivitySpec =
     it "properly handles mixing static paths at different levels" $ do
       level `shouldHaveSameStructureAs` levelRef
 
+serverLayoutSpec :: Spec
+serverLayoutSpec =
+  describe "serverLayout" $ do
+    it "correctly represents the example API" $ do
+      exampleLayout `shouldHaveLayout` expectedExampleLayout
+    it "aggregates capture hints when different" $ do
+      captureDifferentTypes `shouldHaveLayout` expectedCaptureDifferentTypes
+    it "nubs capture hints when equal" $ do
+      captureSameType `shouldHaveLayout` expectedCaptureSameType
+    it "properly displays CaptureAll hints" $ do
+      captureAllLayout `shouldHaveLayout` expectedCaptureAllLayout
+
 shouldHaveSameStructureAs ::
   (HasServer api1 '[], HasServer api2 '[]) => Proxy api1 -> Proxy api2 -> Expectation
 shouldHaveSameStructureAs p1 p2 =
   unless (sameStructure (makeTrivialRouter p1) (makeTrivialRouter p2)) $
     expectationFailure ("expected:\n" ++ unpack (layout p2) ++ "\nbut got:\n" ++ unpack (layout p1))
 
+shouldHaveLayout ::
+  (HasServer api '[]) => Proxy api -> Text -> Expectation
+shouldHaveLayout p l =
+  unless (routerLayout (makeTrivialRouter p) == l) $
+    expectationFailure ("expected:\n" ++ unpack l ++ "\nbut got:\n" ++ unpack (layout p))
+
 makeTrivialRouter :: (HasServer layout '[]) => Proxy layout -> Router ()
 makeTrivialRouter p =
   route p EmptyContext (emptyDelayed (FailFatal err501))
@@ -144,12 +168,12 @@ staticRef = Proxy
 -- structure:
 
 type Dynamic =
-       "a" :> Capture "foo" Int  :> "b" :> End
+       "a" :> Capture "foo" Int :> "b" :> End
-  :<|> "a" :> Capture "bar" Bool :> "c" :> End
+  :<|> "a" :> Capture "foo" Int :> "c" :> End
-  :<|> "a" :> Capture "baz" Char :> "d" :> End
+  :<|> "a" :> Capture "foo" Int :> "d" :> End
 
 type DynamicRef =
-  "a" :> Capture "anything" () :>
+  "a" :> Capture "foo" Int :>
     ("b" :> End :<|> "c" :> End :<|> "d" :> End)
 
 dynamic :: Proxy Dynamic
@@ -339,3 +363,100 @@ level = Proxy
 
 levelRef :: Proxy LevelRef
 levelRef = Proxy
+
+-- The example API for the 'layout' function.
+-- Should get factorized by the 'choice' smart constructor.
+type ExampleLayout =
+       "a" :> "d" :> Get '[JSON] NoContent
+  :<|> "b" :> Capture "x" Int :> Get '[JSON] Bool
+  :<|> "c" :> Put '[JSON] Bool
+  :<|> "a" :> "e" :> Get '[JSON] Int
+  :<|> "b" :> Capture "x" Int :> Put '[JSON] Bool
+  :<|> Raw
+
+exampleLayout :: Proxy ExampleLayout
+exampleLayout = Proxy
+
+-- The expected representation of the example API layout
+--
+expectedExampleLayout :: Text
+expectedExampleLayout =
+  "/\n\
+  \├─ a/\n\
+  \│  ├─ d/\n\
+  \│  │  └─•\n\
+  \│  └─ e/\n\
+  \│     └─•\n\
+  \├─ b/\n\
+  \│  └─ <x::Int>/\n\
+  \│     ├─•\n\
+  \│     ┆\n\
+  \│     └─•\n\
+  \├─ c/\n\
+  \│  └─•\n\
+  \┆\n\
+  \└─ <raw>\n"
+
+-- A capture API with all capture types being the same
+--
+type CaptureSameType =
+       "a" :> Capture "foo" Int :> "b" :> End
+  :<|> "a" :> Capture "foo" Int :> "c" :> End
+  :<|> "a" :> Capture "foo" Int :> "d" :> End
+
+captureSameType :: Proxy CaptureSameType
+captureSameType = Proxy
+
+-- The expected representation of the CaptureSameType API layout.
+--
+expectedCaptureSameType :: Text
+expectedCaptureSameType =
+  "/\n\
+  \└─ a/\n\
+  \   └─ <foo::Int>/\n\
+  \      ├─ b/\n\
+  \      │  └─•\n\
+  \      ├─ c/\n\
+  \      │  └─•\n\
+  \      └─ d/\n\
+  \         └─•\n"
+
+-- A capture API capturing different types
+--
+type CaptureDifferentTypes =
+       "a" :> Capture "foo" Int :> "b" :> End
+  :<|> "a" :> Capture "bar" Bool :> "c" :> End
+  :<|> "a" :> Capture "baz" Char :> "d" :> End
+
+captureDifferentTypes :: Proxy CaptureDifferentTypes
+captureDifferentTypes = Proxy
+
+-- The expected representation of the CaptureDifferentTypes API layout.
+--
+expectedCaptureDifferentTypes :: Text
+expectedCaptureDifferentTypes =
+  "/\n\
+  \└─ a/\n\
+  \   └─ <foo::Int|bar::Bool|baz::Char>/\n\
+  \      ├─ b/\n\
+  \      │  └─•\n\
+  \      ├─ c/\n\
+  \      │  └─•\n\
+  \      └─ d/\n\
+  \         └─•\n"
+
+-- An API with a CaptureAll part
+
+type CaptureAllLayout = "a" :> CaptureAll "foos" Int :> End
+
+captureAllLayout :: Proxy CaptureAllLayout
+captureAllLayout = Proxy
+
+-- The expected representation of the CaptureAllLayout API.
+--
+expectedCaptureAllLayout :: Text
+expectedCaptureAllLayout =
+  "/\n\
+  \└─ a/\n\
+  \   └─ <foos::[Int]>/\n\
+  \      └─•\n"