haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Better overlap rules #779

Browse Source 
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.
This commit is contained in:
Michael Snoyman 2014-07-23 12:38:29 +03:00
parent 21d1965774
commit e23c78f2ce
9 changed files with 131 additions and 106 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

44
yesod-routes/Yesod/Routes/Overlap.hs
View File

@ -1,7 +1,6 @@
-- | Check for overlapping routes. -- | Check for overlapping routes.
module Yesod.Routes.Overlap module Yesod.Routes.Overlap
( findOverlaps ( findOverlapNames
, findOverlapNames
, Overlap (..) , Overlap (..)
) where ) where
@ -10,21 +9,23 @@ import Data.List (intercalate)
data Flattened t = Flattened data Flattened t = Flattened
{ fNames :: [String] { fNames :: [String]
, fPieces :: [(CheckOverlap, Piece t)] , fPieces :: [Piece t]
, fHasSuffix :: Bool , fHasSuffix :: Bool
, fCheck :: CheckOverlap
} }
flatten :: ResourceTree t -> [Flattened t] flatten :: ResourceTree t -> [Flattened t]
flatten = flatten =
go id id go id id True
where where
go names pieces (ResourceLeaf r) = return Flattened go names pieces check (ResourceLeaf r) = return Flattened
{ fNames = names [resourceName r] { fNames = names [resourceName r]
, fPieces = pieces (resourcePieces r) , fPieces = pieces (resourcePieces r)
, fHasSuffix = hasSuffix $ ResourceLeaf r , fHasSuffix = hasSuffix $ ResourceLeaf r
, fCheck = check && resourceCheck r
} }
go names pieces (ResourceParent newname newpieces children) = go names pieces check (ResourceParent newname check' newpieces children) =
concatMap (go names' pieces') children concatMap (go names' pieces' (check && check')) children
where where
names' = names . (newname:) names' = names . (newname:)
pieces' = pieces . (newpieces ++) pieces' = pieces . (newpieces ++)
@ -40,24 +41,7 @@ data OverlapF = OverlapF
, overlapF2 :: [String] , overlapF2 :: [String]
} }
findOverlaps :: ([String] -> [String]) -> [ResourceTree t] -> [Overlap t] overlaps :: [Piece t] -> [Piece t] -> Bool -> Bool -> Bool
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
-- No pieces on either side, will overlap regardless of suffix -- No pieces on either side, will overlap regardless of suffix
overlaps [] [] _ _ = True overlaps [] [] _ _ = True
@ -68,14 +52,8 @@ overlaps [] _ suffixX _ = suffixX
-- Ditto for the right -- Ditto for the right
overlaps _ [] _ suffixY = suffixY 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 -- 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 pieceX pieceY && overlaps xs ys suffixX suffixY
piecesOverlap :: Piece t -> Piece t -> Bool piecesOverlap :: Piece t -> Piece t -> Bool
@ -85,7 +63,7 @@ piecesOverlap _ _ = True
findOverlapNames :: [ResourceTree t] -> [(String, String)] findOverlapNames :: [ResourceTree t] -> [(String, String)]
findOverlapNames = findOverlapNames =
map go . findOverlapsF . concatMap Yesod.Routes.Overlap.flatten map go . findOverlapsF . filter fCheck . concatMap Yesod.Routes.Overlap.flatten
where where
go (OverlapF x y) = go (OverlapF x y) =
(go' x, go' y) (go' x, go' y)

37
yesod-routes/Yesod/Routes/Parse.hs
View File

@ -73,16 +73,29 @@ resourcesFromString =
case takeWhile (/= "--") $ words thisLine of case takeWhile (/= "--") $ words thisLine of
[pattern, constr] | last constr == ':' -> [pattern, constr] | last constr == ':' ->
let (children, otherLines'') = parse (length spaces + 1) otherLines let (children, otherLines'') = parse (length spaces + 1) otherLines
(pieces, Nothing) = piecesFromString $ drop1Slash pattern (pieces, Nothing, check) = piecesFromStringCheck pattern
in ((ResourceParent (init constr) pieces children :), otherLines'') in ((ResourceParent (init constr) check pieces children :), otherLines'')
(pattern:constr:rest) -> (pattern:constr:rest) ->
let (pieces, mmulti) = piecesFromString $ drop1Slash pattern let (pieces, mmulti, check) = piecesFromStringCheck pattern
(attrs, rest') = takeAttrs rest (attrs, rest') = takeAttrs rest
disp = dispatchFromString rest' mmulti disp = dispatchFromString rest' mmulti
in ((ResourceLeaf (Resource constr pieces disp attrs):), otherLines) in ((ResourceLeaf (Resource constr pieces disp attrs check):), otherLines)
[] -> (id, otherLines) [] -> (id, otherLines)
_ -> error $ "Invalid resource line: " ++ thisLine _ -> 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 -- | Take attributes out of the list and put them in the first slot in the
-- result tuple. -- result tuple.
takeAttrs :: [String] -> ([String], [String]) takeAttrs :: [String] -> ([String], [String])
@ -107,7 +120,7 @@ drop1Slash :: String -> String
drop1Slash ('/':x) = x drop1Slash ('/':x) = x
drop1Slash x = x drop1Slash x = x
piecesFromString :: String -> ([(CheckOverlap, Piece String)], Maybe String) piecesFromString :: String -> ([(CheckOverlap, Piece String)], Maybe (CheckOverlap, String))
piecesFromString "" = ([], Nothing) piecesFromString "" = ([], Nothing)
piecesFromString x = piecesFromString x =
case (this, rest) of case (this, rest) of
@ -182,11 +195,19 @@ ttToType (TTTerm s) = ConT $ mkName s
ttToType (TTApp x y) = ttToType x `AppT` ttToType y ttToType (TTApp x y) = ttToType x `AppT` ttToType y
ttToType (TTList t) = ListT `AppT` ttToType t 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)
pieceFromString ('!':'#':x) = Right $ (False, Dynamic x) -- https://github.com/yesodweb/yesod/issues/652 pieceFromString ('!':'#':x) = Right $ (False, Dynamic x) -- https://github.com/yesodweb/yesod/issues/652
pieceFromString ('#':x) = Right $ (True, Dynamic x) 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 $ (False, Static x)
pieceFromString x = Right $ (True, Static x) pieceFromString x = Right $ (True, Static x)

