diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 0a8fda24..e1db0723 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -162,7 +162,7 @@ mkYesodGeneral name args clazzes isSub res = do render'' <- newName "render" let render = LetE [FunD render'' render'] $ VarE render'' - tmh <- [|toMasterHandler|] + tmh <- [|toMasterHandlerDyn|] modMaster <- [|fmap chooseRep|] dispatch' <- createDispatch modMaster tmh th dispatch'' <- newName "dispatch" @@ -188,10 +188,11 @@ fromStatic (StaticPiece s) = s fromStatic _ = error "fromStatic" thResourceFromResource :: Type -> Resource -> Q THResource -thResourceFromResource _ (Resource n ps attribs) - | all (all isUpper) attribs = return (n, Simple ps attribs) +thResourceFromResource _ (Resource n ps atts) + | all (all isUpper) atts = return (n, Simple ps atts) thResourceFromResource master (Resource n ps atts@[stype, toSubArg]) - | all isStatic ps && any (any isLower) atts = do + -- static route to subsite + = do let stype' = ConT $ mkName stype gss <- [|getSubSite|] let inside = ConT ''Maybe `AppT` @@ -213,8 +214,9 @@ thResourceFromResource master (Resource n ps atts@[stype, toSubArg]) , ssRender = render , ssDispatch = dispatch , ssToMasterArg = VarE $ mkName toSubArg - , ssPieces = map fromStatic ps + , ssPieces = ps }) + thResourceFromResource _ (Resource n _ _) = error $ "Invalid attributes for resource: " ++ n diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index ff7b99b4..502f93d9 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -77,6 +77,7 @@ module Yesod.Handler , runHandler , YesodApp (..) , toMasterHandler + , toMasterHandlerDyn , toMasterHandlerMaybe , localNoCurrent , HandlerData @@ -166,6 +167,15 @@ toMasterHandler :: (Route sub -> Route master) toMasterHandler tm ts route (GHandler h) = GHandler $ withReaderT (handlerSubData tm ts route) h +toMasterHandlerDyn :: (Route sub -> Route master) + -> GHandler sub' master sub + -> Route sub + -> GHandler sub master a + -> GHandler sub' master a +toMasterHandlerDyn tm getSub route (GHandler h) = do + sub <- getSub + GHandler $ withReaderT (handlerSubData tm (const sub) route) h + toMasterHandlerMaybe :: (Route sub -> Route master) -> (master -> sub) -> Maybe (Route sub) diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 6a2523c4..71a0a579 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -87,6 +87,8 @@ type Method = String -- to deal with it directly, as the mkYesodSub creates instances appropriately. class Eq (Route s) => YesodSubSite s y where getSubSite :: Site (Route s) (Method -> Maybe (GHandler s y ChooseRep)) + getSiteFromSubSite :: s -> Site (Route s) (Method -> Maybe (GHandler s y ChooseRep)) + getSiteFromSubSite _ = getSubSite -- | Define settings for a Yesod applications. The only required setting is -- 'approot'; other than that, there are intelligent defaults.