Overlap checking (and addresses #174)

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

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 :: String -> Either String (CheckOverlap, Piece String)
-pieceFromString ('#':x) = Right $ Dynamic x
+pieceFromString ('#':'!':x) = Right $ (False, Dynamic x)
+pieceFromString ('#':x) = Right $ (True, Dynamic x)
 pieceFromString ('*':x) = Left x
-pieceFromString x = Right $ Static x
+pieceFromString ('!':x) = Right $ (False, Static x)
-
+pieceFromString x = Right $ (True, 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)
-    -}

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

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

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)|]

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 "BlogPostR" (addCheck [Static "blog", Dynamic $ ConT ''Text]) $ Methods Nothing ["GET", "POST"]
-            , Resource "WikiR" [Static "wiki"] $ Methods (Just texts) []
+            , Resource "WikiR" (addCheck [Static "wiki"]) $ Methods (Just texts) []
-            , Resource "SubsiteR" [Static "subsite"] $ Subsite (ConT ''MySub) "getMySub"
+            , Resource "SubsiteR" (addCheck [Static "subsite"]) $ Subsite (ConT ''MySub) "getMySub"
-            , Resource "SubparamR" [Static "subparam", Dynamic $ ConT ''Int] $ Subsite (ConT ''MySubParam) "getMySubParam"
+            , 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"
 

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