haskell/serversession
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Do not save empty sessions if possible.

Browse Source
This commit is contained in:
Felipe Lessa 2015-05-28 16:39:13 -03:00
parent 3757b4dad9
commit b12b3e7cd1
5 changed files with 113 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -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

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

@ -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)

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

@ -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:
--

26
serversession/src/Web/ServerSession/Core/Internal.hs
View File

@ -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'.

45
serversession/tests/Main.hs
View File

@ -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