diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,7 @@ +#!/usr/bin/env runhaskell + +> module Main where +> import Distribution.Simple + +> main :: IO () +> main = defaultMain diff --git a/Yesod/Routes/Class.hs b/Yesod/Routes/Class.hs new file mode 100644 --- /dev/null +++ b/Yesod/Routes/Class.hs @@ -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)]) diff --git a/Yesod/Routes/Dispatch.lhs b/Yesod/Routes/Dispatch.lhs new file mode 100644 --- /dev/null +++ b/Yesod/Routes/Dispatch.lhs @@ -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 diff --git a/Yesod/Routes/Overlap.hs b/Yesod/Routes/Overlap.hs new file mode 100644 --- /dev/null +++ b/Yesod/Routes/Overlap.hs @@ -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) + -} +-} diff --git a/Yesod/Routes/Parse.hs b/Yesod/Routes/Parse.hs new file mode 100644 --- /dev/null +++ b/Yesod/Routes/Parse.hs @@ -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) diff --git a/Yesod/Routes/TH.hs b/Yesod/Routes/TH.hs new file mode 100644 --- /dev/null +++ b/Yesod/Routes/TH.hs @@ -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 diff --git a/Yesod/Routes/TH/Dispatch.hs b/Yesod/Routes/TH/Dispatch.hs new file mode 100644 --- /dev/null +++ b/Yesod/Routes/TH/Dispatch.hs @@ -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|] diff --git a/Yesod/Routes/TH/RenderRoute.hs b/Yesod/Routes/TH/RenderRoute.hs new file mode 100644 --- /dev/null +++ b/Yesod/Routes/TH/RenderRoute.hs @@ -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] diff --git a/Yesod/Routes/TH/Types.hs b/Yesod/Routes/TH/Types.hs new file mode 100644 --- /dev/null +++ b/Yesod/Routes/TH/Types.hs @@ -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 diff --git a/yesod-routes.cabal b/yesod-routes.cabal new file mode 100644 --- /dev/null +++ b/yesod-routes.cabal @@ -0,0 +1,50 @@ +name: yesod-routes +version: 0.0.1 +license: BSD3 +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/ + +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