diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,7 @@ +#!/usr/bin/env runhaskell + +> module Main where +> import Distribution.Simple + +> main :: IO () +> main = defaultMain diff --git a/serversession.cabal b/serversession.cabal new file mode 100644 --- /dev/null +++ b/serversession.cabal @@ -0,0 +1,73 @@ +name: serversession +version: 1.0 +license: MIT +license-file: LICENSE +author: Felipe Lessa +maintainer: Felipe Lessa +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 +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 diff --git a/src/Web/ServerSession/Core.hs b/src/Web/ServerSession/Core.hs new file mode 100644 --- /dev/null +++ b/src/Web/ServerSession/Core.hs @@ -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 diff --git a/src/Web/ServerSession/Core/Internal.hs b/src/Web/ServerSession/Core/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Web/ServerSession/Core/Internal.hs @@ -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.\" +-- () +-- +-- 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.\" +-- () +-- +-- 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) diff --git a/src/Web/ServerSession/Core/StorageTests.hs b/src/Web/ServerSession/Core/StorageTests.hs new file mode 100644 --- /dev/null +++ b/src/Web/ServerSession/Core/StorageTests.hs @@ -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 diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -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. + -- + 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, ())