Support for idle timeouts, absolute timeouts and non-persistent cookies.

serversession-backend-persistent/src/Web/ServerSession/Backend/Persistent/Internal/Impl.hs

@@ -28,10 +28,11 @@ share
   [mkPersist sqlSettings, mkSave "serverSessionDefs"]
   [persistLowerCase|
     PersistentSession json
-      key       SessionId         -- Session ID, primary key.
+      key        SessionId         -- Session ID, primary key.
-      authId    ByteStringJ Maybe -- Value of "_ID" session key.
+      authId     ByteStringJ Maybe -- Value of "_ID" session key.
-      session   SessionMapJ       -- Rest of the session data.
+      session    SessionMapJ       -- Rest of the session data.
-      createdAt UTCTime           -- When this session was created.
+      createdAt  UTCTime           -- When this session was created.
+      accessedAt UTCTime           -- When this session was last accessed.
       Primary key
       deriving Eq Ord Show Typeable
   |]
@@ -46,10 +47,11 @@ psKey = PersistentSessionKey'
 toPersistentSession :: Session -> PersistentSession
 toPersistentSession Session {..} =
   PersistentSession
-    { persistentSessionKey       = sessionKey
+    { persistentSessionKey        = sessionKey
-    , persistentSessionAuthId    = fmap B sessionAuthId
+    , persistentSessionAuthId     = fmap B sessionAuthId
-    , persistentSessionSession   = M sessionData
+    , persistentSessionSession    = M sessionData
-    , persistentSessionCreatedAt = sessionCreatedAt
+    , persistentSessionCreatedAt  = sessionCreatedAt
+    , persistentSessionAccessedAt = sessionAccessedAt
     }
 
 
@@ -57,10 +59,11 @@ toPersistentSession Session {..} =
 fromPersistentSession :: PersistentSession -> Session
 fromPersistentSession PersistentSession {..} =
   Session
-    { sessionKey       = persistentSessionKey
+    { sessionKey        = persistentSessionKey
-    , sessionAuthId    = fmap unB persistentSessionAuthId
+    , sessionAuthId     = fmap unB persistentSessionAuthId
-    , sessionData      = unM persistentSessionSession
+    , sessionData       = unM persistentSessionSession
-    , sessionCreatedAt = persistentSessionCreatedAt
+    , sessionCreatedAt  = persistentSessionCreatedAt
+    , sessionAccessedAt = persistentSessionAccessedAt
     }
 
 

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

@@ -11,6 +11,7 @@ module Web.ServerSession.Frontend.Yesod
   , setAuthKey
   , setIdleTimeout
   , setAbsoluteTimeout
+  , setPersistentCookies
   , State
   ) where
 

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

@@ -72,7 +72,7 @@ backend state =
       let rawSessionId = findSessionId cookieNameBS req
       (sessionMap, saveSessionToken) <- loadSession state rawSessionId
       let save =
-            fmap ((:[]) . createCookie cookieNameBS) .
+            fmap ((:[]) . createCookie state cookieNameBS) .
             saveSession state saveSessionToken
       return (sessionMap, save)
   }
@@ -81,14 +81,16 @@ backend state =
 
 
 -- | Create a cookie for the given session ID.
-createCookie :: ByteString -> SessionId -> Header
+--
-createCookie cookieNameBS key =
+-- The cookie expiration is set via 'nextExpires'.  Note that this is just an optimization
+createCookie :: State s -> ByteString -> Session -> Header
+createCookie state cookieNameBS session =
   -- Generate a cookie with the final session ID.
   AddCookie def
     { C.setCookieName     = cookieNameBS
-    , C.setCookieValue    = TE.encodeUtf8 $ toPathPiece key
+    , C.setCookieValue    = TE.encodeUtf8 $ toPathPiece $ sessionKey session
     , C.setCookiePath     = Just "/"
-    , C.setCookieExpires  = Just undefined
+    , C.setCookieExpires  = cookieExpires state session
     , C.setCookieDomain   = Nothing
     , C.setCookieHttpOnly = True
     }

serversession/src/Web/ServerSession/Core.hs

@@ -10,6 +10,7 @@ module Web.ServerSession.Core
   , State
   , createState
   , loadSession
+  , cookieExpires
   , saveSession
   , SaveSessionToken
   , forceInvalidateKey
@@ -18,6 +19,7 @@ module Web.ServerSession.Core
   , setAuthKey
   , setIdleTimeout
   , setAbsoluteTimeout
+  , setPersistentCookies
   , ForceInvalidate(..)
   ) where
 

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

@@ -15,7 +15,11 @@ module Web.ServerSession.Core.Internal
   , setAuthKey
   , setIdleTimeout
   , setAbsoluteTimeout
+  , setPersistentCookies
   , loadSession
+  , checkExpired
+  , nextExpires
+  , cookieExpires
   , saveSession
   , SaveSessionToken(..)
   , invalidateIfNeeded
@@ -30,10 +34,10 @@ module Web.ServerSession.Core.Internal
 import Control.Monad (guard, when)
 import Control.Monad.IO.Class (MonadIO(..))
 import Data.ByteString (ByteString)
