diff --git a/yesod-core/Yesod/Handler.hs b/yesod-core/Yesod/Handler.hs index a9410596..d9ae3078 100644 --- a/yesod-core/Yesod/Handler.hs +++ b/yesod-core/Yesod/Handler.hs @@ -624,18 +624,19 @@ invalidArgsI msg = do ------- Headers -- | Set the cookie on the client. --- --- Note: although the value used for key and value is 'Text', you should only --- use ASCII values to be HTTP compliant. -setCookie :: Int -- ^ minutes to timeout - -> Text -- ^ key - -> Text -- ^ value + +setCookie :: SetCookie -> GHandler sub master () -setCookie a b = addHeader . AddCookie a (encodeUtf8 b) . encodeUtf8 +setCookie = addHeader . AddCookie -- | Unset the cookie on the client. -deleteCookie :: Text -> GHandler sub master () -deleteCookie = addHeader . DeleteCookie . encodeUtf8 +-- +-- Note: although the value used for key and path is 'Text', you should only +-- use ASCII values to be HTTP compliant. +deleteCookie :: Text -- ^ key + -> Text -- ^ path + -> GHandler sub master () +deleteCookie a = addHeader . DeleteCookie (encodeUtf8 a) . encodeUtf8 -- | Set the language in the user session. Will show up in 'languages' on the -- next request. @@ -809,32 +810,20 @@ httpAccept = parseHttpAccept . W.requestHeaders -- | Convert Header to a key/value pair. -headerToPair :: S.ByteString -- ^ cookie path - -> (Int -> UTCTime) -- ^ minutes -> expiration time - -> Header +headerToPair :: Header -> (CI H.Ascii, H.Ascii) -headerToPair cp getExpires (AddCookie minutes key value) = - ("Set-Cookie", toByteString $ renderSetCookie $ SetCookie - { setCookieName = key - , setCookieValue = value - , setCookiePath = Just cp - , setCookieExpires = - if minutes == 0 - then Nothing - else Just $ getExpires minutes - , setCookieDomain = Nothing - , setCookieHttpOnly = True - }) -headerToPair cp _ (DeleteCookie key) = +headerToPair (AddCookie sc) = + ("Set-Cookie", toByteString $ renderSetCookie $ sc) +headerToPair (DeleteCookie key path) = ( "Set-Cookie" , S.concat [ key , "=; path=" - , cp + , path , "; expires=Thu, 01-Jan-1970 00:00:00 GMT" ] ) -headerToPair _ _ (Header key value) = (CI.mk key, value) +headerToPair (Header key value) = (CI.mk key, value) -- | Get a unique identifier. newIdent :: GHandler sub master Text diff --git a/yesod-core/Yesod/Internal.hs b/yesod-core/Yesod/Internal.hs index 594e52de..f1530057 100644 --- a/yesod-core/Yesod/Internal.hs +++ b/yesod-core/Yesod/Internal.hs @@ -43,6 +43,7 @@ import Data.String (IsString) import qualified Data.Map as Map import Data.Text.Lazy.Builder (Builder) import Network.HTTP.Types (Ascii) +import Web.Cookie (SetCookie (..)) #if GHC7 #define HAMLET hamlet @@ -64,8 +65,8 @@ instance Exception ErrorResponse ----- header stuff -- | Headers to be added to a 'Result'. data Header = - AddCookie Int Ascii Ascii - | DeleteCookie Ascii + AddCookie SetCookie + | DeleteCookie Ascii Ascii | Header Ascii Ascii deriving (Eq, Show) diff --git a/yesod-core/Yesod/Internal/Core.hs b/yesod-core/Yesod/Internal/Core.hs index a8cffde0..e8654ae0 100644 --- a/yesod-core/Yesod/Internal/Core.hs +++ b/yesod-core/Yesod/Internal/Core.hs @@ -68,6 +68,7 @@ import Blaze.ByteString.Builder (Builder, toByteString) import Blaze.ByteString.Builder.Char.Utf8 (fromText) import Data.List (foldl') import qualified Network.HTTP.Types as H +import Web.Cookie (SetCookie (..)) import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.IO import qualified Data.Text.Lazy.Builder as TB @@ -407,12 +408,16 @@ defaultYesodRunner handler master sub murl toMasterRoute mkey req = do hs' = case mkey of Nothing -> hs - Just _ -> AddCookie - (clientSessionDuration master) - sessionName - sessionVal + Just _ -> AddCookie SetCookie + { setCookieName = sessionName + , setCookieValue = sessionVal + , setCookiePath = Just (cookiePath master) + , setCookieExpires = Just $ getExpires (clientSessionDuration master) + , setCookieDomain = Nothing + , setCookieHttpOnly = True + } : hs - hs'' = map (headerToPair (cookiePath master) getExpires) hs' + hs'' = map headerToPair hs' hs''' = ("Content-Type", ct) : hs'' data AuthResult = Authorized | AuthenticationRequired | Unauthorized Text