Do not save empty sessions if possible.

serversession-frontend-snap/src/Web/ServerSession/Frontend/Snap/Internal.hs

@@ -24,6 +24,7 @@ import qualified Crypto.Nonce as N
 import qualified Data.ByteString.Char8 as B8
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as TE
+import qualified Data.Time as TI
 import qualified Data.Map as M
 import qualified Snap.Core as S
 import qualified Snap.Snaplet as S
@@ -88,8 +89,12 @@ instance Storage s => S.ISessionManager (ServerSessionManager s) where
   commit ssm = do
     -- Save session data to storage backend and set the cookie.
     let Just (sessionMap, saveSessionToken) = currentSession ssm
-    session <- liftIO $ saveSession (state ssm) saveSessionToken sessionMap
+    msession <- liftIO $ saveSession (state ssm) saveSessionToken sessionMap
-    S.modifyResponse $ S.addResponseCookie $ createCookie (state ssm) (cookieName ssm) session
+    S.modifyResponse $ S.addResponseCookie $
+      maybe
+        (deleteCookie (state ssm) (cookieName ssm))
+        (createCookie (state ssm) (cookieName ssm))
+        msession
 
   reset ssm = do
     -- Reset has no defined semantics.  We invalidate the session
@@ -162,6 +167,29 @@ createCookie st cookieNameBS session =
     }
 
 
+-- | Remove the session cookie from the client.  This is used
+-- when 'saveSession' returns @Nothing@:
+--
+--   * If the user didn't have a session cookie, this cookie
+--   deletion will be harmless.
+--
+--   * If the user had a session cookie that was invalidated,
+--   this will remove the invalid cookie from the client.
+-- the server-side as well.
+deleteCookie :: State s -> ByteString -> S.Cookie
+deleteCookie st cookieNameBS =
+  S.Cookie
+    { S.cookieName     = cookieNameBS
+    , S.cookieValue    = ""
+    , S.cookiePath     = Just "/"
+    , S.cookieExpires  = Just aLongTimeAgo
+    , S.cookieDomain   = Nothing
+    , S.cookieHttpOnly = getHttpOnlyCookies st
+    , S.cookieSecure   = getSecureCookies st
+    }
+  where aLongTimeAgo = read "1970-01-01 00:00:01 UTC" :: TI.UTCTime
+
+
 -- | The CSRF key is kept as a session variable like any other
 -- under this key.
 csrfKey :: Text

serversession-frontend-wai/src/Web/ServerSession/Frontend/Wai/Internal.hs

@@ -51,6 +51,10 @@ withServerSession key opts storage = liftIO $ do
 
 -- | Construct the @wai-session@ session store using the given
 -- state.  Note that keys and values types are fixed.
+--
+-- As @wai-session@ always requires a value to be provided, we
+-- return an empty @ByteString@ when the empty session was not
+-- saved.
 sessionStore
   :: (MonadIO m, Storage s)
   => State s                           -- ^ @serversession@ state, incl. storage backend.
@@ -61,8 +65,8 @@ sessionStore state =
     sessionRef <- I.newIORef sessionMap
     let save = do
           sessionMap' <- I.atomicModifyIORef' sessionRef $ \a -> (a, a)
-          session <- saveSession state saveSessionToken sessionMap'
+          msession <- saveSession state saveSessionToken sessionMap'
-          return $ TE.encodeUtf8 $ toPathPiece $ sessionKey session
+          return $ maybe "" (TE.encodeUtf8 . toPathPiece . sessionKey) msession
     return (mkSession sessionRef, save)
 
 

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

@@ -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 Data.Time as TI
 import qualified Network.Wai as W
 import qualified Web.Cookie as C
 
@@ -73,7 +74,8 @@ backend state =
       let rawSessionId = findSessionId cookieNameBS req
       (sessionMap, saveSessionToken) <- loadSession state rawSessionId
       let save =
