diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index ae9e98bd..72d208a8 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -48,8 +48,6 @@ module Yesod.Handler -- ** Short-circuit responses. , sendFile , sendResponse - -- ** Calling foreign subsite handlers - , runSubHandler -- * Setting headers , setCookie , deleteCookie @@ -78,6 +76,7 @@ module Yesod.Handler , runHandler , YesodApp (..) , toMasterHandler + , toMasterHandlerMaybe , localNoCurrent , HandlerData , ErrorResponse (..) @@ -142,10 +141,17 @@ handlerSubData :: (Route sub -> Route master) -> Route sub -> HandlerData oldSub master -> HandlerData sub master -handlerSubData tm ts route hd = hd +handlerSubData tm ts = handlerSubDataMaybe tm ts . Just + +handlerSubDataMaybe :: (Route sub -> Route master) + -> (master -> sub) + -> Maybe (Route sub) + -> HandlerData oldSub master + -> HandlerData sub master +handlerSubDataMaybe tm ts route hd = hd { handlerSub = ts $ handlerMaster hd , handlerToMaster = tm - , handlerRoute = Just route + , handlerRoute = route } -- | Used internally for promoting subsite handler functions to master site @@ -154,10 +160,18 @@ toMasterHandler :: (Route sub -> Route master) -> (master -> sub) -> Route sub -> GHandler sub master a - -> GHandler master master a + -> GHandler sub' master a toMasterHandler tm ts route (GHandler h) = GHandler $ withReaderT (handlerSubData tm ts route) h +toMasterHandlerMaybe :: (Route sub -> Route master) + -> (master -> sub) + -> Maybe (Route sub) + -> GHandler sub master a + -> GHandler sub' master a +toMasterHandlerMaybe tm ts route (GHandler h) = + GHandler $ withReaderT (handlerSubDataMaybe tm ts route) h + -- | A generic handler monad, which can have a different subsite and master -- site. This monad is a combination of 'ReaderT' for basic arguments, a -- 'WriterT' for headers and session, and an 'MEitherT' monad for handling @@ -217,28 +231,6 @@ 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 0519f35f..efff5338 100644 --- a/Yesod/Widget.hs +++ b/Yesod/Widget.hs @@ -40,7 +40,7 @@ import Control.Monad.Trans.State import Text.Hamlet import Text.Cassius import Text.Julius -import Yesod.Handler (Route, GHandler, HandlerData, YesodSubRoute, runSubHandler) +import Yesod.Handler (Route, GHandler, HandlerData, YesodSubRoute(..), toMasterHandlerMaybe, getYesod) import Control.Applicative (Applicative) import Control.Monad.IO.Class (MonadIO) import Control.Monad.Trans.Class (lift) @@ -98,32 +98,32 @@ 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 - +addSubWidget sub w = do master <- liftHandler getYesod + let sr = fromSubRoute sub master + i <- GWidget $ lift $ lift $ lift $ lift $ lift $ lift $ lift get + w' <- liftHandler $ toMasterHandlerMaybe sr (const sub) Nothing $ 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.