diff --git a/Yesod/Core.hs b/Yesod/Core.hs index 53a0bed5..027a27f7 100644 --- a/Yesod/Core.hs +++ b/Yesod/Core.hs @@ -93,8 +93,15 @@ type Method = String -- to deal with it directly, as mkYesodSub creates instances appropriately. class Eq (Route s) => YesodSubSite s y where getSubSite :: Site (Route s) (Method -> Maybe (GHandler s y ChooseRep)) - dispatchSubsite :: y -> Maybe CS.Key -> [String] -> s -> W.Application - dispatchSubsite _ _ _ _ _ = return $ W.responseLBS W.status200 [("Content-Type", "text/plain")] $ L8.pack "FIXME" + getSubSite' :: s -> y -> Site (Route s) (Method -> Maybe (GHandler s y ChooseRep)) + getSubSite' _ _ = getSubSite + dispatchSubsite :: (Yesod y, YesodSite y) + => y + -> Maybe CS.Key + -> [String] + -> (Route s -> Route y) + -> s + -> W.Application -- | Define settings for a Yesod applications. The only required setting is -- 'approot'; other than that, there are intelligent defaults. diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 7f8a4a85..cfc3e8a6 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -173,9 +173,10 @@ mkYesodGeneral name args clazzes isSub res = do else ([], ConT ''YesodSite `AppT` arg, "getSite") subsiteClauses <- catMaybes <$> mapM sc th' nothing <- [|Nothing|] + dds <- [|defaultDispatchSubsite|] let otherMethods = if isSub - then [] + then [ FunD (mkName "dispatchSubsite") [Clause [] (NormalB dds) []]] else [ FunD (mkName "dispatchToSubsite") (subsiteClauses ++ [Clause [WildP, WildP, WildP] (NormalB nothing) []]) ] @@ -190,7 +191,9 @@ mkYesodGeneral name args clazzes isSub res = do just <- [|Just|] (pat', tma', rest) <- mkPat' pieces $ just `AppE` (VarE (mkName toSub) `AppE` VarE master) ds <- [|dispatchSubsite|] - let body' = ds `AppE` VarE master `AppE` VarE mkey `AppE` rest + -- let toMaster = ConE (mkName "SubsiteR") + toMaster <- [|error "FIXME toMaster"|] + let body' = ds `AppE` VarE master `AppE` VarE mkey `AppE` rest `AppE` toMaster fmap' <- [|(<$>)|] let body = InfixE (Just body') fmap' $ Just tma' return $ Just $ Clause @@ -331,6 +334,27 @@ normalDispatch y key' segments env = Nothing -> badMethod Just h -> h +-- FIXME address sub-subsites +defaultDispatchSubsite + :: (Yesod m, YesodSite m, YesodSubSite s m) + => m -> Maybe Key -> [String] + -> (Route s -> Route m) + -> s + -> W.Application +defaultDispatchSubsite y key' segments toMasterRoute s env = + yesodRunner y key' (fmap toMasterRoute murl) handler env + where + method = B.unpack $ W.requestMethod env + murl = either (const Nothing) Just $ parsePathSegments (getSubSite' s y) segments + handler = toMasterHandlerMaybe toMasterRoute (const s) murl handler' + handler' = + case murl of + Nothing -> notFound + Just url -> + case handleSite (getSubSite' s y) (yesodRender y . toMasterRoute) url method of + Nothing -> badMethod + Just h -> h + #if TEST dispatchTestSuite :: Test diff --git a/helloworld.hs b/helloworld.hs new file mode 100644 index 00000000..29d37b6a --- /dev/null +++ b/helloworld.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE QuasiQuotes, TypeFamilies, OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} +import Yesod.Core +import Yesod.Dispatch +import Yesod.Content +import Yesod.Handler +import Network.Wai.Handler.Warp (run) + +data Subsite = Subsite String + +mkYesodSub "Subsite" [] [$parseRoutes| +/ SubRootR GET +|] + +getSubRootR :: GHandler Subsite m RepPlain +getSubRootR = do + Subsite s <- getYesodSub + return $ RepPlain $ toContent $ "Hello Sub World: " ++ s + +data HelloWorld = HelloWorld { getSubsite :: String -> Subsite } +mkYesod "HelloWorld" [$parseRoutes| +/ RootR GET +/subsite/#String SubsiteR Subsite getSubsite +|] +instance Yesod HelloWorld where approot _ = "" +getRootR = return $ RepPlain "Hello World" +main = toWaiApp (HelloWorld Subsite) >>= run 3000