diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 2dc69418..ae9e98bd 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -24,6 +24,7 @@ module Yesod.Handler ( -- * Type families Route + , YesodSubRoute (..) -- * Handler monad , GHandler -- ** Read information from handler @@ -47,6 +48,8 @@ module Yesod.Handler -- ** Short-circuit responses. , sendFile , sendResponse + -- ** Calling foreign subsite handlers + , runSubHandler -- * Setting headers , setCookie , deleteCookie @@ -122,6 +125,9 @@ import Yesod.Content -- | The type-safe URLs associated with a site argument. type family Route a +class YesodSubRoute s y where + fromSubRoute :: s -> y -> Route s -> Route y + data HandlerData sub master = HandlerData { handlerRequest :: Request , handlerSub :: sub @@ -211,6 +217,28 @@ instance RequestReader (GHandler sub master) where getYesodSub :: GHandler sub master sub getYesodSub = handlerSub <$> GHandler ask +-- | Set the subsite in HandlerData +setHandlerSub :: YesodSubRoute sub' master => sub' -> HandlerData sub master -> HandlerData sub' master +setHandlerSub s (HandlerData r _ m _ rn _) = HandlerData r s m Nothing rn $ fromSubRoute s m + +-- | Run a handler from another subsite +runSubHandler :: YesodSubRoute sub' master => sub' -> GHandler sub' master a -> GHandler sub master a +runSubHandler sub handler = do + hd <- setHandlerSub sub <$> GHandler ask + session <- getSession + GHandler $ do + let toErrorHandler = + InternalError + . (show :: Control.Exception.SomeException -> String) + ((contents, headers), finalSession) <- liftIO $ flip runStateT session + $ runWriterT + $ runMEitherT + $ flip runReaderT hd + $ unGHandler handler + lift $ lift $ lift $ put finalSession + lift $ MEitherT $ return contents + + -- | Get the master site appliation argument. getYesod :: GHandler sub master master getYesod = handlerMaster <$> GHandler ask diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs index 037787f5..0519f35f 100644 --- a/Yesod/Widget.hs +++ b/Yesod/Widget.hs @@ -18,6 +18,7 @@ module Yesod.Widget , addHamlet , addHtml , addWidget + , addSubWidget -- ** CSS , addCassius , addStylesheet @@ -39,7 +40,7 @@ import Control.Monad.Trans.State import Text.Hamlet import Text.Cassius import Text.Julius -import Yesod.Handler (Route, GHandler, HandlerData) +import Yesod.Handler (Route, GHandler, HandlerData, YesodSubRoute, runSubHandler) import Control.Applicative (Applicative) import Control.Monad.IO.Class (MonadIO) import Control.Monad.Trans.Class (lift) @@ -96,6 +97,34 @@ instance Monad (HamletMonad (GWidget s m ())) where liftHandler :: GHandler sub master a -> GWidget sub master a liftHandler = GWidget . lift . lift . lift . lift . lift . lift . lift . lift +addSubWidget :: (YesodSubRoute sub master) => sub -> GWidget sub master a -> GWidget sub' master a +addSubWidget sub w = do + i <- GWidget $ lift $ lift $ lift $ lift $ lift $ lift $ lift get + w' <- liftHandler $ runSubHandler sub $ flip runStateT i + $ runWriterT $ runWriterT $ runWriterT $ runWriterT + $ runWriterT $ runWriterT $ runWriterT + $ unGWidget w + let ((((((((a, + body), + title), + scripts), + stylesheets), + style), + jscript), + h), + i') = w' + GWidget $ do + tell body + lift $ tell title + lift $ lift $ tell scripts + lift $ lift $ lift $ tell stylesheets + lift $ lift $ lift $ lift $ tell style + lift $ lift $ lift $ lift $ lift $ tell jscript + lift $ lift $ lift $ lift $ lift $ lift $ tell h + lift $ lift $ lift $ lift $ lift $ lift $ lift $ put i' + return a + + -- | Set the page title. Calling 'setTitle' multiple times overrides previously -- set values. setTitle :: Html -> GWidget sub master ()