Skip to content

Commit 65de6f7

Browse files
author
Gaël Deest
authored
Merge pull request #1556 from nbacquey/router_layout_captures
Display capture hints in router layout
2 parents f5a91d2 + a19cb84 commit 65de6f7

File tree

5 files changed

+248
-26
lines changed

5 files changed

+248
-26
lines changed

‎changelog.d/1556

Lines changed: 81 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -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

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -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

Lines changed: 6 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -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

242244
allowedMethodHead :: Method -> Request -> Bool
243245
allowedMethodHead method request = method == methodGet && requestMethod request == methodHead

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

Lines changed: 31 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -9,12 +9,16 @@ import Prelude.Compat
99

1010
import Data.Function
1111
(on)
12+
import Data.List
13+
(nub)
1214
import Data.Map
1315
(Map)
1416
import qualified Data.Map as M
1517
import Data.Text
1618
(Text)
1719
import qualified Data.Text as T
20+
import Data.Typeable
21+
(TypeRep)
1822
import Network.Wai
1923
(Response, pathInfo)
2024
import Servant.Server.Internal.ErrorFormatter
@@ -24,6 +28,18 @@ import Servant.Server.Internal.ServerError
2428

2529
type 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]
6985
choice :: Router' env a -> Router' env a -> Router' env a
7086
choice (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)
7490
choice router1 (Choice router2 router3) = Choice (choice router1 router2) router3
7591
choice router1 router2 = Choice router1 router2
7692

@@ -84,7 +100,7 @@ choice router1 router2 = Choice router1 router2
84100
--
85101
data 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 =
98114
routerStructure :: Router' env a -> RouterStructure
99115
routerStructure (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
107123
routerStructure (RawRouter _) =
108124
RawRouterStructure
@@ -114,8 +130,8 @@ routerStructure (Choice r1 r2) =
114130
-- | Compare the structure of two routers.
115131
--
116132
sameStructure :: 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,15 +186,15 @@ 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.
176193
[""] -> respond $ Fail $ fmt request
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

0 commit comments

Comments
 (0)