diff --git a/serversession-frontend-snap/src/Web/ServerSession/Frontend/Snap/Internal.hs b/serversession-frontend-snap/src/Web/ServerSession/Frontend/Snap/Internal.hs index 86e9d1d..9065456 100644 --- a/serversession-frontend-snap/src/Web/ServerSession/Frontend/Snap/Internal.hs +++ b/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 - S.modifyResponse $ S.addResponseCookie $ createCookie (state ssm) (cookieName ssm) session + msession <- liftIO $ saveSession (state ssm) saveSessionToken sessionMap + 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 diff --git a/serversession-frontend-wai/src/Web/ServerSession/Frontend/Wai/Internal.hs b/serversession-frontend-wai/src/Web/ServerSession/Frontend/Wai/Internal.hs index 5318afa..1e245d5 100644 --- a/serversession-frontend-wai/src/Web/ServerSession/Frontend/Wai/Internal.hs +++ b/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' - return $ TE.encodeUtf8 $ toPathPiece $ sessionKey session + msession <- saveSession state saveSessionToken sessionMap' + return $ maybe "" (TE.encodeUtf8 . toPathPiece . sessionKey) msession return (mkSession sessionRef, save) 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 ce6871f..9221b4d 100644 --- a/serversession-frontend-yesod/src/Web/ServerSession/Frontend/Yesod/Internal.hs +++ b/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: -- diff --git a/serversession/src/Web/ServerSession/Core/Internal.hs b/serversession/src/Web/ServerSession/Core/Internal.hs index edceefe..5461eab 100644 --- a/serversession/src/Web/ServerSession/Core/Internal.hs +++ b/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. - -> Maybe Session -- ^ The old session, if any. - -> DecomposedSession -- ^ The session data to be saved. - -> TransactionM s Session -- ^ Copy of saved session. + -> UTCTime -- ^ Now. + -> Maybe Session -- ^ The old session, if any. + -> DecomposedSession -- ^ The session data to be saved. + -> 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'. diff --git a/serversession/tests/Main.hs b/serversession/tests/Main.hs index 542ec2d..ab07b98 100644 --- a/serversession/tests/Main.hs +++ b/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 - { 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 + (oldSession, sto, st) <- prepareSaveSessionOnDb 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" $ - pendingWith "wishlist" + it "does not save session if it's empty and there wasn't an old one" $ do + 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