From bc00f3958f2d4299be994c48ada5127d135f1aca Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 7 Sep 2014 16:45:42 +0300 Subject: [PATCH] Unified parsing and dispatching code (still ugly) --- yesod-routes/Yesod/Routes/Dispatch.lhs | 323 --------------------- yesod-routes/Yesod/Routes/TH/ParseRoute.hs | 28 +- yesod-routes/test/Hierarchy.hs | 1 + yesod-routes/test/main.hs | 71 ----- yesod-routes/yesod-routes.cabal | 3 +- 5 files changed, 26 insertions(+), 400 deletions(-) delete mode 100644 yesod-routes/Yesod/Routes/Dispatch.lhs diff --git a/yesod-routes/Yesod/Routes/Dispatch.lhs b/yesod-routes/Yesod/Routes/Dispatch.lhs deleted file mode 100644 index f12665a6..00000000 --- a/yesod-routes/Yesod/Routes/Dispatch.lhs +++ /dev/null @@ -1,323 +0,0 @@ -Title: Optimized route dispatch code - -Let's start with our module declaration and imports. - -> module Yesod.Routes.Dispatch -> ( Piece (..) -> , Route (..) -> , Dispatch -> , toDispatch -> ) where -> -> import Data.Text (Text) -> import qualified Data.Vector as V -> import Data.Maybe (fromMaybe, mapMaybe) -> import qualified Data.Map as Map -> import Data.List (sortBy) -> import Data.Ord (comparing) -> import Control.Arrow (second) -> import Control.Exception (assert) - -This module provides an efficient routing system. The code is pure, requires no -fancy extensions, has no Template Haskell involved and is not Yesod specific. -It does, however, assume a routing system similar to that of Yesod. - -Routing works based on splitting up a path into its components. This is handled -very well by both the web-routes and http-types packages, and this module does -not duplicate that functionality. Instead, it assumes that the requested path -will be provided as a list of 'Text's. - -A route will be specified by a list of pieces (using the 'Piece' datatype). - -> data Piece = Static Text | Dynamic - -Each piece is either a static piece- which is required to match a component of -the path precisely- or a dynamic piece, which will match any component. -Additionally, a route can optionally match all remaining components in the -path, or fail if extra components exist. - -Usually, the behavior of dynamic is not what you really want. Often times, you -will want to match integers, or slugs, or some other limited format. This -brings us nicely to the dispatch function. Each route provides a function of -type: - -> type Dispatch res = [Text] -> Maybe res - -The res argument is application-specific. For example, in a simple -WAI application, it could be the Application datatype. The important -thing to point out about Dispatch is that is takes a list of 'Text's and -returns its response in a Maybe. This gives you a chance to have -finer-grained control over how individual components are parsed. If you don't -want to deal with it, you return 'Nothing' and routing continues. - -Note: You do *not* need to perform any checking on your static pieces, this -module handles that for you automatically. - -So each route is specified by: - -> data Route res = Route -> { rhPieces :: [Piece] -> , rhHasMulti :: Bool -> , rhDispatch :: Dispatch res -> } - -Your application needs to provide this module with a list of routes, and then -this module will give you back a new dispatch function. In other words: - -> toDispatch :: [Route res] -> Dispatch res -> toDispatch rhs = -> bcToDispatch bc -> where -> bc = toBC rhs - -In addition to the requirements listed above for routing, we add one extra -rule: your specified list of routes is treated as ordered, with the earlier -ones matching first. If you have an overlap between two routes, the first one -will be dispatched. - -The simplest approach would be to loop through all of your routes and compare -against the path components. But this has linear complexity. Many existing -frameworks (Rails and Django at least) have such algorithms, usually based on -regular expressions. But we can provide two optimizations: - -* Break up routes based on how many components they can match. We can then - select which group of routes to continue testing. This lookup runs in - constant time. - -* Use a Map to reduce string comparisons for each route to logarithmic - complexity. - -Let's start with the first one. Each route has a fixed number of pieces. Let's -call this *n*. If that route can also match trailing components (rhHasMulti -above), then it will match *n* and up. Otherwise, it will match specifically on -*n*. - -If *max(n)* is the maximum value of *n* for all routes, what we need is -(*max(n)* + 2) groups: a zero group (matching a request for the root of the -application), 1 - *max(n)* groups, and a final extra group containing all -routes that can match more than *max(n)* components. This group will consist of -all the routes with rhHasMulti, and only those routes. - -> data ByCount res = ByCount -> { bcVector :: !(V.Vector (PieceMap res)) -> , bcRest :: !(PieceMap res) -> } - -We haven't covered PieceMap yet; it is used for the second optimization. We'll -discuss it below. - -The following function breaks up a list of routes into groups. Again, please -ignore the PieceMap references for the moment. - -> toBC :: [Route res] -> ByCount res -> toBC rhs = -> ByCount -> { bcVector = groups -> , bcRest = allMultis -> } -> where - -Determine the value of *max(n)*. - -> maxLen -> | null rhs = 0 -> | otherwise = maximum $ map (length . rhPieces) rhs - -Get the list of all routes which can have multis. This will make up the *rest* -group. - -> allMultis = toPieceMap maxLen $ filter rhHasMulti rhs - -And now get all the numbered groups. For each group, we need to get all routes -with *n* components, __and__ all routes with less than *n* components and that -have rhHasMulti set to True. - -> groups = V.map group $ V.enumFromN 0 (maxLen + 1) -> group i = toPieceMap i $ filter (canHaveLength i) rhs -> -> canHaveLength :: Int -> Route res -> Bool -> canHaveLength i rh = -> len == i || (len < i && rhHasMulti rh) -> where -> len = length $ rhPieces rh - -Next we'll set up our routing by maps. What we need is a bunch of nested Maps. -For example, if we have the following routings: - - /foo/bar/1 - /foo/baz/2 - -We would want something that looks vaguely like: - - /foo - /bar - /1 - /baz - /2 - -But there's an added complication: we need to deal with dynamic compnents and HasMulti as well. So what we'd really have is routes looking like: - - /foo/bar/1 - /foo/baz/2 - /*dynamic*/bin/3 - /multi/*bunch of multis* - -We can actually simplify away the multi business. Remember that for each group, -we will have a fixed number of components to match. In the list above, it's -three. Even though the last route only has one component, we can actually just -fill up the missing components with *dynamic*, which will give the same result -for routing. In other words, we'll treat it as: - - /foo - /bar - /1 - /baz - /2 - /*dynamic* - /bin - /3 - /multi - /*dynamic* - /*dynamic* - -What we need is then two extra features on our datatype: - -* Support both a 'Map Text PieceMap' for static pieces, and a general - 'PieceMap' for all dynamic pieces. - -* An extra constructive after we've gone three levels deep, to provide all - matching routes. - -What we end up with is: - -> data PieceMap res = PieceMap -> { pmDynamic :: PieceMap res -> , pmStatic :: Map.Map Text (PieceMap res) -> } | PieceMapEnd [(Int, Dispatch res)] - -Note that the PieceMapEnd is a list of pairs, including an Int. Since the map -process will confuse the original order of our routes, we need some way to get -that back to make sure overlapping is handled correctly. - -We'll need two pieces of information to make a PieceMap: the depth to drill -down to, and the routes in the current group. We'll immediately zip up those -routes with an Int to indicate route priority. - -> toPieceMap :: Int -> [Route res] -> PieceMap res -> toPieceMap depth = toPieceMap' depth . zip [1..] -> -> toPieceMap' :: Int -> -> [(Int, Route res)] -> -> PieceMap res - -The stopping case: we've exhausted the full depth, so let's put together a -PieceMapEnd. Technically speaking, the sort here is unnecessary, since we'll -sort again later. However, that second sorting occurs during each dispatch -occurrence, whereas this sorting only occurs once, in the initial construction -of the PieceMap. Therefore, we presort here. - -> toPieceMap' 0 rhs = -> PieceMapEnd $ map (second rhDispatch) -> $ sortBy (comparing fst) rhs - -Note also that we apply rhDispatch to the route. We are no longer interested in -the rest of the route information, so it can be discarded. - -Now the heart of this algorithm: we construct the pmDynamic and pmStatic -records. For both, we recursively call toPieceMap' again, with the depth -knocked down by 1. - -> toPieceMap' depth rhs = PieceMap -> { pmDynamic = toPieceMap' depth' dynamics -> , pmStatic = Map.map (toPieceMap' depth') statics -> } -> where -> depth' = depth - 1 - -We turn our list of routes into a list of pairs. The first item in the pair -gives the next piece, and the second gives the route again, minus that piece. - -> pairs = map toPair rhs -> toPair (i, Route (p:ps) b c) = (p, (i, Route ps b c)) - -And as we mentioned above, for multi pieces we fill in the remaining pieces -with Dynamic. - -> toPair (i, Route [] b c) = assert b (Dynamic, (i, Route [] b c)) - -Next, we break up our list of dynamics. - -> getDynamic (Dynamic, rh) = Just rh -> getDynamic _ = Nothing -> dynamics = mapMaybe getDynamic pairs - -And now we make a Map for statics. Note that Map.fromList would not be -appropriate here, since it would only keep one route per Text. - -> getStatic (Static t, rh) = Just $ Map.singleton t [rh] -> getStatic _ = Nothing -> statics = Map.unionsWith (++) $ mapMaybe getStatic pairs - -The time has come to actually dispatch. - -> bcToDispatch :: ByCount res -> Dispatch res -> bcToDispatch (ByCount vec rest) ts0 = -> bcToDispatch' ts0 pm0 -> where - -Get the PieceMap for the appropriate group. If the length of the requested path -is greater than *max(n)*, then use the "rest" group. - -> pm0 = fromMaybe rest $ vec V.!? length ts0 - -Stopping case: we've found our list of routes. Sort them, then starting -applying their dispatch functions. If the first one returns Nothing, go to the -next, and so on. - -> bcToDispatch' _ (PieceMapEnd r) = firstJust (\f -> f ts0) $ map snd r - -For each component, get the static PieceMap and the dynamic one, combine them -together, and then continue dispatching. - -> bcToDispatch' (t:ts) (PieceMap dyn sta) = bcToDispatch' ts $ -> case Map.lookup t sta of -> Nothing -> dyn -> Just pm -> append dyn pm - -Handle an impossible case that should never happen. - -> bcToDispatch' [] _ = assert False Nothing - -Helper function: get the first Just response. - -> firstJust :: (a -> Maybe b) -> [a] -> Maybe b -> firstJust _ [] = Nothing -> firstJust f (a:as) = maybe (firstJust f as) Just $ f a - -Combine two PieceMaps together. - -> append :: PieceMap res -> PieceMap res -> PieceMap res - -At the end, just combine the list of routes. But we combine them in such a way -so as to preserve their order. Since a and b come presorted (as mentioned -above), we can just merge the two lists together in linear time. - -> append (PieceMapEnd a) (PieceMapEnd b) = PieceMapEnd $ merge a b - -Combine the dynamic and static portions of the maps. - -> append (PieceMap a x) (PieceMap b y) = -> PieceMap (append a b) (Map.unionWith append x y) - -An impossible case. - -> append _ _ = assert False $ PieceMapEnd [] - -Our O(n) merge. - -> merge :: Ord a => [(a, b)] -> [(a, b)] -> [(a, b)] -> merge x [] = x -> merge [] y = y -> merge x@(a@(ai, _):xs) y@(b@(bi, _):ys) -> | ai < bi = a : merge xs y -> | otherwise = b : merge x ys diff --git a/yesod-routes/Yesod/Routes/TH/ParseRoute.hs b/yesod-routes/Yesod/Routes/TH/ParseRoute.hs index 785f81ad..b1e6d55a 100644 --- a/yesod-routes/Yesod/Routes/TH/ParseRoute.hs +++ b/yesod-routes/Yesod/Routes/TH/ParseRoute.hs @@ -6,16 +6,17 @@ module Yesod.Routes.TH.ParseRoute import Yesod.Routes.TH.Types import Language.Haskell.TH.Syntax -import Data.Text (pack) +import Data.Text (Text, pack) import Web.PathPieces (PathPiece (..), PathMultiPiece (..)) import Yesod.Routes.Class -import qualified Yesod.Routes.Dispatch as D +import Yesod.Routes.TH.Dispatch import Data.List (foldl') import Control.Applicative ((<$>)) import Data.Maybe (catMaybes) import Control.Monad (forM) import Control.Monad (join) +{- FIXME -- | Clauses for the 'parseRoute' method. mkParseRouteClauses :: [ResourceTree a] -> Q [Clause] mkParseRouteClauses ress' = do @@ -46,13 +47,31 @@ mkParseRouteClauses ress' = do noMethods (FlatResource a b c d e) = FlatResource a b c (noMethods' d) e noMethods' (Methods a _) = Methods a [] noMethods' (Subsite a b) = Subsite a b +-} mkParseRouteInstance :: Type -> [ResourceTree a] -> Q Dec mkParseRouteInstance typ ress = do - cls <- mkParseRouteClauses ress + cls <- mkDispatchClause + MkDispatchSettings + { mdsRunHandler = [|\_ _ x _ -> x|] + , mds404 = [|error "mds404"|] + , mds405 = [|error "mds405"|] + , mdsGetPathInfo = [|fst|] + , mdsMethod = [|const ("GET" :: Text)|] -- FIXME wouldn't it be nice to get rid of method dispatching here + , mdsGetHandler = \_ _ -> [|error "mdsGetHandler"|] + , mdsSetPathInfo = [|\p (_, q) -> (p, q)|] + , mdsSubDispatcher = [|\_runHandler _getSub toMaster _env (p, q) -> fmap toMaster (parseRoute (p :: [Text], q :: [(Text, Text)]))|] + } + ress + helper <- newName "helper" + fixer <- [|(\f x -> f () x) :: (() -> ([Text], [(Text, Text)]) -> Maybe (Route a)) -> ([Text], [(Text, Text)]) -> Maybe (Route a)|] return $ InstanceD [] (ConT ''ParseRoute `AppT` typ) - [ FunD 'parseRoute cls + [ FunD 'parseRoute $ return $ Clause + [] + (NormalB $ fixer `AppE` VarE helper) + [FunD helper [cls]] ] + {- FIXME -- | Build a single 'D.Route' expression. buildRoute :: Name -> FlatResource a -> Q Exp @@ -176,3 +195,4 @@ routeFromDynamics ((parent, pieces):rest) name ys = isDynamic Dynamic{} = True isDynamic _ = False here = map VarE here' ++ [routeFromDynamics rest name ys'] +-} diff --git a/yesod-routes/test/Hierarchy.hs b/yesod-routes/test/Hierarchy.hs index c19935b7..2f8e64fd 100644 --- a/yesod-routes/test/Hierarchy.hs +++ b/yesod-routes/test/Hierarchy.hs @@ -7,6 +7,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -ddump-splices #-} module Hierarchy ( hierarchy , Dispatcher (..) diff --git a/yesod-routes/test/main.hs b/yesod-routes/test/main.hs index 7e2a031d..1d940ac3 100644 --- a/yesod-routes/test/main.hs +++ b/yesod-routes/test/main.hs @@ -15,10 +15,8 @@ import Test.Hspec import Test.HUnit ((@?=)) import Data.Text (Text, pack, unpack, singleton) -import Yesod.Routes.Dispatch hiding (Static, Dynamic) import Yesod.Routes.Class hiding (Route) import qualified Yesod.Routes.Class as YRC -import qualified Yesod.Routes.Dispatch as D import Yesod.Routes.Parse (parseRoutesNoCheck, parseTypeTree, TypeTree (..)) import Yesod.Routes.Overlap (findOverlapNames) import Yesod.Routes.TH hiding (Dispatch) @@ -27,48 +25,6 @@ import Hierarchy import qualified Data.ByteString.Char8 as S8 import qualified Data.Set as Set -result :: ([Text] -> Maybe Int) -> Dispatch Int -result f ts = f ts - -justRoot :: Dispatch Int -justRoot = toDispatch - [ Route [] False $ result $ const $ Just 1 - ] - -twoStatics :: Dispatch Int -twoStatics = toDispatch - [ Route [D.Static $ pack "foo"] False $ result $ const $ Just 2 - , Route [D.Static $ pack "bar"] False $ result $ const $ Just 3 - ] - -multi :: Dispatch Int -multi = toDispatch - [ Route [D.Static $ pack "foo"] False $ result $ const $ Just 4 - , Route [D.Static $ pack "bar"] True $ result $ const $ Just 5 - ] - -dynamic :: Dispatch Int -dynamic = toDispatch - [ Route [D.Static $ pack "foo"] False $ result $ const $ Just 6 - , Route [D.Dynamic] False $ result $ \ts -> - case ts of - [t] -> - case reads $ unpack t of - [] -> Nothing - (i, _):_ -> Just i - _ -> error $ "Called dynamic with: " ++ show ts - ] - -overlap :: Dispatch Int -overlap = toDispatch - [ Route [D.Static $ pack "foo"] False $ result $ const $ Just 20 - , Route [D.Static $ pack "foo"] True $ result $ const $ Just 21 - , Route [] True $ result $ const $ Just 22 - ] - -test :: Dispatch Int -> [String] -> Maybe Int -test dispatch ts = dispatch $ map pack ts - data MyApp = MyApp data MySub = MySub @@ -235,33 +191,6 @@ thDispatchAlias master sub toMaster app404 handler405 method0 pieces0 = main :: IO () main = hspec $ do - describe "justRoot" $ do - it "dispatches correctly" $ test justRoot [] @?= Just 1 - it "fails correctly" $ test justRoot ["foo"] @?= Nothing - describe "twoStatics" $ do - it "dispatches correctly to foo" $ test twoStatics ["foo"] @?= Just 2 - it "dispatches correctly to bar" $ test twoStatics ["bar"] @?= Just 3 - it "fails correctly (1)" $ test twoStatics [] @?= Nothing - it "fails correctly (2)" $ test twoStatics ["bar", "baz"] @?= Nothing - describe "multi" $ do - it "dispatches correctly to foo" $ test multi ["foo"] @?= Just 4 - it "dispatches correctly to bar" $ test multi ["bar"] @?= Just 5 - it "dispatches correctly to bar/baz" $ test multi ["bar", "baz"] @?= Just 5 - it "fails correctly (1)" $ test multi [] @?= Nothing - it "fails correctly (2)" $ test multi ["foo", "baz"] @?= Nothing - describe "dynamic" $ do - it "dispatches correctly to foo" $ test dynamic ["foo"] @?= Just 6 - it "dispatches correctly to 7" $ test dynamic ["7"] @?= Just 7 - it "dispatches correctly to 42" $ test dynamic ["42"] @?= Just 42 - it "fails correctly on five" $ test dynamic ["five"] @?= Nothing - it "fails correctly on too many" $ test dynamic ["foo", "baz"] @?= Nothing - it "fails correctly on too few" $ test dynamic [] @?= Nothing - describe "overlap" $ do - it "dispatches correctly to foo" $ test overlap ["foo"] @?= Just 20 - it "dispatches correctly to foo/bar" $ test overlap ["foo", "bar"] @?= Just 21 - it "dispatches correctly to bar" $ test overlap ["bar"] @?= Just 22 - it "dispatches correctly to []" $ test overlap [] @?= Just 22 - describe "RenderRoute instance" $ do it "renders root correctly" $ renderRoute RootR @?= ([], []) it "renders blog post correctly" $ renderRoute (BlogPostR $ pack "foo") @?= (map pack ["blog", "foo"], []) diff --git a/yesod-routes/yesod-routes.cabal b/yesod-routes/yesod-routes.cabal index 5d0ae04f..2beac5c3 100644 --- a/yesod-routes/yesod-routes.cabal +++ b/yesod-routes/yesod-routes.cabal @@ -24,8 +24,7 @@ library , bytestring , random - exposed-modules: Yesod.Routes.Dispatch - Yesod.Routes.TH + exposed-modules: Yesod.Routes.TH Yesod.Routes.Class Yesod.Routes.Parse Yesod.Routes.Overlap