dispatchSubsite is now working

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
+    getSubSite' :: s -> y -> Site (Route s) (Method -> Maybe (GHandler s y ChooseRep))
-    dispatchSubsite _ _ _ _ _ = return $ W.responseLBS W.status200 [("Content-Type", "text/plain")] $ L8.pack "FIXME"
+    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.

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

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