cookiePath

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

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