haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

cookiePath

Browse Source
This commit is contained in:
Michael Snoyman 2011-04-01 13:13:57 +03:00
parent 0a8c8e7f9c
commit b1ecaeee08
2 changed files with 13 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
Yesod/Core.hs
View File

@ -226,6 +226,11 @@ class RenderRoute (Route a) => Yesod a where
sessionIpAddress :: a -> Bool sessionIpAddress :: a -> Bool
sessionIpAddress _ = True 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 defaultYesodRunner :: Yesod master
=> a => a
-> master -> master
@ -289,7 +294,7 @@ defaultYesodRunner s master toMasterRoute mkey murl handler req = do
sessionName sessionName
sessionVal sessionVal
: hs : hs
hs'' = map (headerToPair getExpires) hs' hs'' = map (headerToPair (cookiePath master) getExpires) hs'
hs''' = ("Content-Type", ct) : hs'' hs''' = ("Content-Type", ct) : hs''
data AuthResult = Authorized | AuthenticationRequired | Unauthorized Text data AuthResult = Authorized | AuthenticationRequired | Unauthorized Text

13
Yesod/Handler.hs
View File

@ -739,22 +739,23 @@ httpAccept = parseHttpAccept
. W.requestHeaders . W.requestHeaders
-- | Convert Header to a key/value pair. -- | Convert Header to a key/value pair.
headerToPair :: (Int -> UTCTime) -- ^ minutes -> expiration time headerToPair :: S.ByteString -- ^ cookie path
-> (Int -> UTCTime) -- ^ minutes -> expiration time
-> Header -> Header
-> (CI H.Ascii, H.Ascii) -> (CI H.Ascii, H.Ascii)
headerToPair getExpires (AddCookie minutes key value) = headerToPair cp getExpires (AddCookie minutes key value) =
("Set-Cookie", toByteString $ renderSetCookie $ SetCookie ("Set-Cookie", toByteString $ renderSetCookie $ SetCookie
{ setCookieName = key { setCookieName = key
, setCookieValue = value , setCookieValue = value
, setCookiePath = Just "/" -- FIXME make a config option, or use approot? , setCookiePath = Just cp
, setCookieExpires = Just $ getExpires minutes , setCookieExpires = Just $ getExpires minutes
, setCookieDomain = Nothing , setCookieDomain = Nothing
}) })
headerToPair _ (DeleteCookie key) = headerToPair cp _ (DeleteCookie key) =
( "Set-Cookie" ( "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. -- | Get a unique identifier.
newIdent :: Monad mo => GGHandler sub master mo String newIdent :: Monad mo => GGHandler sub master mo String