From e5203db715021ee9f4f2346723fc53765e0e1c66 Mon Sep 17 00:00:00 2001
From: Felipe Lessa <felipe.lessa@gmail.com>
Date: Mon, 25 May 2015 19:57:43 -0300
Subject: [PATCH] Support for HttpOnly and Secure attributes on the core.

---
 .../src/Web/ServerSession/Frontend/Yesod.hs   |  2 ++
 .../ServerSession/Frontend/Yesod/Internal.hs  | 11 ++++---
 serversession/src/Web/ServerSession/Core.hs   |  2 ++
 .../src/Web/ServerSession/Core/Internal.hs    | 33 ++++++++++++++++++-
 4 files changed, 43 insertions(+), 5 deletions(-)

diff --git a/serversession-frontend-yesod/src/Web/ServerSession/Frontend/Yesod.hs b/serversession-frontend-yesod/src/Web/ServerSession/Frontend/Yesod.hs
index 1a4ac55..d0903be 100644
--- a/serversession-frontend-yesod/src/Web/ServerSession/Frontend/Yesod.hs
+++ b/serversession-frontend-yesod/src/Web/ServerSession/Frontend/Yesod.hs
@@ -12,6 +12,8 @@ module Web.ServerSession.Frontend.Yesod
   , setIdleTimeout
   , setAbsoluteTimeout
   , setPersistentCookies
+  , setHttpOnlyCookies
+  , setSecureCookies
   , State
   ) where
 
diff --git a/serversession-frontend-yesod/src/Web/ServerSession/Frontend/Yesod/Internal.hs b/serversession-frontend-yesod/src/Web/ServerSession/Frontend/Yesod/Internal.hs
index b697706..fdbc784 100644
--- a/serversession-frontend-yesod/src/Web/ServerSession/Frontend/Yesod/Internal.hs
+++ b/serversession-frontend-yesod/src/Web/ServerSession/Frontend/Yesod/Internal.hs
@@ -14,7 +14,7 @@ import Data.ByteString (ByteString)
 import Data.Default (def)
 import Web.PathPieces (toPathPiece)
 import Web.ServerSession.Core
-import Web.ServerSession.Core.Internal (cookieName)
+import Web.ServerSession.Core.Internal (cookieName, httpOnlyCookies, secureCookies)
 import Yesod.Core (MonadHandler)
 import Yesod.Core.Handler (setSessionBS)
 import Yesod.Core.Types (Header(AddCookie), SessionBackend(..))
@@ -43,13 +43,15 @@ import qualified Web.Cookie as C
 --   ...
 -- @
 --
--- For example, if you wanted to disable the idle timeout and decrease the
--- absolute timeout to one day, you could change that line to:
+-- For example, if you wanted to disable the idle timeout,
+-- decrease the absolute timeout to one day and mark cookies as
+-- \"Secure\", you could change that line to:
 --
 -- @
 --   makeSessionBackend = simpleBackend opts . SqlStorage . appConnPool
 --     where opts = setIdleTimeout Nothing
 --                . setAbsoluteTimeout (Just $ 60*60*24)
+--                . setSecureCookies True
 -- @
 simpleBackend
   :: (MonadIO m, Storage s)
@@ -92,7 +94,8 @@ createCookie state cookieNameBS session =
     , C.setCookiePath     = Just "/"
     , C.setCookieExpires  = cookieExpires state session
     , C.setCookieDomain   = Nothing
-    , C.setCookieHttpOnly = True
+    , C.setCookieHttpOnly = httpOnlyCookies state
+    , C.setCookieSecure   = secureCookies state
     }
 
 
diff --git a/serversession/src/Web/ServerSession/Core.hs b/serversession/src/Web/ServerSession/Core.hs
index 7c2b5b8..fb6c321 100644
--- a/serversession/src/Web/ServerSession/Core.hs
+++ b/serversession/src/Web/ServerSession/Core.hs
@@ -20,6 +20,8 @@ module Web.ServerSession.Core
   , setIdleTimeout
   , setAbsoluteTimeout
   , setPersistentCookies
+  , setHttpOnlyCookies
+  , setSecureCookies
   , ForceInvalidate(..)
   ) where
 
diff --git a/serversession/src/Web/ServerSession/Core/Internal.hs b/serversession/src/Web/ServerSession/Core/Internal.hs
index 104ec30..61d7e76 100644
--- a/serversession/src/Web/ServerSession/Core/Internal.hs
+++ b/serversession/src/Web/ServerSession/Core/Internal.hs
@@ -16,6 +16,8 @@ module Web.ServerSession.Core.Internal
   , setIdleTimeout
   , setAbsoluteTimeout
   , setPersistentCookies
+  , setHttpOnlyCookies
+  , setSecureCookies
   , loadSession
   , checkExpired
   , nextExpires
@@ -171,7 +173,9 @@ class MonadIO (TransactionM s) => Storage s where
 --
 --   * Idle and absolute timeouts ('setIdleTimeout' and 'setAbsoluteTimeout').
 --
---   * Whether cookies should be persistent ('setPersistentCookies')
+--   * Whether cookies should be persistent
+--   ('setPersistentCookies'), HTTP-only ('setHTTPOnlyCookies')
+--   and/or secure ('setSecureCookies').
 --
 -- Create a new 'State' using 'createState'.
 data State s =
@@ -183,6 +187,8 @@ data State s =
     , idleTimeout       :: !(Maybe NominalDiffTime)
     , absoluteTimeout   :: !(Maybe NominalDiffTime)
     , persistentCookies :: !Bool
+    , httpOnlyCookies   :: !Bool
+    , secureCookies     :: !Bool
     } deriving (Typeable)
 
 
@@ -199,6 +205,8 @@ createState sto = do
     , idleTimeout       = Just $ 60*60*24*7  -- 7 days
     , absoluteTimeout   = Just $ 60*60*24*60 -- 60 days
     , persistentCookies = True
+    , httpOnlyCookies   = True
+    , secureCookies     = False
     }
 
 
@@ -269,6 +277,29 @@ setPersistentCookies :: Bool -> State s -> State s
 setPersistentCookies val state = state { persistentCookies = val }
 
 
+-- | Set whether cookies should be HTTP-only (@True@) or not
+-- (@False@).  Cookies marked as HTTP-only (\"HttpOnly\") are not
+-- accessible from client-side scripting languages such as
+-- JavaScript, thus preventing a large class of XSS attacks.
+-- It's highly recommended to set this attribute to @True@.
+--
+-- Defaults to @True@.
+setHttpOnlyCookies :: Bool -> State s -> State s
+setHttpOnlyCookies val state = state { httpOnlyCookies = val }
+
+
+-- | Set whether cookies should be mared \"Secure\" (@True@) or not
+-- (@False@).  Cookies marked as \"Secure\" are not sent via
+-- plain HTTP connections, only via HTTPS connections.  It's
+-- highly recommended to set this attribute to @True@.  However,
+-- since many sites do not operate over HTTPS, the default is
+-- @False@.
+--
+-- Defaults to @False@.
+setSecureCookies :: Bool -> State s -> State s
+setSecureCookies val state = state { secureCookies = val }
+
+
 -- | Load the session map from the storage backend.  The value of
 -- the session cookie should be given as argument if present.
 --