More built in support for subsites

Yesod/Hamlet.hs

@@ -28,7 +28,7 @@ data PageContent url = PageContent
     , pageBody :: Hamlet url IO ()
     }
 
-hamletToContent :: Hamlet (Routes y) IO () -> Handler y Content
+hamletToContent :: Hamlet (Routes sub) IO () -> GHandler sub master Content
 hamletToContent h = do
     render <- getUrlRender
     return $ ContentEnum $ go render

Yesod/Handler.hs

@@ -21,13 +21,19 @@
 module Yesod.Handler
     ( -- * Handler monad
       Handler
+    , GHandler
     , getYesod
+    , getYesodMaster
     , getUrlRender
+    , getUrlRenderMaster
     , getRoute
+    , getRouteMaster
     , runHandler
     , runHandler'
+    , runHandlerSub
     , liftIO
     , YesodApp (..)
+    , YesodAppSub (..)
     , Routes
       -- * Special handlers
     , redirect
@@ -61,11 +67,13 @@ import Data.Convertible.Text (cs)
 
 type family Routes y
 
-data HandlerData yesod = HandlerData
+data HandlerData sub master = HandlerData
     { handlerRequest :: Request
-    , handlerYesod :: yesod
+    , handlerSub :: sub
-    , handlerRoute :: Maybe (Routes yesod)
+    , handlerMaster :: master
-    , handlerRender :: (Routes yesod -> String)
+    , handlerRoute :: Maybe (Routes sub)
+    , handlerRender :: (Routes master -> String)
+    , handlerToMaster :: Routes sub -> Routes master
     }
 
 newtype YesodApp = YesodApp
@@ -76,22 +84,26 @@ newtype YesodApp = YesodApp
     -> IO Response
     }
 
+data YesodAppSub master = YesodAppSub
+
 ------ Handler monad
-newtype Handler yesod a = Handler {
+newtype GHandler sub master a = Handler {
-    unHandler :: HandlerData yesod
+    unHandler :: HandlerData sub master
               -> IO ([Header], HandlerContents a)
 }
+type Handler yesod = GHandler yesod yesod
+
 data HandlerContents a =
       HCSpecial SpecialResponse
     | HCError ErrorResponse
     | HCContent a
 
-instance Functor (Handler yesod) where
+instance Functor (GHandler sub master) where
     fmap = liftM
-instance Applicative (Handler yesod) where
+instance Applicative (GHandler sub master) where
     pure = return
     (<*>) = ap
-instance Monad (Handler yesod) where
+instance Monad (GHandler sub master) where
     fail = failure . InternalError -- We want to catch all exceptions anyway
     return x = Handler $ \_ -> return ([], HCContent x)
     (Handler handler) >>= f = Handler $ \rr -> do
@@ -102,21 +114,46 @@ instance Monad (Handler yesod) where
                 (HCSpecial e) -> return ([], HCSpecial e)
                 (HCContent a) -> unHandler (f a) rr
         return (headers ++ headers', c')
-instance MonadIO (Handler yesod) where
+instance MonadIO (GHandler sub master) where
     liftIO i = Handler $ \_ -> i >>= \i' -> return ([], HCContent i')
-instance Failure ErrorResponse (Handler yesod) where
+instance Failure ErrorResponse (GHandler sub master) where
     failure e = Handler $ \_ -> return ([], HCError e)
-instance RequestReader (Handler yesod) where
+instance RequestReader (GHandler sub master) where
     getRequest = Handler $ \r -> return ([], HCContent $ handlerRequest r)
 
-getYesod :: Handler yesod yesod
+getData :: GHandler sub master (HandlerData sub master)
-getYesod = Handler $ \r -> return ([], HCContent $ handlerYesod r)
+getData = Handler $ \r -> return ([], HCContent r)
 
-getUrlRender :: Handler yesod (Routes yesod -> String)
+getYesod :: GHandler sub master sub
-getUrlRender = Handler $ \r -> return ([], HCContent $ handlerRender r)
+getYesod = handlerSub <$> getData
 
