101 lines
3.3 KiB
Haskell
101 lines
3.3 KiB
Haskell
-- | Check for overlapping routes.
|
|
module Yesod.Routes.Overlap
|
|
( findOverlaps
|
|
, findOverlapNames
|
|
, Overlap (..)
|
|
) where
|
|
|
|
import Yesod.Routes.TH.Types
|
|
import Data.List (intercalate)
|
|
|
|
data Overlap t = Overlap
|
|
{ overlapParents :: [String] -> [String] -- ^ parent resource trees
|
|
, overlap1 :: ResourceTree t
|
|
, overlap2 :: ResourceTree t
|
|
}
|
|
|
|
findOverlaps :: ([String] -> [String]) -> [ResourceTree t] -> [Overlap t]
|
|
findOverlaps _ [] = []
|
|
findOverlaps front (x:xs) = concatMap (findOverlap front x) xs ++ findOverlaps front xs
|
|
|
|
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{} -> []
|
|
|
|
hasSuffix :: ResourceTree t -> Bool
|
|
hasSuffix (ResourceLeaf r) =
|
|
case resourceDispatch r of
|
|
Subsite{} -> True
|
|
Methods Just{} _ -> True
|
|
Methods Nothing _ -> False
|
|
hasSuffix ResourceParent{} = True
|
|
|
|
overlaps :: [(CheckOverlap, Piece t)] -> [(CheckOverlap, 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
|
|
|
|
-- 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 =
|
|
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 . findOverlaps id
|
|
where
|
|
go (Overlap front x y) =
|
|
(go' $ resourceTreeName x, go' $ resourceTreeName y)
|
|
where
|
|
go' = intercalate "/" . front . return
|
|
{-
|
|
-- 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)
|
|
-}
|
|
-}
|