diff --git a/yesod-core/Yesod/Core.hs b/yesod-core/Yesod/Core.hs index 0cd10eee..76e19fd1 100644 --- a/yesod-core/Yesod/Core.hs +++ b/yesod-core/Yesod/Core.hs @@ -11,6 +11,7 @@ module Yesod.Core -- * Types , Approot (..) , FileUpload (..) + , ErrorResponse (..) -- * Utitlities , maybeAuthorized , widgetToPageContent diff --git a/yesod-core/Yesod/Core/Class.hs b/yesod-core/Yesod/Core/Class.hs index 920028c2..347d39b4 100644 --- a/yesod-core/Yesod/Core/Class.hs +++ b/yesod-core/Yesod/Core/Class.hs @@ -287,8 +287,7 @@ $doctype 5 yesodMiddleware handler = do setHeader "Vary" "Accept, Accept-Language" route <- getCurrentRoute - toMaster <- getRouteToMaster - case fmap toMaster route of + case route of Nothing -> handler Just url -> do isWrite <- isWriteRequest url diff --git a/yesod-core/Yesod/Handler.hs b/yesod-core/Yesod/Handler.hs index 61f0257e..b8379b5a 100644 --- a/yesod-core/Yesod/Handler.hs +++ b/yesod-core/Yesod/Handler.hs @@ -25,16 +25,15 @@ -- --------------------------------------------------------- module Yesod.Handler - ( -- * Type families - YesodSubRoute (..) - -- * Handler monad - , GHandler + ( -- * Handler monad + GHandler -- ** Read information from handler , getYesod , getYesodSub , getUrlRender , getUrlRenderParams , getCurrentRoute + , getCurrentRouteSub , getRouteToMaster , getRequest , waiRequest @@ -122,11 +121,6 @@ module Yesod.Handler , getMessageRender -- * Per-request caching , cached - -- * Internal Yesod - , YesodApp - , runSubsiteGetter - , HandlerData - , ErrorResponse (..) ) where import Data.Time (UTCTime, addUTCTime, @@ -136,7 +130,7 @@ import Yesod.Core.Internal.Request (langKey, mkFileInfoFile, import Control.Applicative ((<$>)) -import Control.Monad (liftM) +import Control.Monad (ap, liftM) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Trans.Resource (MonadResource, liftResourceT) @@ -176,9 +170,6 @@ import Yesod.Core.Handler.Class import Yesod.Core.Types import Yesod.Routes.Class (Route) -class YesodSubRoute s y where - fromSubRoute :: s -> y -> Route s -> Route y - get :: HandlerState m => m GHState get = getGHState @@ -194,18 +185,6 @@ tell hs = modify $ \g -> g { ghsHeaders = ghsHeaders g `mappend` hs } hcError :: HandlerError m => ErrorResponse -> m a hcError = handlerError . HCError -class SubsiteGetter g m s | g -> s where - runSubsiteGetter :: g -> m s - -instance (master ~ master' - ) => SubsiteGetter (master -> sub) (GHandler anySub master') sub where - runSubsiteGetter getter = getter <$> getYesod - -instance (anySub ~ anySub' - ,master ~ master' - ) => SubsiteGetter (GHandler anySub master sub) (GHandler anySub' master') sub where - runSubsiteGetter = id - getRequest :: HandlerReader m => m YesodRequest getRequest = askYesodRequest @@ -273,8 +252,12 @@ getUrlRenderParams = rheRender `liftM` askHandlerEnv -- | Get the route requested by the user. If this is a 404 response- where the -- user requested an invalid route- this function will return 'Nothing'. -getCurrentRoute :: HandlerReader m => m (Maybe (Route (HandlerSub m))) -getCurrentRoute = rheRoute `liftM` askHandlerEnv +getCurrentRoute :: HandlerReader m => m (Maybe (Route (HandlerMaster m))) +getCurrentRoute = fmap `liftM` getRouteToMaster `ap` getCurrentRouteSub + +-- | Same as 'getCurrentRoute', but for the subsite. +getCurrentRouteSub :: HandlerReader m => m (Maybe (Route (HandlerSub m))) +getCurrentRouteSub = rheRoute `liftM` askHandlerEnv -- | Get the function to promote a route for a subsite to a route for the -- master site. @@ -401,9 +384,8 @@ setUltDestCurrent = do case route of Nothing -> return () Just r -> do - tm <- getRouteToMaster gets' <- reqGetParams `liftM` askYesodRequest - setUltDest (tm r, gets') + setUltDest (r, gets') -- | Sets the ultimate destination to the referer request header, if present. -- diff --git a/yesod-core/Yesod/Internal/Core.hs b/yesod-core/Yesod/Internal/Core.hs index 1e330eb7..a0bc2392 100644 --- a/yesod-core/Yesod/Internal/Core.hs +++ b/yesod-core/Yesod/Internal/Core.hs @@ -71,9 +71,7 @@ class YesodBreadcrumbs y where -- along with their respective titles. breadcrumbs :: YesodBreadcrumbs y => GHandler sub y (Text, [(Route y, Text)]) breadcrumbs = do - x' <- getCurrentRoute - tm <- getRouteToMaster - let x = fmap tm x' + x <- getCurrentRoute case x of Nothing -> return ("Not found", []) Just y -> do diff --git a/yesod-core/Yesod/Widget.hs b/yesod-core/Yesod/Widget.hs index 7391c841..62c54174 100644 --- a/yesod-core/Yesod/Widget.hs +++ b/yesod-core/Yesod/Widget.hs @@ -51,10 +51,7 @@ import Text.Hamlet import Text.Cassius import Text.Julius import Yesod.Routes.Class -import Yesod.Handler - ( YesodSubRoute(..), getYesod - , getMessageRender, getUrlRenderParams - ) +import Yesod.Handler (getMessageRender, getUrlRenderParams) import Yesod.Core.Trans.Class (lift) import Text.Shakespeare.I18N (RenderMessage) import Yesod.Content (toContent) @@ -74,13 +71,17 @@ import Yesod.Core.Types preEscapedLazyText :: TL.Text -> Html preEscapedLazyText = preEscapedToMarkup -addSubWidget :: (YesodSubRoute sub master) => sub -> GWidget sub master a -> GWidget sub' master a -addSubWidget sub (GWidget w) = do - master <- lift getYesod - let sr = fromSubRoute sub master - (a, w') <- lift $ error "FIXME Yesod.Widget.toMasterHandlerMaybe" sr (const sub) Nothing w - tell w' - return a +addSubWidget :: (Route sub -> Route master) -> sub -> GWidget sub master a -> GWidget sub' master a +addSubWidget toMaster sub (GWidget (GHandler f)) = + GWidget $ GHandler $ f . modHD + where + modHD hd = hd + { handlerEnv = (handlerEnv hd) + { rheRoute = Nothing + , rheSub = sub + , rheToMaster = toMaster + } + } class ToWidget sub master a where toWidget :: a -> GWidget sub master () diff --git a/yesod-core/test/YesodCoreTest/Media.hs b/yesod-core/test/YesodCoreTest/Media.hs index 8f6053ec..1dc52dca 100644 --- a/yesod-core/test/YesodCoreTest/Media.hs +++ b/yesod-core/test/YesodCoreTest/Media.hs @@ -15,9 +15,8 @@ mkYesodDispatch "Y" resourcesY instance Yesod Y where addStaticContent _ _ content = do - tm <- getRouteToMaster route <- getCurrentRoute - case fmap tm route of + case route of Just StaticR -> return $ Just $ Left $ if content == "foo2{bar:baz}" then "screen.css"