22
yesod-routes/Yesod/Routes/TH/Dispatch.hs
View File

@ -157,8 +157,8 @@ methodMapName s = mkName $ "methods" ++ s
buildMethodMap :: MkDispatchSettings buildMethodMap :: MkDispatchSettings
-> FlatResource a -> FlatResource a
-> Q (Maybe Dec) -> Q (Maybe Dec)
buildMethodMap _ (FlatResource _ _ _ (Methods _ [])) = return Nothing -- single handle function buildMethodMap _ (FlatResource _ _ _ (Methods _ []) _) = return Nothing -- single handle function
buildMethodMap mds (FlatResource parents name pieces' (Methods mmulti methods)) = do buildMethodMap mds (FlatResource parents name pieces' (Methods mmulti methods) _check) = do
fromList <- [|Map.fromList|] fromList <- [|Map.fromList|]
methods' <- mapM go methods methods' <- mapM go methods
let exp = fromList `AppE` ListE methods' let exp = fromList `AppE` ListE methods'
@ -171,7 +171,7 @@ buildMethodMap mds (FlatResource parents name pieces' (Methods mmulti methods))
pack' <- [|encodeUtf8 . pack|] pack' <- [|encodeUtf8 . pack|]
let isDynamic Dynamic{} = True let isDynamic Dynamic{} = True
isDynamic _ = False 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" xs <- replicateM argCount $ newName "arg"
runHandler <- mdsRunHandler mds runHandler <- mdsRunHandler mds
let rhs let rhs
@ -183,13 +183,13 @@ buildMethodMap mds (FlatResource parents name pieces' (Methods mmulti methods))
[ pack' `AppE` LitE (StringL method) [ pack' `AppE` LitE (StringL method)
, rhs , rhs
] ]
buildMethodMap _ (FlatResource _ _ _ Subsite{}) = return Nothing buildMethodMap _ (FlatResource _ _ _ Subsite{} _check) = return Nothing
-- | Build a single 'D.Route' expression. -- | Build a single 'D.Route' expression.
buildRoute :: MkDispatchSettings -> FlatResource a -> Q Exp 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 -- First two arguments to D.Route
routePieces <- ListE <$> mapM (convertPiece . snd) allPieces routePieces <- ListE <$> mapM convertPiece allPieces
isMulti <- isMulti <-
case resDisp of case resDisp of
Methods Nothing _ -> [|False|] Methods Nothing _ -> [|False|]
@ -202,14 +202,14 @@ buildRoute mds (FlatResource parents name resPieces resDisp) = do
mds mds
parents parents
name name
(map snd allPieces) allPieces
resDisp) resDisp)
|] |]
where where
allPieces = concat $ map snd parents ++ [resPieces] allPieces = concat $ map snd parents ++ [resPieces]
routeArg3 :: MkDispatchSettings routeArg3 :: MkDispatchSettings
-> [(String, [(CheckOverlap, Piece a)])] -> [(String, [Piece a])]
-> String -- ^ name of resource -> String -- ^ name of resource
-> [Piece a] -> [Piece a]
-> Dispatch a -> Dispatch a
@ -277,7 +277,7 @@ routeArg3 mds parents name resPieces resDisp = do
-- | The final expression in the individual Route definitions. -- | The final expression in the individual Route definitions.
buildCaller :: MkDispatchSettings buildCaller :: MkDispatchSettings
-> Name -- ^ xrest -> Name -- ^ xrest
-> [(String, [(CheckOverlap, Piece a)])] -> [(String, [Piece a])]
-> String -- ^ name of resource -> String -- ^ name of resource
-> Dispatch a -> Dispatch a
-> [Name] -- ^ ys -> [Name] -- ^ ys
@ -356,7 +356,7 @@ convertPiece :: Piece a -> Q Exp
convertPiece (Static s) = [|D.Static (pack $(lift s))|] convertPiece (Static s) = [|D.Static (pack $(lift s))|]
convertPiece (Dynamic _) = [|D.Dynamic|] convertPiece (Dynamic _) = [|D.Dynamic|]
routeFromDynamics :: [(String, [(CheckOverlap, Piece a)])] -- ^ parents routeFromDynamics :: [(String, [Piece a])] -- ^ parents
-> String -- ^ constructor name -> String -- ^ constructor name
-> [Name] -> [Name]
-> Exp -> Exp
@ -364,7 +364,7 @@ routeFromDynamics [] name ys = foldl' (\a b -> a `AppE` VarE b) (ConE $ mkName n
routeFromDynamics ((parent, pieces):rest) name ys = routeFromDynamics ((parent, pieces):rest) name ys =
foldl' (\a b -> a `AppE` b) (ConE $ mkName parent) here foldl' (\a b -> a `AppE` b) (ConE $ mkName parent) here
where where
(here', ys') = splitAt (length $ filter (isDynamic . snd) pieces) ys (here', ys') = splitAt (length $ filter isDynamic pieces) ys
isDynamic Dynamic{} = True isDynamic Dynamic{} = True
isDynamic _ = False isDynamic _ = False
here = map VarE here' ++ [routeFromDynamics rest name ys'] here = map VarE here' ++ [routeFromDynamics rest name ys']