-            fmap ((:[]) . createCookie state cookieNameBS) .
+            fmap ((:[]) . maybe (deleteCookie state cookieNameBS)
+                                (createCookie state cookieNameBS)) .
             saveSession state saveSessionToken
       return (sessionMap, save)
   }
@@ -100,6 +102,29 @@ createCookie state cookieNameBS session =
     }
 
 
+-- | Remove the session cookie from the client.  This is used
+-- when 'saveSession' returns @Nothing@:
+--
+--   * If the user didn't have a session cookie, this cookie
+--   deletion will be harmless.
+--
+--   * If the user had a session cookie that was invalidated,
+--   this will remove the invalid cookie from the client.
+deleteCookie :: State s -> ByteString -> Header
+deleteCookie state cookieNameBS =
+  AddCookie def
+    { C.setCookieName     = cookieNameBS
+    , C.setCookieValue    = ""
+    , C.setCookiePath     = Just "/"
+    , C.setCookieExpires  = Just aLongTimeAgo
+    , C.setCookieMaxAge   = Just 0
+    , C.setCookieDomain   = Nothing
+    , C.setCookieHttpOnly = getHttpOnlyCookies state
+    , C.setCookieSecure   = getSecureCookies state
+    }
+  where aLongTimeAgo = read "1970-01-01 00:00:01 UTC" :: TI.UTCTime
+
+
 -- | Fetch the 'SessionId' from the cookie with the given name.
 -- Returns @Nothing@ if:
 --

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

@@ -456,7 +456,14 @@ data SaveSessionToken =
 -- | 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 Session
+--
+-- Returns @Nothing@ if the session was empty and didn't need to
+-- be saved.  Note that this does /not/ necessarily means that
+-- nothing was done.  If you ask for a session to be invalidated
+-- and clear every other sesssion variable, then 'saveSession'
+-- will invalidate the older session but will avoid creating a
+-- new, empty one.
+saveSession :: Storage s => State s -> SaveSessionToken -> SessionMap -> IO (Maybe Session)
 saveSession state (SaveSessionToken maybeInput now) wholeOutputSessionMap =
   runTransactionM (storage state) $ do
     let decomposedSessionMap = decomposeSession state wholeOutputSessionMap
@@ -513,14 +520,19 @@ decomposeSession state sm1 =
 
 -- | Save a session on the database.  If an old session is
 -- supplied, it is replaced, otherwise a new session is
--- generated.
+-- generated.  If the session is empty, it is not saved and
+-- @Nothing@ is returned.
 saveSessionOnDb
   :: Storage s
   => State s
-  -> UTCTime                -- ^ Now.
+  -> UTCTime                        -- ^ Now.
-  -> Maybe Session          -- ^ The old session, if any.
+  -> Maybe Session                  -- ^ The old session, if any.
-  -> DecomposedSession      -- ^ The session data to be saved.
+  -> DecomposedSession              -- ^ The session data to be saved.
-  -> TransactionM s Session -- ^ Copy of saved session.
+  -> TransactionM s (Maybe Session) -- ^ Copy of saved session.
+saveSessionOnDb _ _ Nothing (DecomposedSession Nothing _ m)
+  -- Return Nothing without doing anything whenever the session
+  -- is empty (including auth ID) and there was no prior session.
+  | M.null m = return Nothing
 saveSessionOnDb state now maybeInput DecomposedSession {..} = do
   -- Generate properties if needed or take them from previous
   -- saved session.
@@ -543,7 +555,7 @@ saveSessionOnDb state now maybeInput DecomposedSession {..} = do
         , sessionAccessedAt = now
         }
   saveToDb session
-  return session
+  return (Just session)
 
 
 -- | Create a 'SessionMap' from a 'Session'.

serversession/tests/Main.hs

@@ -216,13 +216,25 @@ main = hspec $ parallel $ do
     it "should have more tests" pending
 
   describe "saveSessionOnDb" $ do
