Overlap checking (and addresses #174)
This commit is contained in:
Michael Snoyman
parent
babd7903b9
commit
e16ed57849
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)|]
|
||||
|
||||
@ -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"
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user