16
yesod-routes/Yesod/Routes/TH/ParseRoute.hs
View File

@ -43,7 +43,7 @@ mkParseRouteClauses ress' = do
[dispatchFun] [dispatchFun]
where where
ress = map noMethods $ flatten ress' 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' (Methods a _) = Methods a []
noMethods' (Subsite a b) = Subsite a b noMethods' (Subsite a b) = Subsite a b
@ -56,9 +56,9 @@ mkParseRouteInstance typ ress = do
-- | Build a single 'D.Route' expression. -- | Build a single 'D.Route' expression.
buildRoute :: Name -> FlatResource a -> Q Exp 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 -- First two arguments to D.Route
routePieces <- ListE <$> mapM (convertPiece . snd) allPieces routePieces <- ListE <$> mapM convertPiece allPieces
isMulti <- isMulti <-
case resDisp of case resDisp of
Methods Nothing _ -> [|False|] Methods Nothing _ -> [|False|]
@ -71,14 +71,14 @@ buildRoute query (FlatResource parents name resPieces resDisp) = do
query query
parents parents
name name
(map snd allPieces) allPieces
resDisp) resDisp)
|] |]
where where
allPieces = concat $ map snd parents ++ [resPieces] allPieces = concat $ map snd parents ++ [resPieces]
routeArg3 :: Name -- ^ query string parameters routeArg3 :: Name -- ^ query string parameters
-> [(String, [(CheckOverlap, Piece a)])] -> [(String, [Piece a])]
-> String -- ^ name of resource -> String -- ^ name of resource
-> [Piece a] -> [Piece a]
-> Dispatch a -> Dispatch a
@ -146,7 +146,7 @@ routeArg3 query parents name resPieces resDisp = do
-- | The final expression in the individual Route definitions. -- | The final expression in the individual Route definitions.
buildCaller :: Name -- ^ query string parameters buildCaller :: Name -- ^ query string parameters
-> Name -- ^ xrest -> Name -- ^ xrest
-> [(String, [(CheckOverlap, Piece a)])] -> [(String, [Piece a])]
-> String -- ^ name of resource -> String -- ^ name of resource
-> Dispatch a -> Dispatch a
-> [Name] -- ^ ys -> [Name] -- ^ ys
@ -164,7 +164,7 @@ convertPiece :: Piece a -> Q Exp
convertPiece (Static s) = [|D.Static (pack $(lift s))|] convertPiece (Static s) = [|D.Static (pack $(lift s))|]
convertPiece (Dynamic _) = [|D.Dynamic|] convertPiece (Dynamic _) = [|D.Dynamic|]
routeFromDynamics :: [(String, [(CheckOverlap, Piece a)])] -- ^ parents routeFromDynamics :: [(String, [Piece a])] -- ^ parents
-> String -- ^ constructor name -> String -- ^ constructor name
-> [Name] -> [Name]
-> Exp -> Exp
@ -172,7 +172,7 @@ routeFromDynamics [] name ys = foldl' (\a b -> a `AppE` VarE b) (ConE $ mkName n
routeFromDynamics ((parent, pieces):rest) name ys = routeFromDynamics ((parent, pieces):rest) name ys =
foldl' (\a b -> a `AppE` b) (ConE $ mkName parent) here foldl' (\a b -> a `AppE` b) (ConE $ mkName parent) here
where where
(here', ys') = splitAt (length $ filter (isDynamic . snd) pieces) ys (here', ys') = splitAt (length $ filter isDynamic pieces) ys
isDynamic Dynamic{} = True isDynamic Dynamic{} = True
isDynamic _ = False isDynamic _ = False
here = map VarE here' ++ [routeFromDynamics rest name ys'] here = map VarE here' ++ [routeFromDynamics rest name ys']

