Merge pull request #1556 from nbacquey/router_layout_captures

Display capture hints in router layout
haskell-servant · Mar 25, 2022 · 65de6f7 · 65de6f7
2 parents f5a91d2 + a19cb84
commit 65de6f7
Show file tree

Hide file tree

Showing 5 changed files with 248 additions and 26 deletions.
diff --git a/changelog.d/1556 b/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)
+```
+}
diff --git a/servant-server/src/Servant/Server.hs b/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.
 --

diff --git a/servant-server/src/Servant/Server/Internal.hs b/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

diff --git a/servant-server/src/Servant/Server/Internal/Router.hs b/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)   =
-  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 +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) =
-  CaptureRouterStructure $
+routerStructure (CaptureRouter hints router) =
+  CaptureRouterStructure hints $
     routerStructure router
-routerStructure (CaptureAllRouter router) =
-  CaptureRouterStructure $
+routerStructure (CaptureAllRouter hints router) =
+  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 =
-  routerStructure r1 == routerStructure r2
+sameStructure router1 router2 =
+    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,15 +186,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