-import Data.Maybe (isJust)
+import Data.Maybe (catMaybes, fromMaybe, isJust)
 import Data.Text (Text)
 import Data.Time (UTCTime, getCurrentTime)
-import Data.Time.Clock (DiffTime, secondsToDiffTime)
+import Data.Time.Clock (NominalDiffTime, addUTCTime)
 import Data.Typeable (Typeable)
 import Web.PathPieces (PathPiece(..))
 
@@ -119,6 +123,8 @@ data Session =
       -- ^ Rest of the session data.
     , sessionCreatedAt :: UTCTime
       -- ^ When this session was created.
+    , sessionAccessedAt :: UTCTime
+      -- ^ When this session was last accessed.
     } deriving (Eq, Ord, Show, Typeable)
 
 
@@ -150,8 +156,6 @@ class MonadIO (TransactionM s) => Storage s where
 ----------------------------------------------------------------------
 
 
--- TODO: expiration
-
 -- TODO: do not create empty sessions
 
 -- | The server-side session backend needs to maintain some state
@@ -167,15 +171,18 @@ class MonadIO (TransactionM s) => Storage s where
 --
 --   * Idle and absolute timeouts ('setIdleTimeout' and 'setAbsoluteTimeout').
 --
+--   * Whether cookies should be persistent ('setPersistentCookies')
+--
 -- Create a new 'State' using 'createState'.
 data State s =
   State
