From 77b92d0d7d7913e8e3cf4d3b1ebd31d3923094f6 Mon Sep 17 00:00:00 2001 From: Nicolas BACQUEY Date: Tue, 8 Mar 2022 14:55:03 +0100 Subject: [PATCH] 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 "" 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. --- servant-server/src/Servant/Server.hs | 5 ++- servant-server/src/Servant/Server/Internal.hs | 10 +++-- .../src/Servant/Server/Internal/Router.hs | 45 +++++++++++++------ .../test/Servant/Server/RouterSpec.hs | 17 ++++--- 4 files changed, 51 insertions(+), 26 deletions(-) diff --git a/servant-server/src/Servant/Server.hs b/servant-server/src/Servant/Server.hs index fa01daeb..79d092b9 100644 --- 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/ --- > │ └─ / +-- > │ └─ / -- > │ ├─• -- > │ ┆ -- > │ └─• @@ -252,7 +252,8 @@ hoistServer p = hoistServerWithContext p (Proxy :: Proxy '[]) -- -- [@─•@] Leaves reflect endpoints. -- --- [@\/@] This is a delayed capture of a path component. +-- [@\/@] This is a delayed capture of a single +-- path component named @x@, of expected type @Int@. -- -- [@\@] 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 index e2df2c4a..a2b4f033 100644 --- 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 index ecee5901..0a3391ce 100644 --- 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 "" (mkRouterLayout False r) + mkRouterLayout c (CaptureRouterStructure hints r) = + mkSubTree c (toCaptureTags hints) (mkRouterLayout False r) mkRouterLayout c RawRouterStructure = if c then ["├─ "] else ["└─ "] 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 diff --git a/servant-server/test/Servant/Server/RouterSpec.hs b/servant-server/test/Servant/Server/RouterSpec.hs index 9b69a2e7..9b84ef07 100644 --- a/servant-server/test/Servant/Server/RouterSpec.hs +++ b/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 @@ -51,7 +53,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 +61,9 @@ routerSpec = do . const $ Route success + hint :: CaptureHint + hint = CaptureHint "anything" $ typeRep (Proxy :: Proxy ()) + router :: Router () router = leafRouter (\_ _ res -> res $ Route success) `Choice` cap @@ -144,12 +149,12 @@ staticRef = Proxy -- structure: type Dynamic = - "a" :> Capture "foo" Int :> "b" :> End - :<|> "a" :> Capture "bar" Bool :> "c" :> End - :<|> "a" :> Capture "baz" Char :> "d" :> End + "a" :> Capture "foo" Int :> "b" :> End + :<|> "a" :> Capture "foo" Int :> "c" :> 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