e23c78f2ce
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.
89 lines
2.6 KiB
Haskell
89 lines
2.6 KiB
Haskell
-- | Check for overlapping routes.
|
|
module Yesod.Routes.Overlap
|
|
( findOverlapNames
|
|
, Overlap (..)
|
|
) where
|
|
|
|
import Yesod.Routes.TH.Types
|
|
import Data.List (intercalate)
|
|
|
|
data Flattened t = Flattened
|
|
{ fNames :: [String]
|
|
, fPieces :: [Piece t]
|
|
, fHasSuffix :: Bool
|
|
, fCheck :: CheckOverlap
|
|
}
|
|
|
|
flatten :: ResourceTree t -> [Flattened t]
|
|
flatten =
|
|
go id id True
|
|
where
|
|
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 check (ResourceParent newname check' newpieces children) =
|
|
concatMap (go names' pieces' (check && check')) children
|
|
where
|
|
names' = names . (newname:)
|
|
pieces' = pieces . (newpieces ++)
|
|
|
|
data Overlap t = Overlap
|
|
{ overlapParents :: [String] -> [String] -- ^ parent resource trees
|
|
, overlap1 :: ResourceTree t
|
|
, overlap2 :: ResourceTree t
|
|
}
|
|
|
|
data OverlapF = OverlapF
|
|
{ overlapF1 :: [String]
|
|
, overlapF2 :: [String]
|
|
}
|
|
|
|
overlaps :: [Piece t] -> [Piece t] -> Bool -> Bool -> Bool
|
|
|
|
-- No pieces on either side, will overlap regardless of suffix
|
|
overlaps [] [] _ _ = True
|
|
|
|
-- No pieces on the left, will overlap if the left side has a suffix
|
|
overlaps [] _ suffixX _ = suffixX
|
|
|
|
-- Ditto for the right
|
|
overlaps _ [] _ suffixY = suffixY
|
|
|
|
-- Compare the actual pieces
|
|
overlaps (pieceX:xs) (pieceY:ys) suffixX suffixY =
|
|
piecesOverlap pieceX pieceY && overlaps xs ys suffixX suffixY
|
|
|
|
piecesOverlap :: Piece t -> Piece t -> Bool
|
|
-- Statics only match if they equal. Dynamics match with anything
|
|
piecesOverlap (Static x) (Static y) = x == y
|
|
piecesOverlap _ _ = True
|
|
|
|
findOverlapNames :: [ResourceTree t] -> [(String, String)]
|
|
findOverlapNames =
|
|
map go . findOverlapsF . filter fCheck . concatMap Yesod.Routes.Overlap.flatten
|
|
where
|
|
go (OverlapF x y) =
|
|
(go' x, go' y)
|
|
where
|
|
go' = intercalate "/"
|
|
|
|
findOverlapsF :: [Flattened t] -> [OverlapF]
|
|
findOverlapsF [] = []
|
|
findOverlapsF (x:xs) = concatMap (findOverlapF x) xs ++ findOverlapsF xs
|
|
|
|
findOverlapF :: Flattened t -> Flattened t -> [OverlapF]
|
|
findOverlapF x y
|
|
| overlaps (fPieces x) (fPieces y) (fHasSuffix x) (fHasSuffix y) = [OverlapF (fNames x) (fNames y)]
|
|
| otherwise = []
|
|
|
|
hasSuffix :: ResourceTree t -> Bool
|
|
hasSuffix (ResourceLeaf r) =
|
|
case resourceDispatch r of
|
|
Subsite{} -> True
|
|
Methods Just{} _ -> True
|
|
Methods Nothing _ -> False
|
|
hasSuffix ResourceParent{} = True
|