moved YesodSubRoute to Yesod.Handler; added runSubHandler, addSubWidget

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

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 ()