diff --git a/Yesod/Routes/Class.hs b/Yesod/Routes/Class.hs --- a/Yesod/Routes/Class.hs +++ b/Yesod/Routes/Class.hs @@ -2,11 +2,20 @@ {-# LANGUAGE FlexibleContexts #-} module Yesod.Routes.Class ( RenderRoute (..) + , ParseRoute (..) + , RouteAttrs (..) ) where import Data.Text (Text) +import Data.Set (Set) class Eq (Route a) => RenderRoute a where -- | The type-safe URLs associated with a site argument. data Route a renderRoute :: Route a -> ([Text], [(Text, Text)]) + +class RenderRoute a => ParseRoute a where + parseRoute :: ([Text], [(Text, Text)]) -> Maybe (Route a) + +class RenderRoute a => RouteAttrs a where + routeAttrs :: Route a -> Set Text diff --git a/Yesod/Routes/Dispatch.lhs b/Yesod/Routes/Dispatch.lhs --- a/Yesod/Routes/Dispatch.lhs +++ b/Yesod/Routes/Dispatch.lhs @@ -1,4 +1,4 @@ -Title: Experimental, optimized route dispatch code +Title: Optimized route dispatch code Let's start with our module declaration and imports. diff --git a/Yesod/Routes/Parse.hs b/Yesod/Routes/Parse.hs --- a/Yesod/Routes/Parse.hs +++ b/Yesod/Routes/Parse.hs @@ -7,6 +7,8 @@ , parseRoutesNoCheck , parseRoutesFileNoCheck , parseType + , parseTypeTree + , TypeTree (..) ) where import Language.Haskell.TH.Syntax @@ -15,6 +17,7 @@ import qualified System.IO as SIO import Yesod.Routes.TH import Yesod.Routes.Overlap (findOverlapNames) +import Data.List (foldl') -- | 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 @@ -73,11 +76,22 @@ in ((ResourceParent (init constr) pieces children :), otherLines'') (pattern:constr:rest) -> let (pieces, mmulti) = piecesFromString $ drop1Slash pattern - disp = dispatchFromString rest mmulti - in ((ResourceLeaf (Resource constr pieces disp):), otherLines) + (attrs, rest') = takeAttrs rest + disp = dispatchFromString rest' mmulti + in ((ResourceLeaf (Resource constr pieces disp attrs):), otherLines) [] -> (id, otherLines) _ -> error $ "Invalid resource line: " ++ thisLine +-- | Take attributes out of the list and put them in the first slot in the +-- result tuple. +takeAttrs :: [String] -> ([String], [String]) +takeAttrs = + go id id + where + go x y [] = (x [], y []) + go x y (('!':attr):rest) = go (x . (attr:)) y rest + go x y (z:rest) = go x (y . (z:)) rest + dispatchFromString :: [String] -> Maybe String -> Dispatch String dispatchFromString rest mmulti | null rest = Methods mmulti [] @@ -105,11 +119,72 @@ rest = piecesFromString $ drop 1 z parseType :: String -> Type -parseType = ConT . mkName -- FIXME handle more complicated stuff +parseType orig = + maybe (error $ "Invalid type: " ++ show orig) ttToType $ parseTypeTree orig +parseTypeTree :: String -> Maybe TypeTree +parseTypeTree orig = + toTypeTree pieces + where + pieces = filter (not . null) $ splitOn '-' $ addDashes orig + addDashes [] = [] + addDashes (x:xs) = + front $ addDashes xs + where + front rest + | x `elem` "()[]" = '-' : x : '-' : rest + | otherwise = x : rest + splitOn c s = + case y' of + _:y -> x : splitOn c y + [] -> [x] + where + (x, y') = break (== c) s + +data TypeTree = TTTerm String + | TTApp TypeTree TypeTree + | TTList TypeTree + deriving (Show, Eq) + +toTypeTree :: [String] -> Maybe TypeTree +toTypeTree orig = do + (x, []) <- gos orig + return x + where + go [] = Nothing + go ("(":xs) = do + (x, rest) <- gos xs + case rest of + ")":rest' -> Just (x, rest') + _ -> Nothing + go ("[":xs) = do + (x, rest) <- gos xs + case rest of + "]":rest' -> Just (TTList x, rest') + _ -> Nothing + go (x:xs) = Just (TTTerm x, xs) + + gos xs1 = do + (t, xs2) <- go xs1 + (ts, xs3) <- gos' id xs2 + Just (foldl' TTApp t ts, xs3) + + gos' front [] = Just (front [], []) + gos' front (x:xs) + | x `elem` words ") ]" = Just (front [], x:xs) + | otherwise = do + (t, xs') <- go $ x:xs + gos' (front . (t:)) xs' + +ttToType :: TypeTree -> Type +ttToType (TTTerm s) = ConT $ mkName s +ttToType (TTApp x y) = ttToType x `AppT` ttToType y +ttToType (TTList t) = ListT `AppT` ttToType t + 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) = Left x pieceFromString ('!':x) = Right $ (False, Static x) pieceFromString x = Right $ (True, Static x) diff --git a/Yesod/Routes/TH.hs b/Yesod/Routes/TH.hs --- a/Yesod/Routes/TH.hs +++ b/Yesod/Routes/TH.hs @@ -3,10 +3,14 @@ ( module Yesod.Routes.TH.Types -- * Functions , module Yesod.Routes.TH.RenderRoute + , module Yesod.Routes.TH.ParseRoute + , module Yesod.Routes.TH.RouteAttrs -- ** Dispatch , module Yesod.Routes.TH.Dispatch ) where import Yesod.Routes.TH.Types import Yesod.Routes.TH.RenderRoute +import Yesod.Routes.TH.ParseRoute +import Yesod.Routes.TH.RouteAttrs import Yesod.Routes.TH.Dispatch diff --git a/Yesod/Routes/TH/Dispatch.hs b/Yesod/Routes/TH/Dispatch.hs --- a/Yesod/Routes/TH/Dispatch.hs +++ b/Yesod/Routes/TH/Dispatch.hs @@ -2,6 +2,8 @@ module Yesod.Routes.TH.Dispatch ( -- ** Dispatch mkDispatchClause + , MkDispatchSettings (..) + , defaultGetHandler ) where import Prelude hiding (exp) @@ -16,16 +18,22 @@ import Web.PathPieces (PathPiece (..), PathMultiPiece (..)) import Control.Applicative ((<$>)) import Data.List (foldl') +import Data.Text.Encoding (encodeUtf8) -data FlatResource a = FlatResource [(String, [(CheckOverlap, Piece a)])] String [(CheckOverlap, Piece a)] (Dispatch a) +data MkDispatchSettings = MkDispatchSettings + { mdsRunHandler :: Q Exp + , mdsSubDispatcher :: Q Exp + , mdsGetPathInfo :: Q Exp + , mdsSetPathInfo :: Q Exp + , mdsMethod :: Q Exp + , mds404 :: Q Exp + , mds405 :: Q Exp + , mdsGetHandler :: Maybe String -> String -> Q Exp + } -flatten :: [ResourceTree a] -> [FlatResource a] -flatten = - concatMap (go id) - where - go front (ResourceLeaf (Resource a b c)) = [FlatResource (front []) a b c] - go front (ResourceParent name pieces children) = - concatMap (go (front . ((name, pieces):))) children +defaultGetHandler :: Maybe String -> String -> Q Exp +defaultGetHandler Nothing s = return $ VarE $ mkName $ "handle" ++ s +defaultGetHandler (Just method) s = return $ VarE $ mkName $ map toLower method ++ s -- | -- @@ -90,12 +98,10 @@ -- @'yesodRunner'@ for the first, @'yesodDispatch'@ for the second and -- @fmap 'chooseRep'@. -mkDispatchClause :: Q Exp -- ^ runHandler function - -> Q Exp -- ^ dispatcher function - -> Q Exp -- ^ fixHandler function +mkDispatchClause :: MkDispatchSettings -> [ResourceTree a] -> Q Clause -mkDispatchClause runHandler dispatcher fixHandler ress' = do +mkDispatchClause mds ress' = do -- Allocate the names to be used. Start off with the names passed to the -- function itself (with a 0 suffix). -- @@ -103,41 +109,42 @@ -- with -Wall). Additionally, we want to ensure that none of the code -- passed to toDispatch uses variables from the closure to prevent the -- dispatch data structure from being rebuilt on each run. - master0 <- newName "master0" - sub0 <- newName "sub0" - toMaster0 <- newName "toMaster0" - app4040 <- newName "app4040" - handler4050 <- newName "handler4050" - method0 <- newName "method0" - pieces0 <- newName "pieces0" + getEnv0 <- newName "yesod_dispatch_env0" + req0 <- newName "req0" + pieces <- [|$(mdsGetPathInfo mds) $(return $ VarE req0)|] -- Name of the dispatch function dispatch <- newName "dispatch" -- Dispatch function applied to the pieces - let dispatched = VarE dispatch `AppE` VarE pieces0 + let dispatched = VarE dispatch `AppE` pieces -- The 'D.Route's used in the dispatch function - routes <- mapM (buildRoute runHandler dispatcher fixHandler) ress + routes <- mapM (buildRoute mds) ress -- The dispatch function itself toDispatch <- [|D.toDispatch|] - let dispatchFun = FunD dispatch [Clause [] (NormalB $ toDispatch `AppE` ListE routes) []] + let dispatchFun = FunD dispatch + [Clause + [] + (NormalB $ toDispatch `AppE` ListE routes) + [] + ] -- The input to the clause. - let pats = map VarP [master0, sub0, toMaster0, app4040, handler4050, method0, pieces0] + let pats = map VarP [getEnv0, req0] -- For each resource that dispatches based on methods, build up a map for handling the dispatching. - methodMaps <- catMaybes <$> mapM (buildMethodMap fixHandler) ress + methodMaps <- catMaybes <$> mapM (buildMethodMap mds) ress u <- [|case $(return dispatched) of - Just f -> f $(return $ VarE master0) - $(return $ VarE sub0) - $(return $ VarE toMaster0) - $(return $ VarE app4040) - $(return $ VarE handler4050) - $(return $ VarE method0) - Nothing -> $(return $ VarE app4040) + Just f -> f $(return $ VarE getEnv0) + $(return $ VarE req0) + Nothing -> $(mdsRunHandler mds) + $(mds404 mds) + $(return $ VarE getEnv0) + Nothing + $(return $ VarE req0) |] return $ Clause pats (NormalB u) $ dispatchFun : methodMaps where @@ -147,11 +154,11 @@ methodMapName :: String -> Name methodMapName s = mkName $ "methods" ++ s -buildMethodMap :: Q Exp -- ^ fixHandler +buildMethodMap :: MkDispatchSettings -> FlatResource a -> Q (Maybe Dec) buildMethodMap _ (FlatResource _ _ _ (Methods _ [])) = return Nothing -- single handle function -buildMethodMap fixHandler (FlatResource parents name pieces' (Methods mmulti methods)) = do +buildMethodMap mds (FlatResource parents name pieces' (Methods mmulti methods)) = do fromList <- [|Map.fromList|] methods' <- mapM go methods let exp = fromList `AppE` ListE methods' @@ -160,20 +167,27 @@ where pieces = concat $ map snd parents ++ [pieces'] go method = do - fh <- fixHandler - let func = VarE $ mkName $ map toLower method ++ name - pack' <- [|pack|] + func <- mdsGetHandler mds (Just method) name + pack' <- [|encodeUtf8 . pack|] let isDynamic Dynamic{} = True isDynamic _ = False 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] + runHandler <- mdsRunHandler mds + let rhs + | null xs = runHandler `AppE` func + | otherwise = + LamE (map VarP xs) $ + runHandler `AppE` (foldl' AppE func $ map VarE xs) + return $ TupE + [ pack' `AppE` LitE (StringL method) + , rhs + ] buildMethodMap _ (FlatResource _ _ _ Subsite{}) = return Nothing -- | Build a single 'D.Route' expression. -buildRoute :: Q Exp -> Q Exp -> Q Exp -> FlatResource a -> Q Exp -buildRoute runHandler dispatcher fixHandler (FlatResource parents name resPieces resDisp) = do +buildRoute :: MkDispatchSettings -> FlatResource a -> Q Exp +buildRoute mds (FlatResource parents name resPieces resDisp) = do -- First two arguments to D.Route routePieces <- ListE <$> mapM (convertPiece . snd) allPieces isMulti <- @@ -181,19 +195,26 @@ Methods Nothing _ -> [|False|] _ -> [|True|] - [|D.Route $(return routePieces) $(return isMulti) $(routeArg3 runHandler dispatcher fixHandler parents name (map snd allPieces) resDisp)|] + [|D.Route + $(return routePieces) + $(return isMulti) + $(routeArg3 + mds + parents + name + (map snd allPieces) + resDisp) + |] where allPieces = concat $ map snd parents ++ [resPieces] -routeArg3 :: Q Exp -- ^ runHandler - -> Q Exp -- ^ dispatcher - -> Q Exp -- ^ fixHandler +routeArg3 :: MkDispatchSettings -> [(String, [(CheckOverlap, Piece a)])] -> String -- ^ name of resource -> [Piece a] -> Dispatch a -> Q Exp -routeArg3 runHandler dispatcher fixHandler parents name resPieces resDisp = do +routeArg3 mds parents name resPieces resDisp = do pieces <- newName "pieces" -- Allocate input piece variables (xs) and variables that have been @@ -235,7 +256,7 @@ _ -> return ([], []) -- The final expression that actually uses the values we've computed - caller <- buildCaller runHandler dispatcher fixHandler xrest parents name resDisp $ map snd ys ++ yrest' + caller <- buildCaller mds xrest parents name resDisp $ map snd ys ++ yrest' -- Put together all the statements just <- [|Just|] @@ -254,25 +275,21 @@ return $ LamE [VarP pieces] $ CaseE (VarE pieces) matches -- | The final expression in the individual Route definitions. -buildCaller :: Q Exp -- ^ runHandler - -> Q Exp -- ^ dispatcher - -> Q Exp -- ^ fixHandler +buildCaller :: MkDispatchSettings -> Name -- ^ xrest -> [(String, [(CheckOverlap, Piece a)])] -> String -- ^ name of resource -> Dispatch a -> [Name] -- ^ ys -> Q Exp -buildCaller runHandler dispatcher fixHandler xrest parents name resDisp ys = do - master <- newName "master" - sub <- newName "sub" - toMaster <- newName "toMaster" - app404 <- newName "_app404" - handler405 <- newName "_handler405" - method <- newName "_method" +buildCaller mds xrest parents name resDisp ys = do + getEnv <- newName "yesod_dispatch_env" + req <- newName "req" - let pat = map VarP [master, sub, toMaster, app404, handler405, method] + method <- [|$(mdsMethod mds) $(return $ VarE req)|] + let pat = map VarP [getEnv, req] + -- Create the route let route = routeFromDynamics parents name ys @@ -281,13 +298,14 @@ Methods _ ms -> do handler <- newName "handler" + env <- [|$(return $ VarE getEnv) (Just $(return route))|] + -- Run the whole thing - runner <- [|$(runHandler) - $(return $ VarE handler) - $(return $ VarE master) - $(return $ VarE sub) + runner <- [|$(return $ VarE handler) + $(return $ VarE getEnv) (Just $(return route)) - $(return $ VarE toMaster)|] + $(return $ VarE req) + |] let myLet handlerExp = LetE [FunD handler [Clause [] (NormalB handlerExp) []]] runner @@ -295,32 +313,40 @@ if null ms then do -- Just a single handler - fh <- fixHandler - let he = fh `AppE` foldl' (\a b -> a `AppE` VarE b) (VarE $ mkName $ "handle" ++ name) ys - return $ myLet he + base <- mdsGetHandler mds Nothing name + let he = foldl' (\a b -> a `AppE` VarE b) base ys + runHandler <- mdsRunHandler mds + return $ myLet $ runHandler `AppE` he else do -- Individual methods - mf <- [|Map.lookup $(return $ VarE method) $(return $ VarE $ methodMapName name)|] + mf <- [|Map.lookup $(return method) $(return $ VarE $ methodMapName name)|] f <- newName "f" let apply = foldl' (\a b -> a `AppE` VarE b) (VarE f) ys - let body405 = - VarE handler405 - `AppE` route + body405 <- + [|$(mdsRunHandler mds) + $(mds405 mds) + $(return $ VarE getEnv) + (Just $(return route)) + $(return $ VarE req) + |] return $ CaseE mf [ Match (ConP 'Just [VarP f]) (NormalB $ myLet apply) [] , Match (ConP 'Nothing []) (NormalB body405) [] ] Subsite _ getSub -> do - let sub2 = foldl' (\a b -> a `AppE` VarE b) (VarE (mkName getSub) `AppE` VarE sub) ys - [|$(dispatcher) - $(return $ VarE master) + sub <- newName "sub" + let sub2 = LamE [VarP sub] + (foldl' (\a b -> a `AppE` VarE b) (VarE (mkName getSub) `AppE` VarE sub) ys) + [|$(mdsSubDispatcher mds) + $(mdsRunHandler mds) $(return sub2) - ($(return $ VarE toMaster) . $(return route)) - $(return $ VarE app404) - ($(return $ VarE handler405) . $(return route)) - $(return $ VarE method) - $(return $ VarE xrest) + $(return route) + $(return $ VarE getEnv) + ($(mdsSetPathInfo mds) + $(return $ VarE xrest) + $(return $ VarE req) + ) |] return $ LamE pat exp diff --git a/Yesod/Routes/TH/ParseRoute.hs b/Yesod/Routes/TH/ParseRoute.hs new file mode 100644 --- /dev/null +++ b/Yesod/Routes/TH/ParseRoute.hs @@ -0,0 +1,178 @@ +{-# LANGUAGE TemplateHaskell #-} +module Yesod.Routes.TH.ParseRoute + ( -- ** ParseRoute + mkParseRouteInstance + ) where + +import Yesod.Routes.TH.Types +import Language.Haskell.TH.Syntax +import Data.Text (pack) +import Web.PathPieces (PathPiece (..), PathMultiPiece (..)) +import Yesod.Routes.Class +import qualified Yesod.Routes.Dispatch as D +import Data.List (foldl') +import Control.Applicative ((<$>)) +import Data.Maybe (catMaybes) +import Control.Monad (forM) +import Control.Monad (join) + +-- | Clauses for the 'parseRoute' method. +mkParseRouteClauses :: [ResourceTree a] -> Q [Clause] +mkParseRouteClauses ress' = do + pieces <- newName "pieces0" + dispatch <- newName "dispatch" + query <- newName "_query" + + -- The 'D.Route's used in the dispatch function + routes <- mapM (buildRoute query) ress + + -- The dispatch function itself + toDispatch <- [|D.toDispatch|] + let dispatchFun = FunD dispatch + [Clause + [] + (NormalB $ toDispatch `AppE` ListE routes) + [] + ] + + join' <- [|join|] + let body = join' `AppE` (VarE dispatch `AppE` VarE pieces) + return $ return $ Clause + [TupP [VarP pieces, VarP query]] + (NormalB body) + [dispatchFun] + where + ress = map noMethods $ flatten ress' + noMethods (FlatResource a b c d) = FlatResource a b c $ noMethods' d + noMethods' (Methods a _) = Methods a [] + noMethods' (Subsite a b) = Subsite a b + +mkParseRouteInstance :: Type -> [ResourceTree a] -> Q Dec +mkParseRouteInstance typ ress = do + cls <- mkParseRouteClauses ress + return $ InstanceD [] (ConT ''ParseRoute `AppT` typ) + [ FunD 'parseRoute cls + ] + +-- | Build a single 'D.Route' expression. +buildRoute :: Name -> FlatResource a -> Q Exp +buildRoute query (FlatResource parents name resPieces resDisp) = do + -- First two arguments to D.Route + routePieces <- ListE <$> mapM (convertPiece . snd) allPieces + isMulti <- + case resDisp of + Methods Nothing _ -> [|False|] + _ -> [|True|] + + [|D.Route + $(return routePieces) + $(return isMulti) + $(routeArg3 + query + parents + name + (map snd allPieces) + resDisp) + |] + where + allPieces = concat $ map snd parents ++ [resPieces] + +routeArg3 :: Name -- ^ query string parameters + -> [(String, [(CheckOverlap, Piece a)])] + -> String -- ^ name of resource + -> [Piece a] + -> Dispatch a + -> Q Exp +routeArg3 query parents name resPieces resDisp = do + pieces <- newName "pieces" + + -- Allocate input piece variables (xs) and variables that have been + -- converted via fromPathPiece (ys) + xs <- forM resPieces $ \piece -> + case piece of + Static _ -> return Nothing + Dynamic _ -> Just <$> newName "x" + + -- Note: the zipping with Ints is just a workaround for (apparently) a bug + -- in GHC where the identifiers are considered to be overlapping. Using + -- newName should avoid the problem, but it doesn't. + ys <- forM (zip (catMaybes xs) [1..]) $ \(x, i) -> do + y <- newName $ "y" ++ show (i :: Int) + return (x, y) + + -- In case we have multi pieces at the end + xrest <- newName "xrest" + yrest <- newName "yrest" + + -- Determine the pattern for matching the pieces + pat <- + case resDisp of + Methods Nothing _ -> return $ ListP $ map (maybe WildP VarP) xs + _ -> do + let cons = mkName ":" + return $ foldr (\a b -> ConP cons [maybe WildP VarP a, b]) (VarP xrest) xs + + -- Convert the xs + fromPathPiece' <- [|fromPathPiece|] + xstmts <- forM ys $ \(x, y) -> return $ BindS (VarP y) (fromPathPiece' `AppE` VarE x) + + -- Convert the xrest if appropriate + (reststmts, yrest') <- + case resDisp of + Methods (Just _) _ -> do + fromPathMultiPiece' <- [|fromPathMultiPiece|] + return ([BindS (VarP yrest) (fromPathMultiPiece' `AppE` VarE xrest)], [yrest]) + _ -> return ([], []) + + -- The final expression that actually uses the values we've computed + caller <- buildCaller query xrest parents name resDisp $ map snd ys ++ yrest' + + -- Put together all the statements + just <- [|Just|] + let stmts = concat + [ xstmts + , reststmts + , [NoBindS $ just `AppE` caller] + ] + + errorMsg <- [|error "Invariant violated"|] + let matches = + [ Match pat (NormalB $ DoE stmts) [] + , Match WildP (NormalB errorMsg) [] + ] + + return $ LamE [VarP pieces] $ CaseE (VarE pieces) matches + +-- | The final expression in the individual Route definitions. +buildCaller :: Name -- ^ query string parameters + -> Name -- ^ xrest + -> [(String, [(CheckOverlap, Piece a)])] + -> String -- ^ name of resource + -> Dispatch a + -> [Name] -- ^ ys + -> Q Exp +buildCaller query xrest parents name resDisp ys = do + -- Create the route + let route = routeFromDynamics parents name ys + + case resDisp of + Methods _ _ -> [|Just $(return route)|] + Subsite _ _ -> [|fmap $(return route) $ parseRoute ($(return $ VarE xrest), $(return $ VarE query))|] + +-- | Convert a 'Piece' to a 'D.Piece' +convertPiece :: Piece a -> Q Exp +convertPiece (Static s) = [|D.Static (pack $(lift s))|] +convertPiece (Dynamic _) = [|D.Dynamic|] + +routeFromDynamics :: [(String, [(CheckOverlap, Piece a)])] -- ^ parents + -> String -- ^ constructor name + -> [Name] + -> Exp +routeFromDynamics [] name ys = foldl' (\a b -> a `AppE` VarE b) (ConE $ mkName name) ys +routeFromDynamics ((parent, pieces):rest) name ys = + foldl' (\a b -> a `AppE` b) (ConE $ mkName parent) here + where + (here', ys') = splitAt (length $ filter (isDynamic . snd) pieces) ys + isDynamic Dynamic{} = True + isDynamic _ = False + here = map VarE here' ++ [routeFromDynamics rest name ys'] diff --git a/Yesod/Routes/TH/RouteAttrs.hs b/Yesod/Routes/TH/RouteAttrs.hs new file mode 100644 --- /dev/null +++ b/Yesod/Routes/TH/RouteAttrs.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE RecordWildCards #-} +module Yesod.Routes.TH.RouteAttrs + ( mkRouteAttrsInstance + ) where + +import Yesod.Routes.TH.Types +import Yesod.Routes.Class +import Language.Haskell.TH.Syntax +import Data.Set (fromList) +import Data.Text (pack) + +mkRouteAttrsInstance :: Type -> [ResourceTree a] -> Q Dec +mkRouteAttrsInstance typ ress = do + clauses <- mapM (goTree id) ress + return $ InstanceD [] (ConT ''RouteAttrs `AppT` typ) + [ FunD 'routeAttrs $ concat clauses + ] + +goTree :: (Pat -> Pat) -> ResourceTree a -> Q [Clause] +goTree front (ResourceLeaf res) = fmap return $ goRes front res +goTree front (ResourceParent name pieces trees) = + fmap concat $ mapM (goTree front') trees + where + ignored = ((replicate toIgnore WildP ++) . return) + toIgnore = length $ filter (isDynamic . snd) pieces + isDynamic Dynamic{} = True + isDynamic Static{} = False + front' = front . ConP (mkName name) . ignored + +goRes :: (Pat -> Pat) -> Resource a -> Q Clause +goRes front Resource {..} = + return $ Clause + [front $ RecP (mkName resourceName) []] + (NormalB $ VarE 'fromList `AppE` ListE (map toText resourceAttrs)) + [] + where + toText s = VarE 'pack `AppE` LitE (StringL s) diff --git a/Yesod/Routes/TH/Types.hs b/Yesod/Routes/TH/Types.hs --- a/Yesod/Routes/TH/Types.hs +++ b/Yesod/Routes/TH/Types.hs @@ -6,10 +6,12 @@ , Piece (..) , Dispatch (..) , CheckOverlap + , FlatResource (..) -- ** Helper functions , resourceMulti , resourceTreePieces , resourceTreeName + , flatten ) where import Language.Haskell.TH.Syntax @@ -37,16 +39,17 @@ { resourceName :: String , resourcePieces :: [(CheckOverlap, Piece typ)] , resourceDispatch :: Dispatch typ + , resourceAttrs :: [String] } deriving Show type CheckOverlap = Bool instance Functor Resource where - fmap f (Resource a b c) = Resource a (map (second $ fmap f) b) (fmap f c) + fmap f (Resource a b c d) = Resource a (map (second $ fmap f) b) (fmap f c) d instance Lift t => Lift (Resource t) where - lift (Resource a b c) = [|Resource $(lift a) $(lift b) $(lift c)|] + lift (Resource a b c d) = [|Resource a b c d|] data Piece typ = Static String | Dynamic typ deriving Show @@ -82,3 +85,13 @@ resourceMulti :: Resource typ -> Maybe typ resourceMulti Resource { resourceDispatch = Methods (Just t) _ } = Just t resourceMulti _ = Nothing + +data FlatResource a = FlatResource [(String, [(CheckOverlap, Piece a)])] String [(CheckOverlap, Piece a)] (Dispatch a) + +flatten :: [ResourceTree a] -> [FlatResource a] +flatten = + concatMap (go id) + where + go front (ResourceLeaf (Resource a b c _)) = [FlatResource (front []) a b c] + go front (ResourceParent name pieces children) = + concatMap (go (front . ((name, pieces):))) children diff --git a/test/Hierarchy.hs b/test/Hierarchy.hs --- a/test/Hierarchy.hs +++ b/test/Hierarchy.hs @@ -1,4 +1,5 @@ {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -8,10 +9,12 @@ module Hierarchy ( hierarchy , Dispatcher (..) - , RunHandler (..) + , runHandler , Handler , App , toText + , Env (..) + , subDispatch ) where import Test.Hspec @@ -22,6 +25,8 @@ import Language.Haskell.TH.Syntax import qualified Yesod.Routes.Class as YRC import Data.Text (Text, pack, append) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as S8 class ToText a where toText :: a -> Text @@ -29,29 +34,42 @@ instance ToText Text where toText = id instance ToText String where toText = pack -type Handler sub master = Text -type App sub master = (Text, Maybe (YRC.Route master)) +type Handler sub master a = a +type Request = ([Text], ByteString) -- path info, method +type App sub master = Request -> (Text, Maybe (YRC.Route master)) +data Env sub master = Env + { envToMaster :: YRC.Route sub -> YRC.Route master + , envSub :: sub + , envMaster :: master + } +subDispatch + :: (Env sub master -> App sub master) + -> (Handler sub master Text -> Env sub master -> Maybe (YRC.Route sub) -> App sub master) + -> (master -> sub) + -> (YRC.Route sub -> YRC.Route master) + -> Env master master + -> App sub master +subDispatch handler _runHandler getSub toMaster env req = + handler env' req + where + env' = env + { envToMaster = envToMaster env . toMaster + , envSub = getSub $ envMaster env + } + class Dispatcher sub master where - dispatcher - :: master - -> sub - -> (YRC.Route sub -> YRC.Route master) - -> App sub master -- ^ 404 page - -> (YRC.Route sub -> App sub master) -- ^ 405 page - -> Text -- ^ method - -> [Text] - -> App sub master + dispatcher :: Env sub master -> App sub master -class RunHandler sub master where - runHandler - :: Handler sub master - -> master - -> sub - -> Maybe (YRC.Route sub) - -> (YRC.Route sub -> YRC.Route master) - -> App sub master +runHandler + :: ToText a + => Handler sub master a + -> Env sub master + -> Maybe (Route sub) + -> App sub master +runHandler h Env {..} route _ = (toText h, fmap envToMaster route) + data Hierarchy = Hierarchy do @@ -63,7 +81,17 @@ /table/#Text TableR GET |] rrinst <- mkRenderRouteInstance (ConT ''Hierarchy) $ map (fmap parseType) resources - dispatch <- mkDispatchClause [|runHandler|] [|dispatcher|] [|toText|] resources + prinst <- mkParseRouteInstance (ConT ''Hierarchy) $ map (fmap parseType) resources + dispatch <- mkDispatchClause MkDispatchSettings + { mdsRunHandler = [|runHandler|] + , mdsSubDispatcher = [|subDispatch|] + , mdsGetPathInfo = [|fst|] + , mdsMethod = [|snd|] + , mdsSetPathInfo = [|\p (_, m) -> (p, m)|] + , mds404 = [|pack "404"|] + , mds405 = [|pack "405"|] + , mdsGetHandler = defaultGetHandler + } resources return $ InstanceD [] @@ -71,32 +99,41 @@ `AppT` ConT ''Hierarchy `AppT` ConT ''Hierarchy) [FunD (mkName "dispatcher") [dispatch]] + : prinst : rrinst -getHomeR :: Handler sub master +getHomeR :: Handler sub master String getHomeR = "home" -getAdminRootR :: Int -> Handler sub master +getAdminRootR :: Int -> Handler sub master Text getAdminRootR i = pack $ "admin root: " ++ show i -getLoginR :: Int -> Handler sub master +getLoginR :: Int -> Handler sub master Text getLoginR i = pack $ "login: " ++ show i -postLoginR :: Int -> Handler sub master +postLoginR :: Int -> Handler sub master Text postLoginR i = pack $ "post login: " ++ show i -getTableR :: Int -> Text -> Handler sub master +getTableR :: Int -> Text -> Handler sub master Text getTableR _ t = append "TableR " t -instance RunHandler Hierarchy master where - runHandler h _ _ subRoute toMaster = (h, fmap toMaster subRoute) - hierarchy :: Spec hierarchy = describe "hierarchy" $ do it "renders root correctly" $ renderRoute (AdminR 5 AdminRootR) @?= (["admin", "5"], []) it "renders table correctly" $ renderRoute (AdminR 6 $ TableR "foo") @?= (["admin", "6", "table", "foo"], []) - let disp m ps = dispatcher Hierarchy Hierarchy id (pack "404", Nothing) (\route -> (pack "405", Just route)) (pack m) (map pack ps) + let disp m ps = dispatcher + (Env + { envToMaster = id + , envMaster = Hierarchy + , envSub = Hierarchy + }) + (map pack ps, S8.pack m) it "dispatches root correctly" $ disp "GET" ["admin", "7"] @?= ("admin root: 7", Just $ AdminR 7 AdminRootR) it "dispatches table correctly" $ disp "GET" ["admin", "8", "table", "bar"] @?= ("TableR bar", Just $ AdminR 8 $ TableR "bar") + it "parses" $ do + parseRoute ([], []) @?= Just HomeR + parseRoute ([], [("foo", "bar")]) @?= Just HomeR + parseRoute (["admin", "5"], []) @?= Just (AdminR 5 AdminRootR) + parseRoute (["admin!", "5"], []) @?= (Nothing :: Maybe (Route Hierarchy)) diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -1,4 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns#-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ExistentialQuantification #-} @@ -15,11 +17,13 @@ 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.Parse (parseRoutesNoCheck, parseTypeTree, TypeTree (..)) import Yesod.Routes.Overlap (findOverlapNames) import Yesod.Routes.TH hiding (Dispatch) import Language.Haskell.TH.Syntax import Hierarchy +import qualified Data.ByteString.Char8 as S8 +import qualified Data.Set as Set result :: ([Text] -> Maybe Int) -> Dispatch Int result f ts = f ts @@ -76,6 +80,8 @@ MySub = MySubRoute ([Text], [(Text, Text)]) deriving (Show, Eq, Read) renderRoute (MySubRoute x) = x +instance ParseRoute MySub where + parseRoute = Just . MySubRoute getMySub :: MyApp -> MySub getMySub MyApp = MySub @@ -91,22 +97,44 @@ MySubParam = ParamRoute Char deriving (Show, Eq, Read) renderRoute (ParamRoute x) = ([singleton x], []) +instance ParseRoute MySubParam where + parseRoute ([unpack -> [x]], _) = Just $ ParamRoute x + parseRoute _ = Nothing getMySubParam :: MyApp -> Int -> MySubParam getMySubParam _ = MySubParam do texts <- [t|[Text]|] - let ress = map ResourceLeaf - [ Resource "RootR" [] $ Methods Nothing ["GET"] - , 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" + let resLeaves = map ResourceLeaf + [ Resource "RootR" [] (Methods Nothing ["GET"]) ["foo", "bar"] + , 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") [] ] + resParent = ResourceParent + "ParentR" + [ (True, Static "foo") + , (True, Dynamic $ ConT ''Text) + ] + [ ResourceLeaf $ Resource "ChildR" [] (Methods Nothing ["GET"]) ["child"] + ] + ress = resParent : resLeaves addCheck = map ((,) True) rrinst <- mkRenderRouteInstance (ConT ''MyApp) ress - dispatch <- mkDispatchClause [|runHandler|] [|dispatcher|] [|toText|] ress + rainst <- mkRouteAttrsInstance (ConT ''MyApp) ress + prinst <- mkParseRouteInstance (ConT ''MyApp) ress + dispatch <- mkDispatchClause MkDispatchSettings + { mdsRunHandler = [|runHandler|] + , mdsSubDispatcher = [|subDispatch dispatcher|] + , mdsGetPathInfo = [|fst|] + , mdsMethod = [|snd|] + , mdsSetPathInfo = [|\p (_, m) -> (p, m)|] + , mds404 = [|pack "404"|] + , mds405 = [|pack "405"|] + , mdsGetHandler = defaultGetHandler + } ress return $ InstanceD [] @@ -114,19 +142,29 @@ `AppT` ConT ''MyApp `AppT` ConT ''MyApp) [FunD (mkName "dispatcher") [dispatch]] + : prinst + : rainst : rrinst -instance RunHandler MyApp master where - runHandler h _ _ subRoute toMaster = (h, fmap toMaster subRoute) - instance Dispatcher MySub master where - dispatcher _ _ toMaster _ _ _ pieces = (pack $ "subsite: " ++ show pieces, Just $ toMaster $ MySubRoute (pieces, [])) + dispatcher env (pieces, _method) = + ( pack $ "subsite: " ++ show pieces + , Just $ envToMaster env route + ) + where + route = MySubRoute (pieces, []) instance Dispatcher MySubParam master where - dispatcher _ (MySubParam i) toMaster app404 _ _ pieces = + dispatcher env (pieces, method) = case map unpack pieces of - [[c]] -> (pack $ "subparam " ++ show i ++ ' ' : [c], Just $ toMaster $ ParamRoute c) - _ -> app404 + [[c]] -> + let route = ParamRoute c + toMaster = envToMaster env + MySubParam i = envSub env + in ( pack $ "subparam " ++ show i ++ ' ' : [c] + , Just $ toMaster route + ) + _ -> (pack "404", Nothing) {- thDispatchAlias @@ -232,10 +270,16 @@ @?= (map pack ["subparam", "6", "c"], []) describe "thDispatch" $ do - let disp m ps = dispatcher MyApp MyApp id (pack "404", Nothing) (\route -> (pack "405", Just route)) (pack m) (map pack ps) + let disp m ps = dispatcher + (Env + { envToMaster = id + , envMaster = MyApp + , envSub = MyApp + }) + (map pack ps, S8.pack m) it "routes to root" $ disp "GET" [] @?= (pack "this is the root", Just RootR) it "POST root is 405" $ disp "POST" [] @?= (pack "405", Just RootR) - it "invalid page is a 404" $ disp "GET" ["not-found"] @?= (pack "404", Nothing) + it "invalid page is a 404" $ disp "GET" ["not-found"] @?= (pack "404", Nothing :: Maybe (YRC.Route MyApp)) it "routes to blog post" $ disp "GET" ["blog", "somepost"] @?= (pack "some blog post: somepost", Just $ BlogPostR $ pack "somepost") it "routes to blog post, POST method" $ disp "POST" ["blog", "somepost2"] @@ -247,6 +291,11 @@ it "routes to subparam" $ disp "PUT" ["subparam", "6", "q"] @?= (pack "subparam 6 q", Just $ SubparamR 6 $ ParamRoute 'q') + describe "parsing" $ do + it "subsites work" $ do + parseRoute ([pack "subsite", pack "foo"], [(pack "bar", pack "baz")]) @?= + Just (SubsiteR $ MySubRoute ([pack "foo"], [(pack "bar", pack "baz")])) + describe "overlap checking" $ do it "catches overlapping statics" $ do let routes = [parseRoutesNoCheck| @@ -298,7 +347,24 @@ /bar/baz Foo3 |] findOverlapNames routes @?= [] + describe "routeAttrs" $ do + it "works" $ do + routeAttrs RootR @?= Set.fromList [pack "foo", pack "bar"] + it "hierarchy" $ do + routeAttrs (ParentR (pack "ignored") ChildR) @?= Set.singleton (pack "child") hierarchy + describe "parseRouteTyoe" $ do + let success s t = it s $ parseTypeTree s @?= Just t + failure s = it s $ parseTypeTree s @?= Nothing + success "Int" $ TTTerm "Int" + success "(Int)" $ TTTerm "Int" + failure "(Int" + failure "(Int))" + failure "[Int" + failure "[Int]]" + success "[Int]" $ TTList $ TTTerm "Int" + success "Foo-Bar" $ TTApp (TTTerm "Foo") (TTTerm "Bar") + success "Foo-Bar-Baz" $ TTApp (TTTerm "Foo") (TTTerm "Bar") `TTApp` TTTerm "Baz" getRootR :: Text getRootR = pack "this is the root" @@ -311,3 +377,6 @@ handleWikiR :: [Text] -> String handleWikiR ts = "the wiki: " ++ show ts + +getChildR :: Text -> Text +getChildR = id diff --git a/yesod-routes.cabal b/yesod-routes.cabal --- a/yesod-routes.cabal +++ b/yesod-routes.cabal @@ -1,5 +1,5 @@ name: yesod-routes -version: 1.1.2 +version: 1.2.0 license: MIT license-file: LICENSE author: Michael Snoyman @@ -29,6 +29,8 @@ Yesod.Routes.Overlap other-modules: Yesod.Routes.TH.Dispatch Yesod.Routes.TH.RenderRoute + Yesod.Routes.TH.ParseRoute + Yesod.Routes.TH.RouteAttrs Yesod.Routes.TH.Types ghc-options: -Wall @@ -46,6 +48,7 @@ , containers , template-haskell , path-pieces + , bytestring ghc-options: -Wall source-repository head