Continued work on subsites

Yesod/Handler.hs

@@ -5,6 +5,7 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE PackageImports #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE Rank2Types #-}
 ---------------------------------------------------------
 --
 -- Module        : Yesod.Handler
@@ -31,9 +32,9 @@ module Yesod.Handler
     , runHandler
     , runHandler'
     , runHandlerSub
+    , runHandlerSub'
     , liftIO
     , YesodApp (..)
-    , YesodAppSub (..)
     , Routes
       -- * Special handlers
     , redirect
@@ -84,8 +85,6 @@ newtype YesodApp = YesodApp
     -> IO Response
     }
 
-data YesodAppSub master = YesodAppSub
-
 ------ Handler monad
 newtype GHandler sub master a = Handler {
     unHandler :: HandlerData sub master
@@ -146,41 +145,32 @@ getRouteMaster = do
     d <- getData
     return $ handlerToMaster d <$> handlerRoute d
 
+runHandlerSub' :: HasReps c
+               => GHandler sub master c
+               -> (master, master -> sub, Routes sub -> Routes master, Routes master -> String)
+               -> Routes sub
+               -> (Routes sub -> String)
+               -> YesodApp
+runHandlerSub' handler arg route render = runHandlerSub handler arg (Just route) render
+
 runHandlerSub :: HasReps c
               => GHandler sub master c
-              -> master
+              -> (master, master -> sub, Routes sub -> Routes master, Routes master -> String)
-              -> (master -> sub)
+              -> Maybe (Routes sub)
-              -> Routes sub
               -> (Routes sub -> String)
-              -> YesodAppSub master
+              -> YesodApp
-runHandlerSub = error "runHandlerSub"
+runHandlerSub handler (ma, tosa, tomr, mrender) sroute _ = YesodApp $ \eh rr cts -> do
-
-runHandler' :: HasReps c
-            => Handler yesod c
-            -> yesod
-            -> Routes yesod
-            -> (Routes yesod -> String)
-            -> YesodApp
-runHandler' handler y route render = runHandler handler y (Just route) render
-
-runHandler :: HasReps c
-           => Handler yesod c
-           -> yesod
-           -> Maybe (Routes yesod)
-           -> (Routes yesod -> String)
-           -> YesodApp
-runHandler handler y route render = YesodApp $ \eh rr cts -> do
     let toErrorHandler =
             InternalError
           . (show :: Control.Exception.SomeException -> String)
     (headers, contents) <- Control.Exception.catch
         (unHandler handler $ HandlerData
             { handlerRequest = rr
-            , handlerSub = y
+            , handlerSub = tosa ma
-            , handlerMaster = y
+            , handlerMaster = ma
-            , handlerRoute = route
+            , handlerRoute = sroute
-            , handlerRender = render
+            , handlerRender = mrender
-            , handlerToMaster = id
+            , handlerToMaster = tomr
             })
         (\e -> return ([], HCError $ toErrorHandler e))
     let handleError e = do
@@ -202,6 +192,23 @@ runHandler handler y route render = YesodApp $ \eh rr cts -> do
             (ct, c) <- chooseRep a cts
             return $ Response W.Status200 headers ct c
 
+runHandler' :: HasReps c
+            => Handler yesod c
+            -> yesod
+            -> Routes yesod
+            -> (Routes yesod -> String)
+            -> YesodApp
+runHandler' handler y route render = runHandler handler y (Just route) render
+
+runHandler :: HasReps c
+           => Handler yesod c
+           -> yesod
+           -> Maybe (Routes yesod)
+           -> (Routes yesod -> String)
+           -> YesodApp
+runHandler handler y route render =
+    runHandlerSub handler (y, id, id, render) route render
+
 safeEh :: ErrorResponse -> YesodApp
 safeEh er = YesodApp $ \_ _ _ -> do
     liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er

Yesod/Helpers/Auth.hs

@@ -25,7 +25,7 @@ module Yesod.Helpers.Auth
     , displayName
     , redirectLogin
     , Auth (..)
-    , siteAuthRoutes
+    , siteAuth
     ) where
 
 import Web.Encodings

Yesod/Helpers/Static.hs

