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