Approot

yesod-core/Yesod/Core.hs

@@ -8,6 +8,8 @@ module Yesod.Core
       -- ** Breadcrumbs
     , YesodBreadcrumbs (..)
     , breadcrumbs
+      -- * Types
+    , Approot (..)
       -- * Utitlities
     , maybeAuthorized
     , widgetToPageContent

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

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
+-- | How to determine the root of the application for constructing URLs.
--- 'approot'; other than that, there are intelligent defaults.
+--
+-- 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
+    -- Default value: 'ApprootRelative'. This is valid under the following
-    -- following conditions:
+    -- 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

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

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", ""]

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|

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
 

yesod-core/test/YesodCoreTest/Links.hs

@@ -15,8 +15,7 @@ mkYesod "Y" [parseRoutes|
 / RootR GET
 |]
 
-instance Yesod Y where
+instance Yesod Y
-    approot _ = ""
 
 getRootR :: Handler RepHtml
 getRootR = defaultLayout $ addHamlet [hamlet|<a href=@{RootR}>|]

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

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
+instance Yesod Y
-    approot _ = fromString ""
 
 getRootR :: Handler ()
 getRootR = return ()

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
 

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|<not escaped>|]

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

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"

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"