serversession (empty) → 1.0
raw patch · 8 files changed
+1716/−0 lines, 8 filesdep +QuickCheckdep +aesondep +basesetup-changed
Dependencies added: QuickCheck, aeson, base, base64-bytestring, bytestring, containers, data-default, hashable, hspec, nonce, path-pieces, serversession, text, time, transformers, unordered-containers
Files
- LICENSE +20/−0
- README.md +5/−0
- Setup.lhs +7/−0
- serversession.cabal +73/−0
- src/Web/ServerSession/Core.hs +36/−0
- src/Web/ServerSession/Core/Internal.hs +791/−0
- src/Web/ServerSession/Core/StorageTests.hs +230/−0
- tests/Main.hs +554/−0
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2015 Felipe Lessa++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,5 @@+# serversession++This is the core package of the serversession family. Please+[read the main README file](https://github.com/yesodweb/serversession/blob/master/README.md)+for general information about the serversession packages.
+ Setup.lhs view
@@ -0,0 +1,7 @@+#!/usr/bin/env runhaskell++> module Main where+> import Distribution.Simple++> main :: IO ()+> main = defaultMain
+ serversession.cabal view
@@ -0,0 +1,73 @@+name: serversession+version: 1.0+license: MIT+license-file: LICENSE+author: Felipe Lessa <felipe.lessa@gmail.com>+maintainer: Felipe Lessa <felipe.lessa@gmail.com>+synopsis: Secure, modular server-side sessions.+category: Web+stability: Stable+cabal-version: >= 1.8+build-type: Simple+homepage: https://github.com/yesodweb/serversession+description: API docs and the README are available at <http://www.stackage.org/package/serversession>+extra-source-files: README.md++library+ hs-source-dirs: src+ build-depends:+ base == 4.*+ , aeson+ , base64-bytestring == 1.0.*+ , bytestring+ , data-default+ , hashable+ , nonce == 1.0.*+ , path-pieces+ , text+ , time+ , transformers+ , unordered-containers+ exposed-modules:+ Web.ServerSession.Core+ Web.ServerSession.Core.Internal+ Web.ServerSession.Core.StorageTests+ extensions:+ DeriveDataTypeable+ FlexibleContexts+ OverloadedStrings+ RecordWildCards+ ScopedTypeVariables+ StandaloneDeriving+ TypeFamilies+ UndecidableInstances+ ghc-options: -Wall+++test-suite tests+ type: exitcode-stdio-1.0+ hs-source-dirs: tests+ build-depends:+ base, aeson, base64-bytestring, bytestring, data-default,+ nonce, path-pieces, text, time, transformers,+ unordered-containers++ , containers+ , hspec >= 2.1 && < 3+ , QuickCheck+ , serversession+ extensions:+ DeriveDataTypeable+ FlexibleContexts+ OverloadedStrings+ StandaloneDeriving+ TupleSections+ TypeFamilies+ UndecidableInstances+ main-is: Main.hs+ ghc-options: -Wall -threaded "-with-rtsopts=-N -s -M1G -c" -rtsopts+++source-repository head+ type: git+ location: https://github.com/yesodweb/serversession
+ src/Web/ServerSession/Core.hs view
@@ -0,0 +1,36 @@+-- | Core server-side session support.+module Web.ServerSession.Core+ ( -- * For serversession storage backends+ SessionId+ , AuthId+ , Session(..)+ , Storage(..)+ , StorageException(..)+ , IsSessionData(..)+ , DecomposedSession(..)++ -- * For serversession frontends+ , SessionMap(..)+ , State+ , createState+ , getCookieName+ , getHttpOnlyCookies+ , getSecureCookies+ , loadSession+ , cookieExpires+ , saveSession+ , SaveSessionToken+ , forceInvalidateKey+ -- ** To be re-exported by frontends+ , setCookieName+ , setAuthKey+ , setIdleTimeout+ , setAbsoluteTimeout+ , setTimeoutResolution+ , setPersistentCookies+ , setHttpOnlyCookies+ , setSecureCookies+ , ForceInvalidate(..)+ ) where++import Web.ServerSession.Core.Internal
+ src/Web/ServerSession/Core/Internal.hs view
@@ -0,0 +1,791 @@+-- | Internal module exposing the guts of the package. Use at+-- your own risk. No API stability guarantees apply.+--+-- @UndecidableInstances@ is required in order to implement @Eq@,+-- @Ord@, @Show@, etc. on data types that have @Decomposed@+-- fields, and should be fairly safe.+module Web.ServerSession.Core.Internal+ ( SessionId(..)+ , checkSessionId+ , generateSessionId++ , AuthId+ , Session(..)+ , SessionMap(..)++ , IsSessionData(..)+ , DecomposedSession(..)++ , Storage(..)+ , StorageException(..)++ , State(..)+ , createState+ , setCookieName+ , setAuthKey+ , setIdleTimeout+ , setAbsoluteTimeout+ , setTimeoutResolution+ , setPersistentCookies+ , setHttpOnlyCookies+ , setSecureCookies+ , getCookieName+ , getHttpOnlyCookies+ , getSecureCookies++ , loadSession+ , checkExpired+ , nextExpires+ , cookieExpires+ , saveSession+ , SaveSessionToken(..)+ , invalidateIfNeeded+ , saveSessionOnDb+ , forceInvalidateKey+ , ForceInvalidate(..)+ ) where++import Control.Applicative ((<$>), (<*>))+import Control.Monad (guard, when)+import Control.Monad.IO.Class (MonadIO(..))+import Data.ByteString (ByteString)+import Data.Hashable (Hashable(..))+import Data.Maybe (catMaybes, fromMaybe, isJust)+import Data.Text (Text)+import Data.Time (UTCTime, getCurrentTime)+import Data.Time.Clock (NominalDiffTime, addUTCTime, diffUTCTime)+import Data.Typeable (Typeable)+import Web.PathPieces (PathPiece(..))++import qualified Control.Exception as E+import qualified Crypto.Nonce as N+import qualified Data.Aeson as A+import qualified Data.ByteString.Base64.URL as B64URL+import qualified Data.ByteString.Char8 as B8+import qualified Data.HashMap.Strict as HM+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+++----------------------------------------------------------------------+++-- | The ID of a session. Always 18 bytes base64url-encoded as+-- 24 characters. The @sess@ type variable is a phantom type for+-- the session data type this session ID points to.+--+-- Implementation notes:+--+-- * Use 'fromPathPiece' for parsing untrusted input.+--+-- * Use 'generateSessionId' for securely generating new+-- session IDs.+newtype SessionId sess = S { unS :: Text }+ deriving (Eq, Ord, Show, Read, Typeable)++-- | Sanity checks input on 'fromPathPiece' (untrusted input).+instance PathPiece (SessionId sess) where+ toPathPiece = unS+ fromPathPiece = checkSessionId++instance A.FromJSON (SessionId sess) where+ parseJSON = fmap S . A.parseJSON++instance A.ToJSON (SessionId sess) where+ toJSON = A.toJSON . unS++instance Hashable (SessionId sess) where+ hashWithSalt s = hashWithSalt s . unS+++-- | (Internal) Check that the given text is a base64url-encoded+-- representation of 18 bytes.+checkSessionId :: Text -> Maybe (SessionId sess)+checkSessionId text = do+ guard (T.length text == 24)+ let bs = TE.encodeUtf8 text+ decoded <- either (const Nothing) Just $ B64URL.decode bs+ guard (B8.length decoded == 18)+ return $ S text+++-- | Securely generate a new SessionId.+generateSessionId :: N.Generator -> IO (SessionId sess)+generateSessionId = fmap S . N.nonce128urlT+++----------------------------------------------------------------------+++-- | Value of the 'authKey' session key.+type AuthId = ByteString+++-- | Representation of a saved session.+--+-- This representation is used by the @serversession@ family of+-- packages, transferring data between this core package and+-- storage backend packages. The @sess@ type variable describes+-- the session data type.+data Session sess =+ Session+ { sessionKey :: SessionId sess+ -- ^ Session ID, primary key.+ , sessionAuthId :: Maybe AuthId+ -- ^ Value of 'authKey' session key, separate from the rest.+ , sessionData :: Decomposed sess+ -- ^ Rest of the session data.+ , sessionCreatedAt :: UTCTime+ -- ^ When this session was created.+ , sessionAccessedAt :: UTCTime+ -- ^ When this session was last accessed.+ } deriving (Typeable)++deriving instance Eq (Decomposed sess) => Eq (Session sess)+deriving instance Ord (Decomposed sess) => Ord (Session sess)+deriving instance Show (Decomposed sess) => Show (Session sess)+++-- | A @newtype@ for a common session map.+--+-- This is a common representation of a session. Although+-- @serversession@ has generalized session data types, you can+-- use this one if you don't want to worry about it. We strive+-- to support this session data type on all frontends and storage+-- backends.+newtype SessionMap =+ SessionMap { unSessionMap :: HM.HashMap Text ByteString }+ deriving (Eq, Show, Read, Typeable)+++----------------------------------------------------------------------+++-- | Class for data types to be used as session data+-- (cf. 'sessionData', 'SessionData').+--+-- The @Show@ constrain is needed for 'StorageException'.+class ( Show (Decomposed sess)+ , Typeable (Decomposed sess)+ , Typeable sess+ ) => IsSessionData sess where+ -- | The type of the session data after being decomposed. This+ -- may be the same as @sess@.+ type Decomposed sess :: *++ -- | Empty session data.+ emptySession :: sess++ -- | Decompose session data into:+ --+ -- * The auth ID of the logged in user (cf. 'setAuthKey',+ -- 'dsAuthId').+ --+ -- * If the session is being forced to be invalidated+ -- (cf. 'forceInvalidateKey', 'ForceInvalidate').+ --+ -- * The rest of the session data (cf. 'Decomposed').+ decomposeSession+ :: Text -- ^ The auth key (cf. 'setAuthKey').+ -> sess -- ^ Session data to be decomposed.+ -> DecomposedSession sess -- ^ Decomposed session data.++ -- | Recompose a decomposed session again into a proper @sess@.+ recomposeSession+ :: Text -- ^ The auth key (cf. 'setAuthKey').+ -> Maybe AuthId -- ^ The @AuthId@, if any.+ -> Decomposed sess -- ^ Decomposed session data to be recomposed.+ -> sess -- ^ Recomposed session data.++ -- | Returns @True@ when both session datas are to be+ -- considered the same.+ --+ -- This is used to optimize storage calls+ -- (cf. 'setTimeoutResolution'). Always returning @False@ will+ -- disable the optimization but won't have any other adverse+ -- effects.+ --+ -- For data types implementing 'Eq', this is usually a good+ -- implementation:+ --+ -- @+ -- isSameDecomposed _ = (==)+ -- @+ isSameDecomposed :: proxy sess -> Decomposed sess -> Decomposed sess -> Bool++ -- | Returns @True@ if the decomposed session data is to be+ -- considered @empty@.+ --+ -- This is used to avoid storing empty session data if at all+ -- possible. Always returning @False@ will disable the+ -- optimization but won't have any other adverse effects.+ isDecomposedEmpty :: proxy sess -> Decomposed sess -> Bool+++-- | A 'SessionMap' decomposes into a 'SessionMap' minus the keys+-- that were removed. The auth key is added back when+-- recomposing.+instance IsSessionData SessionMap where+ type Decomposed SessionMap = SessionMap++ emptySession = SessionMap HM.empty++ isSameDecomposed _ = (==)++ decomposeSession authKey_ (SessionMap sm1) =+ let authId = HM.lookup authKey_ sm1+ force = maybe DoNotForceInvalidate (read . B8.unpack) $+ HM.lookup forceInvalidateKey sm1+ sm2 = HM.delete authKey_ $+ HM.delete forceInvalidateKey sm1+ in DecomposedSession+ { dsAuthId = authId+ , dsForceInvalidate = force+ , dsDecomposed = SessionMap sm2 }++ recomposeSession authKey_ mauthId (SessionMap sm) =+ SessionMap $ maybe id (HM.insert authKey_) mauthId sm++ isDecomposedEmpty _ = HM.null . unSessionMap+++-- | A session data type @sess@ with its special variables taken apart.+data DecomposedSession sess =+ DecomposedSession+ { dsAuthId :: !(Maybe ByteString)+ , dsForceInvalidate :: !ForceInvalidate+ , dsDecomposed :: !(Decomposed sess)+ } deriving (Typeable)++deriving instance Eq (Decomposed sess) => Eq (DecomposedSession sess)+deriving instance Ord (Decomposed sess) => Ord (DecomposedSession sess)+deriving instance Show (Decomposed sess) => Show (DecomposedSession sess)+++----------------------------------------------------------------------+++-- | A storage backend @sto@ for server-side sessions. The+-- @sess@ session data type and\/or its 'Decomposed' version may+-- be constrained depending on the storage backend capabilities.+class ( Typeable sto+ , MonadIO (TransactionM sto)+ , IsSessionData (SessionData sto)+ ) => Storage sto where+ -- | The session data type used by this storage.+ type SessionData sto :: *++ -- | Monad where transactions happen for this backend.+ -- We do not require transactions to be ACID.+ type TransactionM sto :: * -> *++ -- | Run a transaction on the IO monad.+ runTransactionM :: sto -> TransactionM sto a -> IO a++ -- | Get the session for the given session ID. Returns+ -- @Nothing@ if the session is not found.+ getSession+ :: sto+ -> SessionId (SessionData sto)+ -> TransactionM sto (Maybe (Session (SessionData sto)))++ -- | Delete the session with given session ID. Does not do+ -- anything if the session is not found.+ deleteSession :: sto -> SessionId (SessionData sto) -> TransactionM sto ()++ -- | Delete all sessions of the given auth ID. Does not do+ -- anything if there are no sessions of the given auth ID.+ deleteAllSessionsOfAuthId :: sto -> AuthId -> TransactionM sto ()++ -- | Insert a new session. Throws 'SessionAlreadyExists' if+ -- there already exists a session with the same session ID (we+ -- only call this method after generating a fresh session ID).+ insertSession :: sto -> Session (SessionData sto) -> TransactionM sto ()++ -- | Replace the contents of a session. Throws+ -- 'SessionDoesNotExist' if there is no session with the given+ -- session ID (we only call this method when updating a session+ -- that is known to exist).+ --+ -- It is possible to have concurrent requests using the same+ -- session ID such that:+ --+ -- @+ -- request 1: loadSession+ -- request 2: loadSession+ -- request 2: forceInvalidate+ -- request 2: saveSession+ -- request 1: saveSession+ -- @+ --+ -- The request 2's call to 'saveSession' will have called+ -- 'deleteSession' as invalidation was forced. However,+ -- request 1 has no idea and will try to @replaceSession@. The+ -- following behaviors are possible:+ --+ -- 1. Make @replaceSession@ insert the session again.+ -- However, this will undo the invalidation of request 2. As+ -- invalidations are done for security reasons, this is a bad+ -- idea.+ --+ -- 2. Make @replaceSession@ silently discard the session.+ -- The reasoning is that, as the session was going to be+ -- invalidated if request 2 came after request 1, we can+ -- discard its contents. However, we can't be sure that+ -- request 2 would have had the same effect if it had seen+ -- the session changes made by request 1 (and vice versa).+ --+ -- 3. Make @replaceSession@ throw an error. This error is+ -- going to be unrecoverable since usually the session+ -- processing is done at the end of the request processing by+ -- the web framework, thus leading to a 500 Internal Server+ -- Error. However, this signals to the caller that something+ -- went wrong, which is correct.+ --+ -- Most of the time this discussion does not matter.+ -- Invalidations usually occur at times where only one request+ -- is flying.+ replaceSession :: sto -> Session (SessionData sto) -> TransactionM sto ()+++-- | Common exceptions that may be thrown by any storage.+data StorageException sto =+ -- | Exception thrown by 'insertSession' whenever a session+ -- with same ID already exists.+ SessionAlreadyExists+ { seExistingSession :: Session (SessionData sto)+ , seNewSession :: Session (SessionData sto) }+ -- | Exception thrown by 'replaceSession' whenever trying to+ -- replace a session that is not present on the storage.+ | SessionDoesNotExist+ { seNewSession :: Session (SessionData sto) }+ deriving (Typeable)++deriving instance Eq (Decomposed (SessionData sto)) => Eq (StorageException sto)+deriving instance Ord (Decomposed (SessionData sto)) => Ord (StorageException sto)+deriving instance Show (Decomposed (SessionData sto)) => Show (StorageException sto)++instance Storage sto => E.Exception (StorageException sto) where+++----------------------------------------------------------------------+++-- TODO: delete expired sessions.++-- | The server-side session backend needs to maintain some state+-- in order to work:+--+-- * A nonce generator for the session IDs.+--+-- * 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').+--+-- * Timeout resolution ('setTimeoutResolution').+--+-- * Whether cookies should be persistent+-- ('setPersistentCookies'), HTTP-only ('setHTTPOnlyCookies')+-- and/or secure ('setSecureCookies').+--+-- Create a new 'State' using 'createState'.+data State sto =+ State+ { generator :: !N.Generator+ , storage :: !sto+ , cookieName :: !Text+ , authKey :: !Text+ , idleTimeout :: !(Maybe NominalDiffTime)+ , absoluteTimeout :: !(Maybe NominalDiffTime)+ , timeoutResolution :: !(Maybe NominalDiffTime)+ , persistentCookies :: !Bool+ , httpOnlyCookies :: !Bool+ , secureCookies :: !Bool+ } deriving (Typeable)+++-- | Create a new 'State' for the server-side session backend+-- using the given storage backend.+createState :: MonadIO m => sto -> m (State sto)+createState sto = do+ gen <- N.new+ return State+ { generator = gen+ , storage = sto+ , cookieName = "JSESSIONID"+ , authKey = "_ID"+ , idleTimeout = Just $ 60*60*24*7 -- 7 days+ , absoluteTimeout = Just $ 60*60*24*60 -- 60 days+ , timeoutResolution = Just $ 60*10 -- 10 minutes+ , persistentCookies = True+ , httpOnlyCookies = True+ , secureCookies = False+ }+++-- | 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 sto -> State sto+setCookieName val state = state { cookieName = val }+++-- | Set the name of the session variable that keeps track of the+-- logged user.+--+-- This setting is used by session data types that are+-- @Map@-alike, using a @lookup@ function. However, the+-- 'IsSessionData' instance of a session data type may choose not+-- to use it. For example, if you implemented a custom data+-- type, you could return the @AuthId@ without needing a lookup.+--+-- Defaults to \"_ID\" (used by @yesod-auth@).+setAuthKey :: Text -> State sto -> State sto+setAuthKey val state = state { authKey = val }+++-- | Set the idle timeout for all sessions. This is used both on+-- the client side (by setting the cookie expires fields) and on+-- the server side (the idle timeout is enforced even if the+-- cookie expiration is ignored). Setting to @Nothing@ removes+-- the idle timeout entirely.+--+-- \"[The idle timemout] defines the amount of time a session+-- will remain active in case there is no activity in the+-- session, closing and invalidating the session upon the defined+-- idle period since the last HTTP request received by the web+-- application for a given session ID.\"+-- (<https://www.owasp.org/index.php/Session_Management_Cheat_Sheet#Idle_Timeout Source>)+--+-- Defaults to 7 days.+setIdleTimeout :: Maybe NominalDiffTime -> State sto -> State sto+setIdleTimeout (Just d) _ | d <= 0 = error "serversession/setIdleTimeout: Timeout should be positive."+setIdleTimeout val state = state { idleTimeout = val }+++-- | Set the absolute timeout for all sessions. This is used both on+-- the client side (by setting the cookie expires fields) and on+-- the server side (the absolute timeout is enforced even if the+-- cookie expiration is ignored). Setting to @Nothing@ removes+-- the absolute timeout entirely.+--+-- \"[The absolute timeout] defines the maximum amount of time a+-- session can be active, closing and invalidating the session+-- upon the defined absolute period since the given session was+-- initially created by the web application. After invalidating+-- the session, the user is forced to (re)authenticate again in+-- the web application and establish a new session.\"+-- (<https://www.owasp.org/index.php/Session_Management_Cheat_Sheet#Absolute_Timeout Source>)+--+-- Defaults to 60 days.+setAbsoluteTimeout :: Maybe NominalDiffTime -> State sto -> State sto+setAbsoluteTimeout (Just d) _ | d <= 0 = error "serversession/setAbsoluteTimeout: Timeout should be positive."+setAbsoluteTimeout val state = state { absoluteTimeout = val }+++-- | Set the timeout resolution.+--+-- We need to save both the creation and last access times on+-- sessions in order to implement idle and absolute timeouts.+-- This means that we have to save the updated session on the+-- storage backend even if the request didn't change any session+-- variable, if only to update the last access time.+--+-- This setting provides an optimization where the session is not+-- updated on the storage backend provided that:+--+-- * No session variables were changed.+--+-- * The difference between the /current/ time and the last+-- /saved/ access time is less than the timeout resolution.+--+-- For example, with a timeout resolution of 1 minute, every+-- request that does not change the session variables within 1+-- minute of the last update will not generate any updates on the+-- storage backend.+--+-- If the timeout resolution is @Nothing@, then this optimization+-- becomes disabled and the session will always be updated.+--+-- Defaults to 10 minutes.+setTimeoutResolution :: Maybe NominalDiffTime -> State sto -> State sto+setTimeoutResolution (Just d) _ | d <= 0 = error "serversession/setTimeoutResolution: Resolution should be positive."+setTimeoutResolution val state = state { timeoutResolution = 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 sto -> State sto+setPersistentCookies val state = state { persistentCookies = val }+++-- | Set whether cookies should be HTTP-only (@True@) or not+-- (@False@). Cookies marked as HTTP-only (\"HttpOnly\") are not+-- accessible from client-side scripting languages such as+-- JavaScript, thus preventing a large class of XSS attacks.+-- It's highly recommended to set this attribute to @True@.+--+-- Defaults to @True@.+setHttpOnlyCookies :: Bool -> State sto -> State sto+setHttpOnlyCookies val state = state { httpOnlyCookies = val }+++-- | Set whether cookies should be mared \"Secure\" (@True@) or not+-- (@False@). Cookies marked as \"Secure\" are not sent via+-- plain HTTP connections, only via HTTPS connections. It's+-- highly recommended to set this attribute to @True@. However,+-- since many sites do not operate over HTTPS, the default is+-- @False@.+--+-- Defaults to @False@.+setSecureCookies :: Bool -> State sto -> State sto+setSecureCookies val state = state { secureCookies = val }+++-- | Cf. 'setCookieName'.+getCookieName :: State sto -> Text+getCookieName = cookieName+++-- | Cf. 'setHttpOnlyCookies'.+getHttpOnlyCookies :: State sto -> Bool+getHttpOnlyCookies = httpOnlyCookies+++-- | Cf. 'setSecureCookies'.+getSecureCookies :: State sto -> Bool+getSecureCookies = secureCookies+++----------------------------------------------------------------------+++-- | Load the session map from the storage backend. The value of+-- the session cookie should be given as argument if present.+--+-- Returns:+--+-- * The session data @sess@ to be used by the frontend as the+-- current session's value.+--+-- * Information to be passed back to 'saveSession' on the end+-- of the request in order to save the session.+loadSession+ :: Storage sto+ => State sto+ -> Maybe ByteString+ -> IO (SessionData sto, SaveSessionToken sto)+loadSession state mcookieVal = do+ now <- getCurrentTime+ let maybeInputId = mcookieVal >>= fromPathPiece . TE.decodeUtf8+ get = runTransactionM (storage state) . getSession (storage state)+ checkedGet = fmap (>>= checkExpired now state) . get+ maybeInput <- maybe (return Nothing) checkedGet maybeInputId+ let inputData =+ maybe+ emptySession+ (\s -> recomposeSession (authKey state) (sessionAuthId s) (sessionData s))+ maybeInput+ return (inputData, 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 sto -> Session sess -> Maybe (Session sess)+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 sto -> Session sess -> 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 sto -> Session sess -> 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.+data SaveSessionToken sto =+ SaveSessionToken (Maybe (Session (SessionData sto))) UTCTime+ deriving (Typeable)++deriving instance Eq (Decomposed (SessionData sto)) => Eq (SaveSessionToken sto)+deriving instance Ord (Decomposed (SessionData sto)) => Ord (SaveSessionToken sto)+deriving instance Show (Decomposed (SessionData sto)) => Show (SaveSessionToken sto)+++-- | Save the session on the storage backend. A+-- 'SaveSessionToken' given by 'loadSession' is expected besides+-- the new contents of the 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 sto+ => State sto+ -> SaveSessionToken sto+ -> SessionData sto+ -> IO (Maybe (Session (SessionData sto)))+saveSession state (SaveSessionToken maybeInput now) outputData =+ runTransactionM (storage state) $ do+ let outputDecomp = decomposeSession (authKey state) outputData+ newMaybeInput <- invalidateIfNeeded state maybeInput outputDecomp+ saveSessionOnDb state now newMaybeInput outputDecomp+++-- | Invalidates an old session ID if needed. Returns the+-- 'Session' that should be replaced when saving the session, if any.+--+-- Currently we invalidate whenever the auth ID has changed+-- (login, logout, different user) in order to prevent session+-- fixation attacks. We also invalidate when asked to via+-- 'forceInvalidate'.+invalidateIfNeeded+ :: Storage sto+ => State sto+ -> Maybe (Session (SessionData sto))+ -> DecomposedSession (SessionData sto)+ -> TransactionM sto (Maybe (Session (SessionData sto)))+invalidateIfNeeded state maybeInput DecomposedSession {..} = do+ -- Decide which action to take.+ -- "invalidateOthers implies invalidateCurrent" should be true below.+ let inputAuthId = sessionAuthId =<< maybeInput+ invalidateCurrent = dsForceInvalidate /= DoNotForceInvalidate || inputAuthId /= dsAuthId+ invalidateOthers = dsForceInvalidate == AllSessionIdsOfLoggedUser && isJust dsAuthId+ whenMaybe b m f = when b $ maybe (return ()) f m+ -- Delete current and others, as requested.+ whenMaybe invalidateCurrent maybeInput $ deleteSession (storage state) . sessionKey+ whenMaybe invalidateOthers dsAuthId $ deleteAllSessionsOfAuthId (storage state)+ -- Remember the input only if not invalidated.+ return $ guard (not invalidateCurrent) >> maybeInput+++-- | Save a session on the database. If an old session is+-- supplied, it is replaced, otherwise a new session is+-- generated. If the session is empty, it is not saved and+-- @Nothing@ is returned. If the timeout resolution optimization+-- is applied (cf. 'setTimeoutResolution'), the old session is+-- returned and no update is made.+saveSessionOnDb+ :: forall sto. Storage sto+ => State sto+ -> UTCTime -- ^ Now.+ -> Maybe (Session (SessionData sto)) -- ^ The old session, if any.+ -> DecomposedSession (SessionData sto) -- ^ The session data to be saved.+ -> TransactionM sto (Maybe (Session (SessionData sto))) -- ^ 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.+ | isDecomposedEmpty proxy m = return Nothing+ where+ proxy :: Maybe (SessionData sto)+ proxy = Nothing+saveSessionOnDb State { timeoutResolution = Just res } now (Just old) (DecomposedSession authId _ newSession)+ -- If the data is the same and the old access time is within+ -- the timeout resolution, just return the old session without+ -- doing anything else.+ | sessionAuthId old == authId &&+ isSameDecomposed proxy (sessionData old) newSession &&+ abs (diffUTCTime now (sessionAccessedAt old)) < res =+ return (Just old)+ where+ proxy :: Maybe (SessionData sto)+ proxy = Nothing+saveSessionOnDb state now maybeInput DecomposedSession {..} = do+ -- Generate properties if needed or take them from previous+ -- saved session.+ (saveToDb, key, createdAt) <-+ case maybeInput of+ Nothing -> liftIO $+ (,,) <$> return (insertSession $ storage state)+ <*> generateSessionId (generator state)+ <*> return now+ Just Session {..} ->+ return ( replaceSession (storage state)+ , sessionKey+ , sessionCreatedAt)+ -- Save to the database.+ let session = Session+ { sessionKey = key+ , sessionAuthId = dsAuthId+ , sessionData = dsDecomposed+ , sessionCreatedAt = createdAt+ , sessionAccessedAt = now+ }+ saveToDb session+ return (Just session)+++-- | The session key used to signal that the session ID should be+-- invalidated.+forceInvalidateKey :: Text+forceInvalidateKey = "serversession-force-invalidate"+++-- | Which session IDs should be invalidated.+--+-- Note that this is not the same concept of invalidation as used+-- on J2EE. In this context, invalidation means creating a fresh+-- session ID for this user's session and disabling the old ID.+-- Its purpose is to avoid session fixation attacks.+data ForceInvalidate =+ CurrentSessionId+ -- ^ Invalidate the current session ID. The current session+ -- ID is automatically invalidated on login and logout+ -- (cf. 'setAuthKey').+ | AllSessionIdsOfLoggedUser+ -- ^ Invalidate all session IDs beloging to the currently+ -- logged in user. Only the current session ID will be+ -- renewed (the only one for which a cookie can be set).+ --+ -- This is useful, for example, if the user asks to change+ -- their password. It's also useful to provide a button to+ -- clear all other sessions.+ --+ -- If the user is not logged in, this option behaves exactly+ -- as 'CurrentSessionId' (i.e., it /does not/ invalidate the+ -- sessions of all logged out users).+ --+ -- Note that, for the purposes of+ -- 'AllSessionIdsOfLoggedUser', we consider \"logged user\"+ -- the one that is logged in at the *end* of the handler+ -- processing. For example, if the user was logged in but+ -- the current handler logged him out, the session IDs of the+ -- user who was logged in will not be invalidated.+ | DoNotForceInvalidate+ -- ^ Do not force invalidate. Invalidate only if+ -- automatically. This is the default.+ deriving (Eq, Ord, Show, Read, Bounded, Enum, Typeable)
+ src/Web/ServerSession/Core/StorageTests.hs view
@@ -0,0 +1,230 @@+{-# LANGUAGE Rank2Types #-}+-- | This module contains tests that should pass for every+-- storage backend. These are not intended for end-users of the+-- @serversession@ library. However, they are part of the+-- supported API, so they're not an @Internal@ module.+module Web.ServerSession.Core.StorageTests+ ( allStorageTests+ ) where++import Control.Applicative ((<$), (<$>), (<*>))+import Control.Exception (Exception)+import Control.Monad+import Web.ServerSession.Core.Internal++import qualified Crypto.Nonce as N+import qualified Data.ByteString as B+import qualified Data.HashMap.Strict as HM+import qualified Data.Text as T+import qualified Data.Time as TI+++-- | Execute all storage tests using 'SessionMap'.+--+-- This function is meant to be used with @hspec@. However, we+-- don't want to depend on @hspec@, so it takes the relevant+-- @hspec@ functions as arguments. Here's how it should be+-- called:+--+-- @+-- allStorageTests myStorageBackend it runIO parallel shouldBe shouldReturn shouldThrow+-- @+--+-- Some storage backends are difficult to test with a clean+-- slate. For this reason, this collection of tests works with+-- unclean storage backends. In order to enforce these claims,+-- we always test with an unclean storage backend by getting a+-- single reference to it instead of asking for a function that+-- creates storage backends and calling it on every test.+--+-- In addition, this test suite can be executed in parallel,+-- there are no dependencies between tests. However, some tests+-- require a large amount of memory so we try to run them+-- sequentially in order to reduce the peak memory usage of the+-- test suite.+allStorageTests+ :: forall m sto. (Monad m, Storage sto, SessionData sto ~ SessionMap)+ => sto -- ^ Storage backend.+ -> (String -> IO () -> m ()) -- ^ @hspec@'s it.+ -> (forall a. IO a -> m a) -- ^ @hspec@'s runIO.+ -> (m () -> m ()) -- ^ @hspec@'s parallel+ -> (forall a. (Show a, Eq a) => a -> a -> IO ()) -- ^ @hspec@'s shouldBe.+ -> (forall a. (Show a, Eq a) => IO a -> a -> IO ()) -- ^ @hspec@'s shouldReturn.+ -> (forall a e. Exception e => IO a -> (e -> Bool) -> IO ()) -- ^ @hspec@'s shouldThrow.+ -> m ()+allStorageTests storage it runIO parallel _shouldBe shouldReturn shouldThrow = do+ let run :: forall a. TransactionM sto a -> IO a+ run = runTransactionM storage++ gen <- runIO N.new++ parallel $ do+ -- runTransactionM+ it "runTransactionM should be sane" $ do+ run (return 42) `shouldReturn` (42 :: Int)++ -- getSession+ it "getSession should return Nothing for inexistent sessions" $ do+ replicateM_ 1000 $+ (generateSessionId gen >>= run . getSession storage)+ `shouldReturn` Nothing++ -- deleteSession+ it "deleteSession should not fail for inexistent sessions" $ do+ replicateM_ 1000 $+ generateSessionId gen >>= run . deleteSession storage++ it "deleteSession should delete the session" $ do+ replicateM_ 20 $ do+ s <- generateSession gen HasAuthId+ let sid = sessionKey s+ run (getSession storage sid) `shouldReturn` Nothing+ run (insertSession storage s)+ run (getSession storage sid) `shouldReturn` Just s+ run (deleteSession storage sid)+ run (getSession storage sid) `shouldReturn` Nothing+++ -- deleteAllSessionsOfAuthId+ it "deleteAllSessionsOfAuthId should not fail for inexistent auth IDs" $ do+ replicateM_ 1000 $+ generateAuthId gen >>= run . deleteAllSessionsOfAuthId storage++ it "deleteAllSessionsOfAuthId should delete the relevant sessions (but no more)" $ do+ replicateM_ 20 $ do+ master <- generateSession gen HasAuthId+ let Just authId = sessionAuthId master+ preslaves <-+ (++) <$> replicateM 100 (generateSession gen HasAuthId)+ <*> replicateM 100 (generateSession gen NoAuthId)+ let slaves = (\s -> s { sessionAuthId = Just authId }) <$> preslaves+ others <-+ (++) <$> replicateM 30 (generateSession gen HasAuthId)+ <*> replicateM 30 (generateSession gen NoAuthId)+ let allS = master : slaves ++ others++ -- Insert preslaves then replace them with slaves to+ -- further test if the storage backend is able to maintain+ -- its invariants regarding auth IDs.+ run (mapM_ (insertSession storage) (master : preslaves ++ others))+ run (mapM_ (replaceSession storage) slaves)++ run (mapM (getSession storage . sessionKey) allS) `shouldReturn` (Just <$> allS)+ run (deleteAllSessionsOfAuthId storage authId)+ run (mapM (getSession storage . sessionKey) allS) `shouldReturn`+ ((Nothing <$ (master : slaves)) ++ (Just <$> others))++ -- insertSession+ it "getSession should return the contents of insertSession" $ do+ replicateM_ 20 $ do+ s <- generateSession gen HasAuthId+ run (getSession storage (sessionKey s)) `shouldReturn` Nothing+ run (insertSession storage s)+ run (getSession storage (sessionKey s)) `shouldReturn` Just s++ it "insertSession throws an exception if a session already exists" $ do+ replicateM_ 20 $ do+ s1 <- generateSession gen HasAuthId+ s2 <- generateSession gen HasAuthId+ let sid = sessionKey s1+ s3 = s2 { sessionKey = sid }+ run (getSession storage sid) `shouldReturn` Nothing+ run (insertSession storage s1)+ run (getSession storage sid) `shouldReturn` Just s1+ run (insertSession storage s3) `shouldThrow`+ (\(SessionAlreadyExists s1' s3' :: StorageException sto) ->+ s1 == s1' && s3 == s3')+ run (getSession storage sid) `shouldReturn` Just s1++ -- replaceSession+ it "getSession should return the contents of replaceSession" $ do+ replicateM_ 20 $ do+ s1 <- generateSession gen HasAuthId+ sxs <- replicateM 20 (generateSession gen HasAuthId)+ let sid = sessionKey s1+ sxs' = map (\s -> s { sessionKey = sid }) sxs+ run (getSession storage sid) `shouldReturn` Nothing+ run (insertSession storage s1)+ forM_ (zip (s1:sxs') sxs') $ \(before, after) -> do+ run (getSession storage sid) `shouldReturn` Just before+ run (replaceSession storage after)+ run (getSession storage sid) `shouldReturn` Just after++ it "replaceSession throws an exception if a session does not exist" $ do+ replicateM_ 20 $ do+ s <- generateSession gen HasAuthId+ let sid = sessionKey s+ run (getSession storage sid) `shouldReturn` Nothing+ run (replaceSession storage s) `shouldThrow`+ (\(SessionDoesNotExist s' :: StorageException sto) -> s == s')+ run (getSession storage sid) `shouldReturn` Nothing+ run (insertSession storage s)+ run (getSession storage sid) `shouldReturn` Just s+ let s2 = s { sessionAuthId = Nothing }+ run (replaceSession storage s2)+ run (getSession storage sid) `shouldReturn` Just s2+ -- End of call to 'parallel'++ -- Size and representation limits (not tested in parallel)+ let trySessionMap vals = do+ sid <- generateSessionId gen+ now <- TI.getCurrentTime+ let session = Session+ { sessionKey = sid+ , sessionAuthId = Nothing+ , sessionData = SessionMap $ HM.fromList vals+ , sessionCreatedAt = now+ , sessionAccessedAt = now+ }+ ver2 = session { sessionData = SessionMap HM.empty }+ run (getSession storage sid) `shouldReturn` Nothing+ run (insertSession storage session)+ run (getSession storage sid) `shouldReturn` (Just session)+ run (replaceSession storage ver2)+ run (getSession storage sid) `shouldReturn` (Just ver2)+ run (replaceSession storage session)+ run (getSession storage sid) `shouldReturn` (Just session)+ run (deleteSession storage sid)+ run (getSession storage sid) `shouldReturn` Nothing+ mib = 1024*1024++ it "stress test: one million small keys" $+ trySessionMap [(T.pack (show i), "bar") | i <- [1..(1000000 :: Int)]]++ it "stress test: one 100 MiB value" $+ trySessionMap [("foo", B.replicate (100 * mib) 70)]++ it "stress test: one 1 MiB key" $+ trySessionMap [(T.replicate mib "x", "foo")]++ it "stress test: key with all possible Unicode code points and value with all possible byte values" $+ trySessionMap [(T.pack [minBound..maxBound], B.pack [minBound..maxBound])]+++-- | Generate a random auth ID for our tests.+generateAuthId :: N.Generator -> IO AuthId+generateAuthId = N.nonce128url+++-- | Generate a random session for our tests.+generateSession :: N.Generator -> HasAuthId -> IO (Session SessionMap)+generateSession gen hasAuthId = do+ sid <- generateSessionId gen+ authId <-+ case hasAuthId of+ HasAuthId -> Just <$> generateAuthId gen+ NoAuthId -> return Nothing+ data_ <- do+ keys <- replicateM 20 (N.nonce128urlT gen)+ vals <- replicateM 20 (N.nonce128url gen)+ return $ HM.fromList (zip keys vals)+ now <- TI.getCurrentTime+ return Session+ { sessionKey = sid+ , sessionAuthId = authId+ , sessionData = SessionMap data_+ , sessionCreatedAt = TI.addUTCTime (-1000) now+ , sessionAccessedAt = now+ }++data HasAuthId = HasAuthId | NoAuthId
+ tests/Main.hs view
@@ -0,0 +1,554 @@+module Main (main) where++import Control.Applicative ((<$), (<$>), (<*>))+import Control.Arrow+import Control.Monad+import Data.Maybe+import Data.Typeable (Typeable)+import Test.Hspec+import Test.Hspec.QuickCheck+import Web.PathPieces+import Web.ServerSession.Core.Internal+import Web.ServerSession.Core.StorageTests++import qualified Control.Exception as E+import qualified Crypto.Nonce as N+import qualified Data.ByteString.Char8 as B8+import qualified Data.HashMap.Strict as HM+import qualified Data.IORef as I+import qualified Data.Set as S+import qualified Data.Text as T+import qualified Data.Time as TI+import qualified Test.QuickCheck.Property as Q+++main :: IO ()+main = hspec $ parallel $ do+ -- State using () as storage. As () is not a Storage instance,+ -- this is the state to be used when testing functions that+ -- should not touch the storage in any code path.+ stnull <- runIO $ createState ()++ -- State using TNTStorage. This state should be used for+ -- functions that normally need to access the storage but on+ -- the test code path should not do so.+ sttnt <- runIO $ createState TNTStorage++ -- Some functions take a time argument meaning "now". We don't+ -- gain anything using real "now", so here's a fake "now".+ let fakenow = read "2015-05-27 17:55:41 UTC" :: TI.UTCTime++ describe "SessionId" $ do+ gen <- runIO N.new+ it "is generated with 24 bytes from letters, numbers, dashes and underscores" $ do+ let reps = 10000+ sids <- replicateM reps (generateSessionId gen)+ -- Test length to be 24 bytes.+ map (T.length . unS) sids `shouldBe` replicate reps 24+ -- Test that we see all chars, and only the expected ones.+ -- The probability of a given character not appearing on+ -- this test is (63/64)^(24*reps), so it's extremely+ -- unlikely for this test to fail on correct code.+ let observed = S.fromList $ concat $ T.unpack . unS <$> sids+ expected = S.fromList $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "-_"+ observed `shouldBe` expected++ prop "accepts as valid the session IDs generated by ourselves" $+ Q.ioProperty $ do+ sid <- generateSessionId gen+ return $ fromPathPiece (toPathPiece sid) Q.=== Just sid++ it "does not accept as valid some example invalid session IDs" $ do+ let parse = fromPathPiece :: T.Text -> Maybe (SessionId SessionMap)+ parse "" `shouldBe` Nothing+ parse "123456789-123456789-123" `shouldBe` Nothing+ parse "123456789-123456789-12345" `shouldBe` Nothing+ parse "aaaaaaaaaaaaaaaaaa*aaaaa" `shouldBe` Nothing+ -- sanity check+ parse "123456789-123456789-1234" `shouldSatisfy` isJust+ parse "aaaaaaaaaaaaaaaaaaaaaaaa" `shouldSatisfy` isJust++ describe "State" $ do+ it "has the expected default values" $ do+ -- A silly test to avoid unintended change of default values.+ cookieName stnull `shouldBe` "JSESSIONID"+ authKey stnull `shouldBe` "_ID"+ idleTimeout stnull `shouldBe` Just (60*60*24*7)+ absoluteTimeout stnull `shouldBe` Just (60*60*24*60)+ timeoutResolution stnull `shouldBe` Just (60*10)+ persistentCookies stnull `shouldBe` True+ httpOnlyCookies stnull `shouldBe` True+ secureCookies stnull `shouldBe` False++ it "has sane setters of ambiguous types" $ do+ cookieName (setCookieName "a" stnull) `shouldBe` "a"+ authKey (setAuthKey "a" stnull) `shouldBe` "a"+ idleTimeout (setIdleTimeout (Just 1) stnull) `shouldBe` Just 1+ absoluteTimeout (setAbsoluteTimeout (Just 1) stnull) `shouldBe` Just 1+ persistentCookies (setPersistentCookies False stnull) `shouldBe` False+ httpOnlyCookies (setHttpOnlyCookies False stnull) `shouldBe` False+ secureCookies (setSecureCookies True stnull) `shouldBe` True++ describe "loadSession" $ do+ let checkEmptySession (sessionMap, SaveSessionToken msession time) = do+ -- Saved time is close to now, session map is empty,+ -- there's no reference to an existing session.+ let point1 = 0.1 {- second -} :: Double+ now <- TI.getCurrentTime+ abs (realToFrac $ TI.diffUTCTime now time) `shouldSatisfy` (< point1)+ sessionMap `shouldBe` TNTSessionData+ msession `shouldSatisfy` isNothing++ it "returns empty session and token when the session ID cookie is not present" $ do+ ret <- loadSession sttnt Nothing+ checkEmptySession ret++ it "does not need the storage if session ID cookie has invalid data" $ do+ ret <- loadSession sttnt (Just "123456789-123456789-123")+ checkEmptySession ret++ it "returns empty session and token when the session ID cookie refers to inexistent session" $ do+ -- In particular, the save token should *not* refer to the+ -- session ID that was given. We're a strict session+ -- management system.+ -- <https://www.owasp.org/index.php/Session_Management_Cheat_Sheet#Session_ID_Generation_and_Verification:_Permissive_and_Strict_Session_Management>+ st <- createState =<< emptyMockStorage+ ret <- loadSession st (Just "123456789-123456789-1234")+ checkEmptySession ret++ it "returns the session from the storage when the session ID refers to an existing session" $ do+ let session = Session+ { sessionKey = S "123456789-123456789-1234"+ , sessionAuthId = Just authId+ , sessionData = mkSessionMap [("a", "b"), ("c", "d")]+ , sessionCreatedAt = TI.addUTCTime (-10) fakenow+ , sessionAccessedAt = TI.addUTCTime (-5) fakenow+ }+ authId = "auth-id"+ st <- createState =<< prepareMockStorage [session]+ (retSessionMap, SaveSessionToken msession _now) <-+ loadSession st (Just $ B8.pack $ T.unpack $ unS $ sessionKey session)+ retSessionMap `shouldBe` onSM (HM.insert (authKey st) authId) (sessionData session)+ msession `shouldBe` Just session++ describe "checkExpired" $ do+ prop "agrees with nextExpires" $+ \idleSecs absSecs ->+ let idleDiff = realToFrac $ max 1 $ abs (idleSecs :: Int)+ absDiff = realToFrac $ max 1 $ abs (absSecs :: Int)+ st' = setIdleTimeout (Just idleDiff) $+ setAbsoluteTimeout (Just absDiff) stnull+ sessTimes = do+ diff <- [0, idleDiff, absDiff]+ off <- [1, 0, -1]+ return $ TI.addUTCTime (negate $ diff + off) fakenow+ sessions = do+ createdAt <- sessTimes+ accessedAt <- sessTimes+ return $ Session+ { sessionKey = error "irrelevant 1"+ , sessionAuthId = error "irrelevant 2"+ , sessionData = error "irrelevant 3"+ , sessionCreatedAt = createdAt+ , sessionAccessedAt = accessedAt+ }+ test s =+ Q.counterexample+ (unlines+ [ "fakenow = " ++ show fakenow+ , "createdAt = " ++ show (sessionCreatedAt s)+ , "accessedAt = " ++ show (sessionAccessedAt s)+ , "checkRet ~ " ++ show (() <$ checkRet)+ , "nextRet = " ++ show nextRet ])+ (isJust checkRet == (nextRet >= Just fakenow))+ where checkRet = checkExpired fakenow st' s+ nextRet = nextExpires st' s+ in Q.conjoin (test <$> sessions)++ describe "nextExpires" $ do+ it "looks sane" $ do+ let st i a = setIdleTimeout (f i) $ setAbsoluteTimeout (f a) $ stnull+ where f = fmap (realToFrac :: Int -> TI.NominalDiffTime)+ session a c = Session+ { sessionKey = irr 1+ , sessionAuthId = irr 2+ , sessionData = irr 3+ , sessionCreatedAt = c+ , sessionAccessedAt = a+ }+ add x = TI.addUTCTime x fakenow+ irr :: Int -> a+ irr = error . ("irrelevant " ++) . show+ nextExpires (st Nothing Nothing) (session (irr 4) (irr 5)) `shouldBe` Nothing+ nextExpires (st (Just 1) Nothing) (session fakenow (irr 6)) `shouldBe` Just (add 1)+ nextExpires (st Nothing (Just 1)) (session (irr 7) fakenow) `shouldBe` Just (add 1)+ nextExpires (st (Just 3) (Just 7)) (session fakenow fakenow) `shouldBe` Just (add 3)+ nextExpires (st (Just 3) (Just 7)) (session (add 4) fakenow) `shouldBe` Just (add 7)+ nextExpires (st (Just 3) (Just 7)) (session (add 5) fakenow) `shouldBe` Just (add 7)++ describe "cookieExpires" $ do+ prop "is Nothing for non-persistent cookies regardless of session" $+ \midleSecs mabsSecs ->+ let idleDiff = realToFrac . max 1 . abs <$> (midleSecs :: Maybe Int)+ absDiff = realToFrac . max 1 . abs <$> (mabsSecs :: Maybe Int)+ st' = setIdleTimeout idleDiff $+ setAbsoluteTimeout absDiff $+ setPersistentCookies False stnull+ in cookieExpires st' (error "irrelevant") Q.=== Nothing+ it "is a long time for persistent cookies without timeouts regardless of session" $+ let st' = setIdleTimeout Nothing $+ setAbsoluteTimeout Nothing stnull+ session = Session+ { sessionKey = error "irrelevant 1"+ , sessionAuthId = error "irrelevant 2"+ , sessionData = error "irrelevant 3"+ , sessionCreatedAt = error "irrelevant 4"+ , sessionAccessedAt = fakenow+ }+ distantFuture = TI.addUTCTime (60*60*24*365*10) fakenow+ in cookieExpires st' session `shouldSatisfy` maybe False (>= distantFuture)++ describe "saveSession" $ do+ -- We already test the other functions that saveSession+ -- calls. A single unit test just to be sure everything is+ -- connected should be enough.+ it "works for a complex example" $ do+ sto <- emptyMockStorage+ st <- createState sto+ saveSession st (SaveSessionToken Nothing fakenow) emptySM `shouldReturn` Nothing+ getMockOperations sto `shouldReturn` []++ let m1 = mkSessionMap [("a", "b")]+ Just session1 <- saveSession st (SaveSessionToken Nothing fakenow) m1+ sessionAuthId session1 `shouldBe` Nothing+ sessionData session1 `shouldBe` m1+ getMockOperations sto `shouldReturn` [InsertSession session1]++ let m2 = onSM (HM.insert (authKey st) "john") m1+ Just session2 <- saveSession st (SaveSessionToken (Just session1) fakenow) m2+ sessionAuthId session2 `shouldBe` Just "john"+ sessionData session2 `shouldBe` m1+ sessionKey session2 == sessionKey session1 `shouldBe` False+ getMockOperations sto `shouldReturn` [DeleteSession (sessionKey session1), InsertSession session2]++ let m3 = onSM (HM.insert forceInvalidateKey (B8.pack $ show AllSessionIdsOfLoggedUser)) m2+ Just session3 <- saveSession st (SaveSessionToken (Just session2) fakenow) m3+ session3 `shouldBe` session2 { sessionKey = sessionKey session3 }+ getMockOperations sto `shouldReturn`+ [DeleteSession (sessionKey session2), DeleteAllSessionsOfAuthId "john", InsertSession session3]++ let m4 = onSM (HM.insert "x" "y") m2+ Just session4 <- saveSession st (SaveSessionToken (Just session3) fakenow) m4+ session4 `shouldBe` session3 { sessionData = onSM (HM.delete (authKey st)) m4 }+ getMockOperations sto `shouldReturn` [ReplaceSession session4]++ Just session5 <- saveSession st (SaveSessionToken (Just session4) (TI.addUTCTime 10 fakenow)) m4+ session5 `shouldBe` session4+ getMockOperations sto `shouldReturn` []++ describe "invalidateIfNeeded" $ do+ let prepareInvalidateIfNeeded authId = do+ let oldSession = Session+ { sessionKey = S "123456789-123456789-1234"+ , sessionAuthId = authId+ , sessionData = emptySM+ , sessionCreatedAt = TI.addUTCTime (-10) fakenow+ , sessionAccessedAt = TI.addUTCTime (-5) fakenow }+ sto <- prepareMockStorage [oldSession]+ st <- createState sto+ return (oldSession, sto :: MockStorage SessionMap, st)+ allEdges = let x = [Nothing, Just "john", Just "jane"] in (,) <$> x <*> x++ it "does not invalidate when not changing auth ID nor explicitly requesting" $ do+ forM_ [Nothing, Just "john"] $ \authId -> do+ (session, sto, st) <- prepareInvalidateIfNeeded authId+ let d = DecomposedSession authId DoNotForceInvalidate emptySM+ invalidateIfNeeded st (Just session) d `shouldReturn` Just session+ getMockOperations sto `shouldReturn` []++ it "invalidates the current session when changing auth ID" $ do+ forM_ [ (Just "john", Just "jane")+ , (Just "admin", Nothing)+ , (Nothing, Just "joe") ] $ \edgeTransition -> do+ (session, sto, st) <- prepareInvalidateIfNeeded (fst edgeTransition)+ let d = DecomposedSession (snd edgeTransition) DoNotForceInvalidate emptySM+ invalidateIfNeeded st (Just session) d `shouldReturn` Nothing+ getMockOperations sto `shouldReturn` [DeleteSession (sessionKey session)]++ it "invalidates the current session when CurrentSessionId is forced" $ do+ forM_ allEdges $ \edgeTransition -> do+ (session, sto, st) <- prepareInvalidateIfNeeded (fst edgeTransition)+ let d = DecomposedSession (snd edgeTransition) CurrentSessionId emptySM+ invalidateIfNeeded st (Just session) d `shouldReturn` Nothing+ getMockOperations sto `shouldReturn` [DeleteSession (sessionKey session)]++ it "invalidates all of the user's sessions when AllSessionIdsOfLoggedUser is forced" $ do+ forM_ allEdges $ \edgeTransition -> do+ (session, sto, st) <- prepareInvalidateIfNeeded (fst edgeTransition)+ let d = DecomposedSession (snd edgeTransition) AllSessionIdsOfLoggedUser emptySM+ invalidateIfNeeded st (Just session) d `shouldReturn` Nothing+ let expected = DeleteSession (sessionKey session) :+ maybe [] ((:[]) . DeleteAllSessionsOfAuthId) (snd edgeTransition)+ -- It deletes all sessions only when there's an authId.+ getMockOperations sto `shouldReturn` expected++ describe "saveSessionOnDb" $ do+ let prepareSaveSessionOnDb = do+ let oldSession = Session+ { sessionKey = S "123456789-123456789-1234"+ , sessionAuthId = Just "auth"+ , sessionData = mkSessionMap [("a", "b"), ("c", "d")]+ , sessionCreatedAt = TI.addUTCTime (-10) fakenow+ , sessionAccessedAt = TI.addUTCTime (-5) fakenow }+ sto <- prepareMockStorage [oldSession]+ st <- createState sto+ return (oldSession, sto :: MockStorage SessionMap, st)+ emptyDecomp = DecomposedSession Nothing DoNotForceInvalidate emptySM++ it "inserts new sessions when there wasn't an old one" $ do+ sto <- emptyMockStorage+ st <- createState (sto :: MockStorage SessionMap)+ let d = DecomposedSession a DoNotForceInvalidate m+ m = mkSessionMap [("a", "b"), ("c", "d")]+ a = Just "auth"+ Just session <- saveSessionOnDb st fakenow Nothing d+ getMockOperations sto `shouldReturn` [InsertSession session]+ sessionAuthId session `shouldBe` a+ sessionData session `shouldBe` m+ sessionCreatedAt session `shouldBe` fakenow+ sessionAccessedAt session `shouldBe` fakenow++ it "replaces sesssions when there was an old one" $ do+ (oldSession, sto, st) <- prepareSaveSessionOnDb+ let d = DecomposedSession Nothing DoNotForceInvalidate m+ m = mkSessionMap [("a", "b"), ("x", "y")]+ 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" $ 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 = emptySM+ , sessionAuthId = Nothing+ , sessionAccessedAt = fakenow }+ saveSessionOnDb st fakenow (Just oldSession) emptyDecomp `shouldReturn` Just newSession+ getMockOperations sto `shouldReturn` [ReplaceSession newSession]++ it "respects the timeout resolution" $ do+ (session1, sto, st) <- prepareSaveSessionOnDb+ let d = DecomposedSession (sessionAuthId session1) DoNotForceInvalidate (sessionData session1)+ saveSessionOnDb st fakenow (Just session1) d `shouldReturn` Just session1+ getMockOperations sto `shouldReturn` []+ let t i = TI.addUTCTime (res + i) (sessionAccessedAt session1)+ Just res = timeoutResolution st+ saveSessionOnDb st (t (-1)) (Just session1) d `shouldReturn` Just session1+ getMockOperations sto `shouldReturn` []+ -- We don't care about t 0, timeoutResolution is Maybe anyway.+ let session2 = session1 { sessionAccessedAt = t 1 }+ saveSessionOnDb st (t 1) (Just session1) d `shouldReturn` Just session2+ getMockOperations sto `shouldReturn` [ReplaceSession session2]++ describe "decomposeSession/SessionMap" $ do+ let authKey_ = authKey stnull++ prop "it is sane when not finding auth key or force invalidate key" $+ \data_ ->+ let sessionMap = mkSessionMap $ filter (notSpecial . fst) $ data_+ notSpecial = flip notElem [authKey stnull, forceInvalidateKey] . T.pack+ in decomposeSession authKey_ sessionMap `shouldBe`+ DecomposedSession Nothing DoNotForceInvalidate sessionMap++ prop "parses the force invalidate key" $+ \data_ ->+ let sessionMap v = onSM (HM.insert forceInvalidateKey (B8.pack $ show v)) $ mkSessionMap data_+ allForces = [minBound..maxBound] :: [ForceInvalidate]+ test v = dsForceInvalidate (decomposeSession authKey_ $ sessionMap v) Q.=== v+ in Q.conjoin (test <$> allForces)++ it "removes the auth key" $ do+ let m = HM.singleton "a" "b"; m' = HM.insert (authKey stnull) "x" m+ decomposeSession authKey_ (SessionMap m') `shouldBe`+ DecomposedSession (Just "x") DoNotForceInvalidate (SessionMap m)++ describe "recomposeSession/SessionMap" $ do+ let authKey_ = authKey stnull++ prop "does not change session data for sessions without auth ID" $+ \data_ ->+ let s = mkSessionMap data_+ in recomposeSession authKey_ Nothing s Q.=== s++ prop "adds (overwriting) the auth ID to the session data" $+ \authId_ data_ ->+ let s = mkSessionMap ((T.unpack authKey_, "foo") : data_)+ authId = B8.pack authId_+ in recomposeSession authKey_ (Just authId) s+ Q.=== onSM (HM.adjust (const authId) authKey_) s++ describe "MockStorage" $ do+ sto <- runIO emptyMockStorage+ allStorageTests sto it runIO parallel shouldBe shouldReturn shouldThrow+++-- | Used to generate session maps on QuickCheck properties.+mkSessionMap :: [(String, String)] -> SessionMap+mkSessionMap = SessionMap . HM.fromList . map (T.pack *** B8.pack)+++-- | Apply a function to a 'SessionMap'.+onSM+ :: (HM.HashMap T.Text B8.ByteString -> HM.HashMap T.Text B8.ByteString)+ -> (SessionMap -> SessionMap)+onSM f = SessionMap . f . unSessionMap+++-- | Empty 'SessionMap'.+emptySM :: SessionMap+emptySM = emptySession+++----------------------------------------------------------------------+++-- | A storage that explodes if it's used. Useful for checking+-- that the storage is irrelevant on a code path.+data TNTStorage = TNTStorage deriving (Typeable)++instance Storage TNTStorage where+ type TransactionM TNTStorage = IO+ type SessionData TNTStorage = TNTSessionData+ runTransactionM _ = id+ getSession = explode "getSession"+ deleteSession = explode "deleteSession"+ deleteAllSessionsOfAuthId = explode "deleteAllSessionsOfAuthId"+ insertSession = explode "insertSession"+ replaceSession = explode "replaceSession"+++-- | Implementation of all 'Storage' methods of 'TNTStorage'+-- (except for runTransactionM).+explode :: Show a => String -> TNTStorage -> a -> TransactionM TNTStorage b+explode fun _ = E.throwIO . TNTExplosion fun . show+++-- | Exception thrown by 'explode'.+data TNTExplosion = TNTExplosion String String deriving (Show, Typeable)++instance E.Exception TNTExplosion where+++-- | Session data that explodes if it's used. Doesn't explode on+-- 'emptySession'.+data TNTSessionData = TNTSessionData deriving (Eq, Show, Typeable)++instance IsSessionData TNTSessionData where+ type Decomposed TNTSessionData = ()+ emptySession = TNTSessionData+ isSameDecomposed _ = curry (explodeD "isSameDecomposed")+ decomposeSession = curry (explodeD "decomposeSession")+ recomposeSession = (curry . curry) (explodeD "recomposeSession")+ isDecomposedEmpty _ = explodeD "isDecomposedEmpty"+++-- | Implementation of all 'IsSessionData' methods of+-- 'TNTSessionData'.+explodeD :: Show a => String -> a -> b+explodeD fun = E.throw . TNTExplosion fun . show+++----------------------------------------------------------------------+++-- | A mock operation that was executed.+data MockOperation sess =+ GetSession (SessionId sess)+ | DeleteSession (SessionId sess)+ | DeleteAllSessionsOfAuthId AuthId+ | InsertSession (Session sess)+ | ReplaceSession (Session sess)+ deriving (Typeable)++deriving instance Eq (Decomposed sess) => Eq (MockOperation sess)+deriving instance Show (Decomposed sess) => Show (MockOperation sess)+++-- | A mock storage used just for testing.+data MockStorage sess =+ MockStorage+ { mockSessions :: I.IORef (HM.HashMap (SessionId sess) (Session sess))+ , mockOperations :: I.IORef [MockOperation sess]+ }+ deriving (Typeable)++instance IsSessionData sess => Storage (MockStorage sess) where+ type TransactionM (MockStorage sess) = IO+ type SessionData (MockStorage sess) = sess+ runTransactionM _ = id+ getSession sto sid = do+ -- We need to use atomicModifyIORef instead of readIORef+ -- because latter may be reordered (cf. "Memory Model" on+ -- Data.IORef's documentation).+ addMockOperation sto (GetSession sid)+ HM.lookup sid <$> I.atomicModifyIORef' (mockSessions sto) (\a -> (a, a))+ deleteSession sto sid = do+ I.atomicModifyIORef' (mockSessions sto) ((, ()) . HM.delete sid)+ addMockOperation sto (DeleteSession sid)+ deleteAllSessionsOfAuthId sto authId = do+ I.atomicModifyIORef' (mockSessions sto) ((, ()) . HM.filter (\s -> sessionAuthId s /= Just authId))+ addMockOperation sto (DeleteAllSessionsOfAuthId authId)+ insertSession sto session = do+ join $ I.atomicModifyIORef' (mockSessions sto) $ \oldMap ->+ case HM.lookup (sessionKey session) oldMap of+ Just oldVal -> (oldMap, mockThrow $ SessionAlreadyExists oldVal session)+ Nothing -> (HM.insert (sessionKey session) session oldMap, return ())+ addMockOperation sto (InsertSession session)+ replaceSession sto session = do+ join $ I.atomicModifyIORef' (mockSessions sto) $ \oldMap ->+ case HM.lookup (sessionKey session) oldMap of+ Just _ -> (HM.insert (sessionKey session) session oldMap, return ())+ Nothing -> (oldMap, mockThrow $ SessionDoesNotExist session)+ addMockOperation sto (ReplaceSession session)+++-- | Specialization of 'E.throwIO' for 'MockStorage'.+mockThrow+ :: IsSessionData sess+ => StorageException (MockStorage sess)+ -> TransactionM (MockStorage sess) a+mockThrow = E.throwIO+++-- | Creates empty mock storage.+emptyMockStorage :: IO (MockStorage sess)+emptyMockStorage =+ MockStorage+ <$> I.newIORef HM.empty+ <*> I.newIORef []+++-- | Creates mock storage with the given sessions already existing.+prepareMockStorage :: [Session sess] -> IO (MockStorage sess)+prepareMockStorage sessions = do+ sto <- emptyMockStorage+ I.writeIORef (mockSessions sto) (HM.fromList [(sessionKey s, s) | s <- sessions])+ return sto+++-- | Get the list of mock operations that were made and clear+-- them. The operations are listed in chronological order.+getMockOperations :: MockStorage sess -> IO [MockOperation sess]+getMockOperations = flip I.atomicModifyIORef' ((,) [] . reverse) . mockOperations+++-- | Add a mock operations to the log.+addMockOperation :: MockStorage sess -> MockOperation sess -> IO ()+addMockOperation sto op = I.atomicModifyIORef' (mockOperations sto) $ \ops -> (op:ops, ())