From 77b92d0d7d7913e8e3cf4d3b1ebd31d3923094f6 Mon Sep 17 00:00:00 2001 From: Nicolas BACQUEY Date: Tue, 8 Mar 2022 14:55:03 +0100 Subject: [PATCH 1/3] 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 From 9d66e167062c4c35db0cd94a60155c0cefd3a627 Mon Sep 17 00:00:00 2001 From: Nicolas BACQUEY Date: Mon, 14 Mar 2022 10:48:38 +0100 Subject: [PATCH 2/3] Add spec for serverLayout --- .../test/Servant/Server/RouterSpec.hs | 116 ++++++++++++++++++ 1 file changed, 116 insertions(+) diff --git a/servant-server/test/Servant/Server/RouterSpec.hs b/servant-server/test/Servant/Server/RouterSpec.hs index 9b84ef07..6517b627 100644 --- a/servant-server/test/Servant/Server/RouterSpec.hs +++ b/servant-server/test/Servant/Server/RouterSpec.hs @@ -29,6 +29,7 @@ spec :: Spec spec = describe "Servant.Server.Internal.Router" $ do routerSpec distributivitySpec + serverLayoutSpec routerSpec :: Spec routerSpec = do @@ -103,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)) @@ -344,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\ + \│ └─ /\n\ + \│ ├─•\n\ + \│ ┆\n\ + \│ └─•\n\ + \├─ c/\n\ + \│ └─•\n\ + \┆\n\ + \└─ \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\ + \ └─ /\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\ + \ └─ /\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\ + \ └─ /\n\ + \ └─•\n" From a19cb84a0e8f096275b93e81dcb5f506237f5344 Mon Sep 17 00:00:00 2001 From: Nicolas BACQUEY Date: Tue, 8 Mar 2022 16:28:52 +0100 Subject: [PATCH 3/3] Update changelog --- changelog.d/1556 | 81 ++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 81 insertions(+) create mode 100644 changelog.d/1556 diff --git a/changelog.d/1556 b/changelog.d/1556 new file mode 100644 index 00000000..f885d1dc --- /dev/null +++ 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 `` 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/ + └─ / + ├─• + ┆ + └─• +``` + +now we get: + +``` +/ +├─ a/ +│ ├─ d/ +│ │ └─• +│ └─ e/ +│ └─• +└─ b/ + └─ / + ├─• + ┆ + └─• +``` + +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 `` 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) +``` +}