-getRoute :: Handler yesod (Maybe (Routes yesod))
+getYesodMaster :: GHandler sub master master
-getRoute = Handler $ \r -> return ([], HCContent $ handlerRoute r)
+getYesodMaster = handlerMaster <$> getData
+
+getUrlRender :: GHandler sub master (Routes sub -> String)
+getUrlRender = do
+    d <- getData
+    return $ handlerRender d . handlerToMaster d
+
+getUrlRenderMaster :: GHandler sub master (Routes master -> String)
+getUrlRenderMaster = handlerRender <$> getData
+
+getRoute :: GHandler sub master (Maybe (Routes sub))
+getRoute = handlerRoute <$> getData
+
+getRouteMaster :: GHandler sub master (Maybe (Routes master))
+getRouteMaster = do
+    d <- getData
+    return $ handlerToMaster d <$> handlerRoute d
+
+runHandlerSub :: HasReps c
+              => GHandler sub master c
+              -> master
+              -> (master -> sub)
+              -> Routes sub
+              -> (Routes sub -> String)
+              -> YesodAppSub master
+runHandlerSub = error "runHandlerSub"
 
 runHandler' :: HasReps c
             => Handler yesod c
@@ -137,7 +174,14 @@ runHandler handler y route render = YesodApp $ \eh rr cts -> do
             InternalError
           . (show :: Control.Exception.SomeException -> String)
     (headers, contents) <- Control.Exception.catch
-        (unHandler handler $ HandlerData rr y route render)
+        (unHandler handler $ HandlerData
+            { handlerRequest = rr
+            , handlerSub = y
+            , handlerMaster = y
+            , handlerRoute = route
+            , handlerRender = render
+            , handlerToMaster = id
+            })
         (\e -> return ([], HCError $ toErrorHandler e))
     let handleError e = do
             Response _ hs ct c <- unYesodApp (eh e) safeEh rr cts
@@ -164,14 +208,14 @@ safeEh er = YesodApp $ \_ _ _ -> do
     return $ Response W.Status500 [] TypePlain $ cs "Internal Server Error"
 
 ------ Special handlers
-specialResponse :: SpecialResponse -> Handler yesod a
+specialResponse :: SpecialResponse -> GHandler sub master a
 specialResponse er = Handler $ \_ -> return ([], HCSpecial er)
 
 -- | Redirect to the given URL.
-redirect :: RedirectType -> String -> Handler yesod a
+redirect :: RedirectType -> String -> GHandler sub master a
 redirect rt = specialResponse . Redirect rt
 
-sendFile :: ContentType -> FilePath -> Handler yesod a
+sendFile :: ContentType -> FilePath -> GHandler sub master a
 sendFile ct = specialResponse . SendFile ct
 
 -- | Return a 404 not found page. Also denotes no handler available.
@@ -194,16 +238,16 @@ invalidArgs = failure . InvalidArgs
 addCookie :: Int -- ^ minutes to timeout
           -> String -- ^ key
           -> String -- ^ value
-          -> Handler yesod ()
+          -> GHandler sub master ()
 addCookie a b = addHeader . AddCookie a b
 
 -- | Unset the cookie on the client.
-deleteCookie :: String -> Handler yesod ()
+deleteCookie :: String -> GHandler sub master ()
 deleteCookie = addHeader . DeleteCookie
 
 -- | Set an arbitrary header on the client.
-header :: String -> String -> Handler yesod ()
+header :: String -> String -> GHandler sub master ()
 header a = addHeader . Header a
 
-addHeader :: Header -> Handler yesod ()
+addHeader :: Header -> GHandler sub master ()
 addHeader h = Handler $ \_ -> return ([h], HCContent ())

Yesod/Helpers/Auth.hs

@@ -5,6 +5,7 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE NoMonomorphismRestriction #-} -- FIXME I'd like to get rid of this
 ---------------------------------------------------------
 --
 -- Module        : Yesod.Helpers.Auth
@@ -47,15 +48,14 @@ import Control.Applicative ((<$>))
 
 data LoginType = OpenId | Rpxnow
 
-data Auth = forall y. Yesod y => Auth
+data Auth = Auth
     { defaultDest :: String
-    , onRpxnowLogin :: Rpxnow.Identifier -> Handler Auth ()
+    --, onRpxnowLogin :: Rpxnow.Identifier -> GHandler Auth master ()
     , rpxnowApiKey :: Maybe String
     , defaultLoginType :: LoginType
-    , parentYesod :: y
     }
 
