diff --git a/yesod-core/Yesod/Core.hs b/yesod-core/Yesod/Core.hs index 34500f40..740bb1dc 100644 --- a/yesod-core/Yesod/Core.hs +++ b/yesod-core/Yesod/Core.hs @@ -8,6 +8,8 @@ module Yesod.Core -- ** Breadcrumbs , YesodBreadcrumbs (..) , breadcrumbs + -- * Types + , Approot (..) -- * Utitlities , maybeAuthorized , widgetToPageContent diff --git a/yesod-core/Yesod/Dispatch.hs b/yesod-core/Yesod/Dispatch.hs index a7f33d79..38af2a16 100644 --- a/yesod-core/Yesod/Dispatch.hs +++ b/yesod-core/Yesod/Dispatch.hs @@ -182,7 +182,7 @@ sendRedirect y segments' env = , ("Location", Blaze.ByteString.Builder.toByteString dest') ] "Redirecting" where - dest = joinPath y (approot y) segments' [] + dest = joinPath y (resolveApproot y env) segments' [] dest' = if S.null (W.rawQueryString env) then dest diff --git a/yesod-core/Yesod/Internal/Core.hs b/yesod-core/Yesod/Internal/Core.hs index ce4e4e82..9f1d6403 100644 --- a/yesod-core/Yesod/Internal/Core.hs +++ b/yesod-core/Yesod/Internal/Core.hs @@ -28,6 +28,8 @@ module Yesod.Internal.Core -- * Misc , yesodVersion , yesodRender + , resolveApproot + , Approot (..) ) where import Yesod.Content @@ -121,20 +123,36 @@ class YesodDispatch sub master where -> W.Application yesodRunner = defaultYesodRunner --- | Define settings for a Yesod applications. The only required setting is --- 'approot'; other than that, there are intelligent defaults. +-- | How to determine the root of the application for constructing URLs. +-- +-- Note that future versions of Yesod may add new constructors without bumping +-- the major version number. As a result, you should /not/ pattern match on +-- @Approot@ values. +data Approot master = ApprootRelative -- ^ No application root. + | ApprootStatic Text + | ApprootMaster (master -> Text) + | ApprootRequest (master -> W.Request -> Text) + +type ResolvedApproot = Text + +-- | Define settings for a Yesod applications. All methods have intelligent +-- defaults, and therefore no implementation is required. class RenderRoute a => Yesod a where -- | An absolute URL to the root of the application. Do not include -- trailing slash. -- - -- If you want to be lazy, you can supply an empty string under the - -- following conditions: + -- Default value: 'ApprootRelative'. This is valid under the following + -- conditions: -- -- * Your application is served from the root of the domain. -- -- * You do not use any features that require absolute URLs, such as Atom -- feeds and XML sitemaps. - approot :: a -> Text + -- + -- If this is not true, you should override with a different + -- implementation. + approot :: Approot a + approot = ApprootRelative -- | The encryption key to be used for encrypting client sessions. -- Returning 'Nothing' disables sessions. @@ -395,7 +413,8 @@ defaultYesodRunner handler master sub murl toMasterRoute mkey req = do handler let sessionMap = Map.fromList $ filter (\(x, _) -> x /= nonceKey) session' - yar <- handlerToYAR master sub toMasterRoute (yesodRender master) errorHandler rr murl sessionMap h + let ra = resolveApproot master req + yar <- handlerToYAR master sub toMasterRoute (yesodRender master ra) errorHandler rr murl sessionMap h let mnonce = reqNonce rr -- FIXME should we be caching this IV value and reusing it for efficiency? iv <- {-# SCC "iv" #-} maybe (return $ error "Should not be used") (const $ liftIO CS.randomIV) mkey @@ -633,14 +652,23 @@ ynHelper render scripts jscript jsLoc = yesodRender :: Yesod y => y + -> ResolvedApproot -> Route y -> [(Text, Text)] -- ^ url query string -> Text -yesodRender y url params = +yesodRender y ar url params = TE.decodeUtf8 $ toByteString $ fromMaybe - (joinPath y (approot y) ps + (joinPath y ar ps $ params ++ params') (urlRenderOverride y url) where (ps, params') = renderRoute url + +resolveApproot :: Yesod master => master -> W.Request -> ResolvedApproot +resolveApproot master req = + case approot of + ApprootRelative -> "" + ApprootStatic t -> t + ApprootMaster f -> f master + ApprootRequest f -> f master req diff --git a/yesod-core/test/YesodCoreTest/Cache.hs b/yesod-core/test/YesodCoreTest/Cache.hs index c87118a7..30dcfaaa 100644 --- a/yesod-core/test/YesodCoreTest/Cache.hs +++ b/yesod-core/test/YesodCoreTest/Cache.hs @@ -21,7 +21,7 @@ key2 = $(mkCacheKey) mkYesod "C" [parseRoutes|/ RootR GET|] -instance Yesod C where approot _ = "" +instance Yesod C getRootR :: Handler () getRootR = do diff --git a/yesod-core/test/YesodCoreTest/CleanPath.hs b/yesod-core/test/YesodCoreTest/CleanPath.hs index 0428164e..ba3d7a00 100644 --- a/yesod-core/test/YesodCoreTest/CleanPath.hs +++ b/yesod-core/test/YesodCoreTest/CleanPath.hs @@ -41,7 +41,7 @@ mkYesod "Y" [parseRoutes| |] instance Yesod Y where - approot _ = "http://test" + approot = ApprootStatic "http://test" cleanPath _ s@("subsite":_) = Right s cleanPath _ ["bar", ""] = Right ["bar"] cleanPath _ ["bar"] = Left ["bar", ""] diff --git a/yesod-core/test/YesodCoreTest/ErrorHandling.hs b/yesod-core/test/YesodCoreTest/ErrorHandling.hs index 16118e46..b07d3753 100644 --- a/yesod-core/test/YesodCoreTest/ErrorHandling.hs +++ b/yesod-core/test/YesodCoreTest/ErrorHandling.hs @@ -21,7 +21,7 @@ mkYesod "App" [parseRoutes| /after_runRequestBody AfterRunRequestBodyR POST |] -instance Yesod App where approot _ = "" +instance Yesod App getHomeR :: Handler RepHtml getHomeR = defaultLayout $ toWidget [hamlet| diff --git a/yesod-core/test/YesodCoreTest/Exceptions.hs b/yesod-core/test/YesodCoreTest/Exceptions.hs index 2f0e25ef..93368b7a 100644 --- a/yesod-core/test/YesodCoreTest/Exceptions.hs +++ b/yesod-core/test/YesodCoreTest/Exceptions.hs @@ -18,7 +18,7 @@ mkYesod "Y" [parseRoutes| |] instance Yesod Y where - approot _ = "http://test" + approot = ApprootStatic "http://test" errorHandler (InternalError e) = return $ chooseRep $ RepPlain $ toContent e errorHandler x = defaultErrorHandler x diff --git a/yesod-core/test/YesodCoreTest/Links.hs b/yesod-core/test/YesodCoreTest/Links.hs index 6df9ab62..49ece3d1 100644 --- a/yesod-core/test/YesodCoreTest/Links.hs +++ b/yesod-core/test/YesodCoreTest/Links.hs @@ -15,8 +15,7 @@ mkYesod "Y" [parseRoutes| / RootR GET |] -instance Yesod Y where - approot _ = "" +instance Yesod Y getRootR :: Handler RepHtml getRootR = defaultLayout $ addHamlet [hamlet||] diff --git a/yesod-core/test/YesodCoreTest/Media.hs b/yesod-core/test/YesodCoreTest/Media.hs index 0b7e4190..fec2ffdb 100644 --- a/yesod-core/test/YesodCoreTest/Media.hs +++ b/yesod-core/test/YesodCoreTest/Media.hs @@ -15,7 +15,6 @@ import YesodCoreTest.MediaData mkYesodDispatch "Y" resourcesY instance Yesod Y where - approot _ = "" addStaticContent _ _ content = do tm <- getRouteToMaster route <- getCurrentRoute diff --git a/yesod-core/test/YesodCoreTest/NoOverloadedStrings.hs b/yesod-core/test/YesodCoreTest/NoOverloadedStrings.hs index 24f9d75f..b32e6d65 100644 --- a/yesod-core/test/YesodCoreTest/NoOverloadedStrings.hs +++ b/yesod-core/test/YesodCoreTest/NoOverloadedStrings.hs @@ -8,7 +8,6 @@ import Test.Hspec.HUnit () import Yesod.Core hiding (Request) import Network.Wai.Test import Data.Monoid (mempty) -import Data.String (fromString) data Subsite = Subsite @@ -29,8 +28,7 @@ mkYesod "Y" [parseRoutes| /subsite SubsiteR Subsite getSubsite |] -instance Yesod Y where - approot _ = fromString "" +instance Yesod Y getRootR :: Handler () getRootR = return () diff --git a/yesod-core/test/YesodCoreTest/Redirect.hs b/yesod-core/test/YesodCoreTest/Redirect.hs index 71b03db2..5019467a 100644 --- a/yesod-core/test/YesodCoreTest/Redirect.hs +++ b/yesod-core/test/YesodCoreTest/Redirect.hs @@ -13,7 +13,7 @@ mkYesod "Y" [parseRoutes| /r307 R307 GET /rregular RRegular GET |] -instance Yesod Y where approot _ = "http://test" +instance Yesod Y where approot = ApprootStatic "http://test" app :: Session () -> IO () app = yesod Y diff --git a/yesod-core/test/YesodCoreTest/Widget.hs b/yesod-core/test/YesodCoreTest/Widget.hs index ae1e4699..f102136e 100644 --- a/yesod-core/test/YesodCoreTest/Widget.hs +++ b/yesod-core/test/YesodCoreTest/Widget.hs @@ -28,7 +28,7 @@ mkYesod "Y" [parseRoutes| |] instance Yesod Y where - approot _ = "http://test" + approot = ApprootStatic "http://test" getRootR :: Handler RepHtml getRootR = defaultLayout $ toWidgetBody [julius||] diff --git a/yesod-core/test/YesodCoreTest/YesodTest.hs b/yesod-core/test/YesodCoreTest/YesodTest.hs index 9150f5ad..46040f84 100644 --- a/yesod-core/test/YesodCoreTest/YesodTest.hs +++ b/yesod-core/test/YesodCoreTest/YesodTest.hs @@ -3,6 +3,7 @@ module YesodCoreTest.YesodTest ( yesod , parseRoutes, mkYesod, yesodDispatch, renderRoute, Yesod(..) , redirect + , Approot (..) , module Network.Wai , module Network.Wai.Test , module Test.Hspec diff --git a/yesod/scaffold/Foundation.hs.cg b/yesod/scaffold/Foundation.hs.cg index f0f136ab..14e5b821 100644 --- a/yesod/scaffold/Foundation.hs.cg +++ b/yesod/scaffold/Foundation.hs.cg @@ -83,7 +83,7 @@ type Form x = Html -> MForm ~sitearg~ ~sitearg~ (FormResult x, Widget) -- Please see the documentation for the Yesod typeclass. There are a number -- of settings which can be configured by overriding methods here. instance Yesod ~sitearg~ where - approot = appRoot . settings + approot = ApprootMaster $ appRoot . settings -- Place the session key file in the config folder encryptKey _ = fmap Just $ getKey "config/client_session_key.aes" diff --git a/yesod/scaffold/tiny/Foundation.hs.cg b/yesod/scaffold/tiny/Foundation.hs.cg index c93df758..f67df47e 100644 --- a/yesod/scaffold/tiny/Foundation.hs.cg +++ b/yesod/scaffold/tiny/Foundation.hs.cg @@ -60,7 +60,7 @@ mkYesodData "~sitearg~" $(parseRoutesFile "config/routes") -- Please see the documentation for the Yesod typeclass. There are a number -- of settings which can be configured by overriding methods here. instance Yesod ~sitearg~ where - approot = appRoot . settings + approot = ApprootMaster $ appRoot . settings -- Place the session key file in the config folder encryptKey _ = fmap Just $ getKey "config/client_session_key.aes"