This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "snap-core".
The branch, master has been updated
via e6f55ff7f097e639e4d5b67ef1faf092ef227c04 (commit)
from 81db7f64db0b8462b255880322445af49993cd02 (commit)
Summary of changes:
src/Snap/Internal/Routing.hs | 103 +++++++++++++++++++---------
test/suite/Snap/Internal/Routing/Tests.hs | 27 +++++++-
2 files changed, 94 insertions(+), 36 deletions(-)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit e6f55ff7f097e639e4d5b67ef1faf092ef227c04
Author: Shu-yu Guo <[email protected]>
Date: Tue Jun 1 19:30:56 2010 -0700
New routing code, we now merge capture routes correctly
diff --git a/src/Snap/Internal/Routing.hs b/src/Snap/Internal/Routing.hs
index 72e26af..956b048 100644
--- a/src/Snap/Internal/Routing.hs
+++ b/src/Snap/Internal/Routing.hs
@@ -44,20 +44,32 @@ data Route a = Action (Snap a) --
wraps a 'Snap' action
instance Monoid (Route a) where
mempty = NoRoute
- -- Unions two routes, favoring the right-hand side
mappend NoRoute r = r
- mappend l@(Action _) r = case r of
- (Action _) -> r
+ mappend l@(Action a) r = case r of
+ (Action a') -> Action (a <|> a')
(Capture p r' fb) -> Capture p r' (mappend fb l)
(Dir _ _) -> mappend (Dir Map.empty l) r
NoRoute -> l
+ -- Whenever we're unioning two Captures and their capture variables
+ -- differ, we have an ambiguity. We resolve this in the following order:
+ -- 1. Prefer whichever route is longer
+ -- 2. Else, prefer whichever has the earliest non-capture
+ -- 3. Else, prefer the right-hand side
mappend l@(Capture p r' fb) r = case r of
(Action _) -> Capture p r' (mappend fb r)
(Capture p' r'' fb')
- | p == p' -> Capture p (mappend r' r'') (mappend fb fb')
- | otherwise -> r
+ | p == p' -> Capture p (mappend r' r'') (mappend fb fb')
+ | rh' > rh'' -> Capture p r' (mappend fb r)
+ | rh' < rh'' -> Capture p' r'' (mappend fb' l)
+ | en' < en'' -> Capture p r' (mappend fb r)
+ | otherwise -> Capture p' r'' (mappend fb' l)
+ where
+ rh' = routeHeight r'
+ rh'' = routeHeight r''
+ en' = routeEarliestNC r' 1
+ en'' = routeEarliestNC r'' 1
(Dir rm fb') -> Dir rm (mappend fb' l)
NoRoute -> l
@@ -69,6 +81,22 @@ instance Monoid (Route a) where
------------------------------------------------------------------------------
+routeHeight :: Route a -> Int
+routeHeight r = case r of
+ NoRoute -> 1
+ (Action _) -> 1
+ (Capture _ r' _) -> 1+routeHeight r'
+ (Dir rm _) -> 1+foldl max 1 (map routeHeight $ Map.elems rm)
+
+routeEarliestNC :: Route a -> Int -> Int
+routeEarliestNC r n = case r of
+ NoRoute -> n
+ (Action _) -> n
+ (Capture _ r' _) -> routeEarliestNC r' n+1
+ (Dir _ _) -> n
+
+
+------------------------------------------------------------------------------
-- | A web handler which, given a mapping from URL entry points to web
-- handlers, efficiently routes requests to the correct handler.
--
@@ -118,29 +146,35 @@ instance Monoid (Route a) where
-- > , ("login", method POST doLogin) ]
--
route :: [(ByteString, Snap a)] -> Snap a
-route rts = route' (return ()) rts' []
+route rts = do
+ p <- getRequest >>= return . rqPathInfo
+ route' (return ()) ([], splitPath p) Map.empty rts'
where
rts' = mconcat (map pRoute rts)
------------------------------------------------------------------------------
--- | The 'routeLocal' function is the same as 'route', except it doesn't change
+-- | The 'routeLocal' function is the same as 'route'', except it doesn't
change
-- the request's context path. This is useful if you want to route to a
-- particular handler but you want that handler to receive the 'rqPathInfo' as
-- it is.
routeLocal :: [(ByteString, Snap a)] -> Snap a
-routeLocal rts' = do
+routeLocal rts = do
req <- getRequest
let ctx = rqContextPath req
let p = rqPathInfo req
let md = modifyRequest $ \r -> r {rqContextPath=ctx, rqPathInfo=p}
- route' md rts [] <|> (md >> pass)
+ (route' md ([], splitPath p) Map.empty rts') <|> (md >> pass)
where
- rts = mconcat (map pRoute rts')
+ rts' = mconcat (map pRoute rts)
+
+------------------------------------------------------------------------------
+splitPath :: ByteString -> [ByteString]
+splitPath = B.splitWith (== (c2w '/'))
+
-
------------------------------------------------------------------------------
pRoute :: (ByteString, Snap a) -> Route a
pRoute (r, a) = foldr f (Action a) hier
@@ -152,30 +186,33 @@ pRoute (r, a) = foldr f (Action a) hier
------------------------------------------------------------------------------
-route' :: Snap () -- ^ an action to be run before any user
- -- handler
- -> Route a -- ^ currently active routing table
- -> [Route a] -- ^ list of fallback routing tables in case
- -- the current table fails
+route' :: Snap ()
+ -> ([ByteString], [ByteString])
+ -> Params
+ -> Route a
-> Snap a
-route' pre (Action action) _ = pre >> action
-
-route' pre (Capture param rt fb) fbs = do
- cwd <- getRequest >>= return . B.takeWhile (/= (c2w '/')) . rqPathInfo
- if B.null cwd
- then route' pre fb fbs
- else do localRequest (updateContextPath (B.length cwd) . (f cwd)) $
- route' pre rt (fb:fbs)
+route' pre (ctx, _) params (Action action) =
+ localRequest (updateContextPath (B.length ctx') . updateParams)
+ (pre >> action)
+ where
+ ctx' = B.intercalate (B.pack [c2w '/']) (reverse ctx)
+ updateParams req = req
+ { rqParams = Map.unionWith (++) params (rqParams req) }
+
+route' pre (ctx, []) params (Capture _ _ fb) =
+ route' pre (ctx, []) params fb
+route' pre (ctx, cwd:rest) params (Capture p rt fb) =
+ (route' pre (cwd:ctx, rest) params' rt) <|>
+ (route' pre (ctx, cwd:rest) params fb)
where
- f v req = req { rqParams = Map.insertWith (++) param [v] (rqParams req) }
+ params' = Map.insertWith (++) p [cwd] params
-route' pre (Dir rtm fb) fbs = do
- cwd <- getRequest >>= return . B.takeWhile (/= (c2w '/')) . rqPathInfo
+route' pre (ctx, []) params (Dir _ fb) =
+ route' pre (ctx, []) params fb
+route' pre (ctx, cwd:rest) params (Dir rtm fb) =
case Map.lookup cwd rtm of
- Just rt -> do
- localRequest (updateContextPath (B.length cwd)) $
- route' pre rt (fb:fbs)
- Nothing -> route' pre fb fbs
+ Just rt -> (route' pre (cwd:ctx, rest) params rt) <|>
+ (route' pre (ctx, cwd:rest) params fb)
+ Nothing -> route' pre (ctx, cwd:rest) params fb
-route' _ NoRoute [] = pass
-route' pre NoRoute (fb:fbs) = route' pre fb fbs
+route' _ _ _ NoRoute = pass
diff --git a/test/suite/Snap/Internal/Routing/Tests.hs
b/test/suite/Snap/Internal/Routing/Tests.hs
index d2b7a66..bc1877c 100644
--- a/test/suite/Snap/Internal/Routing/Tests.hs
+++ b/test/suite/Snap/Internal/Routing/Tests.hs
@@ -48,6 +48,9 @@ tests = [ testRouting1
, testRouting23
, testRouting24
, testRouting25
+ , testRouting26
+ , testRouting27
+ , testRouting28
, testRouteLocal ]
expectException :: IO a -> IO ()
@@ -95,8 +98,10 @@ routes3 = route [ (":foo" , topCapture )
, ("" , topTop ) ]
routes4 :: Snap ByteString
-routes4 = route [ (":foo" , pass )
- , (":foo" , topCapture ) ]
+routes4 = route [ (":foo" , pass )
+ , (":foo" , topCapture )
+ , (":qqq/:id" , fooCapture )
+ , (":id2/baz" , fooCapture2 ) ]
routes5 :: Snap ByteString
routes5 = route [ ("" , pass )
@@ -148,12 +153,13 @@ fooBarBaz = liftM rqPathInfo getRequest
barQuux = return "barQuux"
bar = return "bar"
+-- TODO more useful test names
+
testRouting1 :: Test
testRouting1 = testCase "routing1" $ do
r1 <- go routes "foo"
assertEqual "/foo" "topFoo" r1
-
testRouting2 :: Test
testRouting2 = testCase "routing2" $ do
r2 <- go routes "foo/baz"
@@ -273,6 +279,21 @@ testRouting25 = testCase "routing25" $ do
r1 <- go routes7 "foooo/bar/baz"
assertEqual "/foooo/bar/baz" "bar" r1
+testRouting26 :: Test
+testRouting26 = testCase "routing26" $ do
+ r1 <- go routes4 "foo/bar"
+ assertEqual "capture union" "bar" r1
+
+testRouting27 :: Test
+testRouting27 = testCase "routing27" $ do
+ r1 <- go routes4 "foo"
+ assertEqual "capture union" "foo" r1
+
+testRouting28 :: Test
+testRouting28 = testCase "routing28" $ do
+ r1 <- go routes4 "quux/baz"
+ assertEqual "capture union" "quux" r1
+
testRouteLocal :: Test
testRouteLocal = testCase "routeLocal" $ do
r4 <- go routesLocal "foo/bar/baz/quux"
-----------------------------------------------------------------------
hooks/post-receive
--
snap-core
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