16
yesod-routes/Yesod/Routes/TH/RenderRoute.hs
View File

@ -27,7 +27,7 @@ mkRouteCons =
con = NormalC (mkName $ resourceName res) con = NormalC (mkName $ resourceName res)
$ map (\x -> (NotStrict, x)) $ map (\x -> (NotStrict, x))
$ concat [singles, multi, sub] $ concat [singles, multi, sub]
singles = concatMap (toSingle . snd) $ resourcePieces res singles = concatMap toSingle $ resourcePieces res
toSingle Static{} = [] toSingle Static{} = []
toSingle (Dynamic typ) = [typ] toSingle (Dynamic typ) = [typ]
@ -37,7 +37,7 @@ mkRouteCons =
case resourceDispatch res of case resourceDispatch res of
Subsite { subsiteType = typ } -> [ConT ''Route `AppT` typ] Subsite { subsiteType = typ } -> [ConT ''Route `AppT` typ]
_ -> [] _ -> []
mkRouteCon (ResourceParent name pieces children) = mkRouteCon (ResourceParent name _check pieces children) =
([con], dec : decs) ([con], dec : decs)
where where
(cons, decs) = mkRouteCons children (cons, decs) = mkRouteCons children
@ -46,7 +46,7 @@ mkRouteCons =
$ concat [singles, [ConT $ mkName name]] $ concat [singles, [ConT $ mkName name]]
dec = DataD [] (mkName name) [] cons [''Show, ''Read, ''Eq] dec = DataD [] (mkName name) [] cons [''Show, ''Read, ''Eq]
singles = concatMap (toSingle . snd) pieces singles = concatMap toSingle pieces
toSingle Static{} = [] toSingle Static{} = []
toSingle (Dynamic typ) = [typ] toSingle (Dynamic typ) = [typ]
@ -58,15 +58,15 @@ mkRenderRouteClauses =
isDynamic Dynamic{} = True isDynamic Dynamic{} = True
isDynamic _ = False isDynamic _ = False
go (ResourceParent name pieces children) = do go (ResourceParent name _check pieces children) = do
let cnt = length $ filter (isDynamic . snd) pieces let cnt = length $ filter isDynamic pieces
dyns <- replicateM cnt $ newName "dyn" dyns <- replicateM cnt $ newName "dyn"
child <- newName "child" child <- newName "child"
let pat = ConP (mkName name) $ map VarP $ dyns ++ [child] let pat = ConP (mkName name) $ map VarP $ dyns ++ [child]
pack' <- [|pack|] pack' <- [|pack|]
tsp <- [|toPathPiece|] 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" childRender <- newName "childRender"
let rr = VarE childRender let rr = VarE childRender
@ -84,7 +84,7 @@ mkRenderRouteClauses =
return $ Clause [pat] (NormalB body) [FunD childRender childClauses] return $ Clause [pat] (NormalB body) [FunD childRender childClauses]
go (ResourceLeaf res) = do 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" dyns <- replicateM cnt $ newName "dyn"
sub <- sub <-
case resourceDispatch res of case resourceDispatch res of
@ -94,7 +94,7 @@ mkRenderRouteClauses =
pack' <- [|pack|] pack' <- [|pack|]
tsp <- [|toPathPiece|] 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 <- piecesMulti <-
case resourceMulti res of case resourceMulti res of

