yesod-routes-1.2.0.1/0000755000000000000000000000000012154156377012514 5ustar0000000000000000yesod-routes-1.2.0.1/LICENSE0000644000000000000000000000207512154156377013525 0ustar0000000000000000Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. yesod-routes-1.2.0.1/yesod-routes.cabal0000644000000000000000000000372612154156377016152 0ustar0000000000000000name: yesod-routes version: 1.2.0.1 license: MIT license-file: LICENSE author: Michael Snoyman maintainer: Michael Snoyman synopsis: Efficient routing for Yesod. description: Provides an efficient routing system, a parser and TH code generation. category: Web, Yesod stability: Stable cabal-version: >= 1.8 build-type: Simple homepage: http://www.yesodweb.com/ extra-source-files: test/main.hs library build-depends: base >= 4 && < 5 , text >= 0.5 && < 0.12 , vector >= 0.8 && < 0.11 , containers >= 0.2 , template-haskell , path-pieces >= 0.1 && < 0.2 exposed-modules: Yesod.Routes.Dispatch 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.ParseRoute Yesod.Routes.TH.RouteAttrs Yesod.Routes.TH.Types ghc-options: -Wall test-suite runtests type: exitcode-stdio-1.0 main-is: main.hs hs-source-dirs: test other-modules: Hierarchy build-depends: base >= 4.3 && < 5 , yesod-routes , text >= 0.5 && < 0.12 , HUnit >= 1.2 && < 1.3 , hspec >= 1.3 , containers , template-haskell , path-pieces , bytestring ghc-options: -Wall source-repository head type: git location: https://github.com/yesodweb/yesod yesod-routes-1.2.0.1/Setup.lhs0000644000000000000000000000016212154156377014323 0ustar0000000000000000#!/usr/bin/env runhaskell > module Main where > import Distribution.Simple > main :: IO () > main = defaultMain yesod-routes-1.2.0.1/Yesod/0000755000000000000000000000000012154156377013577 5ustar0000000000000000yesod-routes-1.2.0.1/Yesod/Routes/0000755000000000000000000000000012154156377015060 5ustar0000000000000000yesod-routes-1.2.0.1/Yesod/Routes/TH.hs0000644000000000000000000000072512154156377015733 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module Yesod.Routes.TH ( 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 yesod-routes-1.2.0.1/Yesod/Routes/Overlap.hs0000644000000000000000000000462612154156377017034 0ustar0000000000000000-- | 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 yesod-routes-1.2.0.1/Yesod/Routes/Class.hs0000644000000000000000000000110212154156377016453 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} {-# 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 yesod-routes-1.2.0.1/Yesod/Routes/Dispatch.lhs0000644000000000000000000002555012154156377017336 0ustar0000000000000000Title: Optimized route dispatch code Let's start with our module declaration and imports. > module Yesod.Routes.Dispatch > ( Piece (..) > , Route (..) > , Dispatch > , toDispatch > ) where > > import Data.Text (Text) > import qualified Data.Vector as V > import Data.Maybe (fromMaybe, mapMaybe) > import qualified Data.Map as Map > import Data.List (sortBy) > import Data.Ord (comparing) > import Control.Arrow (second) > import Control.Exception (assert) This module provides an efficient routing system. The code is pure, requires no fancy extensions, has no Template Haskell involved and is not Yesod specific. It does, however, assume a routing system similar to that of Yesod. Routing works based on splitting up a path into its components. This is handled very well by both the web-routes and http-types packages, and this module does not duplicate that functionality. Instead, it assumes that the requested path will be provided as a list of 'Text's. A route will be specified by a list of pieces (using the 'Piece' datatype). > data Piece = Static Text | Dynamic Each piece is either a static piece- which is required to match a component of the path precisely- or a dynamic piece, which will match any component. Additionally, a route can optionally match all remaining components in the path, or fail if extra components exist. Usually, the behavior of dynamic is not what you really want. Often times, you will want to match integers, or slugs, or some other limited format. This brings us nicely to the dispatch function. Each route provides a function of type: > type Dispatch res = [Text] -> Maybe res The res argument is application-specific. For example, in a simple WAI application, it could be the Application datatype. The important thing to point out about Dispatch is that is takes a list of 'Text's and returns its response in a Maybe. This gives you a chance to have finer-grained control over how individual components are parsed. If you don't want to deal with it, you return 'Nothing' and routing continues. Note: You do *not* need to perform any checking on your static pieces, this module handles that for you automatically. So each route is specified by: > data Route res = Route > { rhPieces :: [Piece] > , rhHasMulti :: Bool > , rhDispatch :: Dispatch res > } Your application needs to provide this module with a list of routes, and then this module will give you back a new dispatch function. In other words: > toDispatch :: [Route res] -> Dispatch res > toDispatch rhs = > bcToDispatch bc > where > bc = toBC rhs In addition to the requirements listed above for routing, we add one extra rule: your specified list of routes is treated as ordered, with the earlier ones matching first. If you have an overlap between two routes, the first one will be dispatched. The simplest approach would be to loop through all of your routes and compare against the path components. But this has linear complexity. Many existing frameworks (Rails and Django at least) have such algorithms, usually based on regular expressions. But we can provide two optimizations: * Break up routes based on how many components they can match. We can then select which group of routes to continue testing. This lookup runs in constant time. * Use a Map to reduce string comparisons for each route to logarithmic complexity. Let's start with the first one. Each route has a fixed number of pieces. Let's call this *n*. If that route can also match trailing components (rhHasMulti above), then it will match *n* and up. Otherwise, it will match specifically on *n*. If *max(n)* is the maximum value of *n* for all routes, what we need is (*max(n)* + 2) groups: a zero group (matching a request for the root of the application), 1 - *max(n)* groups, and a final extra group containing all routes that can match more than *max(n)* components. This group will consist of all the routes with rhHasMulti, and only those routes. > data ByCount res = ByCount > { bcVector :: !(V.Vector (PieceMap res)) > , bcRest :: !(PieceMap res) > } We haven't covered PieceMap yet; it is used for the second optimization. We'll discuss it below. The following function breaks up a list of routes into groups. Again, please ignore the PieceMap references for the moment. > toBC :: [Route res] -> ByCount res > toBC rhs = > ByCount > { bcVector = groups > , bcRest = allMultis > } > where Determine the value of *max(n)*. > maxLen > | null rhs = 0 > | otherwise = maximum $ map (length . rhPieces) rhs Get the list of all routes which can have multis. This will make up the *rest* group. > allMultis = toPieceMap maxLen $ filter rhHasMulti rhs And now get all the numbered groups. For each group, we need to get all routes with *n* components, __and__ all routes with less than *n* components and that have rhHasMulti set to True. > groups = V.map group $ V.enumFromN 0 (maxLen + 1) > group i = toPieceMap i $ filter (canHaveLength i) rhs > > canHaveLength :: Int -> Route res -> Bool > canHaveLength i rh = > len == i || (len < i && rhHasMulti rh) > where > len = length $ rhPieces rh Next we'll set up our routing by maps. What we need is a bunch of nested Maps. For example, if we have the following routings: /foo/bar/1 /foo/baz/2 We would want something that looks vaguely like: /foo /bar /1 /baz /2 But there's an added complication: we need to deal with dynamic compnents and HasMulti as well. So what we'd really have is routes looking like: /foo/bar/1 /foo/baz/2 /*dynamic*/bin/3 /multi/*bunch of multis* We can actually simplify away the multi business. Remember that for each group, we will have a fixed number of components to match. In the list above, it's three. Even though the last route only has one component, we can actually just fill up the missing components with *dynamic*, which will give the same result for routing. In other words, we'll treat it as: /foo /bar /1 /baz /2 /*dynamic* /bin /3 /multi /*dynamic* /*dynamic* What we need is then two extra features on our datatype: * Support both a 'Map Text PieceMap' for static pieces, and a general 'PieceMap' for all dynamic pieces. * An extra constructive after we've gone three levels deep, to provide all matching routes. What we end up with is: > data PieceMap res = PieceMap > { pmDynamic :: PieceMap res > , pmStatic :: Map.Map Text (PieceMap res) > } | PieceMapEnd [(Int, Dispatch res)] Note that the PieceMapEnd is a list of pairs, including an Int. Since the map process will confuse the original order of our routes, we need some way to get that back to make sure overlapping is handled correctly. We'll need two pieces of information to make a PieceMap: the depth to drill down to, and the routes in the current group. We'll immediately zip up those routes with an Int to indicate route priority. > toPieceMap :: Int -> [Route res] -> PieceMap res > toPieceMap depth = toPieceMap' depth . zip [1..] > > toPieceMap' :: Int > -> [(Int, Route res)] > -> PieceMap res The stopping case: we've exhausted the full depth, so let's put together a PieceMapEnd. Technically speaking, the sort here is unnecessary, since we'll sort again later. However, that second sorting occurs during each dispatch occurrence, whereas this sorting only occurs once, in the initial construction of the PieceMap. Therefore, we presort here. > toPieceMap' 0 rhs = > PieceMapEnd $ map (second rhDispatch) > $ sortBy (comparing fst) rhs Note also that we apply rhDispatch to the route. We are no longer interested in the rest of the route information, so it can be discarded. Now the heart of this algorithm: we construct the pmDynamic and pmStatic records. For both, we recursively call toPieceMap' again, with the depth knocked down by 1. > toPieceMap' depth rhs = PieceMap > { pmDynamic = toPieceMap' depth' dynamics > , pmStatic = Map.map (toPieceMap' depth') statics > } > where > depth' = depth - 1 We turn our list of routes into a list of pairs. The first item in the pair gives the next piece, and the second gives the route again, minus that piece. > pairs = map toPair rhs > toPair (i, Route (p:ps) b c) = (p, (i, Route ps b c)) And as we mentioned above, for multi pieces we fill in the remaining pieces with Dynamic. > toPair (i, Route [] b c) = assert b (Dynamic, (i, Route [] b c)) Next, we break up our list of dynamics. > getDynamic (Dynamic, rh) = Just rh > getDynamic _ = Nothing > dynamics = mapMaybe getDynamic pairs And now we make a Map for statics. Note that Map.fromList would not be appropriate here, since it would only keep one route per Text. > getStatic (Static t, rh) = Just $ Map.singleton t [rh] > getStatic _ = Nothing > statics = Map.unionsWith (++) $ mapMaybe getStatic pairs The time has come to actually dispatch. > bcToDispatch :: ByCount res -> Dispatch res > bcToDispatch (ByCount vec rest) ts0 = > bcToDispatch' ts0 pm0 > where Get the PieceMap for the appropriate group. If the length of the requested path is greater than *max(n)*, then use the "rest" group. > pm0 = fromMaybe rest $ vec V.!? length ts0 Stopping case: we've found our list of routes. Sort them, then starting applying their dispatch functions. If the first one returns Nothing, go to the next, and so on. > bcToDispatch' _ (PieceMapEnd r) = firstJust (\f -> f ts0) $ map snd r For each component, get the static PieceMap and the dynamic one, combine them together, and then continue dispatching. > bcToDispatch' (t:ts) (PieceMap dyn sta) = bcToDispatch' ts $ > case Map.lookup t sta of > Nothing -> dyn > Just pm -> append dyn pm Handle an impossible case that should never happen. > bcToDispatch' [] _ = assert False Nothing Helper function: get the first Just response. > firstJust :: (a -> Maybe b) -> [a] -> Maybe b > firstJust _ [] = Nothing > firstJust f (a:as) = maybe (firstJust f as) Just $ f a Combine two PieceMaps together. > append :: PieceMap res -> PieceMap res -> PieceMap res At the end, just combine the list of routes. But we combine them in such a way so as to preserve their order. Since a and b come presorted (as mentioned above), we can just merge the two lists together in linear time. > append (PieceMapEnd a) (PieceMapEnd b) = PieceMapEnd $ merge a b Combine the dynamic and static portions of the maps. > append (PieceMap a x) (PieceMap b y) = > PieceMap (append a b) (Map.unionWith append x y) An impossible case. > append _ _ = assert False $ PieceMapEnd [] Our O(n) merge. > merge :: Ord a => [(a, b)] -> [(a, b)] -> [(a, b)] > merge x [] = x > merge [] y = y > merge x@(a@(ai, _):xs) y@(b@(bi, _):ys) > | ai < bi = a : merge xs y > | otherwise = b : merge x ys yesod-routes-1.2.0.1/Yesod/Routes/Parse.hs0000644000000000000000000001437212154156377016475 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DeriveDataTypeable #-} {-# OPTIONS_GHC -fno-warn-missing-fields #-} -- QuasiQuoter module Yesod.Routes.Parse ( parseRoutes , parseRoutesFile , parseRoutesNoCheck , parseRoutesFileNoCheck , parseType , parseTypeTree , TypeTree (..) ) where import Language.Haskell.TH.Syntax import Data.Char (isUpper) import Language.Haskell.TH.Quote 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 -- checking. See documentation site for details on syntax. parseRoutes :: QuasiQuoter parseRoutes = QuasiQuoter { quoteExp = x } where x s = do let res = resourcesFromString s case findOverlapNames res of [] -> lift res z -> error $ "Overlapping routes: " ++ unlines (map show z) parseRoutesFile :: FilePath -> Q Exp parseRoutesFile = parseRoutesFileWith parseRoutes parseRoutesFileNoCheck :: FilePath -> Q Exp parseRoutesFileNoCheck = parseRoutesFileWith parseRoutesNoCheck parseRoutesFileWith :: QuasiQuoter -> FilePath -> Q Exp parseRoutesFileWith qq fp = do qAddDependentFile fp s <- qRunIO $ readUtf8File fp quoteExp qq s readUtf8File :: FilePath -> IO String readUtf8File fp = do h <- SIO.openFile fp SIO.ReadMode SIO.hSetEncoding h SIO.utf8_bom SIO.hGetContents h -- | Same as 'parseRoutes', but performs no overlap checking. parseRoutesNoCheck :: QuasiQuoter parseRoutesNoCheck = QuasiQuoter { quoteExp = lift . resourcesFromString } -- | Convert a multi-line string to a set of resources. See documentation for -- the format of this string. This is a partial function which calls 'error' on -- invalid input. resourcesFromString :: String -> [ResourceTree String] resourcesFromString = fst . parse 0 . lines where parse _ [] = ([], []) parse indent (thisLine:otherLines) | length spaces < indent = ([], thisLine : otherLines) | otherwise = (this others, remainder) where spaces = takeWhile (== ' ') thisLine (others, remainder) = parse indent otherLines' (this, otherLines') = case takeWhile (/= "--") $ words thisLine of [pattern, constr] | last constr == ':' -> let (children, otherLines'') = parse (length spaces + 1) otherLines (pieces, Nothing) = piecesFromString $ drop1Slash pattern in ((ResourceParent (init constr) pieces children :), otherLines'') (pattern:constr:rest) -> let (pieces, mmulti) = piecesFromString $ drop1Slash pattern (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 [] | all (all isUpper) rest = Methods mmulti rest dispatchFromString [subTyp, subFun] Nothing = Subsite subTyp subFun dispatchFromString [_, _] Just{} = error "Subsites cannot have a multipiece" dispatchFromString rest _ = error $ "Invalid list of methods: " ++ show rest drop1Slash :: String -> String drop1Slash ('/':x) = x drop1Slash x = x piecesFromString :: String -> ([(CheckOverlap, Piece String)], Maybe String) piecesFromString "" = ([], Nothing) piecesFromString x = case (this, rest) of (Left typ, ([], Nothing)) -> ([], Just typ) (Left _, _) -> error "Multipiece must be last piece" (Right piece, (pieces, mtyp)) -> (piece:pieces, mtyp) where (y, z) = break (== '/') x this = pieceFromString y rest = piecesFromString $ drop 1 z parseType :: String -> Type 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) yesod-routes-1.2.0.1/Yesod/Routes/TH/0000755000000000000000000000000012154156377015373 5ustar0000000000000000yesod-routes-1.2.0.1/Yesod/Routes/TH/RenderRoute.hs0000644000000000000000000001236612154156377020175 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module Yesod.Routes.TH.RenderRoute ( -- ** RenderRoute mkRenderRouteInstance , mkRenderRouteInstance' , mkRouteCons , mkRenderRouteClauses ) where import Yesod.Routes.TH.Types import Language.Haskell.TH.Syntax import Data.Maybe (maybeToList) import Control.Monad (replicateM) import Data.Text (pack) import Web.PathPieces (PathPiece (..), PathMultiPiece (..)) import Yesod.Routes.Class import Data.Monoid (mconcat) -- | Generate the constructors of a route data type. mkRouteCons :: [ResourceTree Type] -> ([Con], [Dec]) mkRouteCons = mconcat . map mkRouteCon where mkRouteCon (ResourceLeaf res) = ([con], []) where con = NormalC (mkName $ resourceName res) $ map (\x -> (NotStrict, x)) $ concat [singles, multi, sub] singles = concatMap (toSingle . snd) $ resourcePieces res toSingle Static{} = [] toSingle (Dynamic typ) = [typ] multi = maybeToList $ resourceMulti res sub = case resourceDispatch res of Subsite { subsiteType = typ } -> [ConT ''Route `AppT` typ] _ -> [] mkRouteCon (ResourceParent name pieces children) = ([con], dec : decs) where (cons, decs) = mkRouteCons children con = NormalC (mkName name) $ map (\x -> (NotStrict, x)) $ concat [singles, [ConT $ mkName name]] dec = DataD [] (mkName name) [] cons [''Show, ''Read, ''Eq] singles = concatMap (toSingle . snd) pieces toSingle Static{} = [] toSingle (Dynamic typ) = [typ] -- | Clauses for the 'renderRoute' method. mkRenderRouteClauses :: [ResourceTree Type] -> Q [Clause] mkRenderRouteClauses = mapM go where isDynamic Dynamic{} = True isDynamic _ = False go (ResourceParent name pieces children) = do let cnt = length $ filter (isDynamic . snd) pieces dyns <- replicateM cnt $ newName "dyn" child <- newName "child" let pat = ConP (mkName name) $ map VarP $ dyns ++ [child] pack' <- [|pack|] tsp <- [|toPathPiece|] let piecesSingle = mkPieces (AppE pack' . LitE . StringL) tsp (map snd pieces) dyns childRender <- newName "childRender" let rr = VarE childRender childClauses <- mkRenderRouteClauses children a <- newName "a" b <- newName "b" colon <- [|(:)|] let cons y ys = InfixE (Just y) colon (Just ys) let pieces' = foldr cons (VarE a) piecesSingle let body = LamE [TupP [VarP a, VarP b]] (TupE [pieces', VarE b]) `AppE` (rr `AppE` VarE child) return $ Clause [pat] (NormalB body) [FunD childRender childClauses] go (ResourceLeaf res) = do let cnt = length (filter (isDynamic . snd) $ resourcePieces res) + maybe 0 (const 1) (resourceMulti res) dyns <- replicateM cnt $ newName "dyn" sub <- case resourceDispatch res of Subsite{} -> fmap return $ newName "sub" _ -> return [] let pat = ConP (mkName $ resourceName res) $ map VarP $ dyns ++ sub pack' <- [|pack|] tsp <- [|toPathPiece|] let piecesSingle = mkPieces (AppE pack' . LitE . StringL) tsp (map snd $ resourcePieces res) dyns piecesMulti <- case resourceMulti res of Nothing -> return $ ListE [] Just{} -> do tmp <- [|toPathMultiPiece|] return $ tmp `AppE` VarE (last dyns) body <- case sub of [x] -> do rr <- [|renderRoute|] a <- newName "a" b <- newName "b" colon <- [|(:)|] let cons y ys = InfixE (Just y) colon (Just ys) let pieces = foldr cons (VarE a) piecesSingle return $ LamE [TupP [VarP a, VarP b]] (TupE [pieces, VarE b]) `AppE` (rr `AppE` VarE x) _ -> do colon <- [|(:)|] let cons a b = InfixE (Just a) colon (Just b) return $ TupE [foldr cons piecesMulti piecesSingle, ListE []] return $ Clause [pat] (NormalB body) [] mkPieces _ _ [] _ = [] mkPieces toText tsp (Static s:ps) dyns = toText s : mkPieces toText tsp ps dyns mkPieces toText tsp (Dynamic{}:ps) (d:dyns) = tsp `AppE` VarE d : mkPieces toText tsp ps dyns mkPieces _ _ ((Dynamic _) : _) [] = error "mkPieces 120" -- | Generate the 'RenderRoute' instance. -- -- This includes both the 'Route' associated type and the -- 'renderRoute' method. This function uses both 'mkRouteCons' and -- 'mkRenderRouteClasses'. mkRenderRouteInstance :: Type -> [ResourceTree Type] -> Q [Dec] mkRenderRouteInstance = mkRenderRouteInstance' [] -- | A more general version of 'mkRenderRouteInstance' which takes an -- additional context. mkRenderRouteInstance' :: Cxt -> Type -> [ResourceTree Type] -> Q [Dec] mkRenderRouteInstance' cxt typ ress = do cls <- mkRenderRouteClauses ress let (cons, decs) = mkRouteCons ress return $ InstanceD cxt (ConT ''RenderRoute `AppT` typ) [ DataInstD [] ''Route [typ] cons clazzes , FunD (mkName "renderRoute") cls ] : decs where clazzes = [''Show, ''Eq, ''Read] yesod-routes-1.2.0.1/Yesod/Routes/TH/Types.hs0000644000000000000000000000610512154156377017035 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module Yesod.Routes.TH.Types ( -- * Data types Resource (..) , ResourceTree (..) , Piece (..) , Dispatch (..) , CheckOverlap , FlatResource (..) -- ** Helper functions , resourceMulti , resourceTreePieces , resourceTreeName , flatten ) where import Language.Haskell.TH.Syntax import Control.Arrow (second) data ResourceTree typ = ResourceLeaf (Resource typ) | ResourceParent String [(CheckOverlap, Piece typ)] [ResourceTree typ] resourceTreePieces :: ResourceTree typ -> [(CheckOverlap, Piece typ)] resourceTreePieces (ResourceLeaf r) = resourcePieces r resourceTreePieces (ResourceParent _ x _) = x resourceTreeName :: ResourceTree typ -> String resourceTreeName (ResourceLeaf r) = resourceName r resourceTreeName (ResourceParent x _ _) = x instance Functor ResourceTree where fmap f (ResourceLeaf r) = ResourceLeaf (fmap f r) fmap f (ResourceParent a b c) = ResourceParent a (map (second $ fmap f) b) $ map (fmap f) c instance Lift t => Lift (ResourceTree t) where lift (ResourceLeaf r) = [|ResourceLeaf $(lift r)|] lift (ResourceParent a b c) = [|ResourceParent $(lift a) $(lift b) $(lift c)|] data Resource typ = Resource { 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 d) = Resource a (map (second $ fmap f) b) (fmap f c) d instance Lift t => Lift (Resource t) where lift (Resource a b c d) = [|Resource a b c d|] data Piece typ = Static String | Dynamic typ deriving Show instance Functor Piece where fmap _ (Static s) = (Static s) fmap f (Dynamic t) = Dynamic (f t) instance Lift t => Lift (Piece t) where lift (Static s) = [|Static $(lift s)|] lift (Dynamic t) = [|Dynamic $(lift t)|] data Dispatch typ = Methods { methodsMulti :: Maybe typ -- ^ type of the multi piece at the end , methodsMethods :: [String] -- ^ supported request methods } | Subsite { subsiteType :: typ , subsiteFunc :: String } deriving Show instance Functor Dispatch where fmap f (Methods a b) = Methods (fmap f a) b fmap f (Subsite a b) = Subsite (f a) b instance Lift t => Lift (Dispatch t) where lift (Methods Nothing b) = [|Methods Nothing $(lift b)|] lift (Methods (Just t) b) = [|Methods (Just $(lift t)) $(lift b)|] lift (Subsite t b) = [|Subsite $(lift t) $(lift b)|] 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 yesod-routes-1.2.0.1/Yesod/Routes/TH/Dispatch.hs0000644000000000000000000003422412154156377017473 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module Yesod.Routes.TH.Dispatch ( -- ** Dispatch mkDispatchClause , MkDispatchSettings (..) , defaultGetHandler ) where import Prelude hiding (exp) import Yesod.Routes.TH.Types import Language.Haskell.TH.Syntax import Data.Maybe (catMaybes) import Control.Monad (forM, replicateM) import Data.Text (pack) import qualified Yesod.Routes.Dispatch as D import qualified Data.Map as Map import Data.Char (toLower) import Web.PathPieces (PathPiece (..), PathMultiPiece (..)) import Control.Applicative ((<$>)) import Data.List (foldl') import Data.Text.Encoding (encodeUtf8) 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 } 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 -- | -- -- This function will generate a single clause that will address all -- your routing needs. It takes four arguments. The fourth (a list of -- 'Resource's) is self-explanatory. We\'ll discuss the first -- three. But first, let\'s cover the terminology. -- -- Dispatching involves a master type and a sub type. When you dispatch to the -- top level type, master and sub are the same. Each time to dispatch to -- another subsite, the sub changes. This requires two changes: -- -- * Getting the new sub value. This is handled via 'subsiteFunc'. -- -- * Figure out a way to convert sub routes to the original master route. To -- address this, we keep a toMaster function, and each time we dispatch to a -- new subsite, we compose it with the constructor for that subsite. -- -- Dispatching acts on two different components: the request method and a list -- of path pieces. If we cannot match the path pieces, we need to return a 404 -- response. If the path pieces match, but the method is not supported, we need -- to return a 405 response. -- -- The final result of dispatch is going to be an application type. A simple -- example would be the WAI Application type. However, our handler functions -- will need more input: the master/subsite, the toMaster function, and the -- type-safe route. Therefore, we need to have another type, the handler type, -- and a function that turns a handler into an application, i.e. -- -- > runHandler :: handler sub master -> master -> sub -> Route sub -> (Route sub -> Route master) -> app -- -- This is the first argument to our function. Note that this will almost -- certainly need to be a method of a typeclass, since it will want to behave -- differently based on the subsite. -- -- Note that the 404 response passed in is an application, while the 405 -- response is a handler, since the former can\'t be passed the type-safe -- route. -- -- In the case of a subsite, we don\'t directly deal with a handler function. -- Instead, we redispatch to the subsite, passing on the updated sub value and -- toMaster function, as well as any remaining, unparsed path pieces. This -- function looks like: -- -- > dispatcher :: master -> sub -> (Route sub -> Route master) -> app -> handler sub master -> Text -> [Text] -> app -- -- Where the parameters mean master, sub, toMaster, 404 response, 405 response, -- request method and path pieces. This is the second argument of our function. -- -- Finally, we need a way to decide which of the possible formats -- should the handler send the data out. Think of each URL holding an -- abstract object which has multiple representation (JSON, plain HTML -- etc). Each client might have a preference on which format it wants -- the abstract object in. For example, a javascript making a request -- (on behalf of a browser) might prefer a JSON object over a plain -- HTML file where as a user browsing with javascript disabled would -- want the page in HTML. The third argument is a function that -- converts the abstract object to the desired representation -- depending on the preferences sent by the client. -- -- The typical values for the first three arguments are, -- @'yesodRunner'@ for the first, @'yesodDispatch'@ for the second and -- @fmap 'chooseRep'@. mkDispatchClause :: MkDispatchSettings -> [ResourceTree a] -> Q Clause mkDispatchClause mds ress' = do -- Allocate the names to be used. Start off with the names passed to the -- function itself (with a 0 suffix). -- -- We don't reuse names so as to avoid shadowing names (triggers warnings -- 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. 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` pieces -- The 'D.Route's used in the dispatch function routes <- mapM (buildRoute mds) ress -- The dispatch function itself toDispatch <- [|D.toDispatch|] let dispatchFun = FunD dispatch [Clause [] (NormalB $ toDispatch `AppE` ListE routes) [] ] -- The input to the clause. 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 mds) ress u <- [|case $(return dispatched) of 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 ress = flatten ress' -- | Determine the name of the method map for a given resource name. methodMapName :: String -> Name methodMapName s = mkName $ "methods" ++ s buildMethodMap :: MkDispatchSettings -> FlatResource a -> Q (Maybe Dec) buildMethodMap _ (FlatResource _ _ _ (Methods _ [])) = return Nothing -- single handle function buildMethodMap mds (FlatResource parents name pieces' (Methods mmulti methods)) = do fromList <- [|Map.fromList|] methods' <- mapM go methods let exp = fromList `AppE` ListE methods' let fun = FunD (methodMapName name) [Clause [] (NormalB exp) []] return $ Just fun where pieces = concat $ map snd parents ++ [pieces'] go method = do 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" 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 :: 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 <- case resDisp of Methods Nothing _ -> [|False|] _ -> [|True|] [|D.Route $(return routePieces) $(return isMulti) $(routeArg3 mds parents name (map snd allPieces) resDisp) |] where allPieces = concat $ map snd parents ++ [resPieces] routeArg3 :: MkDispatchSettings -> [(String, [(CheckOverlap, Piece a)])] -> String -- ^ name of resource -> [Piece a] -> Dispatch a -> Q Exp routeArg3 mds 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 mds 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 :: MkDispatchSettings -> Name -- ^ xrest -> [(String, [(CheckOverlap, Piece a)])] -> String -- ^ name of resource -> Dispatch a -> [Name] -- ^ ys -> Q Exp buildCaller mds xrest parents name resDisp ys = do getEnv <- newName "yesod_dispatch_env" req <- newName "req" method <- [|$(mdsMethod mds) $(return $ VarE req)|] let pat = map VarP [getEnv, req] -- Create the route let route = routeFromDynamics parents name ys exp <- case resDisp of Methods _ ms -> do handler <- newName "handler" env <- [|$(return $ VarE getEnv) (Just $(return route))|] -- Run the whole thing runner <- [|$(return $ VarE handler) $(return $ VarE getEnv) (Just $(return route)) $(return $ VarE req) |] let myLet handlerExp = LetE [FunD handler [Clause [] (NormalB handlerExp) []]] runner if null ms then do -- Just a single handler 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 method) $(return $ VarE $ methodMapName name)|] f <- newName "f" let apply = foldl' (\a b -> a `AppE` VarE b) (VarE f) ys 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 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 route) $(return $ VarE getEnv) ($(mdsSetPathInfo mds) $(return $ VarE xrest) $(return $ VarE req) ) |] return $ LamE pat exp -- | 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'] yesod-routes-1.2.0.1/Yesod/Routes/TH/RouteAttrs.hs0000644000000000000000000000235112154156377020044 0ustar0000000000000000{-# 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) yesod-routes-1.2.0.1/Yesod/Routes/TH/ParseRoute.hs0000644000000000000000000001366012154156377020026 0ustar0000000000000000{-# 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'] yesod-routes-1.2.0.1/test/0000755000000000000000000000000012154156377013473 5ustar0000000000000000yesod-routes-1.2.0.1/test/main.hs0000644000000000000000000003532412154156377014762 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns#-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE CPP #-} import Test.Hspec import Test.HUnit ((@?=)) import Data.Text (Text, pack, unpack, singleton) 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, 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 justRoot :: Dispatch Int justRoot = toDispatch [ Route [] False $ result $ const $ Just 1 ] twoStatics :: Dispatch Int twoStatics = toDispatch [ Route [D.Static $ pack "foo"] False $ result $ const $ Just 2 , Route [D.Static $ pack "bar"] False $ result $ const $ Just 3 ] multi :: Dispatch Int multi = toDispatch [ Route [D.Static $ pack "foo"] False $ result $ const $ Just 4 , Route [D.Static $ pack "bar"] True $ result $ const $ Just 5 ] dynamic :: Dispatch Int dynamic = toDispatch [ Route [D.Static $ pack "foo"] False $ result $ const $ Just 6 , Route [D.Dynamic] False $ result $ \ts -> case ts of [t] -> case reads $ unpack t of [] -> Nothing (i, _):_ -> Just i _ -> error $ "Called dynamic with: " ++ show ts ] overlap :: Dispatch Int overlap = toDispatch [ Route [D.Static $ pack "foo"] False $ result $ const $ Just 20 , Route [D.Static $ pack "foo"] True $ result $ const $ Just 21 , Route [] True $ result $ const $ Just 22 ] test :: Dispatch Int -> [String] -> Maybe Int test dispatch ts = dispatch $ map pack ts data MyApp = MyApp data MySub = MySub instance RenderRoute MySub where data #if MIN_VERSION_base(4,5,0) Route #else YRC.Route #endif 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 data MySubParam = MySubParam Int instance RenderRoute MySubParam where data #if MIN_VERSION_base(4,5,0) Route #else YRC.Route #endif 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 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 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 [] (ConT ''Dispatcher `AppT` ConT ''MyApp `AppT` ConT ''MyApp) [FunD (mkName "dispatcher") [dispatch]] : prinst : rainst : rrinst instance Dispatcher MySub master where dispatcher env (pieces, _method) = ( pack $ "subsite: " ++ show pieces , Just $ envToMaster env route ) where route = MySubRoute (pieces, []) instance Dispatcher MySubParam master where dispatcher env (pieces, method) = case map unpack pieces of [[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 :: (master ~ MyApp, sub ~ MyApp, handler ~ String, app ~ (String, Maybe (YRC.Route MyApp))) => master -> sub -> (YRC.Route sub -> YRC.Route master) -> app -- ^ 404 page -> handler -- ^ 405 page -> Text -- ^ method -> [Text] -> app --thDispatchAlias = thDispatch thDispatchAlias master sub toMaster app404 handler405 method0 pieces0 = case dispatch pieces0 of Just f -> f master sub toMaster app404 handler405 method0 Nothing -> app404 where dispatch = toDispatch [ Route [] False $ \pieces -> case pieces of [] -> do Just $ \master' sub' toMaster' _app404' handler405' method -> let handler = case Map.lookup method methodsRootR of Just f -> f Nothing -> handler405' in runHandler handler master' sub' RootR toMaster' _ -> error "Invariant violated" , Route [D.Static "blog", D.Dynamic] False $ \pieces -> case pieces of [_, x2] -> do y2 <- fromPathPiece x2 Just $ \master' sub' toMaster' _app404' handler405' method -> let handler = case Map.lookup method methodsBlogPostR of Just f -> f y2 Nothing -> handler405' in runHandler handler master' sub' (BlogPostR y2) toMaster' _ -> error "Invariant violated" , Route [D.Static "wiki"] True $ \pieces -> case pieces of _:x2 -> do y2 <- fromPathMultiPiece x2 Just $ \master' sub' toMaster' _app404' _handler405' _method -> let handler = handleWikiR y2 in runHandler handler master' sub' (WikiR y2) toMaster' _ -> error "Invariant violated" , Route [D.Static "subsite"] True $ \pieces -> case pieces of _:x2 -> do Just $ \master' sub' toMaster' app404' handler405' method -> dispatcher master' (getMySub sub') (toMaster' . SubsiteR) app404' handler405' method x2 _ -> error "Invariant violated" , Route [D.Static "subparam", D.Dynamic] True $ \pieces -> case pieces of _:x2:x3 -> do y2 <- fromPathPiece x2 Just $ \master' sub' toMaster' app404' handler405' method -> dispatcher master' (getMySubParam sub' y2) (toMaster' . SubparamR y2) app404' handler405' method x3 _ -> error "Invariant violated" ] methodsRootR = Map.fromList [("GET", getRootR)] methodsBlogPostR = Map.fromList [("GET", getBlogPostR), ("POST", postBlogPostR)] -} main :: IO () main = hspec $ do describe "justRoot" $ do it "dispatches correctly" $ test justRoot [] @?= Just 1 it "fails correctly" $ test justRoot ["foo"] @?= Nothing describe "twoStatics" $ do it "dispatches correctly to foo" $ test twoStatics ["foo"] @?= Just 2 it "dispatches correctly to bar" $ test twoStatics ["bar"] @?= Just 3 it "fails correctly (1)" $ test twoStatics [] @?= Nothing it "fails correctly (2)" $ test twoStatics ["bar", "baz"] @?= Nothing describe "multi" $ do it "dispatches correctly to foo" $ test multi ["foo"] @?= Just 4 it "dispatches correctly to bar" $ test multi ["bar"] @?= Just 5 it "dispatches correctly to bar/baz" $ test multi ["bar", "baz"] @?= Just 5 it "fails correctly (1)" $ test multi [] @?= Nothing it "fails correctly (2)" $ test multi ["foo", "baz"] @?= Nothing describe "dynamic" $ do it "dispatches correctly to foo" $ test dynamic ["foo"] @?= Just 6 it "dispatches correctly to 7" $ test dynamic ["7"] @?= Just 7 it "dispatches correctly to 42" $ test dynamic ["42"] @?= Just 42 it "fails correctly on five" $ test dynamic ["five"] @?= Nothing it "fails correctly on too many" $ test dynamic ["foo", "baz"] @?= Nothing it "fails correctly on too few" $ test dynamic [] @?= Nothing describe "overlap" $ do it "dispatches correctly to foo" $ test overlap ["foo"] @?= Just 20 it "dispatches correctly to foo/bar" $ test overlap ["foo", "bar"] @?= Just 21 it "dispatches correctly to bar" $ test overlap ["bar"] @?= Just 22 it "dispatches correctly to []" $ test overlap [] @?= Just 22 describe "RenderRoute instance" $ do it "renders root correctly" $ renderRoute RootR @?= ([], []) it "renders blog post correctly" $ renderRoute (BlogPostR $ pack "foo") @?= (map pack ["blog", "foo"], []) it "renders wiki correctly" $ renderRoute (WikiR $ map pack ["foo", "bar"]) @?= (map pack ["wiki", "foo", "bar"], []) it "renders subsite correctly" $ renderRoute (SubsiteR $ MySubRoute (map pack ["foo", "bar"], [(pack "baz", pack "bin")])) @?= (map pack ["subsite", "foo", "bar"], [(pack "baz", pack "bin")]) it "renders subsite param correctly" $ renderRoute (SubparamR 6 $ ParamRoute 'c') @?= (map pack ["subparam", "6", "c"], []) describe "thDispatch" $ do 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 :: 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"] @?= (pack "POST some blog post: somepost2", Just $ BlogPostR $ pack "somepost2") it "routes to wiki" $ disp "DELETE" ["wiki", "foo", "bar"] @?= (pack "the wiki: [\"foo\",\"bar\"]", Just $ WikiR $ map pack ["foo", "bar"]) it "routes to subsite" $ disp "PUT" ["subsite", "baz"] @?= (pack "subsite: [\"baz\"]", Just $ SubsiteR $ MySubRoute ([pack "baz"], [])) 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| /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 @?= [] it "proper boolean logic" $ do let routes = [parseRoutesNoCheck| /foo/bar Foo1 /foo/baz Foo2 /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" getBlogPostR :: Text -> String getBlogPostR t = "some blog post: " ++ unpack t postBlogPostR :: Text -> Text postBlogPostR t = pack $ "POST some blog post: " ++ unpack t handleWikiR :: [Text] -> String handleWikiR ts = "the wiki: " ++ show ts getChildR :: Text -> Text getChildR = id yesod-routes-1.2.0.1/test/Hierarchy.hs0000644000000000000000000001033312154156377015745 0ustar0000000000000000{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} module Hierarchy ( hierarchy , Dispatcher (..) , runHandler , Handler , App , toText , Env (..) , subDispatch ) where import Test.Hspec import Test.HUnit import Yesod.Routes.Parse import Yesod.Routes.TH import Yesod.Routes.Class 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 instance ToText Text where toText = id instance ToText String where toText = pack 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 :: Env sub 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 let resources = [parseRoutes| / HomeR GET /admin/#Int AdminR: / AdminRootR GET /login LoginR GET POST /table/#Text TableR GET |] rrinst <- mkRenderRouteInstance (ConT ''Hierarchy) $ map (fmap parseType) 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 [] (ConT ''Dispatcher `AppT` ConT ''Hierarchy `AppT` ConT ''Hierarchy) [FunD (mkName "dispatcher") [dispatch]] : prinst : rrinst getHomeR :: Handler sub master String getHomeR = "home" getAdminRootR :: Int -> Handler sub master Text getAdminRootR i = pack $ "admin root: " ++ show i getLoginR :: Int -> Handler sub master Text getLoginR i = pack $ "login: " ++ show i postLoginR :: Int -> Handler sub master Text postLoginR i = pack $ "post login: " ++ show i getTableR :: Int -> Text -> Handler sub master Text getTableR _ t = append "TableR " t 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 (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))