haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge branch 'yesod-routes'

Browse Source
This commit is contained in:
Michael Snoyman 2012-01-05 15:28:27 +02:00
commit 8d5c4a3348
30 changed files with 1423 additions and 811 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
package-list.sh
View File

@ -1,6 +1,7 @@
#!/bin/bash
pkgs=( ./yesod-core
pkgs=( ./yesod-routes
./yesod-core
./yesod-json
./yesod-static
./yesod-persistent

5
yesod-auth/Yesod/Auth.hs
View File

@ -9,8 +9,9 @@
module Yesod.Auth
( -- * Subsite
Auth
, AuthRoute
, Route (..)
, AuthPlugin (..)
, AuthRoute (..)
, getAuth
, YesodAuth (..)
-- * Plugin interface
@ -53,6 +54,8 @@ import Yesod.Form (FormMessage)
data Auth = Auth
type AuthRoute = Route Auth
type Method = Text
type Piece = Text

2
yesod-auth/Yesod/Auth/BrowserId.hs
View File

@ -21,7 +21,7 @@ import Data.Maybe (fromMaybe)
pid :: Text
pid = "browserid"
complete :: AuthRoute
complete :: Route Auth
complete = PluginR pid []
authBrowserIdAudience :: YesodAuth m

124
yesod-core/Yesod/Dispatch.hs
View File

@ -28,11 +28,10 @@ import Data.Either (partitionEithers)
import Prelude hiding (exp)
import Yesod.Internal.Core
import Yesod.Handler hiding (lift)
import Yesod.Internal.Dispatch
import Yesod.Widget (GWidget)
import Web.PathPieces
import Yesod.Internal.RouteParsing (THResource, Pieces (..), createRoutes, createRender, Resource (..), parseRoutes, parseRoutesNoCheck, parseRoutesFile, parseRoutesFileNoCheck)
import Yesod.Routes.Parse (parseRoutes, parseRoutesNoCheck, parseRoutesFile, parseRoutesFileNoCheck)
import Language.Haskell.TH.Syntax
import qualified Network.Wai as W
@ -44,6 +43,15 @@ import Data.ByteString.Lazy.Char8 ()
import Web.ClientSession
import Data.Char (isUpper)
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
import Data.Monoid (mappend)
import qualified Data.ByteString as S
import qualified Blaze.ByteString.Builder
import Network.HTTP.Types (status301)
import Yesod.Routes.TH
import Yesod.Content (chooseRep)
import Yesod.Routes.Parse
type Texts = [Text]
@ -51,7 +59,7 @@ type Texts = [Text]
-- is used for creating sites, /not/ subsites. See 'mkYesodSub' for the latter.
-- Use 'parseRoutes' to create the 'Resource's.
mkYesod :: String -- ^ name of the argument datatype
-> [Resource]
-> [Resource String]
-> Q [Dec]
mkYesod name = fmap (uncurry (++)) . mkYesodGeneral name [] [] False
@ -62,7 +70,7 @@ mkYesod name = fmap (uncurry (++)) . mkYesodGeneral name [] [] False
-- be embedded in other sites.
mkYesodSub :: String -- ^ name of the argument datatype
-> Cxt
-> [Resource]
-> [Resource String]
-> Q [Dec]
mkYesodSub name clazzes =
fmap (uncurry (++)) . mkYesodGeneral name' rest clazzes True
@ -73,28 +81,28 @@ mkYesodSub name clazzes =
-- your handlers elsewhere. For example, this is the only way to break up a
-- monolithic file into smaller parts. Use this function, paired with
-- 'mkYesodDispatch', to do just that.
mkYesodData :: String -> [Resource] -> Q [Dec]
mkYesodData :: String -> [Resource String] -> Q [Dec]
mkYesodData name res = mkYesodDataGeneral name [] False res
mkYesodSubData :: String -> Cxt -> [Resource] -> Q [Dec]
mkYesodSubData :: String -> Cxt -> [Resource String] -> Q [Dec]
mkYesodSubData name clazzes res = mkYesodDataGeneral name clazzes True res
mkYesodDataGeneral :: String -> Cxt -> Bool -> [Resource] -> Q [Dec]
mkYesodDataGeneral :: String -> Cxt -> Bool -> [Resource String] -> Q [Dec]
mkYesodDataGeneral name clazzes isSub res = do
let (name':rest) = words name
(x, _) <- mkYesodGeneral name' rest clazzes isSub res
let rname = mkName $ "resources" ++ name
eres <- lift res
eres <- [|fmap parseType $(lift res)|]
let y = [ SigD rname $ ListT `AppT` ConT ''Resource
, FunD rname [Clause [] (NormalB eres) []]
]
return $ x ++ y
-- | See 'mkYesodData'.
mkYesodDispatch :: String -> [Resource] -> Q [Dec]
mkYesodDispatch :: String -> [Resource String] -> Q [Dec]
mkYesodDispatch name = fmap snd . mkYesodGeneral name [] [] False
mkYesodSubDispatch :: String -> Cxt -> [Resource] -> Q [Dec]
mkYesodSubDispatch :: String -> Cxt -> [Resource String] -> Q [Dec]
mkYesodSubDispatch name clazzes = fmap snd . mkYesodGeneral name' rest clazzes True
where (name':rest) = words name
@ -102,40 +110,26 @@ mkYesodGeneral :: String -- ^ foundation name
-> [String] -- ^ parameters for foundation
-> Cxt -- ^ classes
-> Bool -- ^ is subsite?
-> [Resource]
-> [Resource String]
-> Q ([Dec], [Dec])
mkYesodGeneral name args clazzes isSub res = do
let args' = map mkName args
arg = foldl AppT (ConT name') $ map VarT args'
th' <- mapM thResourceFromResource res
let th = map fst th'
w' <- createRoutes th
let routesName = mkName $ name ++ "Route"
let w = DataD [] routesName [] w' [''Show, ''Read, ''Eq]
let x = TySynInstD ''Route [arg] $ ConT routesName
mkYesodGeneral name args clazzes isSub resS = do
let res = map (fmap parseType) resS
renderRouteDec <- mkRenderRouteInstance (ConT name') res
render <- createRender th
let x' = InstanceD [] (ConT ''RenderRoute `AppT` ConT routesName)
[ FunD (mkName "renderRoute") render
]
let splitter :: (THResource, Maybe String)
-> Either
(THResource, Maybe String)
(THResource, Maybe String)
splitter a@((_, SubSite{}), _) = Left a
splitter a = Right a
let (resSub, resLoc) = partitionEithers $ map splitter th'
yd <- mkYesodDispatch' resSub resLoc
disp <- mkDispatchClause [|yesodRunner|] [|yesodDispatch|] [|fmap chooseRep|] res
let master = mkName "master"
let ctx = if isSub
then ClassP (mkName "Yesod") [VarT master] : clazzes
else []
let args' = map mkName args
arg = foldl AppT (ConT name') $ map VarT args'
let ytyp = if isSub
then ConT ''YesodDispatch `AppT` arg `AppT` VarT master
else ConT ''YesodDispatch `AppT` arg `AppT` arg
let y = InstanceD ctx ytyp [FunD (mkName "yesodDispatch") [yd]]
return ([w, x, x'] ++ masterTypSyns, [y])
let yesodDispatch =
InstanceD ctx ytyp [FunD (mkName "yesodDispatch") [disp]]
return (renderRouteDec : masterTypSyns, [yesodDispatch])
where
name' = mkName name
masterTypSyns
@ -151,45 +145,49 @@ mkYesodGeneral name args clazzes isSub res = do
(ConT ''GWidget `AppT` ConT name' `AppT` ConT name' `AppT` TupleT 0)
]
thResourceFromResource :: Resource -> Q (THResource, Maybe String)
thResourceFromResource (Resource n ps atts)
| all (all isUpper) atts = return ((n, Simple ps atts), Nothing)
thResourceFromResource (Resource n ps [stype, toSubArg]) = do
let stype' = ConT $ mkName stype
parse <- [|error "ssParse"|]
dispatch <- [|error "ssDispatch"|]
render <- [|renderRoute|]
tmg <- [|error "ssToMasterArg"|]
return ((n, SubSite
{ ssType = ConT ''Route `AppT` stype'
, ssParse = parse
, ssRender = render
, ssDispatch = dispatch
, ssToMasterArg = tmg
, ssPieces = ps
}), Just toSubArg)
thResourceFromResource (Resource n _ _) =
error $ "Invalid attributes for resource: " ++ n
-- | Convert the given argument into a WAI application, executable with any WAI
-- handler. This is the same as 'toWaiAppPlain', except it includes two
-- middlewares: GZIP compression and autohead. This is the
-- recommended approach for most users.
toWaiApp :: (Yesod y, YesodDispatch y y) => y -> IO W.Application
toWaiApp :: ( Yesod master
, YesodDispatch master master
) => master -> IO W.Application
toWaiApp y = gzip (gzipCompressFiles y) . autohead <$> toWaiAppPlain y
-- | Convert the given argument into a WAI application, executable with any WAI
-- handler. This differs from 'toWaiApp' in that it uses no middlewares.
toWaiAppPlain :: (Yesod y, YesodDispatch y y) => y -> IO W.Application
toWaiAppPlain :: ( Yesod master
, YesodDispatch master master
) => master -> IO W.Application
toWaiAppPlain a = toWaiApp' a <$> encryptKey a
toWaiApp' :: (Yesod y, YesodDispatch y y)
=> y
toWaiApp' :: ( Yesod master
, YesodDispatch master master
)
=> master
-> Maybe Key
-> W.Application
toWaiApp' y key' env =
case yesodDispatch y key' (W.pathInfo env) y id of
Just app -> app env
Nothing -> yesodRunner y y id key' Nothing notFound env
case cleanPath y $ W.pathInfo env of
Left pieces -> sendRedirect y pieces env
Right pieces ->
yesodDispatch y y id app404 handler405 method pieces key' env
where
app404 = yesodRunner notFound y y Nothing id
handler405 route = yesodRunner badMethod y y (Just route) id
method = decodeUtf8With lenientDecode $ W.requestMethod env
sendRedirect :: Yesod master => master -> [Text] -> W.Application
sendRedirect y segments' env =
return $ W.responseLBS status301
[ ("Content-Type", "text/plain")
, ("Location", Blaze.ByteString.Builder.toByteString dest')
] "Redirecting"
where
dest = joinPath y (approot y) segments' []
dest' =
if S.null (W.rawQueryString env)
then dest
else (dest `mappend`
Blaze.ByteString.Builder.fromByteString (W.rawQueryString env))

9
yesod-core/Yesod/Handler.hs
View File

@ -24,8 +24,7 @@
---------------------------------------------------------
module Yesod.Handler
( -- * Type families
Route
, YesodSubRoute (..)
YesodSubRoute (..)
-- * Handler monad
, GHandler
-- ** Read information from handler
@ -174,9 +173,7 @@ import Network.Wai (requestBody)
import Data.Conduit (($$))
import Control.Monad.Trans.Control
import Control.Monad.Base
-- | The type-safe URLs associated with a site argument.
type family Route a
import Yesod.Routes.Class
class YesodSubRoute s y where
fromSubRoute :: s -> y -> Route s -> Route y
@ -603,7 +600,7 @@ notFound :: GHandler sub master a
notFound = hcError NotFound
-- | Return a 405 method not supported page.
badMethod :: GHandler s m a
badMethod :: GHandler sub master a
badMethod = do
w <- waiRequest
hcError $ BadMethod $ W.requestMethod w

45
yesod-core/Yesod/Internal/Core.hs
View File

@ -33,6 +33,8 @@ module Yesod.Internal.Core
import Yesod.Content
import Yesod.Handler hiding (lift)
import Yesod.Routes.Class
import Control.Arrow ((***))
import Control.Monad (forM)
import Yesod.Widget
@ -92,31 +94,34 @@ yesodVersion = "0.9.4"
#define HAMLET $hamlet
#endif
class Eq u => RenderRoute u where
renderRoute :: u -> ([Text], [(Text, Text)])
-- | This class is automatically instantiated when you use the template haskell
-- mkYesod function. You should never need to deal with it directly.
class YesodDispatch a master where
class YesodDispatch sub master where
yesodDispatch
:: Yesod master
=> a
=> master
-> sub
-> (Route sub -> Route master)
-> (Maybe CS.Key -> W.Application) -- ^ 404 handler
-> (Route sub -> Maybe CS.Key -> W.Application) -- ^ 405 handler
-> Text -- ^ request method
-> [Text] -- ^ pieces
-> Maybe CS.Key
-> [Text]
-> master
-> (Route a -> Route master)
-> Maybe W.Application
-> W.Application
yesodRunner :: Yesod master
=> a
=> GHandler sub master ChooseRep
-> master
-> (Route a -> Route master)
-> Maybe CS.Key -> Maybe (Route a) -> GHandler a master ChooseRep -> W.Application
-> sub
-> Maybe (Route sub)
-> (Route sub -> Route master)
-> Maybe CS.Key
-> W.Application
yesodRunner = defaultYesodRunner
-- | Define settings for a Yesod applications. The only required setting is
-- 'approot'; other than that, there are intelligent defaults.
class RenderRoute (Route a) => Yesod a where
class RenderRoute a => Yesod a where
-- | An absolute URL to the root of the application. Do not include
-- trailing slash.
--
@ -322,14 +327,14 @@ fileLocationToString loc = (loc_package loc) ++ ':' : (loc_module loc) ++
char = show . snd . loc_start
defaultYesodRunner :: Yesod master
=> a
=> GHandler sub master ChooseRep
-> master
-> (Route a -> Route master)
-> sub
-> Maybe (Route sub)
-> (Route sub -> Route master)
-> Maybe CS.Key
-> Maybe (Route a)
-> GHandler a master ChooseRep
-> W.Application
defaultYesodRunner _ m toMaster _ murl _ req
defaultYesodRunner _ m _ murl toMaster _ req
| maximumContentLength m (fmap toMaster murl) < len =
return $ W.responseLBS
(H.Status 413 "Too Large")
@ -341,7 +346,7 @@ defaultYesodRunner _ m toMaster _ murl _ req
case reads $ S8.unpack s of
[] -> Nothing
(x, _):_ -> Just x
defaultYesodRunner s master toMasterRoute mkey murl handler req = do
defaultYesodRunner handler master sub murl toMasterRoute mkey req = do
now <- {-# SCC "getCurrentTime" #-} liftIO getCurrentTime
let getExpires m = {-# SCC "getExpires" #-} fromIntegral (m * 60) `addUTCTime` now
let exp' = {-# SCC "exp'" #-} getExpires $ clientSessionDuration master
@ -374,7 +379,7 @@ defaultYesodRunner s master toMasterRoute mkey murl handler req = do
handler
let sessionMap = Map.fromList
$ filter (\(x, _) -> x /= nonceKey) session'
yar <- handlerToYAR master s toMasterRoute (yesodRender master) errorHandler rr murl sessionMap h
yar <- handlerToYAR master sub toMasterRoute (yesodRender master) errorHandler rr murl sessionMap h
let mnonce = reqNonce rr
-- FIXME should we be caching this IV value and reusing it for efficiency?
iv <- {-# SCC "iv" #-} maybe (return $ error "Should not be used") (const $ liftIO CS.randomIV) mkey

322
yesod-core/Yesod/Internal/Dispatch.hs
View File

@ -1,322 +0,0 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
-- | A bunch of Template Haskell used in the Yesod.Dispatch module.
module Yesod.Internal.Dispatch
( mkYesodDispatch'
) where
import Prelude hiding (exp)
import Language.Haskell.TH.Syntax
import Web.PathPieces
import Yesod.Internal.RouteParsing
import Control.Monad (foldM)
import Yesod.Handler (badMethod)
import Yesod.Content (chooseRep)
import qualified Network.Wai as W
import Yesod.Internal.Core (yesodRunner, yesodDispatch)
import Data.List (foldl')
import Data.Char (toLower)
import qualified Data.ByteString as S
import Yesod.Internal.Core (Yesod (joinPath, approot, cleanPath))
import Network.HTTP.Types (status301)
import Data.Text (Text)
import Data.Monoid (mappend)
import qualified Blaze.ByteString.Builder
import qualified Data.ByteString.Char8 as S8
import qualified Data.Text
{-|
Alright, let's explain how routing works. We want to take a [String] and found
out which route it applies to. For static pieces, we need to ensure an exact
match against the segment. For a single or multi piece, we need to check the
result of fromPathPiece/fromMultiPathPiece, respectively.
We want to create a tree of case statements basically resembling:
case testRoute1 of
Just app -> Just app
Nothing ->
case testRoute2 of
Just app -> Just app
Nothing ->
case testRoute3 of
Just app -> Just app
Nothing -> Nothing
Each testRoute* will look something like this (example of parsing a route /name/#String/age/#Int):
case segments of
"name" : as ->
case as of
[] -> Nothing
b:bs ->
case fromPathPiece b of
Left _ -> Nothing
Right name ->
case bs of
"age":cs ->
case cs of
[] -> Nothing
d:ds ->
case fromPathPiece d of
Left _ -> Nothing
Right age ->
case ds of
[] -> Just $ yesodRunner (PersonR name age) (getPersonR name age)...
_ -> Nothing
_ -> Nothing
_ -> Nothing
Obviously we would never want to write code by hand like this, but generating it is not too bad.
This function generates a clause for the yesodDispatch function based on a set of routes.
NOTE: We deal with subsites first; if none of those match, we try to apply
cleanPath. If that indicates a redirect, we perform it. Otherwise, we match
local routes.
-}
sendRedirect :: Yesod master => master -> [Text] -> W.Application
sendRedirect y segments' env =
return $ W.responseLBS status301
[ ("Content-Type", "text/plain")
, ("Location", Blaze.ByteString.Builder.toByteString dest')
] "Redirecting"
where
dest = joinPath y (approot y) segments' []
dest' =
if S.null (W.rawQueryString env)
then dest
else (dest `mappend`
Blaze.ByteString.Builder.fromByteString (W.rawQueryString env))
mkYesodDispatch' :: [((String, Pieces), Maybe String)]
-> [((String, Pieces), Maybe String)]
-> Q Clause
mkYesodDispatch' resSub resLoc = do
sub <- newName "sub"
master <- newName "master"
mkey <- newName "mkey"
segments <- newName "segments"
segments' <- newName "segmentsClean"
toMasterRoute <- newName "toMasterRoute"
nothing <- [|Nothing|]
bodyLoc <- foldM (go master (VarE sub) (VarE toMasterRoute) mkey segments') nothing resLoc
cp <- [|cleanPath|]
sr <- [|sendRedirect|]
just <- [|Just|]
let bodyLoc' =
CaseE (cp `AppE` VarE master `AppE` VarE segments)
[ Match (ConP (mkName "Left") [VarP segments'])
(NormalB $ just `AppE`
(sr `AppE` VarE master `AppE` VarE segments'))
[]
, Match (ConP (mkName "Right") [VarP segments'])
(NormalB bodyLoc)
[]
]
body <- foldM (go master (VarE sub) (VarE toMasterRoute) mkey segments) bodyLoc' resSub
return $ Clause
[VarP sub, VarP mkey, VarP segments, VarP master, VarP toMasterRoute]
(NormalB body)
[]
where
go master sub toMasterRoute mkey segments onFail ((constr, SubSite { ssPieces = pieces }), Just toSub) = do
test <- mkSubsiteExp segments pieces id (master, sub, toMasterRoute, mkey, constr, VarE $ mkName toSub)
app <- newName "app"
return $ CaseE test
[ Match (ConP (mkName "Nothing") []) (NormalB onFail) []
, Match (ConP (mkName "Just") [VarP app]) (NormalB $ VarE app) []
]
go master sub toMasterRoute mkey segments onFail ((constr, Simple pieces methods), Nothing) = do
test <- mkSimpleExp (VarE segments) pieces id (master, sub, toMasterRoute, mkey, constr, methods)
just <- [|Just|]
app <- newName "app"
return $ CaseE test
[ Match (ConP (mkName "Nothing") []) (NormalB onFail) []
, Match (ConP (mkName "Just") [VarP app]) (NormalB $ just `AppE` VarE app) []
]
go _ _ _ _ _ _ _ = error "Invalid combination"
mkSimpleExp :: Exp -- ^ segments
-> [Piece]
-> ([Exp] -> [Exp]) -- ^ variables already parsed
-> (Name, Exp, Exp, Name, String, [String]) -- ^ master, sub, toMasterRoute, mkey, constructor, methods
-> Q Exp
mkSimpleExp segments [] frontVars (master, sub, toMasterRoute, mkey, constr, methods) = do
just <- [|Just|]
nothing <- [|Nothing|]
onSuccess <- newName "onSuccess"
req <- newName "req"
badMethod' <- [|badMethod|]
rm <- [|S8.unpack . W.requestMethod|]
let caseExp = rm `AppE` VarE req
yr <- [|yesodRunner|]
cr <- [|fmap chooseRep|]
eq <- [|(==)|]
let url = foldl' AppE (ConE $ mkName constr) $ frontVars []
let runHandlerVars h = runHandler' $ cr `AppE` foldl' AppE (VarE $ mkName h) (frontVars [])
runHandler' h = yr `AppE` sub
`AppE` VarE master
`AppE` toMasterRoute
`AppE` VarE mkey
`AppE` (just `AppE` url)
`AppE` h
`AppE` VarE req
let match :: String -> Q Match
match m = do
x <- newName "x"
return $ Match
(VarP x)
(GuardedB
[ ( NormalG $ InfixE (Just $ VarE x) eq (Just $ LitE $ StringL m) -- FIXME need to pack, right?
, runHandlerVars $ map toLower m ++ constr
)
])
[]
clauses <-
case methods of
[] -> return [Clause [VarP req] (NormalB $ runHandlerVars $ "handle" ++ constr) []]
_ -> do
matches <- mapM match methods
return [Clause [VarP req] (NormalB $ CaseE caseExp $ matches ++
[Match WildP (NormalB $ runHandler' badMethod') []]) []]
let exp = CaseE segments
[ Match
(ConP (mkName "[]") [])
(NormalB $ just `AppE` VarE onSuccess)
[FunD onSuccess clauses]
, Match
WildP
(NormalB nothing)
[]
]
return exp
mkSimpleExp segments (StaticPiece s:pieces) frontVars x = do
srest <- newName "segments"
innerExp <- mkSimpleExp (VarE srest) pieces frontVars x
nothing <- [|Nothing|]
y <- newName "y"
pack <- [|Data.Text.pack|]
eq <- [|(==)|]
let exp = CaseE segments
[ Match
(InfixP (VarP y) (mkName ":") (VarP srest))
(GuardedB
[ ( NormalG $ InfixE (Just $ VarE y) eq (Just $ pack `AppE` (LitE $ StringL s))
, innerExp
)
])
[]
, Match WildP (NormalB nothing) []
]
return exp
mkSimpleExp segments (SinglePiece _:pieces) frontVars x = do
srest <- newName "segments"
next' <- newName "next'"
innerExp <- mkSimpleExp (VarE srest) pieces (frontVars . (:) (VarE next')) x
nothing <- [|Nothing|]
next <- newName "next"
fsp <- [|fromPathPiece|]
let exp' = CaseE (fsp `AppE` VarE next)
[ Match
(ConP (mkName "Nothing") [])
(NormalB nothing)
[]
, Match
(ConP (mkName "Just") [VarP next'])
(NormalB innerExp)
[]
]
let exp = CaseE segments
[ Match
(InfixP (VarP next) (mkName ":") (VarP srest))
(NormalB exp')
[]
, Match WildP (NormalB nothing) []
]
return exp
mkSimpleExp segments [MultiPiece _] frontVars x = do
next' <- newName "next'"
srest <- [|[]|]
innerExp <- mkSimpleExp srest [] (frontVars . (:) (VarE next')) x
nothing <- [|Nothing|]
fmp <- [|fromPathMultiPiece|]
let exp = CaseE (fmp `AppE` segments)
[ Match
(ConP (mkName "Nothing") [])
(NormalB nothing)
[]
, Match
(ConP (mkName "Just") [VarP next'])
(NormalB innerExp)
[]
]
return exp
mkSimpleExp _ (MultiPiece _:_) _ _ = error "MultiPiece must be last piece"
mkSubsiteExp :: Name -- ^ segments
-> [Piece]
-> ([Exp] -> [Exp]) -- ^ variables already parsed
-> (Name, Exp, Exp, Name, String, Exp) -- ^ master, sub, toMasterRoute, mkey, constructor, toSub
-> Q Exp
mkSubsiteExp segments [] frontVars (master, sub, toMasterRoute, mkey, constr, toSub) = do
yd <- [|yesodDispatch|]
dot <- [|(.)|]
let con = InfixE (Just toMasterRoute) dot $ Just $ foldl' AppE (ConE $ mkName constr) $ frontVars []
-- proper handling for sub-subsites
let sub' = foldl' AppE (toSub `AppE` sub) $ frontVars []
let app = yd `AppE` sub'
`AppE` VarE mkey
`AppE` VarE segments
`AppE` VarE master
`AppE` con
just <- [|Just|]
return $ just `AppE` app
mkSubsiteExp _ (MultiPiece _:_) _ _ = error "Subsites cannot have MultiPiece"
mkSubsiteExp segments (StaticPiece s:pieces) frontVars x = do
srest <- newName "segments"
innerExp <- mkSubsiteExp srest pieces frontVars x
nothing <- [|Nothing|]
y <- newName "y"
pack <- [|Data.Text.pack|]
eq <- [|(==)|]
let exp = CaseE (VarE segments)
[ Match
(InfixP (VarP y) (mkName ":") (VarP srest))
(GuardedB
[ ( NormalG $ InfixE (Just $ VarE y) eq (Just $ pack `AppE` (LitE $ StringL s))
, innerExp
)
])
[]
, Match WildP (NormalB nothing) []
]
return exp
mkSubsiteExp segments (SinglePiece _:pieces) frontVars x = do
srest <- newName "segments"
next' <- newName "next'"
innerExp <- mkSubsiteExp srest pieces (frontVars . (:) (VarE next')) x
nothing <- [|Nothing|]
next <- newName "next"
fsp <- [|fromPathPiece|]
let exp' = CaseE (fsp `AppE` VarE next)
[ Match
(ConP (mkName "Nothing") [])
(NormalB nothing)
[]
, Match
(ConP (mkName "Just") [VarP next'])
(NormalB innerExp)
[]
]
let exp = CaseE (VarE segments)
[ Match
(InfixP (VarP next) (mkName ":") (VarP srest))
(NormalB exp')
[]
, Match WildP (NormalB nothing) []
]
return exp

354
yesod-core/Yesod/Internal/RouteParsing.hs
View File

@ -1,354 +0,0 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# OPTIONS_GHC -fno-warn-missing-fields #-} -- QuasiQuoter
module Yesod.Internal.RouteParsing
( createRoutes
, createRender
, createParse
, createDispatch
, Pieces (..)
, THResource
, parseRoutes
, parseRoutesFile
, parseRoutesNoCheck
, parseRoutesFileNoCheck
, Resource (..)
, Piece (..)
) where
import Web.PathPieces
import Language.Haskell.TH.Syntax
import Data.Maybe
import Data.Either
import Data.List
import Data.Char (toLower)
import qualified Data.Text
import Language.Haskell.TH.Quote
import Data.Data
import qualified System.IO as SIO
data Pieces =
SubSite
{ ssType :: Type
, ssParse :: Exp
, ssRender :: Exp
, ssDispatch :: Exp
, ssToMasterArg :: Exp
, ssPieces :: [Piece]
}
| Simple [Piece] [String] -- ^ methods
deriving Show
type THResource = (String, Pieces)
createRoutes :: [THResource] -> Q [Con]
createRoutes res =
return $ map go res
where
go (n, SubSite{ssType = s, ssPieces = pieces}) =
NormalC (mkName n) $ mapMaybe go' pieces ++ [(NotStrict, s)]
go (n, Simple pieces _) = NormalC (mkName n) $ mapMaybe go' pieces
go' (SinglePiece x) = Just (NotStrict, ConT $ mkName x)
go' (MultiPiece x) = Just (NotStrict, ConT $ mkName x)
go' (StaticPiece _) = Nothing
-- | Generates the set of clauses necesary to parse the given 'Resource's. See 'quasiParse'.
createParse :: [THResource] -> Q [Clause]
createParse res = do
final' <- final
clauses <- mapM go res
return $ if areResourcesComplete res
then clauses
else clauses ++ [final']
where
cons x y = ConP (mkName ":") [x, y]
go (constr, SubSite{ssParse = p, ssPieces = ps}) = do
ri <- [|Right|]
be <- [|ape|]
(pat', parse) <- mkPat' be ps $ ri `AppE` ConE (mkName constr)
x <- newName "x"
let pat = init pat' ++ [VarP x]
--let pat = foldr (\a b -> cons [LitP (StringL a), b]) (VarP x) pieces
let eitherSub = p `AppE` VarE x
let bod = be `AppE` parse `AppE` eitherSub
--let bod = fmape' `AppE` ConE (mkName constr) `AppE` eitherSub
return $ Clause [foldr1 cons pat] (NormalB bod) []
go (n, Simple ps _) = do
ri <- [|Right|]
be <- [|ape|]
(pat, parse) <- mkPat' be ps $ ri `AppE` ConE (mkName n)
return $ Clause [foldr1 cons pat] (NormalB parse) []
final = do
no <- [|Left "Invalid URL"|]
return $ Clause [WildP] (NormalB no) []
mkPat' :: Exp -> [Piece] -> Exp -> Q ([Pat], Exp)
mkPat' be [MultiPiece s] parse = do
v <- newName $ "var" ++ s
fmp <- [|fromPathMultiPiece|]
let parse' = InfixE (Just parse) be $ Just $ fmp `AppE` VarE v
return ([VarP v], parse')
mkPat' _ (MultiPiece _:_) _parse = error "MultiPiece must be last"
mkPat' be (StaticPiece s:rest) parse = do
(x, parse') <- mkPat' be rest parse
let sp = LitP $ StringL s
return (sp : x, parse')
mkPat' be (SinglePiece s:rest) parse = do
fsp <- [|fromPathPiece|]
v <- newName $ "var" ++ s
let parse' = InfixE (Just parse) be $ Just $ fsp `AppE` VarE v
(x, parse'') <- mkPat' be rest parse'
return (VarP v : x, parse'')
mkPat' _ [] parse = return ([ListP []], parse)
-- | 'ap' for 'Either'
ape :: Either String (a -> b) -> Either String a -> Either String b
ape (Left e) _ = Left e
ape (Right _) (Left e) = Left e
ape (Right f) (Right a) = Right $ f a
-- | Generates the set of clauses necesary to render the given 'Resource's. See
-- 'quasiRender'.
createRender :: [THResource] -> Q [Clause]
createRender = mapM go
where
go (n, Simple ps _) = do
let ps' = zip [1..] ps
let pat = ConP (mkName n) $ mapMaybe go' ps'
bod <- mkBod ps'
return $ Clause [pat] (NormalB $ TupE [bod, ListE []]) []
go (n, SubSite{ssRender = r, ssPieces = pieces}) = do
cons' <- [|\a (b, c) -> (a ++ b, c)|]
let cons a b = cons' `AppE` a `AppE` b
x <- newName "x"
let r' = r `AppE` VarE x
let pieces' = zip [1..] pieces
let pat = ConP (mkName n) $ mapMaybe go' pieces' ++ [VarP x]
bod <- mkBod pieces'
return $ Clause [pat] (NormalB $ cons bod r') []
go' (_, StaticPiece _) = Nothing
go' (i, _) = Just $ VarP $ mkName $ "var" ++ show (i :: Int)
mkBod :: (Show t) => [(t, Piece)] -> Q Exp
mkBod [] = lift ([] :: [String])
mkBod ((_, StaticPiece x):xs) = do
x' <- lift x
pack <- [|Data.Text.pack|]
xs' <- mkBod xs
return $ ConE (mkName ":") `AppE` (pack `AppE` x') `AppE` xs'
mkBod ((i, SinglePiece _):xs) = do
let x' = VarE $ mkName $ "var" ++ show i
tsp <- [|toPathPiece|]
let x'' = tsp `AppE` x'
xs' <- mkBod xs
return $ ConE (mkName ":") `AppE` x'' `AppE` xs'
mkBod ((i, MultiPiece _):_) = do
let x' = VarE $ mkName $ "var" ++ show i
tmp <- [|toPathMultiPiece|]
return $ tmp `AppE` x'
-- | Whether the set of resources cover all possible URLs.
areResourcesComplete :: [THResource] -> Bool
areResourcesComplete res =
let (slurps, noSlurps) = partitionEithers $ mapMaybe go res
in case slurps of
[] -> False
_ -> let minSlurp = minimum slurps
in helper minSlurp $ reverse $ sort noSlurps
where
go :: THResource -> Maybe (Either Int Int)
go (_, Simple ps _) =
case reverse ps of
[] -> Just $ Right 0
(MultiPiece _:rest) -> go' Left rest
x -> go' Right x
go (n, SubSite{ssPieces = ps}) =
go (n, Simple (ps ++ [MultiPiece ""]) [])
go' b x = if all isSingle x then Just (b $ length x) else Nothing
helper 0 _ = True
helper _ [] = False
helper m (i:is)
| i >= m = helper m is
| i + 1 == m = helper i is
| otherwise = False
isSingle (SinglePiece _) = True
isSingle _ = False
notStatic :: Piece -> Bool
notStatic StaticPiece{} = False
notStatic _ = True
createDispatch :: Exp -- ^ modify a master handler
-> Exp -- ^ convert a subsite handler to a master handler
-> [THResource]
-> Q [Clause]
createDispatch modMaster toMaster = mapM go
where
go :: (String, Pieces) -> Q Clause
go (n, Simple ps methods) = do
meth <- newName "method"
xs <- mapM newName $ replicate (length $ filter notStatic ps) "x"
let pat = [ ConP (mkName n) $ map VarP xs
, if null methods then WildP else VarP meth
]
bod <- go' n meth xs methods
return $ Clause pat (NormalB bod) []
go (n, SubSite{ssDispatch = d, ssToMasterArg = tma, ssPieces = ps}) = do
meth <- newName "method"
x <- newName "x"
xs <- mapM newName $ replicate (length $ filter notStatic ps) "x"
let pat = [ConP (mkName n) $ map VarP xs ++ [VarP x], VarP meth]
let bod = d `AppE` VarE x `AppE` VarE meth
fmap' <- [|fmap|]
let routeToMaster = foldl AppE (ConE (mkName n)) $ map VarE xs
tma' = foldl AppE tma $ map VarE xs
let toMaster' = toMaster `AppE` routeToMaster `AppE` tma' `AppE` VarE x
let bod' = InfixE (Just toMaster') fmap' (Just bod)
let bod'' = InfixE (Just modMaster) fmap' (Just bod')
return $ Clause pat (NormalB bod'') []
go' n _ xs [] = do
jus <- [|Just|]
let bod = foldl AppE (VarE $ mkName $ "handle" ++ n) $ map VarE xs
return $ jus `AppE` (modMaster `AppE` bod)
go' n meth xs methods = do
noth <- [|Nothing|]
j <- [|Just|]
let noMatch = Match WildP (NormalB noth) []
return $ CaseE (VarE meth) $ map (go'' n xs j) methods ++ [noMatch]
go'' n xs j method =
let pat = LitP $ StringL method
func = map toLower method ++ n
bod = foldl AppE (VarE $ mkName func) $ map VarE xs
in Match pat (NormalB $ j `AppE` (modMaster `AppE` bod)) []
-- | 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
, quotePat = y
}
where
x s = do
let res = resourcesFromString s
case findOverlaps res of
[] -> lift res
z -> error $ "Overlapping routes: " ++ unlines (map show z)
y = dataToPatQ (const Nothing) . resourcesFromString
parseRoutesFile :: FilePath -> Q Exp
parseRoutesFile fp = do
s <- qRunIO $ readUtf8File fp
quoteExp parseRoutes s
parseRoutesFileNoCheck :: FilePath -> Q Exp
parseRoutesFileNoCheck fp = do
s <- qRunIO $ readUtf8File fp
quoteExp parseRoutesNoCheck 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 = x
, quotePat = y
}
where
x = lift . resourcesFromString
y = dataToPatQ (const Nothing) . resourcesFromString
instance Lift Resource where
lift (Resource s ps h) = do
r <- [|Resource|]
s' <- lift s
ps' <- lift ps
h' <- lift h
return $ r `AppE` s' `AppE` ps' `AppE` h'
-- | A single resource pattern.
--
-- First argument is the name of the constructor, second is the URL pattern to
-- match, third is how to dispatch.
data Resource = Resource String [Piece] [String]
deriving (Read, Show, Eq, Data, Typeable)
-- | A single piece of a URL, delimited by slashes.
--
-- In the case of StaticPiece, the argument is the value of the piece; for the
-- other constructors, it is the name of the parameter represented by this
-- piece. That value is not used here, but may be useful elsewhere.
data Piece = StaticPiece String
| SinglePiece String
| MultiPiece String
deriving (Read, Show, Eq, Data, Typeable)
instance Lift Piece where
lift (StaticPiece s) = do
c <- [|StaticPiece|]
s' <- lift s
return $ c `AppE` s'
lift (SinglePiece s) = do
c <- [|SinglePiece|]
s' <- lift s
return $ c `AppE` s'
lift (MultiPiece s) = do
c <- [|MultiPiece|]
s' <- lift s
return $ c `AppE` s'
-- | 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]
resourcesFromString =
mapMaybe go . lines
where
go s =
case takeWhile (/= "--") $ words s of
(pattern:constr:rest) ->
let pieces = piecesFromString $ drop1Slash pattern
in Just $ Resource constr pieces rest
[] -> Nothing
_ -> error $ "Invalid resource line: " ++ s
drop1Slash :: String -> String
drop1Slash ('/':x) = x
drop1Slash x = x
piecesFromString :: String -> [Piece]
piecesFromString "" = []
piecesFromString x =
let (y, z) = break (== '/') x
in pieceFromString y : piecesFromString (drop1Slash z)
pieceFromString :: String -> Piece
pieceFromString ('#':x) = SinglePiece x
pieceFromString ('*':x) = MultiPiece x
pieceFromString x = StaticPiece x
-- n^2, should be a way to speed it up
findOverlaps :: [Resource] -> [(Resource, Resource)]
findOverlaps = go . map justPieces
where
justPieces :: Resource -> ([Piece], Resource)
justPieces r@(Resource _ ps _) = (ps, r)
go [] = []
go (x:xs) = mapMaybe (mOverlap x) xs ++ go xs
mOverlap :: ([Piece], Resource) -> ([Piece], Resource) ->
Maybe (Resource, Resource)
mOverlap (StaticPiece x:xs, xr) (StaticPiece 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)

3
yesod-core/Yesod/Widget.hs
View File

@ -63,8 +63,9 @@ import Text.Hamlet
import Text.Cassius
import Text.Julius
import Text.Coffee
import Yesod.Routes.Class
import Yesod.Handler
( Route, GHandler, YesodSubRoute(..), toMasterHandlerMaybe, getYesod
( GHandler, YesodSubRoute(..), toMasterHandlerMaybe, getYesod
, getMessageRender, getUrlRenderParams, MonadLift (..)
)
import Yesod.Message (RenderMessage)

10
yesod-core/test/YesodCoreTest/CleanPath.hs
View File

@ -20,14 +20,13 @@ data Subsite = Subsite
getSubsite :: a -> Subsite
getSubsite = const Subsite
data SubsiteRoute = SubsiteRoute [TS.Text]
deriving (Eq, Show, Read)
type instance Route Subsite = SubsiteRoute
instance RenderRoute SubsiteRoute where
instance RenderRoute Subsite where
data Route Subsite = SubsiteRoute [TS.Text]
deriving (Eq, Show, Read)
renderRoute (SubsiteRoute x) = (x, [])
instance YesodDispatch Subsite master where
yesodDispatch _ _ pieces _ _ = Just $ const $ return $ responseLBS
yesodDispatch _ _ _ _ _ _ pieces _ _ = return $ responseLBS
status200
[ ("Content-Type", "SUBSITE")
] $ L8.pack $ show pieces
@ -43,6 +42,7 @@ mkYesod "Y" [parseRoutes|
instance Yesod Y where
approot _ = "http://test"
cleanPath _ s@("subsite":_) = Right s
cleanPath _ ["bar", ""] = Right ["bar"]
cleanPath _ ["bar"] = Left ["bar", ""]
cleanPath _ s =

3
yesod-core/yesod-core.cabal
View File

@ -46,6 +46,7 @@ library
build-depends: wai-test
build-depends: time >= 1.1.4
, yesod-routes >= 0.0 && < 0.1
, wai >= 1.0 && < 1.1
, wai-extra >= 1.0 && < 1.1
, bytestring >= 0.9.1.4 && < 0.10
@ -94,8 +95,6 @@ library
Yesod.Internal.Core
Yesod.Internal.Session
Yesod.Internal.Request
Yesod.Internal.Dispatch
Yesod.Internal.RouteParsing
Paths_yesod_core
ghc-options: -Wall

1
yesod-form/Yesod/Form/Jquery.hs
View File

@ -16,6 +16,7 @@ module Yesod.Form.Jquery
) where
import Yesod.Handler
import Yesod.Core (Route)
import Yesod.Form
import Yesod.Widget
import Data.Time (UTCTime (..), Day, TimeOfDay (..), timeOfDayToTime,

1
yesod-form/Yesod/Form/Nic.hs
View File

@ -11,6 +11,7 @@ module Yesod.Form.Nic
) where
import Yesod.Handler
import Yesod.Core (Route)
import Yesod.Form
import Yesod.Widget
import Text.HTML.SanitizeXSS (sanitizeBalance)

4
yesod-newsfeed/Yesod/AtomFeed.hs
View File

@ -22,9 +22,7 @@ module Yesod.AtomFeed
, module Yesod.FeedTypes
) where
import Yesod.Content
import Yesod.Handler
import Yesod.Widget
import Yesod.Core
import Yesod.FeedTypes
import Text.Hamlet (HtmlUrl, xhamlet, hamlet)
import qualified Data.ByteString.Char8 as S8

2
yesod-newsfeed/Yesod/Feed.hs
View File

@ -25,7 +25,7 @@ import Yesod.FeedTypes
import Yesod.AtomFeed
import Yesod.RssFeed
import Yesod.Content (HasReps (chooseRep), typeAtom, typeRss)
import Yesod.Handler (Route, GHandler)
import Yesod.Core (Route, GHandler)
data RepAtomRss = RepAtomRss RepAtom RepRss
instance HasReps RepAtomRss where

4
yesod-newsfeed/Yesod/RssFeed.hs
View File

@ -18,9 +18,7 @@ module Yesod.RssFeed
, module Yesod.FeedTypes
) where
import Yesod.Handler
import Yesod.Content
import Yesod.Widget
import Yesod.Core
import Yesod.FeedTypes
import Text.Hamlet (HtmlUrl, xhamlet, hamlet)
import qualified Data.ByteString.Char8 as S8

25
yesod-routes/LICENSE Normal file
View File

@ -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.

7
yesod-routes/Setup.lhs Executable file
View File

@ -0,0 +1,7 @@
#!/usr/bin/env runhaskell
> module Main where
> import Distribution.Simple
> main :: IO ()
> main = defaultMain

12
yesod-routes/Yesod/Routes/Class.hs Normal file
View File

@ -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)])

323
yesod-routes/Yesod/Routes/Dispatch.lhs Normal file
View File

@ -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

133
yesod-routes/Yesod/Routes/Parse.hs Normal file
View File

@ -0,0 +1,133 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# OPTIONS_GHC -fno-warn-missing-fields #-} -- QuasiQuoter
module Yesod.Routes.Parse
( parseRoutes
, parseRoutesFile
, parseRoutesNoCheck
, parseRoutesFileNoCheck
, parseType
) where
import Web.PathPieces
import Language.Haskell.TH.Syntax
import Data.Maybe
import Data.Either
import Data.List
import Data.Char (toLower, isUpper)
import qualified Data.Text
import Language.Haskell.TH.Quote
import Data.Data
import qualified System.IO as SIO
import Yesod.Routes.TH
-- | 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 findOverlaps res of
[] -> lift res
z -> error $ "Overlapping routes: " ++ unlines (map (unwords . map resourceName) z)
parseRoutesFile :: FilePath -> Q Exp
parseRoutesFile fp = do
s <- qRunIO $ readUtf8File fp
quoteExp parseRoutes s
parseRoutesFileNoCheck :: FilePath -> Q Exp
parseRoutesFileNoCheck fp = do
s <- qRunIO $ readUtf8File fp
quoteExp parseRoutesNoCheck 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 [subTyp, subFun] 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 -> ([Piece String], Maybe String)
piecesFromString "" = ([], Nothing)
piecesFromString x =
case (this, rest) of
(Left typ, ([], Nothing)) -> ([], Just typ)
(Left typ, _) -> 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 (Piece String)
pieceFromString ('#':x) = Right $ Dynamic x
pieceFromString ('*':x) = Left x
pieceFromString x = Right $ Static x
-- n^2, should be a way to speed it up
findOverlaps :: [Resource a] -> [[Resource a]]
findOverlaps = go . map justPieces
where
justPieces :: Resource a -> ([Piece a], Resource a)
justPieces r@(Resource _ ps _) = (ps, r)
go [] = []
go (x:xs) = mapMaybe (mOverlap x) xs ++ go xs
mOverlap :: ([Piece a], Resource a) -> ([Piece a], Resource a) ->
Maybe [Resource a]
mOverlap _ _ = Nothing
{- FIXME mOverlap
mOverlap (Static x:xs, xr) (Static y:ys, yr)
| x == y = mOverlap (xs, xr) (ys, yr)
| otherwise = Nothing
mOverlap (MultiPiece _:_, xr) (_, yr) = Just (xr, yr)
mOverlap (_, xr) (MultiPiece _:_, yr) = Just (xr, yr)
mOverlap ([], xr) ([], yr) = Just (xr, yr)
mOverlap ([], _) (_, _) = Nothing
mOverlap (_, _) ([], _) = Nothing
mOverlap (_:xs, xr) (_:ys, yr) = mOverlap (xs, xr) (ys, yr)
-}

12
yesod-routes/Yesod/Routes/TH.hs Normal file
View File

@ -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

295
yesod-routes/Yesod/Routes/TH/Dispatch.hs Normal file
View File

@ -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 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 resPieces
isMulti <-
case resDisp of
Methods Nothing _ -> [|False|]
_ -> [|True|]
[|D.Route $(return routePieces) $(return isMulti) $(routeArg3 runHandler dispatcher fixHandler name 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|]

102
yesod-routes/Yesod/Routes/TH/RenderRoute.hs Normal file
View File

@ -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 $ 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 $ 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 (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]

59
yesod-routes/Yesod/Routes/TH/Types.hs Normal file
View File

@ -0,0 +1,59 @@
{-# LANGUAGE TemplateHaskell #-}
module Yesod.Routes.TH.Types
( -- * Data types
Resource (..)
, Piece (..)
, Dispatch (..)
-- ** Helper functions
, resourceMulti
) where
import Language.Haskell.TH.Syntax
data Resource typ = Resource
{ resourceName :: String
, resourcePieces :: [Piece typ]
, resourceDispatch :: Dispatch typ
}
deriving Show
instance Functor Resource where
fmap f (Resource a b c) = Resource a (map (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

273
yesod-routes/test/main.hs Normal file
View File

@ -0,0 +1,273 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE TypeSynonymInstances #-}
import Test.Hspec.Monadic
import Test.Hspec.HUnit ()
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.TH hiding (Dispatch)
import Language.Haskell.TH.Syntax
class ToText a where
toText :: a -> Text
instance ToText Text where toText = id
instance ToText String where toText = pack
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 YRC.Route MySub = MySubRoute ([Text], [(Text, Text)])
deriving (Show, Eq, Read)
renderRoute (MySubRoute x) = x
getMySub :: MyApp -> MySub
getMySub MyApp = MySub
data MySubParam = MySubParam Int
instance RenderRoute MySubParam where
data YRC.Route MySubParam = ParamRoute Char
deriving (Show, Eq, Read)
renderRoute (ParamRoute x) = ([singleton x], [])
getMySubParam :: MyApp -> Int -> MySubParam
getMySubParam _ = MySubParam
type Handler sub master = Text
type App sub master = (Text, Maybe (YRC.Route master))
class Dispatcher sub master where
dispatcher
:: master
-> sub
-> (YRC.Route sub -> YRC.Route master)
-> App sub master -- ^ 404 page
-> (YRC.Route sub -> App sub master) -- ^ 405 page
-> Text -- ^ method
-> [Text]
-> App sub master
class RunHandler sub master where
runHandler
:: Handler sub master
-> master
-> sub
-> Maybe (YRC.Route sub)
-> (YRC.Route sub -> YRC.Route master)
-> App sub master
do
texts <- [t|[Text]|]
let ress =
[ Resource "RootR" [] $ Methods Nothing ["GET"]
, Resource "BlogPostR" [Static "blog", Dynamic $ ConT ''Text] $ Methods Nothing ["GET", "POST"]
, Resource "WikiR" [Static "wiki"] $ Methods (Just texts) []
, Resource "SubsiteR" [Static "subsite"] $ Subsite (ConT ''MySub) "getMySub"
, Resource "SubparamR" [Static "subparam", Dynamic $ ConT ''Int] $ Subsite (ConT ''MySubParam) "getMySubParam"
]
rrinst <- mkRenderRouteInstance (ConT ''MyApp) ress
dispatch <- mkDispatchClause [|runHandler|] [|dispatcher|] [|toText|] ress
return
[ rrinst
, InstanceD
[]
(ConT ''Dispatcher
`AppT` ConT ''MyApp
`AppT` ConT ''MyApp)
[FunD (mkName "dispatcher") [dispatch]]
]
instance RunHandler MyApp master where
runHandler h _ _ subRoute toMaster = (h, fmap toMaster subRoute)
instance Dispatcher MySub master where
dispatcher _ _ toMaster _ _ _ pieces = (pack $ "subsite: " ++ show pieces, Just $ toMaster $ MySubRoute (pieces, []))
instance Dispatcher MySubParam master where
dispatcher _ (MySubParam i) toMaster app404 _ _ pieces =
case map unpack pieces of
[[c]] -> (pack $ "subparam " ++ show i ++ ' ' : [c], Just $ toMaster $ ParamRoute c)
_ -> app404
{-
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 = hspecX $ 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 MyApp MyApp id (pack "404", Nothing) (\route -> (pack "405", Just route)) (pack m) (map pack ps)
it "routes to root" $ disp "GET" [] @?= (pack "this is the root", Just RootR)
it "POST root is 405" $ disp "POST" [] @?= (pack "405", Just RootR)
it "invalid page is a 404" $ disp "GET" ["not-found"] @?= (pack "404", Nothing)
it "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')
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

49
yesod-routes/yesod-routes.cabal Normal file
View File

@ -0,0 +1,49 @@
name: yesod-routes
version: 0.0.0
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
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: git://github.com/yesodweb/yesod.git

2
yesod-sitemap/Yesod/Sitemap.hs
View File

@ -26,7 +26,7 @@ module Yesod.Sitemap
) where
import Yesod.Content (RepXml (..), RepPlain (..), toContent, formatW3)
import Yesod.Handler (Route, GHandler, getUrlRender)
import Yesod.Core (Route, GHandler, getUrlRender)
import Yesod.Handler (hamletToContent)
import Text.Hamlet (HtmlUrl, xhamlet)
import Data.Time (UTCTime)

48
yesod-static/Yesod/Static.hs
View File

@ -29,7 +29,7 @@
module Yesod.Static
( -- * Subsite
Static (..)
, StaticRoute (..)
, Route (..)
-- * Smart constructor
, static
, staticDevel
@ -120,36 +120,32 @@ embed fp =
{ ssFolder = embeddedLookup (toEmbedded $(embedDir fp))
})|]
-- | A route on the static subsite (see also 'staticFiles').
--
-- You may use this constructor directly to manually link to a
-- static file. The first argument is the sub-path to the file
-- being served whereas the second argument is the key-value
-- pairs in the query string. For example,
--
-- > StaticRoute $ StaticR [\"thumb001.jpg\"] [(\"foo\", \"5\"), (\"bar\", \"choc\")]
--
-- would generate a url such as
-- @http://www.example.com/static/thumb001.jpg?foo=5&bar=choc@
-- The StaticRoute constructor can be used when the URL cannot be
-- statically generated at compile-time (e.g. when generating
-- image galleries).
data StaticRoute = StaticRoute [Text] [(Text, Text)]
deriving (Eq, Show, Read)
type instance Route Static = StaticRoute
instance RenderRoute StaticRoute where
instance RenderRoute Static where
-- | A route on the static subsite (see also 'staticFiles').
--
-- You may use this constructor directly to manually link to a
-- static file. The first argument is the sub-path to the file
-- being served whereas the second argument is the key-value
-- pairs in the query string. For example,
--
-- > StaticRoute $ StaticR [\"thumb001.jpg\"] [(\"foo\", \"5\"), (\"bar\", \"choc\")]
--
-- would generate a url such as
-- @http://www.example.com/static/thumb001.jpg?foo=5&bar=choc@
-- The StaticRoute constructor can be used when the URL cannot be
-- statically generated at compile-time (e.g. when generating
-- image galleries).
data Route Static = StaticRoute [Text] [(Text, Text)]
deriving (Eq, Show, Read)
renderRoute (StaticRoute x y) = (x, y)
instance Yesod master => YesodDispatch Static master where
-- Need to append trailing slash to make relative links work
yesodDispatch _ _ [] _ _ = Just $
\req -> return $ responseLBS status301 [("Location", rawPathInfo req `S.append` "/")] ""
yesodDispatch _ _ _ _ _ _ [] _ req =
return $ responseLBS status301 [("Location", rawPathInfo req `S.append` "/")] ""
yesodDispatch (Static set) _ textPieces _ _ = Just $
\req -> staticApp set req { pathInfo = textPieces }
yesodDispatch _ (Static set) _ _ _ _ textPieces _ req =
staticApp set req { pathInfo = textPieces }
notHidden :: Prelude.FilePath -> Bool
notHidden "tmp" = False

2
yesod-static/yesod-static.cabal
View File

@ -13,7 +13,7 @@ homepage: http://www.yesodweb.com/
description: Static file serving subsite for Yesod Web Framework.
extra-source-files:
test/YesodStaticTest.hs
tests.hs
test/tests.hs
flag test
description: Build for use with running tests