From 6e1d3f3f4c9e6fda9cc33568d2b2a4001be56b2f Mon Sep 17 00:00:00 2001
From: Myles C. Maxfield <mmaxfield@google.com>
Date: Fri, 3 Feb 2012 15:16:44 -0800
Subject: [PATCH] Adding Max-Age and Secure attributes to set-cookies

---
 Web/Cookie.hs |   33 ++++++++++++++++++++++++++++-----
 cookie.cabal  |    2 +-
 2 files changed, 29 insertions(+), 6 deletions(-)

diff --git a/Web/Cookie.hs b/Web/Cookie.hs
index fa89518..87ff0e3 100644
--- a/Web/Cookie.hs
+++ b/Web/Cookie.hs
@@ -26,6 +26,7 @@ import Blaze.ByteString.Builder.Char8 (fromChar)
 import Data.Monoid (mempty, mappend, mconcat)
 import Data.Word (Word8)
 import Data.Time (UTCTime, formatTime, parseTime)
+import Data.Time.Clock (DiffTime, secondsToDiffTime)
 import System.Locale (defaultTimeLocale)
 import Control.Arrow (first)
 import Data.Text (Text)
@@ -84,10 +85,12 @@ data SetCookie = SetCookie
     , setCookieValue :: S.ByteString
     , setCookiePath :: Maybe S.ByteString
     , setCookieExpires :: Maybe UTCTime
+    , setCookieMaxAge :: Maybe DiffTime
     , setCookieDomain :: Maybe S.ByteString
     , setCookieHttpOnly :: Bool
+    , setCookieSecure :: Bool
     }
-    deriving (Eq, Show, Read)
+    deriving (Eq, Show)
 
 renderSetCookie :: SetCookie -> Builder
 renderSetCookie sc = mconcat
@@ -96,19 +99,26 @@ renderSetCookie sc = mconcat
     , fromByteString (setCookieValue sc)
     , case setCookiePath sc of
         Nothing -> mempty
-        Just path -> copyByteString "; path="
+        Just path -> copyByteString "; Path="
                      `mappend` fromByteString path
     , case setCookieExpires sc of
         Nothing -> mempty
-        Just e -> copyByteString "; expires=" `mappend`
+        Just e -> copyByteString "; Expires=" `mappend`
                   fromByteString (formatCookieExpires e)
+    , case setCookieMaxAge sc of
+        Nothing -> mempty
+        Just ma -> copyByteString"; Max-Age=" `mappend`
+                   fromByteString (formatCookieMaxAge ma)
     , case setCookieDomain sc of
         Nothing -> mempty
-        Just d -> copyByteString "; domain=" `mappend`
+        Just d -> copyByteString "; Domain=" `mappend`
                   fromByteString d
     , if setCookieHttpOnly sc
         then copyByteString "; HttpOnly"
         else mempty
+    , if setCookieSecure sc
+        then copyByteString "; Secure"
+        else mempty
     ]
 
 parseSetCookie :: S.ByteString -> SetCookie
@@ -118,8 +128,11 @@ parseSetCookie a = SetCookie
     , setCookiePath = lookup "path" pairs
     , setCookieExpires =
         lookup "expires" pairs >>= parseCookieExpires
+    , setCookieMaxAge =
+        lookup "max-age" pairs >>= parseCookieMaxAge
     , setCookieDomain = lookup "domain" pairs
-    , setCookieHttpOnly = isJust $ lookup "HttpOnly" pairs
+    , setCookieHttpOnly = isJust $ lookup "httponly" pairs
+    , setCookieSecure = isJust $ lookup "secure" pairs
     }
   where
     (key, value, b) = parsePair a
@@ -144,3 +157,13 @@ formatCookieExpires =
 
 parseCookieExpires :: S.ByteString -> Maybe UTCTime
 parseCookieExpires = parseTime defaultTimeLocale expiresFormat . S8.unpack
+
+-- | Format a 'DiffTime' for a cookie.
+formatCookieMaxAge :: DiffTime -> S.ByteString
+formatCookieMaxAge difftime = S8.pack $ show (floor difftime :: Integer)
+
+parseCookieMaxAge :: S.ByteString -> Maybe DiffTime
+parseCookieMaxAge bs
+  | all (\ c -> c >= '0' && c <= '9') $ unpacked = Just $ secondsToDiffTime $ read unpacked
+  | otherwise = Nothing
+  where unpacked = S8.unpack bs
diff --git a/cookie.cabal b/cookie.cabal
index 4c0210c..b218976 100644
--- a/cookie.cabal
+++ b/cookie.cabal
@@ -16,7 +16,7 @@ library
                    , bytestring                >= 0.9.1.4  && < 0.10
                    , blaze-builder             >= 0.2.1    && < 0.4
                    , old-locale                >= 1        && < 1.1
-                   , time                      >= 1.1.4
+                   , time                      >= 1.3
                    , text                      >= 0.7      && < 1.0
     exposed-modules: Web.Cookie
     ghc-options:     -Wall
-- 
1.7.5.1

