77b92d0 · servant · git.iko.soy

git.iko.soy/servant

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 "<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.

commit77b92d0d7d7913e8e3cf4d3b1ebd31d3923094f6 authorNicolas BACQUEY <nicolas.bacquey@tweag.io> dateTue 8 Mar 2022, 14:55 (5 years ago) parentde923fc

4 files changed+51−26

compare with master

unifiedsplit

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+11−6

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

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+11−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

@@ -51,7 +53,7 @@ routerSpec = do

5153 toApp = toApplication . runRouter (const err404)

5254

5355 cap :: Router ()

54− cap = CaptureRouter $

56+ cap = CaptureRouter [hint] $

5557 let delayed = addCapture (emptyDelayed $ Route pure) (const $ delayedFail err400)

5658 in leafRouter

5759 $ \env req res ->

@@ -59,6 +61,9 @@ routerSpec = do

5961 . const

6062 $ Route success

6163

64+ hint :: CaptureHint

65+ hint = CaptureHint "anything" $ typeRep (Proxy :: Proxy ())

66+

6267 router :: Router ()

6368 router = leafRouter (\_ _ res -> res $ Route success)

6469 `Choice` cap

@@ -144,12 +149,12 @@ staticRef = Proxy

144149-- structure:

145150

146151type Dynamic =

147− "a" :> Capture "foo" Int :> "b" :> End

148− :<|> "a" :> Capture "bar" Bool :> "c" :> End

149− :<|> "a" :> Capture "baz" Char :> "d" :> End

152+ "a" :> Capture "foo" Int :> "b" :> End

153+ :<|> "a" :> Capture "foo" Int :> "c" :> End

154+ :<|> "a" :> Capture "foo" Int :> "d" :> End

150155

151156type DynamicRef =

152− "a" :> Capture "anything" () :>

157+ "a" :> Capture "foo" Int :>

153158 ("b" :> End :<|> "c" :> End :<|> "d" :> End)

154159

155160dynamic :: Proxy Dynamic