From e23c78f2ce60591574a177de9f3ce5d634384e4a Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 23 Jul 2014 12:38:29 +0300 Subject: [PATCH] Better overlap rules #779 We now have the concept that either an entire route is overlap checked or not. This is essentially what we had before, except there was code littered everywhere on the mistaken assumption that just one component could be overlap checked. This also allows us to mark parent routes or multipiece components as non-overlapped checked. In addition, if you put a bang at the beginning of the pattern, the entire route is not overlap checked. The previous syntax is kept for backwards compatibility. --- yesod-routes/Yesod/Routes/Overlap.hs | 44 +++++--------------- yesod-routes/Yesod/Routes/Parse.hs | 37 +++++++++++++---- yesod-routes/Yesod/Routes/TH/Dispatch.hs | 22 +++++----- yesod-routes/Yesod/Routes/TH/ParseRoute.hs | 16 ++++---- yesod-routes/Yesod/Routes/TH/RenderRoute.hs | 16 ++++---- yesod-routes/Yesod/Routes/TH/RouteAttrs.hs | 4 +- yesod-routes/Yesod/Routes/TH/Simple.hs | 12 +++--- yesod-routes/Yesod/Routes/TH/Types.hs | 45 +++++++++++---------- yesod-routes/test/main.hs | 41 ++++++++++++++----- 9 files changed, 131 insertions(+), 106 deletions(-) diff --git a/yesod-routes/Yesod/Routes/Overlap.hs b/yesod-routes/Yesod/Routes/Overlap.hs index dbd3f3e0..52ab9c97 100644 --- a/yesod-routes/Yesod/Routes/Overlap.hs +++ b/yesod-routes/Yesod/Routes/Overlap.hs @@ -1,7 +1,6 @@ -- | Check for overlapping routes. module Yesod.Routes.Overlap - ( findOverlaps - , findOverlapNames + ( findOverlapNames , Overlap (..) ) where @@ -10,21 +9,23 @@ import Data.List (intercalate) data Flattened t = Flattened { fNames :: [String] - , fPieces :: [(CheckOverlap, Piece t)] + , fPieces :: [Piece t] , fHasSuffix :: Bool + , fCheck :: CheckOverlap } flatten :: ResourceTree t -> [Flattened t] flatten = - go id id + go id id True where - go names pieces (ResourceLeaf r) = return Flattened + go names pieces check (ResourceLeaf r) = return Flattened { fNames = names [resourceName r] , fPieces = pieces (resourcePieces r) , fHasSuffix = hasSuffix $ ResourceLeaf r + , fCheck = check && resourceCheck r } - go names pieces (ResourceParent newname newpieces children) = - concatMap (go names' pieces') children + go names pieces check (ResourceParent newname check' newpieces children) = + concatMap (go names' pieces' (check && check')) children where names' = names . (newname:) pieces' = pieces . (newpieces ++) @@ -40,24 +41,7 @@ data OverlapF = OverlapF , overlapF2 :: [String] } -findOverlaps :: ([String] -> [String]) -> [ResourceTree t] -> [Overlap t] -findOverlaps _ [] = [] -findOverlaps front (x:xs) = concatMap (findOverlap front x) xs ++ findOverlaps front xs -{-# DEPRECATED findOverlaps "This function is no longer used" #-} - -findOverlap :: ([String] -> [String]) -> ResourceTree t -> ResourceTree t -> [Overlap t] -findOverlap front x y = - here rest - where - here - | overlaps (resourceTreePieces x) (resourceTreePieces y) (hasSuffix x) (hasSuffix y) = (Overlap front x y:) - | otherwise = id - rest = - case x of - ResourceParent name _ children -> findOverlaps (front . (name:)) children - ResourceLeaf{} -> [] - -overlaps :: [(CheckOverlap, Piece t)] -> [(CheckOverlap, Piece t)] -> Bool -> Bool -> Bool +overlaps :: [Piece t] -> [Piece t] -> Bool -> Bool -> Bool -- No pieces on either side, will overlap regardless of suffix overlaps [] [] _ _ = True @@ -68,14 +52,8 @@ overlaps [] _ suffixX _ = suffixX -- Ditto for the right overlaps _ [] _ suffixY = suffixY --- As soon as we ignore a single piece (via CheckOverlap == False), we say that --- the routes don't overlap at all. In other words, disabling overlap checking --- on a single piece disables it on the whole route. -overlaps ((False, _):_) _ _ _ = False -overlaps _ ((False, _):_) _ _ = False - -- Compare the actual pieces -overlaps ((True, pieceX):xs) ((True, pieceY):ys) suffixX suffixY = +overlaps (pieceX:xs) (pieceY:ys) suffixX suffixY = piecesOverlap pieceX pieceY && overlaps xs ys suffixX suffixY piecesOverlap :: Piece t -> Piece t -> Bool @@ -85,7 +63,7 @@ piecesOverlap _ _ = True findOverlapNames :: [ResourceTree t] -> [(String, String)] findOverlapNames = - map go . findOverlapsF . concatMap Yesod.Routes.Overlap.flatten + map go . findOverlapsF . filter fCheck . concatMap Yesod.Routes.Overlap.flatten where go (OverlapF x y) = (go' x, go' y) diff --git a/yesod-routes/Yesod/Routes/Parse.hs b/yesod-routes/Yesod/Routes/Parse.hs index 361ec8a5..482111e0 100644 --- a/yesod-routes/Yesod/Routes/Parse.hs +++ b/yesod-routes/Yesod/Routes/Parse.hs @@ -73,16 +73,29 @@ resourcesFromString = case takeWhile (/= "--") $ words thisLine of [pattern, constr] | last constr == ':' -> let (children, otherLines'') = parse (length spaces + 1) otherLines - (pieces, Nothing) = piecesFromString $ drop1Slash pattern - in ((ResourceParent (init constr) pieces children :), otherLines'') + (pieces, Nothing, check) = piecesFromStringCheck pattern + in ((ResourceParent (init constr) check pieces children :), otherLines'') (pattern:constr:rest) -> - let (pieces, mmulti) = piecesFromString $ drop1Slash pattern + let (pieces, mmulti, check) = piecesFromStringCheck pattern (attrs, rest') = takeAttrs rest disp = dispatchFromString rest' mmulti - in ((ResourceLeaf (Resource constr pieces disp attrs):), otherLines) + in ((ResourceLeaf (Resource constr pieces disp attrs check):), otherLines) [] -> (id, otherLines) _ -> error $ "Invalid resource line: " ++ thisLine +piecesFromStringCheck :: String -> ([Piece String], Maybe String, Bool) +piecesFromStringCheck s0 = + (pieces, mmulti, check) + where + (s1, check1) = stripBang s0 + (pieces', mmulti') = piecesFromString $ drop1Slash s1 + pieces = map snd pieces' + mmulti = fmap snd mmulti' + check = check1 && all fst pieces' && maybe True fst mmulti' + + stripBang ('!':rest) = (rest, False) + stripBang x = (x, True) + -- | Take attributes out of the list and put them in the first slot in the -- result tuple. takeAttrs :: [String] -> ([String], [String]) @@ -107,7 +120,7 @@ drop1Slash :: String -> String drop1Slash ('/':x) = x drop1Slash x = x -piecesFromString :: String -> ([(CheckOverlap, Piece String)], Maybe String) +piecesFromString :: String -> ([(CheckOverlap, Piece String)], Maybe (CheckOverlap, String)) piecesFromString "" = ([], Nothing) piecesFromString x = case (this, rest) of @@ -182,11 +195,19 @@ ttToType (TTTerm s) = ConT $ mkName s ttToType (TTApp x y) = ttToType x `AppT` ttToType y ttToType (TTList t) = ListT `AppT` ttToType t -pieceFromString :: String -> Either String (CheckOverlap, Piece String) +pieceFromString :: String -> Either (CheckOverlap, String) (CheckOverlap, Piece String) pieceFromString ('#':'!':x) = Right $ (False, Dynamic x) pieceFromString ('!':'#':x) = Right $ (False, Dynamic x) -- https://github.com/yesodweb/yesod/issues/652 pieceFromString ('#':x) = Right $ (True, Dynamic x) -pieceFromString ('*':x) = Left x -pieceFromString ('+':x) = Left x + +pieceFromString ('*':'!':x) = Left (False, x) +pieceFromString ('+':'!':x) = Left (False, x) + +pieceFromString ('!':'*':x) = Left (False, x) +pieceFromString ('!':'+':x) = Left (False, x) + +pieceFromString ('*':x) = Left (True, x) +pieceFromString ('+':x) = Left (True, x) + pieceFromString ('!':x) = Right $ (False, Static x) pieceFromString x = Right $ (True, Static x) diff --git a/yesod-routes/Yesod/Routes/TH/Dispatch.hs b/yesod-routes/Yesod/Routes/TH/Dispatch.hs index 9770875a..93dde40b 100644 --- a/yesod-routes/Yesod/Routes/TH/Dispatch.hs +++ b/yesod-routes/Yesod/Routes/TH/Dispatch.hs @@ -157,8 +157,8 @@ methodMapName s = mkName $ "methods" ++ s buildMethodMap :: MkDispatchSettings -> FlatResource a -> Q (Maybe Dec) -buildMethodMap _ (FlatResource _ _ _ (Methods _ [])) = return Nothing -- single handle function -buildMethodMap mds (FlatResource parents name pieces' (Methods mmulti methods)) = do +buildMethodMap _ (FlatResource _ _ _ (Methods _ []) _) = return Nothing -- single handle function +buildMethodMap mds (FlatResource parents name pieces' (Methods mmulti methods) _check) = do fromList <- [|Map.fromList|] methods' <- mapM go methods let exp = fromList `AppE` ListE methods' @@ -171,7 +171,7 @@ buildMethodMap mds (FlatResource parents name pieces' (Methods mmulti methods)) pack' <- [|encodeUtf8 . pack|] let isDynamic Dynamic{} = True isDynamic _ = False - let argCount = length (filter (isDynamic . snd) pieces) + maybe 0 (const 1) mmulti + let argCount = length (filter isDynamic pieces) + maybe 0 (const 1) mmulti xs <- replicateM argCount $ newName "arg" runHandler <- mdsRunHandler mds let rhs @@ -183,13 +183,13 @@ buildMethodMap mds (FlatResource parents name pieces' (Methods mmulti methods)) [ pack' `AppE` LitE (StringL method) , rhs ] -buildMethodMap _ (FlatResource _ _ _ Subsite{}) = return Nothing +buildMethodMap _ (FlatResource _ _ _ Subsite{} _check) = return Nothing -- | Build a single 'D.Route' expression. buildRoute :: MkDispatchSettings -> FlatResource a -> Q Exp -buildRoute mds (FlatResource parents name resPieces resDisp) = do +buildRoute mds (FlatResource parents name resPieces resDisp _) = do -- First two arguments to D.Route - routePieces <- ListE <$> mapM (convertPiece . snd) allPieces + routePieces <- ListE <$> mapM convertPiece allPieces isMulti <- case resDisp of Methods Nothing _ -> [|False|] @@ -202,14 +202,14 @@ buildRoute mds (FlatResource parents name resPieces resDisp) = do mds parents name - (map snd allPieces) + allPieces resDisp) |] where allPieces = concat $ map snd parents ++ [resPieces] routeArg3 :: MkDispatchSettings - -> [(String, [(CheckOverlap, Piece a)])] + -> [(String, [Piece a])] -> String -- ^ name of resource -> [Piece a] -> Dispatch a @@ -277,7 +277,7 @@ routeArg3 mds parents name resPieces resDisp = do -- | The final expression in the individual Route definitions. buildCaller :: MkDispatchSettings -> Name -- ^ xrest - -> [(String, [(CheckOverlap, Piece a)])] + -> [(String, [Piece a])] -> String -- ^ name of resource -> Dispatch a -> [Name] -- ^ ys @@ -356,7 +356,7 @@ convertPiece :: Piece a -> Q Exp convertPiece (Static s) = [|D.Static (pack $(lift s))|] convertPiece (Dynamic _) = [|D.Dynamic|] -routeFromDynamics :: [(String, [(CheckOverlap, Piece a)])] -- ^ parents +routeFromDynamics :: [(String, [Piece a])] -- ^ parents -> String -- ^ constructor name -> [Name] -> Exp @@ -364,7 +364,7 @@ routeFromDynamics [] name ys = foldl' (\a b -> a `AppE` VarE b) (ConE $ mkName n routeFromDynamics ((parent, pieces):rest) name ys = foldl' (\a b -> a `AppE` b) (ConE $ mkName parent) here where - (here', ys') = splitAt (length $ filter (isDynamic . snd) pieces) ys + (here', ys') = splitAt (length $ filter isDynamic pieces) ys isDynamic Dynamic{} = True isDynamic _ = False here = map VarE here' ++ [routeFromDynamics rest name ys'] diff --git a/yesod-routes/Yesod/Routes/TH/ParseRoute.hs b/yesod-routes/Yesod/Routes/TH/ParseRoute.hs index b61037ba..785f81ad 100644 --- a/yesod-routes/Yesod/Routes/TH/ParseRoute.hs +++ b/yesod-routes/Yesod/Routes/TH/ParseRoute.hs @@ -43,7 +43,7 @@ mkParseRouteClauses ress' = do [dispatchFun] where ress = map noMethods $ flatten ress' - noMethods (FlatResource a b c d) = FlatResource a b c $ noMethods' d + 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 @@ -56,9 +56,9 @@ mkParseRouteInstance typ ress = do -- | Build a single 'D.Route' expression. buildRoute :: Name -> FlatResource a -> Q Exp -buildRoute query (FlatResource parents name resPieces resDisp) = do +buildRoute query (FlatResource parents name resPieces resDisp _check) = do -- First two arguments to D.Route - routePieces <- ListE <$> mapM (convertPiece . snd) allPieces + routePieces <- ListE <$> mapM convertPiece allPieces isMulti <- case resDisp of Methods Nothing _ -> [|False|] @@ -71,14 +71,14 @@ buildRoute query (FlatResource parents name resPieces resDisp) = do query parents name - (map snd allPieces) + allPieces resDisp) |] where allPieces = concat $ map snd parents ++ [resPieces] routeArg3 :: Name -- ^ query string parameters - -> [(String, [(CheckOverlap, Piece a)])] + -> [(String, [Piece a])] -> String -- ^ name of resource -> [Piece a] -> Dispatch a @@ -146,7 +146,7 @@ routeArg3 query parents name resPieces resDisp = do -- | The final expression in the individual Route definitions. buildCaller :: Name -- ^ query string parameters -> Name -- ^ xrest - -> [(String, [(CheckOverlap, Piece a)])] + -> [(String, [Piece a])] -> String -- ^ name of resource -> Dispatch a -> [Name] -- ^ ys @@ -164,7 +164,7 @@ convertPiece :: Piece a -> Q Exp convertPiece (Static s) = [|D.Static (pack $(lift s))|] convertPiece (Dynamic _) = [|D.Dynamic|] -routeFromDynamics :: [(String, [(CheckOverlap, Piece a)])] -- ^ parents +routeFromDynamics :: [(String, [Piece a])] -- ^ parents -> String -- ^ constructor name -> [Name] -> Exp @@ -172,7 +172,7 @@ routeFromDynamics [] name ys = foldl' (\a b -> a `AppE` VarE b) (ConE $ mkName n routeFromDynamics ((parent, pieces):rest) name ys = foldl' (\a b -> a `AppE` b) (ConE $ mkName parent) here where - (here', ys') = splitAt (length $ filter (isDynamic . snd) pieces) ys + (here', ys') = splitAt (length $ filter isDynamic pieces) ys isDynamic Dynamic{} = True isDynamic _ = False here = map VarE here' ++ [routeFromDynamics rest name ys'] diff --git a/yesod-routes/Yesod/Routes/TH/RenderRoute.hs b/yesod-routes/Yesod/Routes/TH/RenderRoute.hs index b45b1b3a..1d715720 100644 --- a/yesod-routes/Yesod/Routes/TH/RenderRoute.hs +++ b/yesod-routes/Yesod/Routes/TH/RenderRoute.hs @@ -27,7 +27,7 @@ mkRouteCons = con = NormalC (mkName $ resourceName res) $ map (\x -> (NotStrict, x)) $ concat [singles, multi, sub] - singles = concatMap (toSingle . snd) $ resourcePieces res + singles = concatMap toSingle $ resourcePieces res toSingle Static{} = [] toSingle (Dynamic typ) = [typ] @@ -37,7 +37,7 @@ mkRouteCons = case resourceDispatch res of Subsite { subsiteType = typ } -> [ConT ''Route `AppT` typ] _ -> [] - mkRouteCon (ResourceParent name pieces children) = + mkRouteCon (ResourceParent name _check pieces children) = ([con], dec : decs) where (cons, decs) = mkRouteCons children @@ -46,7 +46,7 @@ mkRouteCons = $ concat [singles, [ConT $ mkName name]] dec = DataD [] (mkName name) [] cons [''Show, ''Read, ''Eq] - singles = concatMap (toSingle . snd) pieces + singles = concatMap toSingle pieces toSingle Static{} = [] toSingle (Dynamic typ) = [typ] @@ -58,15 +58,15 @@ mkRenderRouteClauses = isDynamic Dynamic{} = True isDynamic _ = False - go (ResourceParent name pieces children) = do - let cnt = length $ filter (isDynamic . snd) pieces + go (ResourceParent name _check pieces children) = do + let cnt = length $ filter isDynamic pieces dyns <- replicateM cnt $ newName "dyn" child <- newName "child" let pat = ConP (mkName name) $ map VarP $ dyns ++ [child] pack' <- [|pack|] tsp <- [|toPathPiece|] - let piecesSingle = mkPieces (AppE pack' . LitE . StringL) tsp (map snd pieces) dyns + let piecesSingle = mkPieces (AppE pack' . LitE . StringL) tsp pieces dyns childRender <- newName "childRender" let rr = VarE childRender @@ -84,7 +84,7 @@ mkRenderRouteClauses = return $ Clause [pat] (NormalB body) [FunD childRender childClauses] go (ResourceLeaf res) = do - let cnt = length (filter (isDynamic . snd) $ resourcePieces res) + maybe 0 (const 1) (resourceMulti res) + let cnt = length (filter isDynamic $ resourcePieces res) + maybe 0 (const 1) (resourceMulti res) dyns <- replicateM cnt $ newName "dyn" sub <- case resourceDispatch res of @@ -94,7 +94,7 @@ mkRenderRouteClauses = pack' <- [|pack|] tsp <- [|toPathPiece|] - let piecesSingle = mkPieces (AppE pack' . LitE . StringL) tsp (map snd $ resourcePieces res) dyns + let piecesSingle = mkPieces (AppE pack' . LitE . StringL) tsp (resourcePieces res) dyns piecesMulti <- case resourceMulti res of diff --git a/yesod-routes/Yesod/Routes/TH/RouteAttrs.hs b/yesod-routes/Yesod/Routes/TH/RouteAttrs.hs index 539e038c..c0022e4e 100644 --- a/yesod-routes/Yesod/Routes/TH/RouteAttrs.hs +++ b/yesod-routes/Yesod/Routes/TH/RouteAttrs.hs @@ -19,11 +19,11 @@ mkRouteAttrsInstance typ ress = do goTree :: (Pat -> Pat) -> ResourceTree a -> Q [Clause] goTree front (ResourceLeaf res) = fmap return $ goRes front res -goTree front (ResourceParent name pieces trees) = +goTree front (ResourceParent name _check pieces trees) = fmap concat $ mapM (goTree front') trees where ignored = ((replicate toIgnore WildP ++) . return) - toIgnore = length $ filter (isDynamic . snd) pieces + toIgnore = length $ filter isDynamic pieces isDynamic Dynamic{} = True isDynamic Static{} = False front' = front . ConP (mkName name) . ignored diff --git a/yesod-routes/Yesod/Routes/TH/Simple.hs b/yesod-routes/Yesod/Routes/TH/Simple.hs index 88f4b9f8..62ba97b4 100644 --- a/yesod-routes/Yesod/Routes/TH/Simple.hs +++ b/yesod-routes/Yesod/Routes/TH/Simple.hs @@ -52,14 +52,14 @@ mkSimpleDispatchClause MkDispatchSettings {..} resources = do (NormalB $ helperE `AppE` pathInfo) [FunD helperName $ clauses ++ [clause404']] where - handlePiece :: (CheckOverlap, Piece a) -> Q (Pat, Maybe Exp) - handlePiece (_, Static str) = return (LitP $ StringL str, Nothing) - handlePiece (_, Dynamic _) = do + handlePiece :: Piece a -> Q (Pat, Maybe Exp) + handlePiece (Static str) = return (LitP $ StringL str, Nothing) + handlePiece (Dynamic _) = do x <- newName "dyn" let pat = ViewP (VarE 'fromPathPiece) (ConP 'Just [VarP x]) return (pat, Just $ VarE x) - handlePieces :: [(CheckOverlap, Piece a)] -> Q ([Pat], [Exp]) + handlePieces :: [Piece a] -> Q ([Pat], [Exp]) handlePieces = fmap (second catMaybes . unzip) . mapM handlePiece mkCon :: String -> [Exp] -> Exp @@ -72,7 +72,7 @@ mkSimpleDispatchClause MkDispatchSettings {..} resources = do addPat x y = ConP '(:) [x, y] go :: SDC -> ResourceTree a -> Q Clause - go sdc (ResourceParent name pieces children) = do + go sdc (ResourceParent name _check pieces children) = do (pats, dyns) <- handlePieces pieces let sdc' = sdc { extraParams = extraParams sdc ++ dyns @@ -91,7 +91,7 @@ mkSimpleDispatchClause MkDispatchSettings {..} resources = do [mkPathPat restP pats] (NormalB $ helperE `AppE` restE) [FunD helperName $ childClauses ++ [clause404 sdc]] - go SDC {..} (ResourceLeaf (Resource name pieces dispatch _)) = do + go SDC {..} (ResourceLeaf (Resource name pieces dispatch _ _check)) = do (pats, dyns) <- handlePieces pieces (chooseMethod, finalPat) <- handleDispatch dispatch dyns diff --git a/yesod-routes/Yesod/Routes/TH/Types.hs b/yesod-routes/Yesod/Routes/TH/Types.hs index d0a04052..e1133f76 100644 --- a/yesod-routes/Yesod/Routes/TH/Types.hs +++ b/yesod-routes/Yesod/Routes/TH/Types.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE TemplateHaskell #-} module Yesod.Routes.TH.Types ( -- * Data types @@ -15,41 +16,37 @@ module Yesod.Routes.TH.Types ) where import Language.Haskell.TH.Syntax -import Control.Arrow (second) -data ResourceTree typ = ResourceLeaf (Resource typ) | ResourceParent String [(CheckOverlap, Piece typ)] [ResourceTree typ] +data ResourceTree typ + = ResourceLeaf (Resource typ) + | ResourceParent String CheckOverlap [Piece typ] [ResourceTree typ] + deriving Functor -resourceTreePieces :: ResourceTree typ -> [(CheckOverlap, Piece typ)] +resourceTreePieces :: ResourceTree typ -> [Piece typ] resourceTreePieces (ResourceLeaf r) = resourcePieces r -resourceTreePieces (ResourceParent _ x _) = x +resourceTreePieces (ResourceParent _ _ x _) = x resourceTreeName :: ResourceTree typ -> String resourceTreeName (ResourceLeaf r) = resourceName r -resourceTreeName (ResourceParent x _ _) = x - -instance Functor ResourceTree where - fmap f (ResourceLeaf r) = ResourceLeaf (fmap f r) - fmap f (ResourceParent a b c) = ResourceParent a (map (second $ fmap f) b) $ map (fmap f) c +resourceTreeName (ResourceParent x _ _ _) = x instance Lift t => Lift (ResourceTree t) where lift (ResourceLeaf r) = [|ResourceLeaf $(lift r)|] - lift (ResourceParent a b c) = [|ResourceParent $(lift a) $(lift b) $(lift c)|] + lift (ResourceParent a b c d) = [|ResourceParent $(lift a) $(lift b) $(lift c) $(lift d)|] data Resource typ = Resource { resourceName :: String - , resourcePieces :: [(CheckOverlap, Piece typ)] + , resourcePieces :: [Piece typ] , resourceDispatch :: Dispatch typ , resourceAttrs :: [String] + , resourceCheck :: CheckOverlap } - deriving Show + deriving (Show, Functor) type CheckOverlap = Bool -instance Functor Resource where - fmap f (Resource a b c d) = Resource a (map (second $ fmap f) b) (fmap f c) d - instance Lift t => Lift (Resource t) where - lift (Resource a b c d) = [|Resource a b c d|] + lift (Resource a b c d e) = [|Resource a b c d e|] data Piece typ = Static String | Dynamic typ deriving Show @@ -86,12 +83,18 @@ resourceMulti :: Resource typ -> Maybe typ resourceMulti Resource { resourceDispatch = Methods (Just t) _ } = Just t resourceMulti _ = Nothing -data FlatResource a = FlatResource [(String, [(CheckOverlap, Piece a)])] String [(CheckOverlap, Piece a)] (Dispatch a) +data FlatResource a = FlatResource + { frParentPieces :: [(String, [Piece a])] + , frName :: String + , frPieces :: [Piece a] + , frDispatch :: Dispatch a + , frCheck :: Bool + } flatten :: [ResourceTree a] -> [FlatResource a] flatten = - concatMap (go id) + concatMap (go id True) where - go front (ResourceLeaf (Resource a b c _)) = [FlatResource (front []) a b c] - go front (ResourceParent name pieces children) = - concatMap (go (front . ((name, pieces):))) children + go front check' (ResourceLeaf (Resource a b c _ check)) = [FlatResource (front []) a b c (check' && check)] + go front check' (ResourceParent name check pieces children) = + concatMap (go (front . ((name, pieces):)) (check && check')) children diff --git a/yesod-routes/test/main.hs b/yesod-routes/test/main.hs index b51dd8fc..f782590e 100644 --- a/yesod-routes/test/main.hs +++ b/yesod-routes/test/main.hs @@ -112,21 +112,21 @@ getMySubParam _ = MySubParam do texts <- [t|[Text]|] let resLeaves = map ResourceLeaf - [ Resource "RootR" [] (Methods Nothing ["GET"]) ["foo", "bar"] - , Resource "BlogPostR" (addCheck [Static "blog", Dynamic $ ConT ''Text]) (Methods Nothing ["GET", "POST"]) [] - , Resource "WikiR" (addCheck [Static "wiki"]) (Methods (Just texts) []) [] - , Resource "SubsiteR" (addCheck [Static "subsite"]) (Subsite (ConT ''MySub) "getMySub") [] - , Resource "SubparamR" (addCheck [Static "subparam", Dynamic $ ConT ''Int]) (Subsite (ConT ''MySubParam) "getMySubParam") [] + [ Resource "RootR" [] (Methods Nothing ["GET"]) ["foo", "bar"] True + , Resource "BlogPostR" [Static "blog", Dynamic $ ConT ''Text] (Methods Nothing ["GET", "POST"]) [] True + , Resource "WikiR" [Static "wiki"] (Methods (Just texts) []) [] True + , Resource "SubsiteR" [Static "subsite"] (Subsite (ConT ''MySub) "getMySub") [] True + , Resource "SubparamR" [Static "subparam", Dynamic $ ConT ''Int] (Subsite (ConT ''MySubParam) "getMySubParam") [] True ] resParent = ResourceParent "ParentR" - [ (True, Static "foo") - , (True, Dynamic $ ConT ''Text) + True + [ Static "foo" + , Dynamic $ ConT ''Text ] - [ ResourceLeaf $ Resource "ChildR" [] (Methods Nothing ["GET"]) ["child"] + [ ResourceLeaf $ Resource "ChildR" [] (Methods Nothing ["GET"]) ["child"] True ] ress = resParent : resLeaves - addCheck = map ((,) True) rrinst <- mkRenderRouteInstance (ConT ''MyApp) ress rainst <- mkRouteAttrsInstance (ConT ''MyApp) ress prinst <- mkParseRouteInstance (ConT ''MyApp) ress @@ -347,6 +347,29 @@ main = hspec $ do /foo Foo1 /#!String Foo2 /!foo Foo3 +|] + findOverlapNames routes @?= [] + it "obeys multipiece ignore rules #779" $ do + let routes = [parseRoutesNoCheck| +/foo Foo1 +/+![String] Foo2 +|] + findOverlapNames routes @?= [] + it "ignore rules for entire route #779" $ do + let routes = [parseRoutesNoCheck| +/foo Foo1 +!/+[String] Foo2 +!/#String Foo3 +!/foo Foo4 +|] + findOverlapNames routes @?= [] + it "ignore rules for hierarchy" $ do + let routes = [parseRoutesNoCheck| +/+[String] Foo1 +!/foo Foo2: + /foo Foo3 +/foo Foo4: + /!#foo Foo5 |] findOverlapNames routes @?= [] it "proper boolean logic" $ do