git.iko.soy/typeable/servant
on master help sign in
Merge pull request #1556 from nbacquey/router_layout_captures

Display capture hints in router layout

commit65de6f701c263a5f072e212db90de271bbb8bbed authorGaël Deest <gael.deest@tweag.io> dateFri 25 Mar 2022, 10:42 (5 years ago) parentf5a91d2a19cb84
5 files changed+248−26
compare with master
unifiedsplit
changelog.d/1556+81 servant-server/src/Servant/Server.hs+3−2 servant-server/src/Servant/Server/Internal.hs+6−4 servant-server/src/Servant/Server/Internal/Router.hs+31−14 servant-server/test/Servant/Server/RouterSpec.hs+127−6
changelog.d/1556new file+81
@@ -0,0 +1,81 @@
1+synopsis: Display capture hints in router layout
2+prs: #1556
3+
4+description: {
5+
6+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.
7+
8+Example:
9+
10+For the following API
11+```haskell
12+type API =
13+ "a" :> "d" :> Get '[JSON] NoContent
14+ :<|> "b" :> Capture "x" Int :> Get '[JSON] Bool
15+ :<|> "a" :> "e" :> Get '[JSON] Int
16+```
17+
18+we previously got the following output:
19+
20+```
21+/
22+├─ a/
23+│ ├─ d/
24+│ │ └─•
25+│ └─ e/
26+│ └─•
27+└─ b/
28+ └─ <capture>/
29+ ├─•
30+ ┆
31+ └─•
32+```
33+
34+now we get:
35+
36+```
37+/
38+├─ a/
39+│ ├─ d/
40+│ │ └─•
41+│ └─ e/
42+│ └─•
43+└─ b/
44+ └─ <x::Int>/
45+ ├─•
46+ ┆
47+ └─•
48+```
49+
50+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.
51+CaptureHint values are then used in routerLayout, to display the name and type of captured values, instead of just `<capture>` previously.
52+
53+N.B.:
54+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.
55+
56+This PR also introduces Spec tests for the routerLayout function.
57+
58+Warning:
59+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`.
60+In those cases, the fix is easy: it suffices to add `Typeable a` to the left-hand side of the quantification constraint.
61+
62+For instance, the following code will no longer compile:
63+```haskell
64+type MyAPI a = Capture "foo" a :> Get '[JSON] ()
65+
66+myServer :: forall a. Server (MyAPI a)
67+myServer = const $ return ()
68+
69+myApi :: forall a. Proxy (MyAPI a)
70+myApi = Proxy
71+
72+app :: forall a. (FromHttpApiData a) => Application
73+app = serve (myApi @a) (myServer @a)
74+```
75+
76+Indeed, `app` should be replaced with:
77+```haskell
78+app :: forall a. (FromHttpApiData a, Typeable a) => Application
79+app = serve (myApi @a) (myServer @a)
80+```
81+}
servant-server/src/Servant/Server.hs+3−2
@@ -235,7 +235,7 @@ hoistServer p = hoistServerWithContext p (Proxy :: Proxy '[])
235235-- > │ └─ e/
236236-- > │ └─•
237237-- > ├─ b/
238−-- > │ └─ <capture>/
238+-- > │ └─ <x::Int>/
239239-- > │ ├─•
240240-- > │ ┆
241241-- > │ └─•
@@ -252,7 +252,8 @@ hoistServer p = hoistServerWithContext p (Proxy :: Proxy '[])
252252--
253253-- [@─•@] Leaves reflect endpoints.
254254--
255−-- [@\<capture\>/@] This is a delayed capture of a path component.
255+-- [@\<x::Int\>/@] This is a delayed capture of a single
256+-- path component named @x@, of expected type @Int@.
256257--
257258-- [@\<raw\>@] This is a part of the API we do not know anything about.
258259--
servant-server/src/Servant/Server/Internal.hs+6−4
@@ -173,7 +173,7 @@ instance (HasServer a context, HasServer b context) => HasServer (a :<|> b) cont
173173-- > server = getBook
174174-- > where getBook :: Text -> Handler Book
175175-- > getBook isbn = ...
176−instance (KnownSymbol capture, FromHttpApiData a
176+instance (KnownSymbol capture, FromHttpApiData a, Typeable a
177177 , HasServer api context, SBoolI (FoldLenient mods)
178178 , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
179179 )
@@ -185,7 +185,7 @@ instance (KnownSymbol capture, FromHttpApiData a
185185 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
186186
187187 route Proxy context d =
188− CaptureRouter $
188+ CaptureRouter [hint] $
189189 route (Proxy :: Proxy api)
190190 context
191191 (addCapture d $ \ txt -> withRequest $ \ request ->
@@ -197,6 +197,7 @@ instance (KnownSymbol capture, FromHttpApiData a
197197 where
198198 rep = typeRep (Proxy :: Proxy Capture')
199199 formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
200+ hint = CaptureHint (T.pack $ symbolVal $ Proxy @capture) (typeRep (Proxy :: Proxy a))
200201
201202-- | If you use 'CaptureAll' in one of the endpoints for your API,
202203-- this automatically requires your server-side handler to be a
@@ -215,7 +216,7 @@ instance (KnownSymbol capture, FromHttpApiData a
215216-- > server = getSourceFile
216217-- > where getSourceFile :: [Text] -> Handler Book
217218-- > getSourceFile pathSegments = ...
218−instance (KnownSymbol capture, FromHttpApiData a
219+instance (KnownSymbol capture, FromHttpApiData a, Typeable a
219220 , HasServer api context
220221 , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
221222 )
@@ -227,7 +228,7 @@ instance (KnownSymbol capture, FromHttpApiData a
227228 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
228229
229230 route Proxy context d =
230− CaptureAllRouter $
231+ CaptureAllRouter [hint] $
231232 route (Proxy :: Proxy api)
232233 context
233234 (addCapture d $ \ txts -> withRequest $ \ request ->
@@ -238,6 +239,7 @@ instance (KnownSymbol capture, FromHttpApiData a
238239 where
239240 rep = typeRep (Proxy :: Proxy CaptureAll)
240241 formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
242+ hint = CaptureHint (T.pack $ symbolVal $ Proxy @capture) (typeRep (Proxy :: Proxy [a]))
241243
242244allowedMethodHead :: Method -> Request -> Bool
243245allowedMethodHead method request = method == methodGet && requestMethod request == methodHead
servant-server/src/Servant/Server/Internal/Router.hs+31−14
@@ -9,12 +9,16 @@ import Prelude.Compat
99
1010import Data.Function
1111 (on)
12+import Data.List
13+ (nub)
1214import Data.Map
1315 (Map)
1416import qualified Data.Map as M
1517import Data.Text
1618 (Text)
1719import qualified Data.Text as T
20+import Data.Typeable
21+ (TypeRep)
1822import Network.Wai
1923 (Response, pathInfo)
2024import Servant.Server.Internal.ErrorFormatter
@@ -24,6 +28,18 @@ import Servant.Server.Internal.ServerError
2428
2529type Router env = Router' env RoutingApplication
2630
31+data CaptureHint = CaptureHint
32+ { captureName :: Text
33+ , captureType :: TypeRep
34+ }
35+ deriving (Show, Eq)
36+
37+toCaptureTag :: CaptureHint -> Text
38+toCaptureTag hint = captureName hint <> "::" <> (T.pack . show) (captureType hint)
39+
40+toCaptureTags :: [CaptureHint] -> Text
41+toCaptureTags hints = "<" <> T.intercalate "|" (map toCaptureTag hints) <> ">"
42+
2743-- | Internal representation of a router.
2844--
2945-- The first argument describes an environment type that is
@@ -36,10 +52,10 @@ data Router' env a =
3652 -- ^ the map contains routers for subpaths (first path component used
3753 -- for lookup and removed afterwards), the list contains handlers
3854 -- for the empty path, to be tried in order
39− | CaptureRouter (Router' (Text, env) a)
55+ | CaptureRouter [CaptureHint] (Router' (Text, env) a)
4056 -- ^ first path component is passed to the child router in its
4157 -- environment and removed afterwards
42− | CaptureAllRouter (Router' ([Text], env) a)
58+ | CaptureAllRouter [CaptureHint] (Router' ([Text], env) a)
4359 -- ^ all path components are passed to the child router in its
4460 -- environment and are removed afterwards
4561 | RawRouter (env -> a)
@@ -69,8 +85,8 @@ leafRouter l = StaticRouter M.empty [l]
6985choice :: Router' env a -> Router' env a -> Router' env a
7086choice (StaticRouter table1 ls1) (StaticRouter table2 ls2) =
7187 StaticRouter (M.unionWith choice table1 table2) (ls1 ++ ls2)
72−choice (CaptureRouter router1) (CaptureRouter router2) =
73− CaptureRouter (choice router1 router2)
88+choice (CaptureRouter hints1 router1) (CaptureRouter hints2 router2) =
89+ CaptureRouter (nub $ hints1 ++ hints2) (choice router1 router2)
7490choice router1 (Choice router2 router3) = Choice (choice router1 router2) router3
7591choice router1 router2 = Choice router1 router2
7692
@@ -84,7 +100,7 @@ choice router1 router2 = Choice router1 router2
84100--
85101data RouterStructure =
86102 StaticRouterStructure (Map Text RouterStructure) Int
87− | CaptureRouterStructure RouterStructure
103+ | CaptureRouterStructure [CaptureHint] RouterStructure
88104 | RawRouterStructure
89105 | ChoiceStructure RouterStructure RouterStructure
90106 deriving (Eq, Show)
@@ -98,11 +114,11 @@ data RouterStructure =
98114routerStructure :: Router' env a -> RouterStructure
99115routerStructure (StaticRouter m ls) =
100116 StaticRouterStructure (fmap routerStructure m) (length ls)
101−routerStructure (CaptureRouter router) =
102− CaptureRouterStructure $
117+routerStructure (CaptureRouter hints router) =
118+ CaptureRouterStructure hints $
103119 routerStructure router
104−routerStructure (CaptureAllRouter router) =
105− CaptureRouterStructure $
120+routerStructure (CaptureAllRouter hints router) =
121+ CaptureRouterStructure hints $
106122 routerStructure router
107123routerStructure (RawRouter _) =
108124 RawRouterStructure
@@ -114,8 +130,8 @@ routerStructure (Choice r1 r2) =
114130-- | Compare the structure of two routers.
115131--
116132sameStructure :: Router' env a -> Router' env b -> Bool
117−sameStructure r1 r2 =
118− routerStructure r1 == routerStructure r2
133+sameStructure router1 router2 =
134+ routerStructure router1 == routerStructure router2
119135
120136-- | Provide a textual representation of the
121137-- structure of a router.
@@ -126,7 +142,8 @@ routerLayout router =
126142 where
127143 mkRouterLayout :: Bool -> RouterStructure -> [Text]
128144 mkRouterLayout c (StaticRouterStructure m n) = mkSubTrees c (M.toList m) n
129− mkRouterLayout c (CaptureRouterStructure r) = mkSubTree c "<capture>" (mkRouterLayout False r)
145+ mkRouterLayout c (CaptureRouterStructure hints r) =
146+ mkSubTree c (toCaptureTags hints) (mkRouterLayout False r)
130147 mkRouterLayout c RawRouterStructure =
131148 if c then ["├─ <raw>"] else ["└─ <raw>"]
132149 mkRouterLayout c (ChoiceStructure r1 r2) =
@@ -169,7 +186,7 @@ runRouterEnv fmt router env request respond =
169186 -> let request' = request { pathInfo = rest }
170187 in runRouterEnv fmt router' env request' respond
171188 _ -> respond $ Fail $ fmt request
172− CaptureRouter router' ->
189+ CaptureRouter _ router' ->
173190 case pathInfo request of
174191 [] -> respond $ Fail $ fmt request
175192 -- This case is to handle trailing slashes.
@@ -177,7 +194,7 @@ runRouterEnv fmt router env request respond =
177194 first : rest
178195 -> let request' = request { pathInfo = rest }
179196 in runRouterEnv fmt router' (first, env) request' respond
180− CaptureAllRouter router' ->
197+ CaptureAllRouter _ router' ->
181198 let segments = pathInfo request
182199 request' = request { pathInfo = [] }
183200 in runRouterEnv fmt router' (segments, env) request' respond
servant-server/test/Servant/Server/RouterSpec.hs+127−6
@@ -9,7 +9,9 @@ import Control.Monad
99import Data.Proxy
1010 (Proxy (..))
1111import Data.Text
12− (unpack)
12+ (Text, unpack)
13+import Data.Typeable
14+ (typeRep)
1315import Network.HTTP.Types
1416 (Status (..))
1517import Network.Wai
@@ -27,6 +29,7 @@ spec :: Spec
2729spec = describe "Servant.Server.Internal.Router" $ do
2830 routerSpec
2931 distributivitySpec
32+ serverLayoutSpec
3033
3134routerSpec :: Spec
3235routerSpec = do
@@ -51,7 +54,7 @@ routerSpec = do
5154 toApp = toApplication . runRouter (const err404)
5255
5356 cap :: Router ()
54− cap = CaptureRouter $
57+ cap = CaptureRouter [hint] $
5558 let delayed = addCapture (emptyDelayed $ Route pure) (const $ delayedFail err400)
5659 in leafRouter
5760 $ \env req res ->
@@ -59,6 +62,9 @@ routerSpec = do
5962 . const
6063 $ Route success
6164
65+ hint :: CaptureHint
66+ hint = CaptureHint "anything" $ typeRep (Proxy :: Proxy ())
67+
6268 router :: Router ()
6369 router = leafRouter (\_ _ res -> res $ Route success)
6470 `Choice` cap
@@ -98,12 +104,30 @@ distributivitySpec =
98104 it "properly handles mixing static paths at different levels" $ do
99105 level `shouldHaveSameStructureAs` levelRef
100106
107+serverLayoutSpec :: Spec
108+serverLayoutSpec =
109+ describe "serverLayout" $ do
110+ it "correctly represents the example API" $ do
111+ exampleLayout `shouldHaveLayout` expectedExampleLayout
112+ it "aggregates capture hints when different" $ do
113+ captureDifferentTypes `shouldHaveLayout` expectedCaptureDifferentTypes
114+ it "nubs capture hints when equal" $ do
115+ captureSameType `shouldHaveLayout` expectedCaptureSameType
116+ it "properly displays CaptureAll hints" $ do
117+ captureAllLayout `shouldHaveLayout` expectedCaptureAllLayout
118+
101119shouldHaveSameStructureAs ::
102120 (HasServer api1 '[], HasServer api2 '[]) => Proxy api1 -> Proxy api2 -> Expectation
103121shouldHaveSameStructureAs p1 p2 =
104122 unless (sameStructure (makeTrivialRouter p1) (makeTrivialRouter p2)) $
105123 expectationFailure ("expected:\n" ++ unpack (layout p2) ++ "\nbut got:\n" ++ unpack (layout p1))
106124
125+shouldHaveLayout ::
126+ (HasServer api '[]) => Proxy api -> Text -> Expectation
127+shouldHaveLayout p l =
128+ unless (routerLayout (makeTrivialRouter p) == l) $
129+ expectationFailure ("expected:\n" ++ unpack l ++ "\nbut got:\n" ++ unpack (layout p))
130+
107131makeTrivialRouter :: (HasServer layout '[]) => Proxy layout -> Router ()
108132makeTrivialRouter p =
109133 route p EmptyContext (emptyDelayed (FailFatal err501))
@@ -144,12 +168,12 @@ staticRef = Proxy
144168-- structure:
145169
146170type Dynamic =
147− "a" :> Capture "foo" Int :> "b" :> End
148− :<|> "a" :> Capture "bar" Bool :> "c" :> End
149− :<|> "a" :> Capture "baz" Char :> "d" :> End
171+ "a" :> Capture "foo" Int :> "b" :> End
172+ :<|> "a" :> Capture "foo" Int :> "c" :> End
173+ :<|> "a" :> Capture "foo" Int :> "d" :> End
150174
151175type DynamicRef =
152− "a" :> Capture "anything" () :>
176+ "a" :> Capture "foo" Int :>
153177 ("b" :> End :<|> "c" :> End :<|> "d" :> End)
154178
155179dynamic :: Proxy Dynamic
@@ -339,3 +363,100 @@ level = Proxy
339363
340364levelRef :: Proxy LevelRef
341365levelRef = Proxy
366+
367+-- The example API for the 'layout' function.
368+-- Should get factorized by the 'choice' smart constructor.
369+type ExampleLayout =
370+ "a" :> "d" :> Get '[JSON] NoContent
371+ :<|> "b" :> Capture "x" Int :> Get '[JSON] Bool
372+ :<|> "c" :> Put '[JSON] Bool
373+ :<|> "a" :> "e" :> Get '[JSON] Int
374+ :<|> "b" :> Capture "x" Int :> Put '[JSON] Bool
375+ :<|> Raw
376+
377+exampleLayout :: Proxy ExampleLayout
378+exampleLayout = Proxy
379+
380+-- The expected representation of the example API layout
381+--
382+expectedExampleLayout :: Text
383+expectedExampleLayout =
384+ "/\n\
385+ \├─ a/\n\
386+ \│ ├─ d/\n\
387+ \│ │ └─•\n\
388+ \│ └─ e/\n\
389+ \│ └─•\n\
390+ \├─ b/\n\
391+ \│ └─ <x::Int>/\n\
392+ \│ ├─•\n\
393+ \│ ┆\n\
394+ \│ └─•\n\
395+ \├─ c/\n\
396+ \│ └─•\n\
397+ \┆\n\
398+ \└─ <raw>\n"
399+
400+-- A capture API with all capture types being the same
401+--
402+type CaptureSameType =
403+ "a" :> Capture "foo" Int :> "b" :> End
404+ :<|> "a" :> Capture "foo" Int :> "c" :> End
405+ :<|> "a" :> Capture "foo" Int :> "d" :> End
406+
407+captureSameType :: Proxy CaptureSameType
408+captureSameType = Proxy
409+
410+-- The expected representation of the CaptureSameType API layout.
411+--
412+expectedCaptureSameType :: Text
413+expectedCaptureSameType =
414+ "/\n\
415+ \└─ a/\n\
416+ \ └─ <foo::Int>/\n\
417+ \ ├─ b/\n\
418+ \ │ └─•\n\
419+ \ ├─ c/\n\
420+ \ │ └─•\n\
421+ \ └─ d/\n\
422+ \ └─•\n"
423+
424+-- A capture API capturing different types
425+--
426+type CaptureDifferentTypes =
427+ "a" :> Capture "foo" Int :> "b" :> End
428+ :<|> "a" :> Capture "bar" Bool :> "c" :> End
429+ :<|> "a" :> Capture "baz" Char :> "d" :> End
430+
431+captureDifferentTypes :: Proxy CaptureDifferentTypes
432+captureDifferentTypes = Proxy
433+
434+-- The expected representation of the CaptureDifferentTypes API layout.
435+--
436+expectedCaptureDifferentTypes :: Text
437+expectedCaptureDifferentTypes =
438+ "/\n\
439+ \└─ a/\n\
440+ \ └─ <foo::Int|bar::Bool|baz::Char>/\n\
441+ \ ├─ b/\n\
442+ \ │ └─•\n\
443+ \ ├─ c/\n\
444+ \ │ └─•\n\
445+ \ └─ d/\n\
446+ \ └─•\n"
447+
448+-- An API with a CaptureAll part
449+
450+type CaptureAllLayout = "a" :> CaptureAll "foos" Int :> End
451+
452+captureAllLayout :: Proxy CaptureAllLayout
453+captureAllLayout = Proxy
454+
455+-- The expected representation of the CaptureAllLayout API.
456+--
457+expectedCaptureAllLayout :: Text
458+expectedCaptureAllLayout =
459+ "/\n\
460+ \└─ a/\n\
461+ \ └─ <foos::[Int]>/\n\
462+ \ └─•\n"