77b92d0 · servant · git.iko.soy

git.iko.soy/servant

on master help sign in

Display capture hints in router layout

77b92d0Nicolas BACQUEY5 years ago

servant-server/src/Servant/Server.hs+3−2

compare with master

unifiedsplit

@@ -235,7 +235,7 @@ hoistServer p = hoistServerWithContext p (Proxy :: Proxy '[])

235-- > │ └─ e/

236-- > │ └─•

237-- > ├─ b/

238−-- > │ └─ <capture>/

238+-- > │ └─ <x::Int>/

239-- > │ ├─•

240-- > │ ┆

241-- > │ └─•

@@ -252,7 +252,8 @@ hoistServer p = hoistServerWithContext p (Proxy :: Proxy '[])

252--

253-- [@─•@] Leaves reflect endpoints.

254--

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

256--

257--

257-- [@\<raw\>@] This is a part of the API we do not know anything about.

258-- [@\<raw\>@] This is a part of the API we do not know anything about.

258--

259--

servant-server/src/Servant/Server/Internal.hs+6−4

@@ -173,7 +173,7 @@ instance (HasServer a context, HasServer b context) => HasServer (a :<|> b) cont

173-- > server = getBook

174-- > where getBook :: Text -> Handler Book

175-- > getBook isbn = ...

176−instance (KnownSymbol capture, FromHttpApiData a

176+instance (KnownSymbol capture, FromHttpApiData a, Typeable a

177 , HasServer api context, SBoolI (FoldLenient mods)

178 , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters

179 )

@@ -185,7 +185,7 @@ instance (KnownSymbol capture, FromHttpApiData a

185 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s

186

187 route Proxy context d =

188− CaptureRouter $

188+ CaptureRouter [hint] $

189 route (Proxy :: Proxy api)

190 context

191 (addCapture d $ \ txt -> withRequest $ \ request ->

@@ -197,6 +197,7 @@ instance (KnownSymbol capture, FromHttpApiData a

197 where

198 rep = typeRep (Proxy :: Proxy Capture')

199 formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)

200+ hint = CaptureHint (T.pack $ symbolVal $ Proxy @capture) (typeRep (Proxy :: Proxy a))

200

201

201-- | If you use 'CaptureAll' in one of the endpoints for your API,

202-- | If you use 'CaptureAll' in one of the endpoints for your API,

202-- this automatically requires your server-side handler to be a

203-- this automatically requires your server-side handler to be a

@@ -215,7 +216,7 @@ instance (KnownSymbol capture, FromHttpApiData a

215-- > server = getSourceFile

216-- > server = getSourceFile

216-- > where getSourceFile :: [Text] -> Handler Book

217-- > where getSourceFile :: [Text] -> Handler Book

217-- > getSourceFile pathSegments = ...

218-- > getSourceFile pathSegments = ...

218−instance (KnownSymbol capture, FromHttpApiData a

219+instance (KnownSymbol capture, FromHttpApiData a, Typeable a

219 , HasServer api context

220 , HasServer api context

220 , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters

221 , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters

221 )

222 )

@@ -227,7 +228,7 @@ instance (KnownSymbol capture, FromHttpApiData a

227 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s

228 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s

228

229

229 route Proxy context d =

230 route Proxy context d =

230− CaptureAllRouter $

231+ CaptureAllRouter [hint] $

231 route (Proxy :: Proxy api)

232 route (Proxy :: Proxy api)

232 context

233 context

233 (addCapture d $ \ txts -> withRequest $ \ request ->

234 (addCapture d $ \ txts -> withRequest $ \ request ->

@@ -238,6 +239,7 @@ instance (KnownSymbol capture, FromHttpApiData a

238 where

239 where

239 rep = typeRep (Proxy :: Proxy CaptureAll)

240 rep = typeRep (Proxy :: Proxy CaptureAll)

240 formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)

241 formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)

242+ hint = CaptureHint (T.pack $ symbolVal $ Proxy @capture) (typeRep (Proxy :: Proxy [a]))

241

243

242allowedMethodHead :: Method -> Request -> Bool

244allowedMethodHead :: Method -> Request -> Bool

243allowedMethodHead method request = method == methodGet && requestMethod request == methodHead

245allowedMethodHead method request = method == methodGet && requestMethod request == methodHead

servant-server/src/Servant/Server/Internal/Router.hs+31−14

@@ -9,12 +9,16 @@ import Prelude.Compat

10import Data.Function

11 (on)

12+import Data.List

13+ (nub)

12import Data.Map

14import Data.Map

13 (Map)

15 (Map)

14import qualified Data.Map as M

16import qualified Data.Map as M

15import Data.Text

17import Data.Text

16 (Text)

18 (Text)

17import qualified Data.Text as T

19import qualified Data.Text as T

20+import Data.Typeable

21+ (TypeRep)

18import Network.Wai

22import Network.Wai

19 (Response, pathInfo)

23 (Response, pathInfo)

20import Servant.Server.Internal.ErrorFormatter

24import Servant.Server.Internal.ErrorFormatter

@@ -24,6 +28,18 @@ import Servant.Server.Internal.ServerError

25type Router env = Router' env RoutingApplication

29type Router env = Router' env RoutingApplication

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+

27-- | Internal representation of a router.

43-- | Internal representation of a router.

28--

44--

29-- The first argument describes an environment type that is

45-- The first argument describes an environment type that is

@@ -36,10 +52,10 @@ data Router' env a =

36 -- ^ the map contains routers for subpaths (first path component used

52 -- ^ the map contains routers for subpaths (first path component used

37 -- for lookup and removed afterwards), the list contains handlers

53 -- for lookup and removed afterwards), the list contains handlers

38 -- for the empty path, to be tried in order

54 -- for the empty path, to be tried in order

39− | CaptureRouter (Router' (Text, env) a)

55+ | CaptureRouter [CaptureHint] (Router' (Text, env) a)

40 -- ^ first path component is passed to the child router in its

56 -- ^ first path component is passed to the child router in its

41 -- environment and removed afterwards

57 -- environment and removed afterwards

42− | CaptureAllRouter (Router' ([Text], env) a)

58+ | CaptureAllRouter [CaptureHint] (Router' ([Text], env) a)

43 -- ^ all path components are passed to the child router in its

59 -- ^ all path components are passed to the child router in its

44 -- environment and are removed afterwards

60 -- environment and are removed afterwards

45 | RawRouter (env -> a)

61 | RawRouter (env -> a)

@@ -69,8 +85,8 @@ leafRouter l = StaticRouter M.empty [l]

69choice :: Router' env a -> Router' env a -> Router' env a

85choice :: Router' env a -> Router' env a -> Router' env a

70choice (StaticRouter table1 ls1) (StaticRouter table2 ls2) =

86choice (StaticRouter table1 ls1) (StaticRouter table2 ls2) =

71 StaticRouter (M.unionWith choice table1 table2) (ls1 ++ ls2)

87 StaticRouter (M.unionWith choice table1 table2) (ls1 ++ ls2)

72−choice (CaptureRouter router1) (CaptureRouter router2) =

88+choice (CaptureRouter hints1 router1) (CaptureRouter hints2 router2) =

73− CaptureRouter (choice router1 router2)

89+ CaptureRouter (nub $ hints1 ++ hints2) (choice router1 router2)

74choice router1 (Choice router2 router3) = Choice (choice router1 router2) router3

90choice router1 (Choice router2 router3) = Choice (choice router1 router2) router3

75choice router1 router2 = Choice router1 router2

91choice router1 router2 = Choice router1 router2

@@ -84,7 +100,7 @@ choice router1 router2 = Choice router1 router2

84--

100--

85data RouterStructure =

101data RouterStructure =

86 StaticRouterStructure (Map Text RouterStructure) Int

102 StaticRouterStructure (Map Text RouterStructure) Int

87− | CaptureRouterStructure RouterStructure

103+ | CaptureRouterStructure [CaptureHint] RouterStructure

88 | RawRouterStructure

104 | RawRouterStructure

89 | ChoiceStructure RouterStructure RouterStructure

105 | ChoiceStructure RouterStructure RouterStructure

90 deriving (Eq, Show)

106 deriving (Eq, Show)

@@ -98,11 +114,11 @@ data RouterStructure =

98routerStructure :: Router' env a -> RouterStructure

114routerStructure :: Router' env a -> RouterStructure

99routerStructure (StaticRouter m ls) =

115routerStructure (StaticRouter m ls) =

100 StaticRouterStructure (fmap routerStructure m) (length ls)

116 StaticRouterStructure (fmap routerStructure m) (length ls)

101−routerStructure (CaptureRouter router) =

117+routerStructure (CaptureRouter hints router) =

102− CaptureRouterStructure $

118+ CaptureRouterStructure hints $

103 routerStructure router

119 routerStructure router

104−routerStructure (CaptureAllRouter router) =

120+routerStructure (CaptureAllRouter hints router) =

105− CaptureRouterStructure $

121+ CaptureRouterStructure hints $

106 routerStructure router

122 routerStructure router

107routerStructure (RawRouter _) =

123routerStructure (RawRouter _) =

108 RawRouterStructure

124 RawRouterStructure

@@ -114,8 +130,8 @@ routerStructure (Choice r1 r2) =

114-- | Compare the structure of two routers.

130-- | Compare the structure of two routers.

115--

131--

116sameStructure :: Router' env a -> Router' env b -> Bool

132sameStructure :: Router' env a -> Router' env b -> Bool

117−sameStructure r1 r2 =

133+sameStructure router1 router2 =

118− routerStructure r1 == routerStructure r2

134+ routerStructure router1 == routerStructure router2

119

135

120-- | Provide a textual representation of the

136-- | Provide a textual representation of the

121-- structure of a router.

137-- structure of a router.

@@ -126,7 +142,8 @@ routerLayout router =

126 where

142 where

127 mkRouterLayout :: Bool -> RouterStructure -> [Text]

143 mkRouterLayout :: Bool -> RouterStructure -> [Text]

128 mkRouterLayout c (StaticRouterStructure m n) = mkSubTrees c (M.toList m) n

144 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)

130 mkRouterLayout c RawRouterStructure =

147 mkRouterLayout c RawRouterStructure =

131 if c then ["├─ <raw>"] else ["└─ <raw>"]

148 if c then ["├─ <raw>"] else ["└─ <raw>"]

132 mkRouterLayout c (ChoiceStructure r1 r2) =

149 mkRouterLayout c (ChoiceStructure r1 r2) =

@@ -169,7 +186,7 @@ runRouterEnv fmt router env request respond =

169 -> let request' = request { pathInfo = rest }

186 -> let request' = request { pathInfo = rest }

170 in runRouterEnv fmt router' env request' respond

187 in runRouterEnv fmt router' env request' respond

171 _ -> respond $ Fail $ fmt request

188 _ -> respond $ Fail $ fmt request

172− CaptureRouter router' ->

189+ CaptureRouter _ router' ->

173 case pathInfo request of

190 case pathInfo request of

174 [] -> respond $ Fail $ fmt request

191 [] -> respond $ Fail $ fmt request

175 -- This case is to handle trailing slashes.

192 -- This case is to handle trailing slashes.

@@ -177,7 +194,7 @@ runRouterEnv fmt router env request respond =

177 first : rest

194 first : rest

178 -> let request' = request { pathInfo = rest }

195 -> let request' = request { pathInfo = rest }

179 in runRouterEnv fmt router' (first, env) request' respond

196 in runRouterEnv fmt router' (first, env) request' respond

180− CaptureAllRouter router' ->

197+ CaptureAllRouter _ router' ->

181 let segments = pathInfo request

198 let segments = pathInfo request

182 request' = request { pathInfo = [] }

199 request' = request { pathInfo = [] }

183 in runRouterEnv fmt router' (segments, env) request' respond

200 in runRouterEnv fmt router' (segments, env) request' respond

servant-server/test/Servant/Server/RouterSpec.hs+11−6

@@ -9,7 +9,9 @@ import Control.Monad

9import Data.Proxy

10 (Proxy (..))

11import Data.Text

12− (unpack)

12+ (Text, unpack)

13+import Data.Typeable

14+ (typeRep)

13import Network.HTTP.Types

15import Network.HTTP.Types

14 (Status (..))

16 (Status (..))

15import Network.Wai

17import Network.Wai

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

51 toApp = toApplication . runRouter (const err404)

53 toApp = toApplication . runRouter (const err404)

53 cap :: Router ()

55 cap :: Router ()

54− cap = CaptureRouter $

56+ cap = CaptureRouter [hint] $

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

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

56 in leafRouter

58 in leafRouter

57 $ \env req res ->

59 $ \env req res ->

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

59 . const

61 . const

60 $ Route success

62 $ Route success

64+ hint :: CaptureHint

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

66+

62 router :: Router ()

67 router :: Router ()

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

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

64 `Choice` cap

69 `Choice` cap

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

144-- structure:

149-- structure:

145

150

146type Dynamic =

151type Dynamic =

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

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

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

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

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

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

150

155

151type DynamicRef =

156type DynamicRef =

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

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

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

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

154

159

155dynamic :: Proxy Dynamic

160dynamic :: Proxy Dynamic