4
yesod-routes/Yesod/Routes/TH/RouteAttrs.hs
View File

@ -19,11 +19,11 @@ mkRouteAttrsInstance typ ress = do
goTree :: (Pat -> Pat) -> ResourceTree a -> Q [Clause] goTree :: (Pat -> Pat) -> ResourceTree a -> Q [Clause]
goTree front (ResourceLeaf res) = fmap return $ goRes front res 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 fmap concat $ mapM (goTree front') trees
where where
ignored = ((replicate toIgnore WildP ++) . return) ignored = ((replicate toIgnore WildP ++) . return)
toIgnore = length $ filter (isDynamic . snd) pieces toIgnore = length $ filter isDynamic pieces
isDynamic Dynamic{} = True isDynamic Dynamic{} = True
isDynamic Static{} = False isDynamic Static{} = False
front' = front . ConP (mkName name) . ignored front' = front . ConP (mkName name) . ignored

12
yesod-routes/Yesod/Routes/TH/Simple.hs
View File

@ -52,14 +52,14 @@ mkSimpleDispatchClause MkDispatchSettings {..} resources = do
(NormalB $ helperE `AppE` pathInfo) (NormalB $ helperE `AppE` pathInfo)
[FunD helperName $ clauses ++ [clause404']] [FunD helperName $ clauses ++ [clause404']]
where where
handlePiece :: (CheckOverlap, Piece a) -> Q (Pat, Maybe Exp) handlePiece :: Piece a -> Q (Pat, Maybe Exp)
handlePiece (_, Static str) = return (LitP $ StringL str, Nothing) handlePiece (Static str) = return (LitP $ StringL str, Nothing)
handlePiece (_, Dynamic _) = do handlePiece (Dynamic _) = do
x <- newName "dyn" x <- newName "dyn"
let pat = ViewP (VarE 'fromPathPiece) (ConP 'Just [VarP x]) let pat = ViewP (VarE 'fromPathPiece) (ConP 'Just [VarP x])
return (pat, Just $ VarE 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 handlePieces = fmap (second catMaybes . unzip) . mapM handlePiece
mkCon :: String -> [Exp] -> Exp mkCon :: String -> [Exp] -> Exp
@ -72,7 +72,7 @@ mkSimpleDispatchClause MkDispatchSettings {..} resources = do
addPat x y = ConP '(:) [x, y] addPat x y = ConP '(:) [x, y]
go :: SDC -> ResourceTree a -> Q Clause 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 (pats, dyns) <- handlePieces pieces
let sdc' = sdc let sdc' = sdc
{ extraParams = extraParams sdc ++ dyns { extraParams = extraParams sdc ++ dyns
@ -91,7 +91,7 @@ mkSimpleDispatchClause MkDispatchSettings {..} resources = do
[mkPathPat restP pats] [mkPathPat restP pats]
(NormalB $ helperE `AppE` restE) (NormalB $ helperE `AppE` restE)
[FunD helperName $ childClauses ++ [clause404 sdc]] [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 (pats, dyns) <- handlePieces pieces
(chooseMethod, finalPat) <- handleDispatch dispatch dyns (chooseMethod, finalPat) <- handleDispatch dispatch dyns

45
yesod-routes/Yesod/Routes/TH/Types.hs
View File

@ -1,3 +1,4 @@
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
module Yesod.Routes.TH.Types module Yesod.Routes.TH.Types
( -- * Data types ( -- * Data types
@ -15,41 +16,37 @@ module Yesod.Routes.TH.Types
) where ) where
import Language.Haskell.TH.Syntax 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 (ResourceLeaf r) = resourcePieces r
resourceTreePieces (ResourceParent _ x _) = x resourceTreePieces (ResourceParent _ _ x _) = x
resourceTreeName :: ResourceTree typ -> String resourceTreeName :: ResourceTree typ -> String
resourceTreeName (ResourceLeaf r) = resourceName r resourceTreeName (ResourceLeaf r) = resourceName r
resourceTreeName (ResourceParent x _ _) = x 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
instance Lift t => Lift (ResourceTree t) where instance Lift t => Lift (ResourceTree t) where
lift (ResourceLeaf r) = [|ResourceLeaf $(lift r)|] 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 data Resource typ = Resource
{ resourceName :: String { resourceName :: String
, resourcePieces :: [(CheckOverlap, Piece typ)] , resourcePieces :: [Piece typ]
, resourceDispatch :: Dispatch typ , resourceDispatch :: Dispatch typ
, resourceAttrs :: [String] , resourceAttrs :: [String]
, resourceCheck :: CheckOverlap
} }
deriving Show deriving (Show, Functor)
type CheckOverlap = Bool 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 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 data Piece typ = Static String | Dynamic typ
deriving Show deriving Show
@ -86,12 +83,18 @@ resourceMulti :: Resource typ -> Maybe typ
resourceMulti Resource { resourceDispatch = Methods (Just t) _ } = Just t resourceMulti Resource { resourceDispatch = Methods (Just t) _ } = Just t
resourceMulti _ = Nothing 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 :: [ResourceTree a] -> [FlatResource a]
flatten = flatten =
concatMap (go id) concatMap (go id True)
where where
go front (ResourceLeaf (Resource a b c _)) = [FlatResource (front []) a b c] go front check' (ResourceLeaf (Resource a b c _ check)) = [FlatResource (front []) a b c (check' && check)]
go front (ResourceParent name pieces children) = go front check' (ResourceParent name check pieces children) =
concatMap (go (front . ((name, pieces):))) children concatMap (go (front . ((name, pieces):)) (check && check')) children

41
yesod-routes/test/main.hs
View File

@ -112,21 +112,21 @@ getMySubParam _ = MySubParam
do do
texts <- [t|[Text]|] texts <- [t|[Text]|]
let resLeaves = map ResourceLeaf let resLeaves = map ResourceLeaf
[ Resource "RootR" [] (Methods Nothing ["GET"]) ["foo", "bar"] [ Resource "RootR" [] (Methods Nothing ["GET"]) ["foo", "bar"] True
, Resource "BlogPostR" (addCheck [Static "blog", Dynamic $ ConT ''Text]) (Methods Nothing ["GET", "POST"]) [] , Resource "BlogPostR" [Static "blog", Dynamic $ ConT ''Text] (Methods Nothing ["GET", "POST"]) [] True
, Resource "WikiR" (addCheck [Static "wiki"]) (Methods (Just texts) []) [] , Resource "WikiR" [Static "wiki"] (Methods (Just texts) []) [] True
, Resource "SubsiteR" (addCheck [Static "subsite"]) (Subsite (ConT ''MySub) "getMySub") [] , Resource "SubsiteR" [Static "subsite"] (Subsite (ConT ''MySub) "getMySub") [] True
, Resource "SubparamR" (addCheck [Static "subparam", Dynamic $ ConT ''Int]) (Subsite (ConT ''MySubParam) "getMySubParam") [] , Resource "SubparamR" [Static "subparam", Dynamic $ ConT ''Int] (Subsite (ConT ''MySubParam) "getMySubParam") [] True
] ]
resParent = ResourceParent resParent = ResourceParent
"ParentR" "ParentR"
[ (True, Static "foo") True
, (True, Dynamic $ ConT ''Text) [ Static "foo"
, Dynamic $ ConT ''Text
] ]
[ ResourceLeaf $ Resource "ChildR" [] (Methods Nothing ["GET"]) ["child"] [ ResourceLeaf $ Resource "ChildR" [] (Methods Nothing ["GET"]) ["child"] True
] ]
ress = resParent : resLeaves ress = resParent : resLeaves
addCheck = map ((,) True)
rrinst <- mkRenderRouteInstance (ConT ''MyApp) ress rrinst <- mkRenderRouteInstance (ConT ''MyApp) ress
rainst <- mkRouteAttrsInstance (ConT ''MyApp) ress rainst <- mkRouteAttrsInstance (ConT ''MyApp) ress
prinst <- mkParseRouteInstance (ConT ''MyApp) ress prinst <- mkParseRouteInstance (ConT ''MyApp) ress
@ -347,6 +347,29 @@ main = hspec $ do
/foo Foo1 /foo Foo1
/#!String Foo2 /#!String Foo2
/!foo Foo3 /!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 @?= [] findOverlapNames routes @?= []
it "proper boolean logic" $ do it "proper boolean logic" $ do