@@ -21,7 +21,7 @@
 module Yesod.Helpers.Static
     ( FileLookup
     , fileLookupDir
-    , siteStaticRoutes
+    , siteStatic
     , StaticRoutes
     , staticArgs
     , Static
@@ -33,6 +33,7 @@ import Control.Monad
 import Yesod
 import Data.List (intercalate)
 import Network.Wai
+import Web.Routes
 
 type FileLookup = FilePath -> IO (Maybe (Either FilePath Content))
 
@@ -42,10 +43,15 @@ staticArgs :: FileLookup -> Static
 staticArgs = Static
 
 -- FIXME bug in web-routes-quasi generates warning here
-$(mkYesod "Static" [$parseRoutes|
+$(mkYesodSub "Static" [$parseRoutes|
 /* StaticRoute GET
 |])
 
+siteStatic' :: Site StaticRoutes (String -> YesodApp
+    -> (master, master -> Static, StaticRoutes -> Routes master, Routes master -> String)
+    -> YesodApp)
+siteStatic' = siteStatic
+
 -- | A 'FileLookup' for files in a directory. Note that this function does not
 -- check if the requested path does unsafe things, eg expose hidden files. You
 -- should provide this checking elsewhere.
@@ -60,7 +66,7 @@ fileLookupDir dir = Static $ \fp -> do
         then return $ Just $ Left fp'
         else return Nothing
 
-getStatic :: FileLookup -> [String] -> Handler y [(ContentType, Content)]
+getStatic :: FileLookup -> [String] -> GHandler sub master [(ContentType, Content)]
 getStatic fl fp' = do
     when (any isUnsafe fp') notFound
     wai <- waiRequest
@@ -76,7 +82,7 @@ getStatic fl fp' = do
     isUnsafe ('.':_) = True
     isUnsafe _ = False
 
-getStaticRoute :: [String] -> Handler Static [(ContentType, Content)]
+getStaticRoute :: [String] -> GHandler Static master [(ContentType, Content)]
 getStaticRoute fp = do
     Static fl <- getYesod
     getStatic fl fp

Yesod/Resource.hs

@@ -6,7 +6,7 @@ module Yesod.Resource
     , mkYesodSub
     ) where
 
-import Web.Routes.Quasi (parseRoutes, createRoutes, Resource (..))
+import Web.Routes.Quasi
 import Yesod.Handler
 import Language.Haskell.TH.Syntax
 import Yesod.Yesod
@@ -15,24 +15,31 @@ mkYesod :: String -> [Resource] -> Q [Dec]
 mkYesod name res = do
     let name' = mkName name
     let tySyn = TySynInstD ''Routes [ConT $ name'] (ConT $ mkName $ name ++ "Routes")
-    let gsbod = NormalB $ VarE $ mkName $ "site" ++ name ++ "Routes"
+    let site = mkName $ "site" ++ name
+    let gsbod = NormalB $ VarE site
     let yes' = FunD (mkName "getSite") [Clause [] gsbod []]
     let yes = InstanceD [] (ConT ''YesodSite `AppT` ConT name') [yes']
-    decs <- createRoutes (name ++ "Routes")
+    CreateRoutesResult x y z <- createRoutes $ CreateRoutesSettings
-                         (ConT ''YesodApp)
+                { crRoutes = mkName $ name ++ "Routes"
-                         name'
+                , crApplication = ConT ''YesodApp
-                         "runHandler'"
+                , crArgument = ConT $ mkName name
-                         res
+                , crExplode = VarE $ mkName "runHandler'"
-    return $ tySyn : yes : decs
+                , crResources = res
+                , crSite = site
+                }
+    return [tySyn, yes, x, y, z]
 
 mkYesodSub :: String -> [Resource] -> Q [Dec]
 mkYesodSub name res = do
     let name' = mkName name
-    let tySyn = TySynInstD ''Routes [ConT $ name'] (ConT $ mkName $ name ++ "Routes")
+    let site = mkName $ "site" ++ name
-    let yas = ConT ''YesodApp `AppT` VarT (mkName "master")
+    let tySyn = TySynInstD ''Routes [ConT name'] (ConT $ mkName $ name ++ "Routes")
-    decs <- createRoutes (name ++ "Routes")
+    CreateRoutesResult x _ z <- createRoutes $ CreateRoutesSettings
-                         yas
+                { crRoutes = mkName $ name ++ "Routes"
-                         name'
+                , crApplication = ConT ''YesodApp
-                         "runHandlerSub"
+                , crArgument = ConT $ mkName name
-                         res
+                , crExplode = VarE $ mkName "runHandlerSub'"
-    return $ tySyn : decs
+                , crResources = res
+                , crSite = site
+                }
+    return [tySyn, x, z]

examples/static.hs

@@ -10,7 +10,7 @@ import Network.Wai.Handler.SimpleServer
 data StaticExample = StaticExample
 
 mkYesod "StaticExample" [$parseRoutes|
-/     Root    StaticRoutes siteStaticRoutes getStaticSite
+/     Root    StaticRoutes siteStatic getStaticSite
 |]
 
 instance Yesod StaticExample where