Merge pull request #246 from paronsson/master

Issue #237: A generalized setCookie function must be available

yesod-core/Yesod/Handler.hs

@@ -59,6 +59,7 @@ module Yesod.Handler
     , sendWaiResponse
       -- * Setting headers
     , setCookie
+    , getExpires
     , deleteCookie
     , setHeader
     , setLanguage
@@ -120,7 +121,7 @@ module Yesod.Handler
 import Prelude hiding (catch)
 import Yesod.Internal.Request
 import Yesod.Internal
-import Data.Time (UTCTime)
+import Data.Time (UTCTime, getCurrentTime, addUTCTime)
 
 import Control.Exception hiding (Handler, catch, finally)
 import Control.Applicative
@@ -624,18 +625,28 @@ invalidArgsI msg = do
 
 ------- Headers
 -- | Set the cookie on the client.
---
+
--- Note: although the value used for key and value is 'Text', you should only
+setCookie :: SetCookie
--- use ASCII values to be HTTP compliant.
-setCookie :: Int -- ^ minutes to timeout
-          -> Text -- ^ key
-          -> Text -- ^ value
           -> GHandler sub master ()
-setCookie a b = addHeader . AddCookie a (encodeUtf8 b) . encodeUtf8
+setCookie = addHeader . AddCookie
+
+-- | Helper function for setCookieExpires value
+getExpires :: Int -- ^ minutes
+          -> IO UTCTime
+getExpires m = do
+    now <- liftIO getCurrentTime
+    return $ fromIntegral (m * 60) `addUTCTime` now
+
 
 -- | 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.
@@ -782,25 +793,7 @@ yarToResponse renderHeaders (YARPlain s hs ct c sessionFinal) =
     finalHeaders = renderHeaders hs ct sessionFinal
     finalHeaders' len = ("Content-Length", S8.pack $ show len)
                       : finalHeaders
-    {-
+
-    getExpires m = fromIntegral (m * 60) `addUTCTime` now
-    sessionVal =
-        case key' of
-            Nothing -> B.empty
-            Just key'' -> encodeSession key'' exp' host
-                        $ Map.toList
-                        $ Map.insert nonceKey (reqNonce rr) sessionFinal
-    hs' =
-            case key' of
-                Nothing -> hs
-                Just _ -> AddCookie
-                        (clientSessionDuration y)
-                        sessionName
-                        (bsToChars sessionVal)
-                      : hs
-    hs'' = map (headerToPair getExpires) hs'
-    hs''' = ("Content-Type", charsToBs ct) : hs''
-    -}
 
 httpAccept :: W.Request -> [ContentType]
 httpAccept = parseHttpAccept
@@ -809,32 +802,20 @@ httpAccept = parseHttpAccept
            . W.requestHeaders
 
 -- | Convert Header to a key/value pair.
-headerToPair :: S.ByteString -- ^ cookie path
+headerToPair :: Header
-             -> (Int -> UTCTime) -- ^ minutes -> expiration time
-             -> Header
              -> (CI H.Ascii, H.Ascii)
-headerToPair cp getExpires (AddCookie minutes key value) =
+headerToPair (AddCookie sc) =
-    ("Set-Cookie", toByteString $ renderSetCookie $ SetCookie
+    ("Set-Cookie", toByteString $ renderSetCookie $ sc)
-        { setCookieName = key
+headerToPair (DeleteCookie key path) =
-        , setCookieValue = value
-        , setCookiePath = Just cp
-        , setCookieExpires =
-            if minutes == 0
-                then Nothing
-                else Just $ getExpires minutes
-        , setCookieDomain = Nothing
-        , setCookieHttpOnly = True
-        })
-headerToPair cp _ (DeleteCookie key) =
     ( "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

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
+    AddCookie SetCookie
-    | DeleteCookie Ascii
+    | DeleteCookie Ascii Ascii
     | Header Ascii Ascii
     deriving (Eq, Show)
 

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
+                Just _ -> AddCookie SetCookie
-                            (clientSessionDuration master)
+                            { setCookieName = sessionName
-                            sessionName
+                            , setCookieValue = sessionVal
-                            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