diff --git a/Yesod/Core.hs b/Yesod/Core.hs index 92c5d53a..72a7b779 100644 --- a/Yesod/Core.hs +++ b/Yesod/Core.hs @@ -226,6 +226,11 @@ class RenderRoute (Route a) => Yesod a where sessionIpAddress :: a -> Bool sessionIpAddress _ = True + -- | The path value to set for cookies. By default, uses \"\/\", meaning + -- cookies will be sent to every page on the current domain. + cookiePath :: a -> S8.ByteString + cookiePath _ = "/" + defaultYesodRunner :: Yesod master => a -> master @@ -289,7 +294,7 @@ defaultYesodRunner s master toMasterRoute mkey murl handler req = do sessionName sessionVal : hs - hs'' = map (headerToPair getExpires) hs' + hs'' = map (headerToPair (cookiePath master) getExpires) hs' hs''' = ("Content-Type", ct) : hs'' data AuthResult = Authorized | AuthenticationRequired | Unauthorized Text diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 9b3e6268..8b1e820d 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -739,22 +739,23 @@ httpAccept = parseHttpAccept . W.requestHeaders -- | Convert Header to a key/value pair. -headerToPair :: (Int -> UTCTime) -- ^ minutes -> expiration time +headerToPair :: S.ByteString -- ^ cookie path + -> (Int -> UTCTime) -- ^ minutes -> expiration time -> Header -> (CI H.Ascii, H.Ascii) -headerToPair getExpires (AddCookie minutes key value) = +headerToPair cp getExpires (AddCookie minutes key value) = ("Set-Cookie", toByteString $ renderSetCookie $ SetCookie { setCookieName = key , setCookieValue = value - , setCookiePath = Just "/" -- FIXME make a config option, or use approot? + , setCookiePath = Just cp , setCookieExpires = Just $ getExpires minutes , setCookieDomain = Nothing }) -headerToPair _ (DeleteCookie key) = +headerToPair cp _ (DeleteCookie key) = ( "Set-Cookie" - , key `mappend` "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT" + , key `mappend` "=; path=" `mappend` cp `mappend` "; expires=Thu, 01-Jan-1970 00:00:00 GMT" ) -headerToPair _ (Header key value) = (key, value) +headerToPair _ _ (Header key value) = (key, value) -- | Get a unique identifier. newIdent :: Monad mo => GGHandler sub master mo String