-    { generator       :: !N.Generator
+    { generator         :: !N.Generator
-    , storage         :: !s
+    , storage           :: !s
-    , cookieName      :: !Text
+    , cookieName        :: !Text
-    , authKey         :: !Text
+    , authKey           :: !Text
-    , idleTimeout     :: !(Maybe DiffTime)
+    , idleTimeout       :: !(Maybe NominalDiffTime)
-    , absoluteTimeout :: !(Maybe DiffTime)
+    , absoluteTimeout   :: !(Maybe NominalDiffTime)
+    , persistentCookies :: !Bool
     } deriving (Typeable)
 
 
@@ -185,12 +192,13 @@ createState :: MonadIO m => s -> m (State s)
 createState sto = do
   gen <- N.new
   return State
-    { generator       = gen
+    { generator         = gen
-    , storage         = sto
+    , storage           = sto
-    , cookieName      = "JSESSIONID"
+    , cookieName        = "JSESSIONID"
-    , authKey         = "_ID"
+    , authKey           = "_ID"
-    , idleTimeout     = Just $ secondsToDiffTime $ 60*60*24*7  -- 7 days
+    , idleTimeout       = Just $ 60*60*24*7  -- 7 days
-    , absoluteTimeout = Just $ secondsToDiffTime $ 60*60*24*60 -- 60 days
+    , absoluteTimeout   = Just $ 60*60*24*60 -- 60 days
+    , persistentCookies = True
     }
 
 
@@ -222,7 +230,7 @@ setAuthKey val state = state { authKey = val }
 -- (<https://www.owasp.org/index.php/Session_Management_Cheat_Sheet#Idle_Timeout Source>)
 --
 -- Defaults to 7 days.
-setIdleTimeout :: Maybe DiffTime -> State s -> State s
+setIdleTimeout :: Maybe NominalDiffTime -> State s -> State s
 setIdleTimeout (Just d) _ | d <= 0 = error "serversession/setIdleTimeout: Timeout should be positive."
 setIdleTimeout val state = state { idleTimeout = val }
 
@@ -242,11 +250,25 @@ setIdleTimeout val state = state { idleTimeout = val }
 -- (<https://www.owasp.org/index.php/Session_Management_Cheat_Sheet#Absolute_Timeout Source>)
 --
 -- Defaults to 60 days.
-setAbsoluteTimeout :: Maybe DiffTime -> State s -> State s
+setAbsoluteTimeout :: Maybe NominalDiffTime -> State s -> State s
 setAbsoluteTimeout (Just d) _ | d <= 0 = error "serversession/setAbsoluteTimeout: Timeout should be positive."
 setAbsoluteTimeout val state = state { absoluteTimeout = val }
 
 
+-- | Set whether by default cookies should be persistent (@True@) or
+-- non-persistent (@False@).  Persistent cookies are saved across
+-- browser sessions.  Non-persistent cookies are discarded when
+-- the browser is closed.
+--
+-- If you set cookies to be persistent and do not define any
+-- timeouts ('setIdleTimeout' or 'setAbsoluteTimeout'), then the
+-- cookie is set to expire in 10 years.
+--
+-- Defaults to @True@.
+setPersistentCookies :: Bool -> State s -> State s
+setPersistentCookies val state = state { persistentCookies = val }
+
+
 -- | Load the session map from the storage backend.  The value of
 -- the session cookie should be given as argument if present.
 --
@@ -259,27 +281,60 @@ setAbsoluteTimeout val state = state { absoluteTimeout = val }
 --   of the request in order to save the session.
 loadSession :: Storage s => State s -> Maybe ByteString -> IO (SessionMap, SaveSessionToken)
 loadSession state mcookieVal = do
+  now <- getCurrentTime
   let maybeInputId = mcookieVal >>= fromPathPiece . TE.decodeUtf8
-      get = runTransactionM (storage state) . getSession (storage state)
+      get          = runTransactionM (storage state) . getSession (storage state)
-  maybeInput <- maybe (return Nothing) get maybeInputId
+      checkedGet   = fmap (>>= checkExpired now state) . get
+  maybeInput <- maybe (return Nothing) checkedGet maybeInputId
   let inputSessionMap = maybe M.empty (toSessionMap state) maybeInput
-  return (inputSessionMap, SaveSessionToken maybeInput)
+  return (inputSessionMap, SaveSessionToken maybeInput now)
+
+
+-- | Check if a session @s@ has expired.  Returns the @Just s@ if
+-- not expired, or @Nothing@ if expired.
+checkExpired :: UTCTime {-^ Now. -} -> State s -> Session -> Maybe Session
+checkExpired now state session =
+  let expired = maybe False (< now) (nextExpires state session)
+  in guard (not expired) >> return session
+
+
+-- | Calculate the next point in time where the given session
+-- will expire assuming that it sees no activity until then.
+-- Returns @Nothing@ iff the state does not have any expirations
+-- set to @Just@.
+nextExpires :: State s -> Session -> Maybe UTCTime
+nextExpires State {..} Session {..} =
+  let viaIdle     = flip addUTCTime sessionAccessedAt <$> idleTimeout
+      viaAbsolute = flip addUTCTime sessionCreatedAt  <$> absoluteTimeout
+      minimum' [] = Nothing
+      minimum' xs = Just $ minimum xs
+  in minimum' $ catMaybes [viaIdle, viaAbsolute]
+
+
+-- | Calculate the date that should be used for the cookie's
+-- \"Expires\" field.
+cookieExpires :: State s -> Session -> Maybe UTCTime
+cookieExpires State {..} _ | not persistentCookies = Nothing
+cookieExpires state session =
+  Just $ fromMaybe tenYearsFromNow $ nextExpires state session
+  where tenYearsFromNow = addUTCTime (60*60*24*3652) now
+        now = sessionAccessedAt session -- :)
 
 
 -- | Opaque token containing the necessary information for
 -- 'saveSession' to save the session.
-newtype SaveSessionToken = SaveSessionToken (Maybe Session)
+data SaveSessionToken = SaveSessionToken (Maybe Session) UTCTime
 
 
 -- | Save the session on the storage backend.  A
 -- 'SaveSessionToken' given by 'loadSession' is expected besides
 -- the new contents of the session.
-saveSession :: Storage s => State s -> SaveSessionToken -> SessionMap -> IO SessionId
+saveSession :: Storage s => State s -> SaveSessionToken -> SessionMap -> IO Session
-saveSession state (SaveSessionToken maybeInput) wholeOutputSessionMap =
+saveSession state (SaveSessionToken maybeInput now) wholeOutputSessionMap =
   runTransactionM (storage state) $ do
     let decomposedSessionMap = decomposeSession state wholeOutputSessionMap
     newMaybeInput <- invalidateIfNeeded state maybeInput decomposedSessionMap
-    saveSessionOnDb state newMaybeInput decomposedSessionMap
+    saveSessionOnDb state now newMaybeInput decomposedSessionMap
 
 
 -- | Invalidates an old session ID if needed.  Returns the
@@ -335,10 +390,11 @@ decomposeSession state sm1 =
 saveSessionOnDb
   :: Storage s
   => State s
-  -> Maybe Session            -- ^ The old session, if any.
+  -> UTCTime                -- ^ Now.
-  -> DecomposedSession        -- ^ The session data to be saved.
+  -> Maybe Session          -- ^ The old session, if any.
-  -> TransactionM s SessionId -- ^ The ID of the saved session.
+  -> DecomposedSession      -- ^ The session data to be saved.
-saveSessionOnDb state maybeInput DecomposedSession {..} = do
+  -> TransactionM s Session -- ^ Copy of saved session.
+saveSessionOnDb state now maybeInput DecomposedSession {..} = do
   -- Generate properties if needed or take them from previous
   -- saved session.
   (saveToDb, key, createdAt) <-
@@ -346,14 +402,21 @@ saveSessionOnDb state maybeInput DecomposedSession {..} = do
       Nothing -> liftIO $
         (,,) <$> return (insertSession $ storage state)
              <*> generateSessionId (generator state)
-             <*> getCurrentTime
+             <*> return now
       Just Session {..} ->
         return ( replaceSession (storage state)
                , sessionKey
                , sessionCreatedAt)
   -- Save to the database.
-  saveToDb $ Session key dsAuthId dsSessionMap createdAt
+  let session = Session
-  return key
+        { sessionKey        = key
+        , sessionAuthId     = dsAuthId
+        , sessionData       = dsSessionMap
+        , sessionCreatedAt  = createdAt
+        , sessionAccessedAt = now
+        }
+  saveToDb session
+  return session
 
 
 -- | Create a 'SessionMap' from a 'Session'.