yesod-routes (empty) → 0.0.1
raw patch · 11 files changed
+1075/−0 lines, 11 filesdep +HUnitdep +basedep +containerssetup-changed
Dependencies added: HUnit, base, containers, hspec, path-pieces, template-haskell, text, vector, yesod-routes
Files
- LICENSE +25/−0
- Setup.lhs +7/−0
- Yesod/Routes/Class.hs +12/−0
- Yesod/Routes/Dispatch.lhs +323/−0
- Yesod/Routes/Overlap.hs +81/−0
- Yesod/Routes/Parse.hs +105/−0
- Yesod/Routes/TH.hs +12/−0
- Yesod/Routes/TH/Dispatch.hs +295/−0
- Yesod/Routes/TH/RenderRoute.hs +102/−0
- Yesod/Routes/TH/Types.hs +63/−0
- yesod-routes.cabal +50/−0
+ LICENSE view
@@ -0,0 +1,25 @@+The following license covers this documentation, and the source code, except+where otherwise indicated.++Copyright 2010, Michael Snoyman. All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO+EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,+OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.lhs view
@@ -0,0 +1,7 @@+#!/usr/bin/env runhaskell++> module Main where+> import Distribution.Simple++> main :: IO ()+> main = defaultMain
+ Yesod/Routes/Class.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+module Yesod.Routes.Class+ ( RenderRoute (..)+ ) where++import Data.Text (Text)++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)])
+ Yesod/Routes/Dispatch.lhs view
@@ -0,0 +1,323 @@+Title: Experimental, 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 moudle 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/Overlap.hs view
@@ -0,0 +1,81 @@+-- | Check for overlapping routes.+module Yesod.Routes.Overlap+ ( findOverlaps+ , findOverlapNames+ ) where++import Yesod.Routes.TH.Types+import Control.Arrow ((***))+import Data.Maybe (mapMaybe)++findOverlaps :: [Resource t] -> [(Resource t, Resource t)]+findOverlaps [] = []+findOverlaps (x:xs) = mapMaybe (findOverlap x) xs ++ findOverlaps xs++findOverlap :: Resource t -> Resource t -> Maybe (Resource t, Resource t)+findOverlap x y+ | overlaps (resourcePieces x) (resourcePieces y) (hasSuffix x) (hasSuffix y) = Just (x, y)+ | otherwise = Nothing++hasSuffix :: Resource t -> Bool+hasSuffix r =+ case resourceDispatch r of+ Subsite{} -> True+ Methods Just{} _ -> True+ Methods Nothing _ -> False++overlaps :: [(CheckOverlap, Piece t)] -> [(CheckOverlap, Piece t)] -> Bool -> Bool -> Bool++-- 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 :: [Resource t] -> [(String, String)]+findOverlapNames = map (resourceName *** resourceName) . findOverlaps++{-+-- n^2, should be a way to speed it up+findOverlaps :: [Resource a] -> [[Resource a]]+findOverlaps = go . map justPieces+ where+ justPieces :: Resource a -> ([Piece a], Resource a)+ justPieces r@(Resource _ ps _) = (ps, r)++ go [] = []+ go (x:xs) = mapMaybe (mOverlap x) xs ++ go xs++ mOverlap :: ([Piece a], Resource a) -> ([Piece a], Resource a) ->+ Maybe [Resource a]+ mOverlap _ _ = Nothing+ {- FIXME mOverlap+ mOverlap (Static x:xs, xr) (Static y:ys, yr)+ | x == y = mOverlap (xs, xr) (ys, yr)+ | otherwise = Nothing+ mOverlap (MultiPiece _:_, xr) (_, yr) = Just (xr, yr)+ mOverlap (_, xr) (MultiPiece _:_, yr) = Just (xr, yr)+ mOverlap ([], xr) ([], yr) = Just (xr, yr)+ mOverlap ([], _) (_, _) = Nothing+ mOverlap (_, _) ([], _) = Nothing+ mOverlap (_:xs, xr) (_:ys, yr) = mOverlap (xs, xr) (ys, yr)+ -}+-}
+ Yesod/Routes/Parse.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# OPTIONS_GHC -fno-warn-missing-fields #-} -- QuasiQuoter+module Yesod.Routes.Parse+ ( parseRoutes+ , parseRoutesFile+ , parseRoutesNoCheck+ , parseRoutesFileNoCheck+ , parseType+ ) where++import Language.Haskell.TH.Syntax+import Data.Maybe+import Data.Char (isUpper)+import Language.Haskell.TH.Quote+import qualified System.IO as SIO+import Yesod.Routes.TH+import Yesod.Routes.Overlap (findOverlapNames)++-- | A quasi-quoter to parse a string into a list of 'Resource's. Checks for+-- overlapping routes, failing if present; use 'parseRoutesNoCheck' to skip the+-- 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+ 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 -> [Resource String]+resourcesFromString =+ mapMaybe go . lines+ where+ go s =+ case takeWhile (/= "--") $ words s of+ (pattern:constr:rest) ->+ let (pieces, mmulti) = piecesFromString $ drop1Slash pattern+ disp = dispatchFromString rest mmulti+ in Just $ Resource constr pieces disp+ [] -> Nothing+ _ -> error $ "Invalid resource line: " ++ s++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 = ConT . mkName -- FIXME handle more complicated stuff++pieceFromString :: String -> Either String (CheckOverlap, Piece String)+pieceFromString ('#':'!':x) = Right $ (False, Dynamic x)+pieceFromString ('#':x) = Right $ (True, Dynamic x)+pieceFromString ('*':x) = Left x+pieceFromString ('!':x) = Right $ (False, Static x)+pieceFromString x = Right $ (True, Static x)
+ Yesod/Routes/TH.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE TemplateHaskell #-}+module Yesod.Routes.TH+ ( module Yesod.Routes.TH.Types+ -- * Functions+ , module Yesod.Routes.TH.RenderRoute+ -- ** Dispatch+ , module Yesod.Routes.TH.Dispatch+ ) where++import Yesod.Routes.TH.Types+import Yesod.Routes.TH.RenderRoute+import Yesod.Routes.TH.Dispatch
+ Yesod/Routes/TH/Dispatch.hs view
@@ -0,0 +1,295 @@+{-# LANGUAGE TemplateHaskell #-}+module Yesod.Routes.TH.Dispatch+ ( -- ** Dispatch+ mkDispatchClause+ ) 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')++-- |+--+-- This function will generate a single clause that will address all your+-- routing needs. It takes three arguments. The third (a list of 'Resource's)+-- is self-explanatory. We\'ll discuss the first two. 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.+mkDispatchClause :: Q Exp -- ^ runHandler function+ -> Q Exp -- ^ dispatcher function+ -> Q Exp -- ^ fixHandler function+ -> [Resource a]+ -> Q Clause+mkDispatchClause runHandler dispatcher fixHandler 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.+ master0 <- newName "master0"+ sub0 <- newName "sub0"+ toMaster0 <- newName "toMaster0"+ app4040 <- newName "app4040"+ handler4050 <- newName "handler4050"+ method0 <- newName "method0"+ pieces0 <- newName "pieces0"++ -- Name of the dispatch function+ dispatch <- newName "dispatch"++ -- Dispatch function applied to the pieces+ let dispatched = VarE dispatch `AppE` VarE pieces0++ -- The 'D.Route's used in the dispatch function+ routes <- mapM (buildRoute runHandler dispatcher fixHandler) 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 [master0, sub0, toMaster0, app4040, handler4050, method0, pieces0]++ -- For each resource that dispatches based on methods, build up a map for handling the dispatching.+ methodMaps <- catMaybes <$> mapM (buildMethodMap fixHandler) 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)+ |]+ return $ Clause pats (NormalB u) $ dispatchFun : methodMaps++-- | Determine the name of the method map for a given resource name.+methodMapName :: String -> Name+methodMapName s = mkName $ "methods" ++ s++buildMethodMap :: Q Exp -- ^ fixHandler+ -> Resource a+ -> Q (Maybe Dec)+buildMethodMap _ (Resource _ _ (Methods _ [])) = return Nothing -- single handle function+buildMethodMap fixHandler (Resource 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+ go method = do+ fh <- fixHandler+ let func = VarE $ mkName $ map toLower method ++ name+ pack' <- [|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]+buildMethodMap _ (Resource _ _ Subsite{}) = return Nothing++-- | Build a single 'D.Route' expression.+buildRoute :: Q Exp -> Q Exp -> Q Exp -> Resource a -> Q Exp+buildRoute runHandler dispatcher fixHandler (Resource name resPieces resDisp) = do+ -- First two arguments to D.Route+ routePieces <- ListE <$> mapM (convertPiece . snd) resPieces+ isMulti <-+ case resDisp of+ Methods Nothing _ -> [|False|]+ _ -> [|True|]++ [|D.Route $(return routePieces) $(return isMulti) $(routeArg3 runHandler dispatcher fixHandler name (map snd resPieces) resDisp)|]++routeArg3 :: Q Exp -- ^ runHandler+ -> Q Exp -- ^ dispatcher+ -> Q Exp -- ^ fixHandler+ -> String -- ^ name of resource+ -> [Piece a]+ -> Dispatch a+ -> Q Exp+routeArg3 runHandler dispatcher fixHandler 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"++ ys <- forM (catMaybes xs) $ \x -> do+ y <- newName "y"+ 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 runHandler dispatcher fixHandler xrest 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 :: Q Exp -- ^ runHandler+ -> Q Exp -- ^ dispatcher+ -> Q Exp -- ^ fixHandler+ -> Name -- ^ xrest+ -> String -- ^ name of resource+ -> Dispatch a+ -> [Name] -- ^ ys+ -> Q Exp+buildCaller runHandler dispatcher fixHandler xrest name resDisp ys = do+ master <- newName "master"+ sub <- newName "sub"+ toMaster <- newName "toMaster"+ app404 <- newName "_app404"+ handler405 <- newName "_handler405"+ method <- newName "_method"++ let pat = map VarP [master, sub, toMaster, app404, handler405, method]++ -- Create the route+ let route = foldl' (\a b -> a `AppE` VarE b) (ConE $ mkName name) ys++ exp <-+ case resDisp of+ Methods _ ms -> do+ handler <- newName "handler"++ -- Run the whole thing+ runner <- [|$(runHandler)+ $(return $ VarE handler)+ $(return $ VarE master)+ $(return $ VarE sub)+ (Just $(return route))+ $(return $ VarE toMaster)|]++ let myLet handlerExp =+ LetE [FunD handler [Clause [] (NormalB handlerExp) []]] runner++ 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+ else do+ -- Individual methods+ mf <- [|Map.lookup $(return $ VarE 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+ 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)+ $(return sub2)+ ($(return $ VarE toMaster) . $(return route))+ $(return $ VarE app404)+ ($(return $ VarE handler405) . $(return route))+ $(return $ VarE method)+ $(return $ VarE xrest)+ |]++ 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|]
+ Yesod/Routes/TH/RenderRoute.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE TemplateHaskell #-}+module Yesod.Routes.TH.RenderRoute+ ( -- ** RenderRoute+ 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++-- | Generate the constructors of a route data type.+mkRouteCons :: [Resource Type] -> [Con]+mkRouteCons =+ map mkRouteCon+ where+ mkRouteCon res =+ NormalC (mkName $ resourceName res)+ $ map (\x -> (NotStrict, x))+ $ concat [singles, multi, sub]+ where+ 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]+ _ -> []++-- | Clauses for the 'renderRoute' method.+mkRenderRouteClauses :: [Resource Type] -> Q [Clause]+mkRenderRouteClauses =+ mapM go+ where+ isDynamic Dynamic{} = True+ isDynamic _ = False++ go 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 -> [Resource Type] -> Q Dec+mkRenderRouteInstance typ ress = do+ cls <- mkRenderRouteClauses ress+ return $ InstanceD [] (ConT ''RenderRoute `AppT` typ)+ [ DataInstD [] ''Route [typ] (mkRouteCons ress) clazzes+ , FunD (mkName "renderRoute") cls+ ]+ where+ clazzes = [''Show, ''Eq, ''Read]
+ Yesod/Routes/TH/Types.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE TemplateHaskell #-}+module Yesod.Routes.TH.Types+ ( -- * Data types+ Resource (..)+ , Piece (..)+ , Dispatch (..)+ , CheckOverlap+ -- ** Helper functions+ , resourceMulti+ ) where++import Language.Haskell.TH.Syntax+import Control.Arrow (second)++data Resource typ = Resource+ { resourceName :: String+ , resourcePieces :: [(CheckOverlap, Piece typ)]+ , resourceDispatch :: Dispatch typ+ }+ 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)++instance Lift t => Lift (Resource t) where+ lift (Resource a b c) = [|Resource $(lift a) $(lift b) $(lift c)|]++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
+ yesod-routes.cabal view
@@ -0,0 +1,50 @@+name: yesod-routes+version: 0.0.1+license: BSD3+license-file: LICENSE+author: Michael Snoyman <michael@snoyman.com>+maintainer: Michael Snoyman <michael@snoyman.com>+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/++library+ build-depends: base >= 4 && < 5+ , text >= 0.5 && < 0.12+ , vector >= 0.8 && < 0.10+ , containers >= 0.2 && < 0.5+ , 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.Types+ ghc-options: -Wall++test-suite runtests+ type: exitcode-stdio-1.0+ main-is: main.hs+ hs-source-dirs: test++ build-depends: base >= 4.3 && < 5+ , yesod-routes+ , text >= 0.5 && < 0.12+ , HUnit >= 1.2 && < 1.3+ , hspec >= 0.6 && < 0.10+ , containers+ , template-haskell+ , path-pieces+ ghc-options: -Wall++source-repository head+ type: git+ location: https://github.com/yesodweb/yesod