+    let prepareSaveSessionOnDb = do
+          let oldSession = Session
+                { sessionKey        = S "123456789-123456789-1234"
+                , sessionAuthId     = Just "auth"
+                , sessionData       = M.fromList [("a", "b"), ("c", "d")]
+                , sessionCreatedAt  = TI.addUTCTime (-10) fakenow
+                , sessionAccessedAt = TI.addUTCTime (-5)  fakenow }
+          sto <- prepareMockStorage [oldSession]
+          st  <- createState sto
+          return (oldSession, sto, st)
+        emptyDecomp = DecomposedSession Nothing DoNotForceInvalidate M.empty
+
     it "inserts new sessions when there wasn't an old one" $ do
       sto <- emptyMockStorage
       st  <- createState sto
       let d = DecomposedSession a DoNotForceInvalidate m
           m = M.fromList [("a", "b"), ("c", "d")]
           a = Just "auth"
-      session <- saveSessionOnDb st fakenow Nothing d
+      Just session <- saveSessionOnDb st fakenow Nothing d
       getMockOperations sto `shouldReturn` [InsertSession session]
       sessionAuthId     session `shouldBe` a
       sessionData       session `shouldBe` m
@@ -230,25 +242,29 @@ main = hspec $ parallel $ do
       sessionAccessedAt session `shouldBe` fakenow
 
     it "replaces sesssions when there was an old one" $ do
-      let oldSession = Session
+      (oldSession, sto, st) <- prepareSaveSessionOnDb
-            { sessionKey        = S "123456789-123456789-1234"
-            , sessionAuthId     = Just "auth"
-            , sessionData       = M.fromList [("a", "b"), ("c", "d")]
-            , sessionCreatedAt  = TI.addUTCTime (-10) fakenow
-            , sessionAccessedAt = TI.addUTCTime (-5)  fakenow }
-      sto <- prepareMockStorage [oldSession]
-      st  <- createState sto
       let d = DecomposedSession Nothing DoNotForceInvalidate m
           m = M.fromList [("a", "b"), ("x", "y")]
-      session <- saveSessionOnDb st fakenow (Just oldSession) d
+      Just session <- saveSessionOnDb st fakenow (Just oldSession) d
       getMockOperations sto `shouldReturn` [ReplaceSession session]
       session `shouldBe` oldSession
                            { sessionData       = m
                            , sessionAuthId     = Nothing
                            , sessionAccessedAt = fakenow }
 
-    it "does not save session if it's empty and there wasn't an old one" $
+    it "does not save session if it's empty and there wasn't an old one" $ do
-      pendingWith "wishlist"
+      sto <- emptyMockStorage
+      st  <- createState sto
+      saveSessionOnDb st fakenow Nothing emptyDecomp `shouldReturn` Nothing
+      getMockOperations sto `shouldReturn` []
+
+    it "saves session if it's empty but there was an old one" $ do
+      (oldSession, sto, st) <- prepareSaveSessionOnDb
+      let newSession = oldSession { sessionData       = M.empty
+                                  , sessionAuthId     = Nothing
+                                  , sessionAccessedAt = fakenow }
+      saveSessionOnDb st fakenow (Just oldSession) emptyDecomp `shouldReturn` Just newSession
+      getMockOperations sto `shouldReturn` [ReplaceSession newSession]
 
     it "does not save session if only difference was accessedAt, and it was less than threshold" $
       pendingWith "wishlist"
@@ -268,7 +284,10 @@ main = hspec $ parallel $ do
             test v       = dsForceInvalidate (decomposeSession stnull $ sessionMap v) Q.=== v
         in Q.conjoin (test <$> allForces)
 
-    it "should have more tests" pending
+    it "removes the auth key" $ do
+      let m = M.singleton "a" "b"; m' = M.insert (authKey stnull) "x" m
+      decomposeSession stnull m' `shouldBe`
+        DecomposedSession (Just "x") DoNotForceInvalidate m
 
   describe "toSessionMap" $ do
     let mkSession authId data_ = Session