diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index ac410bc5..85c52a83 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -28,6 +28,7 @@ module Yesod.Dispatch import Prelude hiding (exp) import Yesod.Core import Yesod.Handler +import Yesod.Internal.Dispatch import Web.Routes.Quasi import Web.Routes.Quasi.Parse @@ -42,14 +43,12 @@ import qualified Data.ByteString.Char8 as B import qualified Data.ByteString as S import Data.ByteString.Lazy.Char8 () -import Control.Monad import Web.ClientSession -import Data.Char (isUpper, toLower) +import Data.Char (isUpper) import Web.Routes (decodePathInfo) import Control.Monad.IO.Class (liftIO) -import Data.List (foldl') #if TEST import Test.Framework (testGroup, Test) @@ -58,8 +57,6 @@ import Test.QuickCheck import System.IO.Unsafe #endif -import Yesod.Content - -- | Generates URL datatype and site function for the given 'Resource's. This -- is used for creating sites, /not/ subsites. See 'mkYesodSub' for the latter. -- Use 'parseRoutes' to create the 'Resource's. @@ -133,8 +130,7 @@ mkYesodGeneral name args clazzes isSub res = do [ FunD (mkName "renderRoute") render ] - let sortedRes = filter (not . isSubSite) th' ++ filter isSubSite th' - yd <- mkYesodDispatch' sortedRes + yd <- mkYesodDispatch' th' let master = mkName "master" let ctx = if isSub then ClassP (mkName "Yesod") [VarT master] : clazzes @@ -145,195 +141,6 @@ mkYesodGeneral name args clazzes isSub res = do let y = InstanceD ctx ytyp [FunD (mkName "yesodDispatch") [yd]] return ([w, x, x'], [y]) -isSubSite :: ((String, Pieces), a) -> Bool -isSubSite ((_, SubSite{}), _) = True -isSubSite _ = False - -mkYesodDispatch' :: [((String, Pieces), Maybe String)] -> Q Clause -mkYesodDispatch' sortedRes = do - sub <- newName "sub" - master <- newName "master" - mkey <- newName "mkey" - segments <- newName "segments" - toMasterRoute <- newName "toMasterRoute" - nothing <- [|Nothing|] - body <- foldM (go master (VarE sub) (VarE toMasterRoute) mkey segments) nothing sortedRes - 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 <- [|W.requestMethod|] - let caseExp = rm `AppE` VarE req - yr <- [|yesodRunner|] - cr <- [|fmap chooseRep|] - let url = foldl' AppE (ConE $ mkName constr) $ frontVars [] - let runHandlerVars h = runHandler' $ cr `AppE` foldl' AppE (VarE $ mkName h) (frontVars []) - runHandler' h = NormalB $ yr `AppE` sub - `AppE` VarE master - `AppE` toMasterRoute - `AppE` VarE mkey - `AppE` (just `AppE` url) - `AppE` h - `AppE` VarE req - let match m = Match (LitP $ StringL m) (runHandlerVars $ map toLower m ++ constr) [] - let clauses = - case methods of - [] -> [Clause [VarP req] (runHandlerVars $ "handle" ++ constr) []] - _ -> [Clause [VarP req] (NormalB $ CaseE caseExp $ map match methods ++ - [Match WildP (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|] - let exp = CaseE segments - [ Match - (InfixP (LitP $ StringL s) (mkName ":") (VarP srest)) - (NormalB 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 <- [|fromSinglePiece|] - let exp' = CaseE (fsp `AppE` VarE next) - [ Match - (ConP (mkName "Left") [WildP]) - (NormalB nothing) - [] - , Match - (ConP (mkName "Right") [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 <- [|fromMultiPiece|] - let exp = CaseE (fmp `AppE` segments) - [ Match - (ConP (mkName "Left") [WildP]) - (NormalB nothing) - [] - , Match - (ConP (mkName "Right") [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|] - let exp = CaseE (VarE segments) - [ Match - (InfixP (LitP $ StringL s) (mkName ":") (VarP srest)) - (NormalB 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 <- [|fromSinglePiece|] - let exp' = CaseE (fsp `AppE` VarE next) - [ Match - (ConP (mkName "Left") [WildP]) - (NormalB nothing) - [] - , Match - (ConP (mkName "Right") [VarP next']) - (NormalB innerExp) - [] - ] - let exp = CaseE (VarE segments) - [ Match - (InfixP (VarP next) (mkName ":") (VarP srest)) - (NormalB exp') - [] - , Match WildP (NormalB nothing) [] - ] - return exp - thResourceFromResource :: Resource -> Q (THResource, Maybe String) thResourceFromResource (Resource n ps atts) | all (all isUpper) atts = return ((n, Simple ps atts), Nothing) @@ -406,22 +213,6 @@ toWaiApp' y key' env = do , ("Location", dest') ] "Redirecting" -{- -defaultDispatchSubsite - :: (Yesod m, YesodDispatch m, YesodSubSite s m) - => m -> Maybe Key -> [String] - -> (Route s -> Route m) - -> s - -> W.Application -defaultDispatchSubsite y key' segments toMasterRoute s env = error "FIXME" {- - case dispatchToSubSubsite y key' segments toMasterRoute s of - Just app -> app env - Nothing -> - case dispatchSubLocal y key' segments toMasterRoute s of - Just app -> app env - Nothing -> yesodRunner y key' Nothing notFound env-} --} - #if TEST dispatchTestSuite :: Test diff --git a/Yesod/Internal/Dispatch.hs b/Yesod/Internal/Dispatch.hs new file mode 100644 index 00000000..3b52352e --- /dev/null +++ b/Yesod/Internal/Dispatch.hs @@ -0,0 +1,250 @@ +{-# LANGUAGE TemplateHaskell #-} +-- | 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.Routes.Quasi +import Web.Routes.Quasi.Parse +import Web.Routes.Quasi.TH +import Control.Monad (foldM) +import Yesod.Handler (badMethod) +import Yesod.Content (chooseRep) +import qualified Network.Wai as W +import Yesod.Core (yesodRunner, yesodDispatch) +import Data.List (foldl') +import Data.Char (toLower) + +{-| + +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 fromSinglePiece/fromMultiPiece, 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 fromSinglePiece b of + Left _ -> Nothing + Right name -> + case bs of + "age":cs -> + case cs of + [] -> Nothing + d:ds -> + case fromSinglePiece 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. +-} +mkYesodDispatch' :: [((String, Pieces), Maybe String)] -> Q Clause +mkYesodDispatch' res = do + sub <- newName "sub" + master <- newName "master" + mkey <- newName "mkey" + segments <- newName "segments" + toMasterRoute <- newName "toMasterRoute" + nothing <- [|Nothing|] + body <- foldM (go master (VarE sub) (VarE toMasterRoute) mkey segments) nothing res + 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 <- [|W.requestMethod|] + let caseExp = rm `AppE` VarE req + yr <- [|yesodRunner|] + cr <- [|fmap chooseRep|] + let url = foldl' AppE (ConE $ mkName constr) $ frontVars [] + let runHandlerVars h = runHandler' $ cr `AppE` foldl' AppE (VarE $ mkName h) (frontVars []) + runHandler' h = NormalB $ yr `AppE` sub + `AppE` VarE master + `AppE` toMasterRoute + `AppE` VarE mkey + `AppE` (just `AppE` url) + `AppE` h + `AppE` VarE req + let match m = Match (LitP $ StringL m) (runHandlerVars $ map toLower m ++ constr) [] + let clauses = + case methods of + [] -> [Clause [VarP req] (runHandlerVars $ "handle" ++ constr) []] + _ -> [Clause [VarP req] (NormalB $ CaseE caseExp $ map match methods ++ + [Match WildP (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|] + let exp = CaseE segments + [ Match + (InfixP (LitP $ StringL s) (mkName ":") (VarP srest)) + (NormalB 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 <- [|fromSinglePiece|] + let exp' = CaseE (fsp `AppE` VarE next) + [ Match + (ConP (mkName "Left") [WildP]) + (NormalB nothing) + [] + , Match + (ConP (mkName "Right") [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 <- [|fromMultiPiece|] + let exp = CaseE (fmp `AppE` segments) + [ Match + (ConP (mkName "Left") [WildP]) + (NormalB nothing) + [] + , Match + (ConP (mkName "Right") [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|] + let exp = CaseE (VarE segments) + [ Match + (InfixP (LitP $ StringL s) (mkName ":") (VarP srest)) + (NormalB 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 <- [|fromSinglePiece|] + let exp' = CaseE (fsp `AppE` VarE next) + [ Match + (ConP (mkName "Left") [WildP]) + (NormalB nothing) + [] + , Match + (ConP (mkName "Right") [VarP next']) + (NormalB innerExp) + [] + ] + let exp = CaseE (VarE segments) + [ Match + (InfixP (VarP next) (mkName ":") (VarP srest)) + (NormalB exp') + [] + , Match WildP (NormalB nothing) [] + ] + return exp diff --git a/yesod-core.cabal b/yesod-core.cabal index 8cc2e95e..776f190e 100644 --- a/yesod-core.cabal +++ b/yesod-core.cabal @@ -57,6 +57,7 @@ library other-modules: Yesod.Internal Yesod.Internal.Session Yesod.Internal.Request + Yesod.Internal.Dispatch Paths_yesod_core ghc-options: -Wall -Werror