From e16ed578498cba7e6eb41d057be923d0fcb11bfe Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 10 Jan 2012 13:42:35 +0200 Subject: [PATCH] Overlap checking (and addresses #174) --- yesod-routes/Yesod/Routes/Overlap.hs | 29 ++++++++++- yesod-routes/Yesod/Routes/Parse.hs | 40 ++++----------- yesod-routes/Yesod/Routes/TH/Dispatch.hs | 6 +-- yesod-routes/Yesod/Routes/TH/RenderRoute.hs | 6 +-- yesod-routes/Yesod/Routes/TH/Types.hs | 8 ++- yesod-routes/test/main.hs | 57 +++++++++++++++++++-- yesod-routes/yesod-routes.cabal | 1 + 7 files changed, 103 insertions(+), 44 deletions(-) diff --git a/yesod-routes/Yesod/Routes/Overlap.hs b/yesod-routes/Yesod/Routes/Overlap.hs index 002c6cc9..67b37c2f 100644 --- a/yesod-routes/Yesod/Routes/Overlap.hs +++ b/yesod-routes/Yesod/Routes/Overlap.hs @@ -6,9 +6,36 @@ module Yesod.Routes.Overlap import Yesod.Routes.TH.Types import Control.Arrow ((***)) +import Data.Maybe (mapMaybe) findOverlaps :: [Resource t] -> [(Resource t, Resource t)] -findOverlaps = undefined +findOverlaps [] = [] +findOverlaps (x:xs) = mapMaybe (findOverlap x) xs ++ findOverlaps xs + +findOverlap :: Resource t -> Resource t -> Maybe (Resource t, Resource t) +findOverlap x y + | overlaps (resourcePieces x) (resourcePieces y) (hasSuffix x) (hasSuffix y) = Just (x, y) + | otherwise = Nothing + +hasSuffix :: Resource t -> Bool +hasSuffix r = + case resourceDispatch r of + Subsite{} -> True + Methods Just{} _ -> True + Methods Nothing _ -> False + +overlaps :: [(CheckOverlap, Piece t)] -> [(CheckOverlap, Piece t)] -> Bool -> Bool -> Bool +overlaps [] [] False False = False +overlaps [] _ suffixX _ = suffixX +overlaps _ [] _ suffixY = suffixY +overlaps ((False, _):xs) (_:ys) suffixX suffixY = overlaps xs ys suffixX suffixY +overlaps (_:xs) ((False, _):ys) suffixX suffixY = overlaps xs ys suffixX suffixY +overlaps ((True, pieceX):xs) ((True, pieceY):ys) suffixX suffixY = + piecesOverlap pieceX pieceY || overlaps xs ys suffixX suffixY + +piecesOverlap :: Piece t -> Piece t -> Bool +piecesOverlap (Static x) (Static y) = x == y +piecesOverlap _ _ = True findOverlapNames :: [Resource t] -> [(String, String)] findOverlapNames = map (resourceName *** resourceName) . findOverlaps diff --git a/yesod-routes/Yesod/Routes/Parse.hs b/yesod-routes/Yesod/Routes/Parse.hs index c23ce6ff..40cf88f3 100644 --- a/yesod-routes/Yesod/Routes/Parse.hs +++ b/yesod-routes/Yesod/Routes/Parse.hs @@ -15,6 +15,7 @@ import Data.Char (isUpper) import Language.Haskell.TH.Quote import qualified System.IO as SIO import Yesod.Routes.TH +import Yesod.Routes.Overlap (findOverlapNames) -- | A quasi-quoter to parse a string into a list of 'Resource's. Checks for -- overlapping routes, failing if present; use 'parseRoutesNoCheck' to skip the @@ -26,9 +27,9 @@ parseRoutes = QuasiQuoter where x s = do let res = resourcesFromString s - case findOverlaps res of + case findOverlapNames res of [] -> lift res - z -> error $ "Overlapping routes: " ++ unlines (map (unwords . map resourceName) z) + z -> error $ "Overlapping routes: " ++ unlines (map show z) parseRoutesFile :: FilePath -> Q Exp parseRoutesFile fp = do @@ -82,7 +83,7 @@ drop1Slash :: String -> String drop1Slash ('/':x) = x drop1Slash x = x -piecesFromString :: String -> ([Piece String], Maybe String) +piecesFromString :: String -> ([(CheckOverlap, Piece String)], Maybe String) piecesFromString "" = ([], Nothing) piecesFromString x = case (this, rest) of @@ -97,32 +98,9 @@ piecesFromString x = parseType :: String -> Type parseType = ConT . mkName -- FIXME handle more complicated stuff -pieceFromString :: String -> Either String (Piece String) -pieceFromString ('#':x) = Right $ Dynamic x +pieceFromString :: String -> Either String (CheckOverlap, Piece String) +pieceFromString ('#':'!':x) = Right $ (False, Dynamic x) +pieceFromString ('#':x) = Right $ (True, Dynamic x) pieceFromString ('*':x) = Left x -pieceFromString x = Right $ Static x - --- n^2, should be a way to speed it up -findOverlaps :: [Resource a] -> [[Resource a]] -findOverlaps = go . map justPieces - where - justPieces :: Resource a -> ([Piece a], Resource a) - justPieces r@(Resource _ ps _) = (ps, r) - - go [] = [] - go (x:xs) = mapMaybe (mOverlap x) xs ++ go xs - - mOverlap :: ([Piece a], Resource a) -> ([Piece a], Resource a) -> - Maybe [Resource a] - mOverlap _ _ = Nothing - {- FIXME mOverlap - mOverlap (Static x:xs, xr) (Static y:ys, yr) - | x == y = mOverlap (xs, xr) (ys, yr) - | otherwise = Nothing - mOverlap (MultiPiece _:_, xr) (_, yr) = Just (xr, yr) - mOverlap (_, xr) (MultiPiece _:_, yr) = Just (xr, yr) - mOverlap ([], xr) ([], yr) = Just (xr, yr) - mOverlap ([], _) (_, _) = Nothing - mOverlap (_, _) ([], _) = Nothing - mOverlap (_:xs, xr) (_:ys, yr) = mOverlap (xs, xr) (ys, yr) - -} +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 9563e618..c8797bca 100644 --- a/yesod-routes/Yesod/Routes/TH/Dispatch.hs +++ b/yesod-routes/Yesod/Routes/TH/Dispatch.hs @@ -136,7 +136,7 @@ buildMethodMap fixHandler (Resource name pieces (Methods mmulti methods)) = do pack' <- [|pack|] let isDynamic Dynamic{} = True isDynamic _ = False - let argCount = length (filter isDynamic pieces) + maybe 0 (const 1) mmulti + let argCount = length (filter (isDynamic . snd) pieces) + maybe 0 (const 1) mmulti xs <- replicateM argCount $ newName "arg" let rhs = LamE (map VarP xs) $ fh `AppE` (foldl' AppE func $ map VarE xs) return $ TupE [pack' `AppE` LitE (StringL method), rhs] @@ -146,13 +146,13 @@ buildMethodMap _ (Resource _ _ Subsite{}) = return Nothing buildRoute :: Q Exp -> Q Exp -> Q Exp -> Resource a -> Q Exp buildRoute runHandler dispatcher fixHandler (Resource name resPieces resDisp) = do -- First two arguments to D.Route - routePieces <- ListE <$> mapM convertPiece resPieces + routePieces <- ListE <$> mapM (convertPiece . snd) resPieces isMulti <- case resDisp of Methods Nothing _ -> [|False|] _ -> [|True|] - [|D.Route $(return routePieces) $(return isMulti) $(routeArg3 runHandler dispatcher fixHandler name resPieces resDisp)|] + [|D.Route $(return routePieces) $(return isMulti) $(routeArg3 runHandler dispatcher fixHandler name (map snd resPieces) resDisp)|] routeArg3 :: Q Exp -- ^ runHandler -> Q Exp -- ^ dispatcher diff --git a/yesod-routes/Yesod/Routes/TH/RenderRoute.hs b/yesod-routes/Yesod/Routes/TH/RenderRoute.hs index 04edc094..097cd8d7 100644 --- a/yesod-routes/Yesod/Routes/TH/RenderRoute.hs +++ b/yesod-routes/Yesod/Routes/TH/RenderRoute.hs @@ -24,7 +24,7 @@ mkRouteCons = $ map (\x -> (NotStrict, x)) $ concat [singles, multi, sub] where - singles = concatMap toSingle $ resourcePieces res + singles = concatMap (toSingle . snd) $ resourcePieces res toSingle Static{} = [] toSingle (Dynamic typ) = [typ] @@ -44,7 +44,7 @@ mkRenderRouteClauses = isDynamic _ = False go res = do - let cnt = length (filter isDynamic $ resourcePieces res) + maybe 0 (const 1) (resourceMulti res) + let cnt = length (filter (isDynamic . snd) $ resourcePieces res) + maybe 0 (const 1) (resourceMulti res) dyns <- replicateM cnt $ newName "dyn" sub <- case resourceDispatch res of @@ -54,7 +54,7 @@ mkRenderRouteClauses = pack' <- [|pack|] tsp <- [|toPathPiece|] - let piecesSingle = mkPieces (AppE pack' . LitE . StringL) tsp (resourcePieces res) dyns + let piecesSingle = mkPieces (AppE pack' . LitE . StringL) tsp (map snd $ resourcePieces res) dyns piecesMulti <- case resourceMulti res of diff --git a/yesod-routes/Yesod/Routes/TH/Types.hs b/yesod-routes/Yesod/Routes/TH/Types.hs index 54428ab8..e0a74b5c 100644 --- a/yesod-routes/Yesod/Routes/TH/Types.hs +++ b/yesod-routes/Yesod/Routes/TH/Types.hs @@ -4,21 +4,25 @@ module Yesod.Routes.TH.Types Resource (..) , Piece (..) , Dispatch (..) + , CheckOverlap -- ** Helper functions , resourceMulti ) where import Language.Haskell.TH.Syntax +import Control.Arrow (second) data Resource typ = Resource { resourceName :: String - , resourcePieces :: [Piece typ] + , resourcePieces :: [(CheckOverlap, Piece typ)] , resourceDispatch :: Dispatch typ } deriving Show +type CheckOverlap = Bool + instance Functor Resource where - fmap f (Resource a b c) = Resource a (map (fmap f) b) (fmap f c) + fmap f (Resource a b c) = Resource a (map (second $ fmap f) b) (fmap f c) instance Lift t => Lift (Resource t) where lift (Resource a b c) = [|Resource $(lift a) $(lift b) $(lift c)|] diff --git a/yesod-routes/test/main.hs b/yesod-routes/test/main.hs index a8b2b045..51f5d260 100644 --- a/yesod-routes/test/main.hs +++ b/yesod-routes/test/main.hs @@ -6,6 +6,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE QuasiQuotes #-} import Test.Hspec.Monadic import Test.Hspec.HUnit () import Test.HUnit ((@?=)) @@ -14,6 +15,8 @@ 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) +import Yesod.Routes.Overlap (findOverlapNames) import Yesod.Routes.TH hiding (Dispatch) import Language.Haskell.TH.Syntax @@ -112,11 +115,12 @@ do texts <- [t|[Text]|] let ress = [ Resource "RootR" [] $ Methods Nothing ["GET"] - , Resource "BlogPostR" [Static "blog", Dynamic $ ConT ''Text] $ Methods Nothing ["GET", "POST"] - , Resource "WikiR" [Static "wiki"] $ Methods (Just texts) [] - , Resource "SubsiteR" [Static "subsite"] $ Subsite (ConT ''MySub) "getMySub" - , Resource "SubparamR" [Static "subparam", Dynamic $ ConT ''Int] $ Subsite (ConT ''MySubParam) "getMySubParam" + , 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" ] + addCheck = map ((,) True) rrinst <- mkRenderRouteInstance (ConT ''MyApp) ress dispatch <- mkDispatchClause [|runHandler|] [|dispatcher|] [|toText|] ress return @@ -260,6 +264,51 @@ main = hspecX $ do it "routes to subparam" $ disp "PUT" ["subparam", "6", "q"] @?= (pack "subparam 6 q", Just $ SubparamR 6 $ ParamRoute 'q') + describe "overlap checking" $ do + it "catches overlapping statics" $ do + let routes = [parseRoutesNoCheck| +/foo Foo1 +/foo Foo2 +|] + findOverlapNames routes @?= [("Foo1", "Foo2")] + it "catches overlapping dynamics" $ do + let routes = [parseRoutesNoCheck| +/#Int Foo1 +/#String Foo2 +|] + findOverlapNames routes @?= [("Foo1", "Foo2")] + it "catches overlapping statics and dynamics" $ do + let routes = [parseRoutesNoCheck| +/foo Foo1 +/#String Foo2 +|] + findOverlapNames routes @?= [("Foo1", "Foo2")] + it "catches overlapping multi" $ do + let routes = [parseRoutesNoCheck| +/foo Foo1 +/*Strings Foo2 +|] + findOverlapNames routes @?= [("Foo1", "Foo2")] + it "catches overlapping subsite" $ do + let routes = [parseRoutesNoCheck| +/foo Foo1 +/foo Foo2 Subsite getSubsite +|] + findOverlapNames routes @?= [("Foo1", "Foo2")] + it "no false positives" $ do + let routes = [parseRoutesNoCheck| +/foo Foo1 +/bar/#String Foo2 +|] + findOverlapNames routes @?= [] + it "obeys ignore rules" $ do + let routes = [parseRoutesNoCheck| +/foo Foo1 +/#!String Foo2 +/!foo Foo3 +|] + findOverlapNames routes @?= [] + getRootR :: Text getRootR = pack "this is the root" diff --git a/yesod-routes/yesod-routes.cabal b/yesod-routes/yesod-routes.cabal index f8d9a83a..5accde39 100644 --- a/yesod-routes/yesod-routes.cabal +++ b/yesod-routes/yesod-routes.cabal @@ -24,6 +24,7 @@ library Yesod.Routes.TH Yesod.Routes.Class Yesod.Routes.Parse + Yesod.Routes.Overlap other-modules: Yesod.Routes.TH.Dispatch Yesod.Routes.TH.RenderRoute Yesod.Routes.TH.Types