-$(mkYesod "Auth" [$parseRoutes|
+$(mkYesodSub "Auth" [$parseRoutes|
 /check                 Check              GET
 /logout                Logout             GET
 /openid                OpenIdR            GET
@@ -68,13 +68,13 @@ data ExpectedSingleParam = ExpectedSingleParam
     deriving (Show, Typeable)
 instance Exception ExpectedSingleParam
 
-getOpenIdR :: Handler Auth RepHtml
+getOpenIdR :: Yesod master => GHandler Auth master RepHtml
 getOpenIdR = do
     rr <- getRequest
     case getParams rr "dest" of
         [] -> return ()
         (x:_) -> addCookie destCookieTimeout destCookieName x
-    (Auth _ _ _ _ y) <- getYesod
+    y <- getYesodMaster
     let html = template (getParams rr "message", id)
     let pc = PageContent
                 { pageTitle = cs "Log in via OpenID"
@@ -97,7 +97,7 @@ $if hasMessage
     %input!type=submit!value=Login
 |]
 
-getOpenIdForward :: Handler Auth ()
+getOpenIdForward :: GHandler Auth master ()
 getOpenIdForward = do
     rr <- getRequest
     oid <- case getParams rr "openid" of
@@ -112,7 +112,7 @@ getOpenIdForward = do
       (redirect RedirectTemporary)
       res
 
-getOpenIdComplete :: Handler Auth ()
+getOpenIdComplete :: GHandler Auth master ()
 getOpenIdComplete = do
     rr <- getRequest
     let gets' = reqGetParams rr
@@ -126,7 +126,7 @@ getOpenIdComplete = do
         redirectToDest RedirectTemporary $ defaultDest y
     attempt onFailure onSuccess res
 
-handleRpxnowR :: Handler Auth ()
+handleRpxnowR :: GHandler Auth master ()
 handleRpxnowR = do
     ay <- getYesod
     apiKey <- case rpxnowApiKey ay of
@@ -146,7 +146,10 @@ handleRpxnowR = do
                 (d:_) -> d
     ident <- liftIO $ Rpxnow.authenticate apiKey token
     auth <- getYesod
-    onRpxnowLogin auth ident
+    {- FIXME onRpxnowLogin
+    case auth of
+        Auth _ f _ _ _ -> f ident
+    -}
     header authCookieName $ Rpxnow.identifier ident
     header authDisplayName $ getDisplayName ident
     redirectToDest RedirectTemporary dest
@@ -164,12 +167,12 @@ getDisplayName (Rpxnow.Identifier ident extra) = helper choices where
                         Nothing -> helper xs
                         Just y -> y
 
-getCheck :: Handler Auth RepHtml
+getCheck :: Yesod master => GHandler Auth master RepHtml
 getCheck = do
     ident <- maybeIdentifier
     dn <- displayName
     -- FIXME applyLayoutJson
-    hamletToRepHtml $ [$hamlet|
+    simpleApplyLayout "Authentication Status" $ [$hamlet|
 %h1 Authentication Status
 %dl
     %dt identifier
@@ -178,7 +181,7 @@ getCheck = do
     %dd $snd$
 |] (cs $ fromMaybe "" ident, cs $ fromMaybe "" dn)
 
-getLogout :: Handler Auth ()
+getLogout :: GHandler Auth master ()
 getLogout = do
     y <- getYesod
     deleteCookie authCookieName
@@ -198,12 +201,12 @@ displayName = do
 
 -- | Gets the identifier for a user. If user is not logged in, redirects them
 -- to the login page.
-authIdentifier :: Handler Auth String
+authIdentifier :: GHandler Auth master String
 authIdentifier = maybeIdentifier >>= maybe redirectLogin return
 
 -- | Redirect the user to the 'defaultLoginPath', setting the DEST cookie
 -- appropriately.
-redirectLogin :: Handler Auth a
+redirectLogin :: GHandler Auth master a
 redirectLogin = do
     y <- getYesod
     let r = case defaultLoginType y of
@@ -228,8 +231,8 @@ requestPath = do
 -- | Redirect to the given URL, and set a cookie with the current URL so the
 -- user will ultimately be sent back here.
 redirectSetDest :: RedirectType
-                -> Routes y -- ^ redirect page
+                -> Routes sub -- ^ redirect page
-                -> Handler y a
+                -> GHandler sub master a
 redirectSetDest rt dest = do
     ur <- getUrlRender
     curr <- getRoute
@@ -242,7 +245,7 @@ redirectSetDest rt dest = do
 
 -- | Read the 'destCookieName' cookie and redirect to this destination. If the
 -- cookie is missing, then use the default path provided.
-redirectToDest :: RedirectType -> String -> Handler y a
+redirectToDest :: RedirectType -> String -> GHandler sub master a
 redirectToDest rt def = do
     rr <- getRequest
     dest <- case cookies rr destCookieName of

Yesod/Resource.hs

@@ -3,6 +3,7 @@
 module Yesod.Resource
     ( parseRoutes
     , mkYesod
+    , mkYesodSub
     ) where
 
 import Web.Routes.Quasi (parseRoutes, createRoutes, Resource (..))
@@ -18,8 +19,20 @@ mkYesod name res = do
     let yes' = FunD (mkName "getSite") [Clause [] gsbod []]
     let yes = InstanceD [] (ConT ''YesodSite `AppT` ConT name') [yes']
     decs <- createRoutes (name ++ "Routes")
-                         ''YesodApp
+                         (ConT ''YesodApp)
                          name'
                          "runHandler'"
                          res
     return $ tySyn : yes : decs
+
+mkYesodSub :: String -> [Resource] -> Q [Dec]
+mkYesodSub name res = do
+    let name' = mkName name
+    let tySyn = TySynInstD ''Routes [ConT $ name'] (ConT $ mkName $ name ++ "Routes")
+    let yas = ConT ''YesodApp `AppT` VarT (mkName "master")
+    decs <- createRoutes (name ++ "Routes")
+                         yas
+                         name'
+                         "runHandlerSub"
+                         res
+    return $ tySyn : decs

Yesod/Yesod.hs

@@ -77,40 +77,44 @@ class YesodSite a => Yesod a where
     approot :: a -> Approot
 
 -- | A convenience wrapper around 'simpleApplyLayout for HTML-only data.
-simpleApplyLayout :: Yesod y
+simpleApplyLayout :: Yesod master
                   => String -- ^ title
-                  -> Hamlet (Routes y) IO () -- ^ body
+                  -> Hamlet (Routes sub) IO () -- ^ body
-                  -> Handler y ChooseRep
+                  -> GHandler sub master RepHtml
 simpleApplyLayout t b = do
     let pc = PageContent
                 { pageTitle = cs t
                 , pageHead = return ()
                 , pageBody = b
                 }
-    y <- getYesod
+    y <- getYesodMaster
     rr <- getRequest
     content <- hamletToContent $ applyLayout y pc rr
-    return $ chooseRep
+    return $ RepHtml content
-        [ (TypeHtml, content)
-        ]
 
 getApproot :: Yesod y => Handler y Approot
 getApproot = approot `fmap` getYesod
 
+simpleApplyLayout' :: Yesod master
+                   => String -- ^ title
+                   -> Hamlet (Routes sub) IO () -- ^ body
+                   -> GHandler sub master ChooseRep
+simpleApplyLayout' t = fmap chooseRep . simpleApplyLayout t
+
 defaultErrorHandler :: Yesod y => ErrorResponse -> Handler y ChooseRep
 defaultErrorHandler NotFound = do
     r <- waiRequest
-    simpleApplyLayout "Not Found" $ [$hamlet|
+    simpleApplyLayout' "Not Found" $ [$hamlet|
 %h1 Not Found
 %p $helper$
 |] r
   where
     helper = Unencoded . cs . W.pathInfo
 defaultErrorHandler PermissionDenied =
-    simpleApplyLayout "Permission Denied" $ [$hamlet|
+    simpleApplyLayout' "Permission Denied" $ [$hamlet|
 %h1 Permission denied|] ()
 defaultErrorHandler (InvalidArgs ia) =
-    simpleApplyLayout "Invalid Arguments" $ [$hamlet|
+    simpleApplyLayout' "Invalid Arguments" $ [$hamlet|
 %h1 Invalid Arguments
 %dl
     $forall ias pair
@@ -120,12 +124,12 @@ defaultErrorHandler (InvalidArgs ia) =
   where
     ias _ = map (cs *** cs) ia
 defaultErrorHandler (InternalError e) =
-    simpleApplyLayout "Internal Server Error" $ [$hamlet|
+    simpleApplyLayout' "Internal Server Error" $ [$hamlet|
 %h1 Internal Server Error
 %p $cs$
 |] e
 defaultErrorHandler (BadMethod m) =
-    simpleApplyLayout "Bad Method" $ [$hamlet|
+    simpleApplyLayout' "Bad Method" $ [$hamlet|
 %h1 Method Not Supported
 %p Method "$cs$" not supported
 |] m

examples/helloworld.lhs

@@ -15,7 +15,7 @@ mkYesod "HelloWorld" [$parseRoutes|
 instance Yesod HelloWorld where
     approot _ = "http://localhost:3000"
 
-getHome :: Handler HelloWorld ChooseRep
+getHome :: Handler HelloWorld RepHtml
 getHome = simpleApplyLayout "Hello World" $ cs "Hello world!"
 
 main :: IO ()