Set the cookie name on State instead of leaving to frontends.

serversession-frontend-yesod/src/Web/ServerSession/Frontend/Yesod/Internal.hs

@@ -10,9 +10,9 @@ import Control.Monad (guard)
 import Control.Monad.IO.Class (MonadIO)
 import Data.ByteString (ByteString)
 import Data.Default (def)
-import Web.Cookie (parseCookies, SetCookie(..))
 import Web.PathPieces (toPathPiece)
 import Web.ServerSession.Core
+import Web.ServerSession.Core.Internal (cookieName)
 import Yesod.Core (MonadHandler)
 import Yesod.Core.Handler (setSessionBS)
 import Yesod.Core.Types (Header(AddCookie), SessionBackend(..))
@@ -20,6 +20,7 @@ import Yesod.Core.Types (Header(AddCookie), SessionBackend(..))
 import qualified Data.ByteString.Char8 as B8
 import qualified Data.Text.Encoding as TE
 import qualified Network.Wai as W
+import qualified Web.Cookie as C
 
 
 -- | Construct the server-side session backend using
@@ -34,51 +35,60 @@ import qualified Network.Wai as W
 --
 -- instance Yesod App where
 --   ...
---   makeSessionBackend = simpleBackend . SqlStorage . appConnPool
+--   makeSessionBackend = simpleBackend id . SqlStorage . appConnPool
 --   -- Do not forget to add migration code to your Application.hs!
 --   -- Please check serversession-backend-persistent's documentation.
 --   ...
 -- @
+--
+-- For example, if you wanted to disable the idle timeout and decrease the
+-- absolute timeout to one day, you could change that line to:
+--
+-- @
+--   makeSessionBackend = simpleBackend opts . SqlStorage . appConnPool
+--     where opts = setIdleTimeout Nothing
+--                . setAbsoluteTimeout (Just $ 60*60*24)
+-- @
 simpleBackend
   :: (MonadIO m, Storage s)
-  => s                        -- ^ Storage backend.
+  => (State s -> State s)     -- ^ Set any options on the @serversession@ state.
+  -> s                        -- ^ Storage backend.
   -> m (Maybe SessionBackend) -- ^ Yesod session backend (always @Just@).
-simpleBackend s = do
+simpleBackend opts s =
-  state <- createState s
+  return . Just . backend . opts =<< createState s
-  let cookieName = "JSESSIONID" -- LOL :)
-  return $ Just $ backend state cookieName
 
 
 -- | Construct the server-side session backend using the given
--- state and cookie name.
+-- state.
 backend
   :: Storage s
   => State s        -- ^ @serversession@ state, incl. storage backend.
-  -> ByteString     -- ^ Cookie name.
   -> SessionBackend -- ^ Yesod session backend.
-backend state cookieName =
+backend state =
   SessionBackend {
     sbLoadSession = \req -> do
-      let rawSessionId = findSessionId cookieName req
+      let rawSessionId = findSessionId cookieNameBS req
       (sessionMap, saveSessionToken) <- loadSession state rawSessionId
       let save =
-            fmap ((:[]) . createCookie cookieName) .
+            fmap ((:[]) . createCookie cookieNameBS) .
             saveSession state saveSessionToken
       return (sessionMap, save)
   }
+  where
+    cookieNameBS = TE.encodeUtf8 $ cookieName state
 
 
 -- | Create a cookie for the given session ID.
 createCookie :: ByteString -> SessionId -> Header
-createCookie cookieName key =
+createCookie cookieNameBS key =
   -- Generate a cookie with the final session ID.
   AddCookie def
-    { setCookieName     = cookieName
+    { C.setCookieName     = cookieNameBS
-    , setCookieValue    = TE.encodeUtf8 $ toPathPiece key
+    , C.setCookieValue    = TE.encodeUtf8 $ toPathPiece key
-    , setCookiePath     = Just "/"
+    , C.setCookiePath     = Just "/"
-    , setCookieExpires  = Just undefined
+    , C.setCookieExpires  = Just undefined
-    , setCookieDomain   = Nothing
+    , C.setCookieDomain   = Nothing
-    , setCookieHttpOnly = True
+    , C.setCookieHttpOnly = True
     }
 
 
@@ -89,11 +99,11 @@ createCookie cookieName key =
 --
 --   * There is more than one cookie with the given name.
 findSessionId :: ByteString -> W.Request -> Maybe ByteString
-findSessionId cookieName req = do
+findSessionId cookieNameBS req = do
   [raw] <- return $ do
     ("Cookie", header) <- W.requestHeaders req
-    (k, v) <- parseCookies header
+    (k, v) <- C.parseCookies header
-    guard (k == cookieName)
+    guard (k == cookieNameBS)
     return v
   return raw
 

serversession/src/Web/ServerSession/Core.hs

@@ -15,6 +15,7 @@ module Web.ServerSession.Core
   , SaveSessionToken
   , forceInvalidateKey
     -- ** To be re-exported by frontends
+  , setCookieName
   , ForceInvalidate(..)
   ) where
 

serversession/src/Web/ServerSession/Core/Internal.hs

@@ -11,6 +11,7 @@ module Web.ServerSession.Core.Internal
 
   , State(..)
   , createState
+  , setCookieName
   , setAuthKey
   , loadSession
   , saveSession
@@ -30,6 +31,7 @@ import Data.ByteString (ByteString)
 import Data.Maybe (isJust)
 import Data.Text (Text)
 import Data.Time (UTCTime, getCurrentTime)
+import Data.Time.Clock (DiffTime, secondsToDiffTime)
 import Data.Typeable (Typeable)
 import Web.PathPieces (PathPiece(..))
 
@@ -157,25 +159,45 @@ class MonadIO (TransactionM s) => Storage s where
 --
 --   * A reference to the storage backend.
 --
+--   * The name of cookie where the session ID will be saved ('setCookieName').
+--
 --   * Authentication session variable ('setAuthKey').
 --
+--   * Idle and absolute timeouts ('setIdleTimeout' and 'setAbsoluteTimeout').
+--
 -- Create a new 'State' using 'createState'.
 data State s =
   State
-    { generator :: !N.Generator
+    { generator       :: !N.Generator
-    , storage   :: !s
+    , storage         :: !s
-    , authKey   :: Text
+    , cookieName      :: !Text
+    , authKey         :: !Text
+    , idleTimeout     :: !(Maybe DiffTime)
+    , absoluteTimeout :: !(Maybe DiffTime)
     } deriving (Typeable)
 
 
 -- | Create a new 'State' for the server-side session backend
 -- using the given storage backend.
 createState :: MonadIO m => s -> m (State s)
-createState storage =
+createState sto = do
-  State
+  gen <- N.new
-    <$> N.new
+  return State
-    <*> return storage
+    { generator       = gen
-    <*> return "_ID"
+    , storage         = sto
+    , cookieName      = "JSESSIONID"
+    , authKey         = "_ID"
+    , idleTimeout     = Just $ secondsToDiffTime $ 60*60*24*7  -- 7 days
+    , absoluteTimeout = Just $ secondsToDiffTime $ 60*60*24*60 -- 60 days
+    }
+
+
+-- | Set the name of cookie where the session ID will be saved.
+-- Defaults to \"JSESSIONID\", which is a generic cookie name
+-- used by many frameworks thus making it harder to fingerprint
+-- this implementation.
+setCookieName :: Text -> State s -> State s
+setCookieName val state = state { cookieName = val }
 
 
 -- | Set the name of the session variable that keeps track of the