-- | 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 as A
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 { SessionId sess -> Text
unS :: Text }
  deriving (SessionId sess -> SessionId sess -> Bool
(SessionId sess -> SessionId sess -> Bool)
-> (SessionId sess -> SessionId sess -> Bool)
-> Eq (SessionId sess)
forall sess. SessionId sess -> SessionId sess -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SessionId sess -> SessionId sess -> Bool
$c/= :: forall sess. SessionId sess -> SessionId sess -> Bool
== :: SessionId sess -> SessionId sess -> Bool
$c== :: forall sess. SessionId sess -> SessionId sess -> Bool
Eq, Eq (SessionId sess)
Eq (SessionId sess)
-> (SessionId sess -> SessionId sess -> Ordering)
-> (SessionId sess -> SessionId sess -> Bool)
-> (SessionId sess -> SessionId sess -> Bool)
-> (SessionId sess -> SessionId sess -> Bool)
-> (SessionId sess -> SessionId sess -> Bool)
-> (SessionId sess -> SessionId sess -> SessionId sess)
-> (SessionId sess -> SessionId sess -> SessionId sess)
-> Ord (SessionId sess)
SessionId sess -> SessionId sess -> Bool
SessionId sess -> SessionId sess -> Ordering
SessionId sess -> SessionId sess -> SessionId sess
forall sess. Eq (SessionId sess)
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall sess. SessionId sess -> SessionId sess -> Bool
forall sess. SessionId sess -> SessionId sess -> Ordering
forall sess. SessionId sess -> SessionId sess -> SessionId sess
min :: SessionId sess -> SessionId sess -> SessionId sess
$cmin :: forall sess. SessionId sess -> SessionId sess -> SessionId sess
max :: SessionId sess -> SessionId sess -> SessionId sess
$cmax :: forall sess. SessionId sess -> SessionId sess -> SessionId sess
>= :: SessionId sess -> SessionId sess -> Bool
$c>= :: forall sess. SessionId sess -> SessionId sess -> Bool
> :: SessionId sess -> SessionId sess -> Bool
$c> :: forall sess. SessionId sess -> SessionId sess -> Bool
<= :: SessionId sess -> SessionId sess -> Bool
$c<= :: forall sess. SessionId sess -> SessionId sess -> Bool
< :: SessionId sess -> SessionId sess -> Bool
$c< :: forall sess. SessionId sess -> SessionId sess -> Bool
compare :: SessionId sess -> SessionId sess -> Ordering
$ccompare :: forall sess. SessionId sess -> SessionId sess -> Ordering
$cp1Ord :: forall sess. Eq (SessionId sess)
Ord, Int -> SessionId sess -> ShowS
[SessionId sess] -> ShowS
SessionId sess -> String
(Int -> SessionId sess -> ShowS)
-> (SessionId sess -> String)
-> ([SessionId sess] -> ShowS)
-> Show (SessionId sess)
forall sess. Int -> SessionId sess -> ShowS
forall sess. [SessionId sess] -> ShowS
forall sess. SessionId sess -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SessionId sess] -> ShowS
$cshowList :: forall sess. [SessionId sess] -> ShowS
show :: SessionId sess -> String
$cshow :: forall sess. SessionId sess -> String
showsPrec :: Int -> SessionId sess -> ShowS
$cshowsPrec :: forall sess. Int -> SessionId sess -> ShowS
Show, ReadPrec [SessionId sess]
ReadPrec (SessionId sess)
Int -> ReadS (SessionId sess)
ReadS [SessionId sess]
(Int -> ReadS (SessionId sess))
-> ReadS [SessionId sess]
-> ReadPrec (SessionId sess)
-> ReadPrec [SessionId sess]
-> Read (SessionId sess)
forall sess. ReadPrec [SessionId sess]
forall sess. ReadPrec (SessionId sess)
forall sess. Int -> ReadS (SessionId sess)
forall sess. ReadS [SessionId sess]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [SessionId sess]
$creadListPrec :: forall sess. ReadPrec [SessionId sess]
readPrec :: ReadPrec (SessionId sess)
$creadPrec :: forall sess. ReadPrec (SessionId sess)
readList :: ReadS [SessionId sess]
$creadList :: forall sess. ReadS [SessionId sess]
readsPrec :: Int -> ReadS (SessionId sess)
$creadsPrec :: forall sess. Int -> ReadS (SessionId sess)
Read, Typeable)

-- | Sanity checks input on 'fromPathPiece' (untrusted input).
instance PathPiece (SessionId sess) where
  toPathPiece :: SessionId sess -> Text
toPathPiece = SessionId sess -> Text
forall sess. SessionId sess -> Text
unS
  fromPathPiece :: Text -> Maybe (SessionId sess)
fromPathPiece = Text -> Maybe (SessionId sess)
forall sess. Text -> Maybe (SessionId sess)
checkSessionId

instance A.FromJSON (SessionId sess) where
  parseJSON :: Value -> Parser (SessionId sess)
parseJSON = (Text -> SessionId sess) -> Parser Text -> Parser (SessionId sess)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> SessionId sess
forall sess. Text -> SessionId sess
S (Parser Text -> Parser (SessionId sess))
-> (Value -> Parser Text) -> Value -> Parser (SessionId sess)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Parser Text
forall a. FromJSON a => Value -> Parser a
A.parseJSON

instance A.ToJSON (SessionId sess) where
  toJSON :: SessionId sess -> Value
toJSON = Text -> Value
forall a. ToJSON a => a -> Value
A.toJSON (Text -> Value)
-> (SessionId sess -> Text) -> SessionId sess -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SessionId sess -> Text
forall sess. SessionId sess -> Text
unS

instance Hashable (SessionId sess) where
  hashWithSalt :: Int -> SessionId sess -> Int
hashWithSalt Int
s = Int -> Text -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
s (Text -> Int) -> (SessionId sess -> Text) -> SessionId sess -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SessionId sess -> Text
forall sess. SessionId sess -> Text
unS


-- | (Internal) Check that the given text is a base64url-encoded
-- representation of 18 bytes.
checkSessionId :: Text -> Maybe (SessionId sess)
checkSessionId :: Text -> Maybe (SessionId sess)
checkSessionId Text
text = do
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Text -> Int
T.length Text
text Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
24)
  let bs :: ByteString
bs = Text -> ByteString
TE.encodeUtf8 Text
text
  ByteString
decoded <- (String -> Maybe ByteString)
-> (ByteString -> Maybe ByteString)
-> Either String ByteString
-> Maybe ByteString
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe ByteString -> String -> Maybe ByteString
forall a b. a -> b -> a
const Maybe ByteString
forall a. Maybe a
Nothing) ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (Either String ByteString -> Maybe ByteString)
-> Either String ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> Either String ByteString
B64URL.decode ByteString
bs
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (ByteString -> Int
B8.length ByteString
decoded Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
18)
  SessionId sess -> Maybe (SessionId sess)
forall (m :: * -> *) a. Monad m => a -> m a
return (SessionId sess -> Maybe (SessionId sess))
-> SessionId sess -> Maybe (SessionId sess)
forall a b. (a -> b) -> a -> b
$ Text -> SessionId sess
forall sess. Text -> SessionId sess
S Text
text


-- | Securely generate a new SessionId.
generateSessionId :: N.Generator -> IO (SessionId sess)
generateSessionId :: Generator -> IO (SessionId sess)
generateSessionId = (Text -> SessionId sess) -> IO Text -> IO (SessionId sess)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> SessionId sess
forall sess. Text -> SessionId sess
S (IO Text -> IO (SessionId sess))
-> (Generator -> IO Text) -> Generator -> IO (SessionId sess)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Generator -> IO Text
forall (m :: * -> *). MonadIO m => Generator -> m Text
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
    { Session sess -> SessionId sess
sessionKey :: SessionId sess
      -- ^ Session ID, primary key.
    , Session sess -> Maybe ByteString
sessionAuthId :: Maybe AuthId
      -- ^ Value of 'authKey' session key, separate from the rest.
    , Session sess -> Decomposed sess
sessionData :: Decomposed sess
      -- ^ Rest of the session data.
    , Session sess -> UTCTime
sessionCreatedAt :: UTCTime
      -- ^ When this session was created.
    , Session sess -> UTCTime
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 { SessionMap -> HashMap Text ByteString
unSessionMap :: HM.HashMap Text ByteString }
  deriving (SessionMap -> SessionMap -> Bool
(SessionMap -> SessionMap -> Bool)
-> (SessionMap -> SessionMap -> Bool) -> Eq SessionMap
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SessionMap -> SessionMap -> Bool
$c/= :: SessionMap -> SessionMap -> Bool
== :: SessionMap -> SessionMap -> Bool
$c== :: SessionMap -> SessionMap -> Bool
Eq, Int -> SessionMap -> ShowS
[SessionMap] -> ShowS
SessionMap -> String
(Int -> SessionMap -> ShowS)
-> (SessionMap -> String)
-> ([SessionMap] -> ShowS)
-> Show SessionMap
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SessionMap] -> ShowS
$cshowList :: [SessionMap] -> ShowS
show :: SessionMap -> String
$cshow :: SessionMap -> String
showsPrec :: Int -> SessionMap -> ShowS
$cshowsPrec :: Int -> SessionMap -> ShowS
Show, ReadPrec [SessionMap]
ReadPrec SessionMap
Int -> ReadS SessionMap
ReadS [SessionMap]
(Int -> ReadS SessionMap)
-> ReadS [SessionMap]
-> ReadPrec SessionMap
-> ReadPrec [SessionMap]
-> Read SessionMap
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [SessionMap]
$creadListPrec :: ReadPrec [SessionMap]
readPrec :: ReadPrec SessionMap
$creadPrec :: ReadPrec SessionMap
readList :: ReadS [SessionMap]
$creadList :: ReadS [SessionMap]
readsPrec :: Int -> ReadS SessionMap
$creadsPrec :: Int -> ReadS SessionMap
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
emptySession = HashMap Text ByteString -> SessionMap
SessionMap HashMap Text ByteString
forall k v. HashMap k v
HM.empty

  isSameDecomposed :: proxy SessionMap
-> Decomposed SessionMap -> Decomposed SessionMap -> Bool
isSameDecomposed proxy SessionMap
_ = Decomposed SessionMap -> Decomposed SessionMap -> Bool
forall a. Eq a => a -> a -> Bool
(==)

  decomposeSession :: Text -> SessionMap -> DecomposedSession SessionMap
decomposeSession Text
authKey_ (SessionMap HashMap Text ByteString
sm1) =
    let authId :: Maybe ByteString
authId = Text -> HashMap Text ByteString -> Maybe ByteString
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Text
authKey_ HashMap Text ByteString
sm1
        force :: ForceInvalidate
force  = ForceInvalidate
-> (ByteString -> ForceInvalidate)
-> Maybe ByteString
-> ForceInvalidate
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ForceInvalidate
DoNotForceInvalidate (String -> ForceInvalidate
forall a. Read a => String -> a
read (String -> ForceInvalidate)
-> (ByteString -> String) -> ByteString -> ForceInvalidate
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
B8.unpack) (Maybe ByteString -> ForceInvalidate)
-> Maybe ByteString -> ForceInvalidate
forall a b. (a -> b) -> a -> b
$
                 Text -> HashMap Text ByteString -> Maybe ByteString
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Text
forceInvalidateKey HashMap Text ByteString
sm1
        sm2 :: HashMap Text ByteString
sm2    = Text -> HashMap Text ByteString -> HashMap Text ByteString
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
HM.delete Text
authKey_ (HashMap Text ByteString -> HashMap Text ByteString)
-> HashMap Text ByteString -> HashMap Text ByteString
forall a b. (a -> b) -> a -> b
$
                 Text -> HashMap Text ByteString -> HashMap Text ByteString
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
HM.delete Text
forceInvalidateKey HashMap Text ByteString
sm1
    in DecomposedSession :: forall sess.
Maybe ByteString
-> ForceInvalidate -> Decomposed sess -> DecomposedSession sess
DecomposedSession
         { dsAuthId :: Maybe ByteString
dsAuthId          = Maybe ByteString
authId
         , dsForceInvalidate :: ForceInvalidate
dsForceInvalidate = ForceInvalidate
force
         , dsDecomposed :: Decomposed SessionMap
dsDecomposed      = HashMap Text ByteString -> SessionMap
SessionMap HashMap Text ByteString
sm2 }

  recomposeSession :: Text -> Maybe ByteString -> Decomposed SessionMap -> SessionMap
recomposeSession Text
authKey_ Maybe ByteString
mauthId (SessionMap sm) =
    HashMap Text ByteString -> SessionMap
SessionMap (HashMap Text ByteString -> SessionMap)
-> HashMap Text ByteString -> SessionMap
forall a b. (a -> b) -> a -> b
$ (HashMap Text ByteString -> HashMap Text ByteString)
-> (ByteString
    -> HashMap Text ByteString -> HashMap Text ByteString)
-> Maybe ByteString
-> HashMap Text ByteString
-> HashMap Text ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe HashMap Text ByteString -> HashMap Text ByteString
forall a. a -> a
id (Text
-> ByteString -> HashMap Text ByteString -> HashMap Text ByteString
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert Text
authKey_) Maybe ByteString
mauthId HashMap Text ByteString
sm

  isDecomposedEmpty :: proxy SessionMap -> Decomposed SessionMap -> Bool
isDecomposedEmpty proxy SessionMap
_ = HashMap Text ByteString -> Bool
forall k v. HashMap k v -> Bool
HM.null (HashMap Text ByteString -> Bool)
-> (SessionMap -> HashMap Text ByteString) -> SessionMap -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SessionMap -> HashMap Text ByteString
unSessionMap


-- | A session data type @sess@ with its special variables taken apart.
data DecomposedSession sess =
  DecomposedSession
    { DecomposedSession sess -> Maybe ByteString
dsAuthId          :: !(Maybe ByteString)
    , DecomposedSession sess -> ForceInvalidate
dsForceInvalidate :: !ForceInvalidate
    , DecomposedSession sess -> Decomposed sess
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
      { StorageException sto -> Session (SessionData sto)
seExistingSession :: Session (SessionData sto)
      , StorageException sto -> 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
    { State sto -> Generator
generator         :: !N.Generator
    , State sto -> sto
storage           :: !sto
    , State sto -> Text
cookieName        :: !Text
    , State sto -> Text
authKey           :: !Text
    , State sto -> Maybe NominalDiffTime
idleTimeout       :: !(Maybe NominalDiffTime)
    , State sto -> Maybe NominalDiffTime
absoluteTimeout   :: !(Maybe NominalDiffTime)
    , State sto -> Maybe NominalDiffTime
timeoutResolution :: !(Maybe NominalDiffTime)
    , State sto -> Bool
persistentCookies :: !Bool
    , State sto -> Bool
httpOnlyCookies   :: !Bool
    , State sto -> 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 -> m (State sto)
createState sto
sto = do
  Generator
gen <- m Generator
forall (m :: * -> *). MonadIO m => m Generator
N.new
  State sto -> m (State sto)
forall (m :: * -> *) a. Monad m => a -> m a
return State :: forall sto.
Generator
-> sto
-> Text
-> Text
-> Maybe NominalDiffTime
-> Maybe NominalDiffTime
-> Maybe NominalDiffTime
-> Bool
-> Bool
-> Bool
-> State sto
State
    { generator :: Generator
generator         = Generator
gen
    , storage :: sto
storage           = sto
sto
    , cookieName :: Text
cookieName        = Text
"JSESSIONID"
    , authKey :: Text
authKey           = Text
"_ID"
    , idleTimeout :: Maybe NominalDiffTime
idleTimeout       = NominalDiffTime -> Maybe NominalDiffTime
forall a. a -> Maybe a
Just (NominalDiffTime -> Maybe NominalDiffTime)
-> NominalDiffTime -> Maybe NominalDiffTime
forall a b. (a -> b) -> a -> b
$ NominalDiffTime
60NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
*NominalDiffTime
60NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
*NominalDiffTime
24NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
*NominalDiffTime
7  -- 7 days
    , absoluteTimeout :: Maybe NominalDiffTime
absoluteTimeout   = NominalDiffTime -> Maybe NominalDiffTime
forall a. a -> Maybe a
Just (NominalDiffTime -> Maybe NominalDiffTime)
-> NominalDiffTime -> Maybe NominalDiffTime
forall a b. (a -> b) -> a -> b
$ NominalDiffTime
60NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
*NominalDiffTime
60NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
*NominalDiffTime
24NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
*NominalDiffTime
60 -- 60 days
    , timeoutResolution :: Maybe NominalDiffTime
timeoutResolution = NominalDiffTime -> Maybe NominalDiffTime
forall a. a -> Maybe a
Just (NominalDiffTime -> Maybe NominalDiffTime)
-> NominalDiffTime -> Maybe NominalDiffTime
forall a b. (a -> b) -> a -> b
$ NominalDiffTime
60NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
*NominalDiffTime
10       -- 10 minutes
    , persistentCookies :: Bool
persistentCookies = Bool
True
    , httpOnlyCookies :: Bool
httpOnlyCookies   = Bool
True
    , secureCookies :: Bool
secureCookies     = Bool
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 :: Text -> State sto -> State sto
setCookieName Text
val State sto
state = State sto
state { cookieName :: Text
cookieName = Text
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 :: Text -> State sto -> State sto
setAuthKey Text
val State sto
state = State sto
state { authKey :: Text
authKey = Text
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 :: Maybe NominalDiffTime -> State sto -> State sto
setIdleTimeout (Just NominalDiffTime
d) State sto
_ | NominalDiffTime
d NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
<= NominalDiffTime
0 = String -> State sto
forall a. HasCallStack => String -> a
error String
"serversession/setIdleTimeout: Timeout should be positive."
setIdleTimeout Maybe NominalDiffTime
val State sto
state = State sto
state { idleTimeout :: Maybe NominalDiffTime
idleTimeout = Maybe NominalDiffTime
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 :: Maybe NominalDiffTime -> State sto -> State sto
setAbsoluteTimeout (Just NominalDiffTime
d) State sto
_ | NominalDiffTime
d NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
<= NominalDiffTime
0 = String -> State sto
forall a. HasCallStack => String -> a
error String
"serversession/setAbsoluteTimeout: Timeout should be positive."
setAbsoluteTimeout Maybe NominalDiffTime
val State sto
state = State sto
state { absoluteTimeout :: Maybe NominalDiffTime
absoluteTimeout = Maybe NominalDiffTime
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 :: Maybe NominalDiffTime -> State sto -> State sto
setTimeoutResolution (Just NominalDiffTime
d) State sto
_ | NominalDiffTime
d NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
<= NominalDiffTime
0 = String -> State sto
forall a. HasCallStack => String -> a
error String
"serversession/setTimeoutResolution: Resolution should be positive."
setTimeoutResolution Maybe NominalDiffTime
val State sto
state = State sto
state { timeoutResolution :: Maybe NominalDiffTime
timeoutResolution = Maybe NominalDiffTime
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 :: Bool -> State sto -> State sto
setPersistentCookies Bool
val State sto
state = State sto
state { persistentCookies :: Bool
persistentCookies = Bool
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 :: Bool -> State sto -> State sto
setHttpOnlyCookies Bool
val State sto
state = State sto
state { httpOnlyCookies :: Bool
httpOnlyCookies = Bool
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 :: Bool -> State sto -> State sto
setSecureCookies Bool
val State sto
state = State sto
state { secureCookies :: Bool
secureCookies = Bool
val }


-- | Cf. 'setCookieName'.
getCookieName :: State sto -> Text
getCookieName :: State sto -> Text
getCookieName = State sto -> Text
forall sto. State sto -> Text
cookieName


-- | Cf. 'setHttpOnlyCookies'.
getHttpOnlyCookies :: State sto -> Bool
getHttpOnlyCookies :: State sto -> Bool
getHttpOnlyCookies = State sto -> Bool
forall sto. State sto -> Bool
httpOnlyCookies


-- | Cf. 'setSecureCookies'.
getSecureCookies :: State sto -> Bool
getSecureCookies :: State sto -> Bool
getSecureCookies = State sto -> Bool
forall sto. State sto -> Bool
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 sto
-> Maybe ByteString -> IO (SessionData sto, SaveSessionToken sto)
loadSession State sto
state Maybe ByteString
mcookieVal = do
  UTCTime
now <- IO UTCTime
getCurrentTime
  let maybeInputId :: Maybe (SessionId (SessionData sto))
maybeInputId = Maybe ByteString
mcookieVal Maybe ByteString
-> (ByteString -> Maybe (SessionId (SessionData sto)))
-> Maybe (SessionId (SessionData sto))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe (SessionId (SessionData sto))
forall s. PathPiece s => Text -> Maybe s
fromPathPiece (Text -> Maybe (SessionId (SessionData sto)))
-> (ByteString -> Text)
-> ByteString
-> Maybe (SessionId (SessionData sto))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
TE.decodeUtf8
      get :: SessionId (SessionData sto)
-> IO (Maybe (Session (SessionData sto)))
get          = sto
-> TransactionM sto (Maybe (Session (SessionData sto)))
-> IO (Maybe (Session (SessionData sto)))
forall sto a. Storage sto => sto -> TransactionM sto a -> IO a
runTransactionM (State sto -> sto
forall sto. State sto -> sto
storage State sto
state) (TransactionM sto (Maybe (Session (SessionData sto)))
 -> IO (Maybe (Session (SessionData sto))))
-> (SessionId (SessionData sto)
    -> TransactionM sto (Maybe (Session (SessionData sto))))
-> SessionId (SessionData sto)
-> IO (Maybe (Session (SessionData sto)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. sto
-> SessionId (SessionData sto)
-> TransactionM sto (Maybe (Session (SessionData sto)))
forall sto.
Storage sto =>
sto
-> SessionId (SessionData sto)
-> TransactionM sto (Maybe (Session (SessionData sto)))
getSession (State sto -> sto
forall sto. State sto -> sto
storage State sto
state)
      checkedGet :: SessionId (SessionData sto)
-> IO (Maybe (Session (SessionData sto)))
checkedGet   = (Maybe (Session (SessionData sto))
 -> Maybe (Session (SessionData sto)))
-> IO (Maybe (Session (SessionData sto)))
-> IO (Maybe (Session (SessionData sto)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe (Session (SessionData sto))
-> (Session (SessionData sto) -> Maybe (Session (SessionData sto)))
-> Maybe (Session (SessionData sto))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= UTCTime
-> State sto
-> Session (SessionData sto)
-> Maybe (Session (SessionData sto))
forall sto sess.
UTCTime -> State sto -> Session sess -> Maybe (Session sess)
checkExpired UTCTime
now State sto
state) (IO (Maybe (Session (SessionData sto)))
 -> IO (Maybe (Session (SessionData sto))))
-> (SessionId (SessionData sto)
    -> IO (Maybe (Session (SessionData sto))))
-> SessionId (SessionData sto)
-> IO (Maybe (Session (SessionData sto)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SessionId (SessionData sto)
-> IO (Maybe (Session (SessionData sto)))
get
  Maybe (Session (SessionData sto))
maybeInput <- IO (Maybe (Session (SessionData sto)))
-> (SessionId (SessionData sto)
    -> IO (Maybe (Session (SessionData sto))))
-> Maybe (SessionId (SessionData sto))
-> IO (Maybe (Session (SessionData sto)))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe (Session (SessionData sto))
-> IO (Maybe (Session (SessionData sto)))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Session (SessionData sto))
forall a. Maybe a
Nothing) SessionId (SessionData sto)
-> IO (Maybe (Session (SessionData sto)))
checkedGet Maybe (SessionId (SessionData sto))
maybeInputId
  let inputData :: SessionData sto
inputData =
        SessionData sto
-> (Session (SessionData sto) -> SessionData sto)
-> Maybe (Session (SessionData sto))
-> SessionData sto
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
          SessionData sto
forall sess. IsSessionData sess => sess
emptySession
          (\Session (SessionData sto)
s -> Text
-> Maybe ByteString
-> Decomposed (SessionData sto)
-> SessionData sto
forall sess.
IsSessionData sess =>
Text -> Maybe ByteString -> Decomposed sess -> sess
recomposeSession (State sto -> Text
forall sto. State sto -> Text
authKey State sto
state) (Session (SessionData sto) -> Maybe ByteString
forall sess. Session sess -> Maybe ByteString
sessionAuthId Session (SessionData sto)
s) (Session (SessionData sto) -> Decomposed (SessionData sto)
forall sess. Session sess -> Decomposed sess
sessionData Session (SessionData sto)
s))
          Maybe (Session (SessionData sto))
maybeInput
  (SessionData sto, SaveSessionToken sto)
-> IO (SessionData sto, SaveSessionToken sto)
forall (m :: * -> *) a. Monad m => a -> m a
return (SessionData sto
inputData, Maybe (Session (SessionData sto))
-> UTCTime -> SaveSessionToken sto
forall sto.
Maybe (Session (SessionData sto))
-> UTCTime -> SaveSessionToken sto
SaveSessionToken Maybe (Session (SessionData sto))
maybeInput UTCTime
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 :: UTCTime -> State sto -> Session sess -> Maybe (Session sess)
checkExpired UTCTime
now State sto
state Session sess
session =
  let expired :: Bool
expired = Bool -> (UTCTime -> Bool) -> Maybe UTCTime -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
< UTCTime
now) (State sto -> Session sess -> Maybe UTCTime
forall sto sess. State sto -> Session sess -> Maybe UTCTime
nextExpires State sto
state Session sess
session)
  in Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not Bool
expired) Maybe () -> Maybe (Session sess) -> Maybe (Session sess)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Session sess -> Maybe (Session sess)
forall (m :: * -> *) a. Monad m => a -> m a
return Session sess
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 sto -> Session sess -> Maybe UTCTime
nextExpires State {sto
Bool
Maybe NominalDiffTime
Text
Generator
secureCookies :: Bool
httpOnlyCookies :: Bool
persistentCookies :: Bool
timeoutResolution :: Maybe NominalDiffTime
absoluteTimeout :: Maybe NominalDiffTime
idleTimeout :: Maybe NominalDiffTime
authKey :: Text
cookieName :: Text
storage :: sto
generator :: Generator
secureCookies :: forall sto. State sto -> Bool
httpOnlyCookies :: forall sto. State sto -> Bool
persistentCookies :: forall sto. State sto -> Bool
timeoutResolution :: forall sto. State sto -> Maybe NominalDiffTime
absoluteTimeout :: forall sto. State sto -> Maybe NominalDiffTime
idleTimeout :: forall sto. State sto -> Maybe NominalDiffTime
authKey :: forall sto. State sto -> Text
cookieName :: forall sto. State sto -> Text
storage :: forall sto. State sto -> sto
generator :: forall sto. State sto -> Generator
..} Session {Maybe ByteString
UTCTime
Decomposed sess
SessionId sess
sessionAccessedAt :: UTCTime
sessionCreatedAt :: UTCTime
sessionData :: Decomposed sess
sessionAuthId :: Maybe ByteString
sessionKey :: SessionId sess
sessionAccessedAt :: forall sess. Session sess -> UTCTime
sessionCreatedAt :: forall sess. Session sess -> UTCTime
sessionData :: forall sess. Session sess -> Decomposed sess
sessionAuthId :: forall sess. Session sess -> Maybe ByteString
sessionKey :: forall sess. Session sess -> SessionId sess
..} =
  let viaIdle :: Maybe UTCTime
viaIdle     = (NominalDiffTime -> UTCTime -> UTCTime)
-> UTCTime -> NominalDiffTime -> UTCTime
forall a b c. (a -> b -> c) -> b -> a -> c
flip NominalDiffTime -> UTCTime -> UTCTime
addUTCTime UTCTime
sessionAccessedAt (NominalDiffTime -> UTCTime)
-> Maybe NominalDiffTime -> Maybe UTCTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe NominalDiffTime
idleTimeout
      viaAbsolute :: Maybe UTCTime
viaAbsolute = (NominalDiffTime -> UTCTime -> UTCTime)
-> UTCTime -> NominalDiffTime -> UTCTime
forall a b c. (a -> b -> c) -> b -> a -> c
flip NominalDiffTime -> UTCTime -> UTCTime
addUTCTime UTCTime
sessionCreatedAt  (NominalDiffTime -> UTCTime)
-> Maybe NominalDiffTime -> Maybe UTCTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe NominalDiffTime
absoluteTimeout
      minimum' :: [a] -> Maybe a
minimum' [] = Maybe a
forall a. Maybe a
Nothing
      minimum' [a]
xs = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> a -> Maybe a
forall a b. (a -> b) -> a -> b
$ [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [a]
xs
  in [UTCTime] -> Maybe UTCTime
forall a. Ord a => [a] -> Maybe a
minimum' ([UTCTime] -> Maybe UTCTime) -> [UTCTime] -> Maybe UTCTime
forall a b. (a -> b) -> a -> b
$ [Maybe UTCTime] -> [UTCTime]
forall a. [Maybe a] -> [a]
catMaybes [Maybe UTCTime
viaIdle, Maybe UTCTime
viaAbsolute]


-- | Calculate the date that should be used for the cookie's
-- \"Expires\" field.
cookieExpires :: State sto -> Session sess -> Maybe UTCTime
cookieExpires :: State sto -> Session sess -> Maybe UTCTime
cookieExpires State {sto
Bool
Maybe NominalDiffTime
Text
Generator
secureCookies :: Bool
httpOnlyCookies :: Bool
persistentCookies :: Bool
timeoutResolution :: Maybe NominalDiffTime
absoluteTimeout :: Maybe NominalDiffTime
idleTimeout :: Maybe NominalDiffTime
authKey :: Text
cookieName :: Text
storage :: sto
generator :: Generator
secureCookies :: forall sto. State sto -> Bool
httpOnlyCookies :: forall sto. State sto -> Bool
persistentCookies :: forall sto. State sto -> Bool
timeoutResolution :: forall sto. State sto -> Maybe NominalDiffTime
absoluteTimeout :: forall sto. State sto -> Maybe NominalDiffTime
idleTimeout :: forall sto. State sto -> Maybe NominalDiffTime
authKey :: forall sto. State sto -> Text
cookieName :: forall sto. State sto -> Text
storage :: forall sto. State sto -> sto
generator :: forall sto. State sto -> Generator
..} Session sess
_ | Bool -> Bool
not Bool
persistentCookies = Maybe UTCTime
forall a. Maybe a
Nothing
cookieExpires State sto
state Session sess
session =
  UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just (UTCTime -> Maybe UTCTime) -> UTCTime -> Maybe UTCTime
forall a b. (a -> b) -> a -> b
$ UTCTime -> Maybe UTCTime -> UTCTime
forall a. a -> Maybe a -> a
fromMaybe UTCTime
tenYearsFromNow (Maybe UTCTime -> UTCTime) -> Maybe UTCTime -> UTCTime
forall a b. (a -> b) -> a -> b
$ State sto -> Session sess -> Maybe UTCTime
forall sto sess. State sto -> Session sess -> Maybe UTCTime
nextExpires State sto
state Session sess
session
  where tenYearsFromNow :: UTCTime
tenYearsFromNow = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (NominalDiffTime
60NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
*NominalDiffTime
60NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
*NominalDiffTime
24NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
*NominalDiffTime
3652) UTCTime
now
        now :: UTCTime
now = Session sess -> UTCTime
forall sess. Session sess -> UTCTime
sessionAccessedAt Session sess
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 sto
-> SaveSessionToken sto
-> SessionData sto
-> IO (Maybe (Session (SessionData sto)))
saveSession State sto
state (SaveSessionToken Maybe (Session (SessionData sto))
maybeInput UTCTime
now) SessionData sto
outputData =
  sto
-> TransactionM sto (Maybe (Session (SessionData sto)))
-> IO (Maybe (Session (SessionData sto)))
forall sto a. Storage sto => sto -> TransactionM sto a -> IO a
runTransactionM (State sto -> sto
forall sto. State sto -> sto
storage State sto
state) (TransactionM sto (Maybe (Session (SessionData sto)))
 -> IO (Maybe (Session (SessionData sto))))
-> TransactionM sto (Maybe (Session (SessionData sto)))
-> IO (Maybe (Session (SessionData sto)))
forall a b. (a -> b) -> a -> b
$ do
    let outputDecomp :: DecomposedSession (SessionData sto)
outputDecomp = Text -> SessionData sto -> DecomposedSession (SessionData sto)
forall sess.
IsSessionData sess =>
Text -> sess -> DecomposedSession sess
decomposeSession (State sto -> Text
forall sto. State sto -> Text
authKey State sto
state) SessionData sto
outputData
    Maybe (Session (SessionData sto))
newMaybeInput <- State sto
-> Maybe (Session (SessionData sto))
-> DecomposedSession (SessionData sto)
-> TransactionM sto (Maybe (Session (SessionData sto)))
forall sto.
Storage sto =>
State sto
-> Maybe (Session (SessionData sto))
-> DecomposedSession (SessionData sto)
-> TransactionM sto (Maybe (Session (SessionData sto)))
invalidateIfNeeded State sto
state Maybe (Session (SessionData sto))
maybeInput DecomposedSession (SessionData sto)
outputDecomp
    State sto
-> UTCTime
-> Maybe (Session (SessionData sto))
-> DecomposedSession (SessionData sto)
-> TransactionM sto (Maybe (Session (SessionData sto)))
forall sto.
Storage sto =>
State sto
-> UTCTime
-> Maybe (Session (SessionData sto))
-> DecomposedSession (SessionData sto)
-> TransactionM sto (Maybe (Session (SessionData sto)))
saveSessionOnDb State sto
state UTCTime
now Maybe (Session (SessionData sto))
newMaybeInput DecomposedSession (SessionData sto)
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 sto
-> Maybe (Session (SessionData sto))
-> DecomposedSession (SessionData sto)
-> TransactionM sto (Maybe (Session (SessionData sto)))
invalidateIfNeeded State sto
state Maybe (Session (SessionData sto))
maybeInput DecomposedSession {Maybe ByteString
ForceInvalidate
Decomposed (SessionData sto)
dsDecomposed :: Decomposed (SessionData sto)
dsForceInvalidate :: ForceInvalidate
dsAuthId :: Maybe ByteString
dsDecomposed :: forall sess. DecomposedSession sess -> Decomposed sess
dsForceInvalidate :: forall sess. DecomposedSession sess -> ForceInvalidate
dsAuthId :: forall sess. DecomposedSession sess -> Maybe ByteString
..} = do
  -- Decide which action to take.
  -- "invalidateOthers implies invalidateCurrent" should be true below.
  let inputAuthId :: Maybe ByteString
inputAuthId       = Session (SessionData sto) -> Maybe ByteString
forall sess. Session sess -> Maybe ByteString
sessionAuthId (Session (SessionData sto) -> Maybe ByteString)
-> Maybe (Session (SessionData sto)) -> Maybe ByteString
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe (Session (SessionData sto))
maybeInput
      invalidateCurrent :: Bool
invalidateCurrent = ForceInvalidate
dsForceInvalidate ForceInvalidate -> ForceInvalidate -> Bool
forall a. Eq a => a -> a -> Bool
/= ForceInvalidate
DoNotForceInvalidate Bool -> Bool -> Bool
|| Maybe ByteString
inputAuthId Maybe ByteString -> Maybe ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe ByteString
dsAuthId
      invalidateOthers :: Bool
invalidateOthers  = ForceInvalidate
dsForceInvalidate ForceInvalidate -> ForceInvalidate -> Bool
forall a. Eq a => a -> a -> Bool
== ForceInvalidate
AllSessionIdsOfLoggedUser Bool -> Bool -> Bool
&& Maybe ByteString -> Bool
forall a. Maybe a -> Bool
isJust Maybe ByteString
dsAuthId
      whenMaybe :: Bool -> Maybe a -> (a -> f ()) -> f ()
whenMaybe Bool
b Maybe a
m a -> f ()
f   = Bool -> f () -> f ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
b (f () -> f ()) -> f () -> f ()
forall a b. (a -> b) -> a -> b
$ f () -> (a -> f ()) -> Maybe a -> f ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> f ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) a -> f ()
f Maybe a
m
  -- Delete current and others, as requested.
  Bool
-> Maybe (Session (SessionData sto))
-> (Session (SessionData sto) -> TransactionM sto ())
-> TransactionM sto ()
forall (f :: * -> *) a.
Monad f =>
Bool -> Maybe a -> (a -> f ()) -> f ()
whenMaybe Bool
invalidateCurrent Maybe (Session (SessionData sto))
maybeInput ((Session (SessionData sto) -> TransactionM sto ())
 -> TransactionM sto ())
-> (Session (SessionData sto) -> TransactionM sto ())
-> TransactionM sto ()
forall a b. (a -> b) -> a -> b
$ sto -> SessionId (SessionData sto) -> TransactionM sto ()
forall sto.
Storage sto =>
sto -> SessionId (SessionData sto) -> TransactionM sto ()
deleteSession (State sto -> sto
forall sto. State sto -> sto
storage State sto
state) (SessionId (SessionData sto) -> TransactionM sto ())
-> (Session (SessionData sto) -> SessionId (SessionData sto))
-> Session (SessionData sto)
-> TransactionM sto ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Session (SessionData sto) -> SessionId (SessionData sto)
forall sess. Session sess -> SessionId sess
sessionKey
  Bool
-> Maybe ByteString
-> (ByteString -> TransactionM sto ())
-> TransactionM sto ()
forall (f :: * -> *) a.
Monad f =>
Bool -> Maybe a -> (a -> f ()) -> f ()
whenMaybe Bool
invalidateOthers  Maybe ByteString
dsAuthId   ((ByteString -> TransactionM sto ()) -> TransactionM sto ())
-> (ByteString -> TransactionM sto ()) -> TransactionM sto ()
forall a b. (a -> b) -> a -> b
$ sto -> ByteString -> TransactionM sto ()
forall sto. Storage sto => sto -> ByteString -> TransactionM sto ()
deleteAllSessionsOfAuthId (State sto -> sto
forall sto. State sto -> sto
storage State sto
state)
  -- Remember the input only if not invalidated.
  Maybe (Session (SessionData sto))
-> TransactionM sto (Maybe (Session (SessionData sto)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Session (SessionData sto))
 -> TransactionM sto (Maybe (Session (SessionData sto))))
-> Maybe (Session (SessionData sto))
-> TransactionM sto (Maybe (Session (SessionData sto)))
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not Bool
invalidateCurrent) Maybe ()
-> Maybe (Session (SessionData sto))
-> Maybe (Session (SessionData sto))
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe (Session (SessionData sto))
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 :: State sto
-> UTCTime
-> Maybe (Session (SessionData sto))
-> DecomposedSession (SessionData sto)
-> TransactionM sto (Maybe (Session (SessionData sto)))
saveSessionOnDb State sto
_ UTCTime
_ Maybe (Session (SessionData sto))
Nothing (DecomposedSession Maybe ByteString
Nothing ForceInvalidate
_ Decomposed (SessionData sto)
m)
  -- Return Nothing without doing anything whenever the session
  -- is empty (including auth ID) and there was no prior session.
  | Maybe (SessionData sto) -> Decomposed (SessionData sto) -> Bool
forall sess (proxy :: * -> *).
IsSessionData sess =>
proxy sess -> Decomposed sess -> Bool
isDecomposedEmpty Maybe (SessionData sto)
proxy Decomposed (SessionData sto)
m = Maybe (Session (SessionData sto))
-> TransactionM sto (Maybe (Session (SessionData sto)))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Session (SessionData sto))
forall a. Maybe a
Nothing
    where
      proxy :: Maybe (SessionData sto)
      proxy :: Maybe (SessionData sto)
proxy = Maybe (SessionData sto)
forall a. Maybe a
Nothing
saveSessionOnDb State { timeoutResolution :: forall sto. State sto -> Maybe NominalDiffTime
timeoutResolution = Just NominalDiffTime
res } UTCTime
now (Just Session (SessionData sto)
old) (DecomposedSession Maybe ByteString
authId ForceInvalidate
_ Decomposed (SessionData sto)
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.
  | Session (SessionData sto) -> Maybe ByteString
forall sess. Session sess -> Maybe ByteString
sessionAuthId Session (SessionData sto)
old Maybe ByteString -> Maybe ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe ByteString
authId Bool -> Bool -> Bool
&&
    Maybe (SessionData sto)
-> Decomposed (SessionData sto)
-> Decomposed (SessionData sto)
-> Bool
forall sess (proxy :: * -> *).
IsSessionData sess =>
proxy sess -> Decomposed sess -> Decomposed sess -> Bool
isSameDecomposed Maybe (SessionData sto)
proxy (Session (SessionData sto) -> Decomposed (SessionData sto)
forall sess. Session sess -> Decomposed sess
sessionData Session (SessionData sto)
old) Decomposed (SessionData sto)
newSession Bool -> Bool -> Bool
&&
    NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a
abs (UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
now (Session (SessionData sto) -> UTCTime
forall sess. Session sess -> UTCTime
sessionAccessedAt Session (SessionData sto)
old)) NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
< NominalDiffTime
res =
      Maybe (Session (SessionData sto))
-> TransactionM sto (Maybe (Session (SessionData sto)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Session (SessionData sto) -> Maybe (Session (SessionData sto))
forall a. a -> Maybe a
Just Session (SessionData sto)
old)
    where
      proxy :: Maybe (SessionData sto)
      proxy :: Maybe (SessionData sto)
proxy = Maybe (SessionData sto)
forall a. Maybe a
Nothing
saveSessionOnDb State sto
state UTCTime
now Maybe (Session (SessionData sto))
maybeInput DecomposedSession {Maybe ByteString
ForceInvalidate
Decomposed (SessionData sto)
dsDecomposed :: Decomposed (SessionData sto)
dsForceInvalidate :: ForceInvalidate
dsAuthId :: Maybe ByteString
dsDecomposed :: forall sess. DecomposedSession sess -> Decomposed sess
dsForceInvalidate :: forall sess. DecomposedSession sess -> ForceInvalidate
dsAuthId :: forall sess. DecomposedSession sess -> Maybe ByteString
..} = do
  -- Generate properties if needed or take them from previous
  -- saved session.
  (Session (SessionData sto) -> TransactionM sto ()
saveToDb, SessionId (SessionData sto)
key, UTCTime
createdAt) <-
    case Maybe (Session (SessionData sto))
maybeInput of
      Maybe (Session (SessionData sto))
Nothing -> IO
  (Session (SessionData sto) -> TransactionM sto (),
   SessionId (SessionData sto), UTCTime)
-> TransactionM
     sto
     (Session (SessionData sto) -> TransactionM sto (),
      SessionId (SessionData sto), UTCTime)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO
   (Session (SessionData sto) -> TransactionM sto (),
    SessionId (SessionData sto), UTCTime)
 -> TransactionM
      sto
      (Session (SessionData sto) -> TransactionM sto (),
       SessionId (SessionData sto), UTCTime))
-> IO
     (Session (SessionData sto) -> TransactionM sto (),
      SessionId (SessionData sto), UTCTime)
-> TransactionM
     sto
     (Session (SessionData sto) -> TransactionM sto (),
      SessionId (SessionData sto), UTCTime)
forall a b. (a -> b) -> a -> b
$
        (,,) ((Session (SessionData sto) -> TransactionM sto ())
 -> SessionId (SessionData sto)
 -> UTCTime
 -> (Session (SessionData sto) -> TransactionM sto (),
     SessionId (SessionData sto), UTCTime))
-> IO (Session (SessionData sto) -> TransactionM sto ())
-> IO
     (SessionId (SessionData sto)
      -> UTCTime
      -> (Session (SessionData sto) -> TransactionM sto (),
          SessionId (SessionData sto), UTCTime))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
A.<$> (Session (SessionData sto) -> TransactionM sto ())
-> IO (Session (SessionData sto) -> TransactionM sto ())
forall (m :: * -> *) a. Monad m => a -> m a
return (sto -> Session (SessionData sto) -> TransactionM sto ()
forall sto.
Storage sto =>
sto -> Session (SessionData sto) -> TransactionM sto ()
insertSession (sto -> Session (SessionData sto) -> TransactionM sto ())
-> sto -> Session (SessionData sto) -> TransactionM sto ()
forall a b. (a -> b) -> a -> b
$ State sto -> sto
forall sto. State sto -> sto
storage State sto
state)
             IO
  (SessionId (SessionData sto)
   -> UTCTime
   -> (Session (SessionData sto) -> TransactionM sto (),
       SessionId (SessionData sto), UTCTime))
-> IO (SessionId (SessionData sto))
-> IO
     (UTCTime
      -> (Session (SessionData sto) -> TransactionM sto (),
          SessionId (SessionData sto), UTCTime))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Generator -> IO (SessionId (SessionData sto))
forall sess. Generator -> IO (SessionId sess)
generateSessionId (State sto -> Generator
forall sto. State sto -> Generator
generator State sto
state)
             IO
  (UTCTime
   -> (Session (SessionData sto) -> TransactionM sto (),
       SessionId (SessionData sto), UTCTime))
-> IO UTCTime
-> IO
     (Session (SessionData sto) -> TransactionM sto (),
      SessionId (SessionData sto), UTCTime)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> UTCTime -> IO UTCTime
forall (m :: * -> *) a. Monad m => a -> m a
return UTCTime
now
      Just Session {Maybe ByteString
UTCTime
Decomposed (SessionData sto)
SessionId (SessionData sto)
sessionAccessedAt :: UTCTime
sessionCreatedAt :: UTCTime
sessionData :: Decomposed (SessionData sto)
sessionAuthId :: Maybe ByteString
sessionKey :: SessionId (SessionData sto)
sessionAccessedAt :: forall sess. Session sess -> UTCTime
sessionCreatedAt :: forall sess. Session sess -> UTCTime
sessionData :: forall sess. Session sess -> Decomposed sess
sessionAuthId :: forall sess. Session sess -> Maybe ByteString
sessionKey :: forall sess. Session sess -> SessionId sess
..} ->
        (Session (SessionData sto) -> TransactionM sto (),
 SessionId (SessionData sto), UTCTime)
-> TransactionM
     sto
     (Session (SessionData sto) -> TransactionM sto (),
      SessionId (SessionData sto), UTCTime)
forall (m :: * -> *) a. Monad m => a -> m a
return ( sto -> Session (SessionData sto) -> TransactionM sto ()
forall sto.
Storage sto =>
sto -> Session (SessionData sto) -> TransactionM sto ()
replaceSession (State sto -> sto
forall sto. State sto -> sto
storage State sto
state)
               , SessionId (SessionData sto)
sessionKey
               , UTCTime
sessionCreatedAt)
  -- Save to the database.
  let session :: Session (SessionData sto)
session = Session :: forall sess.
SessionId sess
-> Maybe ByteString
-> Decomposed sess
-> UTCTime
-> UTCTime
-> Session sess
Session
        { sessionKey :: SessionId (SessionData sto)
sessionKey        = SessionId (SessionData sto)
key
        , sessionAuthId :: Maybe ByteString
sessionAuthId     = Maybe ByteString
dsAuthId
        , sessionData :: Decomposed (SessionData sto)
sessionData       = Decomposed (SessionData sto)
dsDecomposed
        , sessionCreatedAt :: UTCTime
sessionCreatedAt  = UTCTime
createdAt
        , sessionAccessedAt :: UTCTime
sessionAccessedAt = UTCTime
now
        }
  Session (SessionData sto) -> TransactionM sto ()
saveToDb Session (SessionData sto)
session
  Maybe (Session (SessionData sto))
-> TransactionM sto (Maybe (Session (SessionData sto)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Session (SessionData sto) -> Maybe (Session (SessionData sto))
forall a. a -> Maybe a
Just Session (SessionData sto)
session)


-- | The session key used to signal that the session ID should be
-- invalidated.
forceInvalidateKey :: Text
forceInvalidateKey :: Text
forceInvalidateKey = Text
"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 (ForceInvalidate -> ForceInvalidate -> Bool
(ForceInvalidate -> ForceInvalidate -> Bool)
-> (ForceInvalidate -> ForceInvalidate -> Bool)
-> Eq ForceInvalidate
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ForceInvalidate -> ForceInvalidate -> Bool
$c/= :: ForceInvalidate -> ForceInvalidate -> Bool
== :: ForceInvalidate -> ForceInvalidate -> Bool
$c== :: ForceInvalidate -> ForceInvalidate -> Bool
Eq, Eq ForceInvalidate
Eq ForceInvalidate
-> (ForceInvalidate -> ForceInvalidate -> Ordering)
-> (ForceInvalidate -> ForceInvalidate -> Bool)
-> (ForceInvalidate -> ForceInvalidate -> Bool)
-> (ForceInvalidate -> ForceInvalidate -> Bool)
-> (ForceInvalidate -> ForceInvalidate -> Bool)
-> (ForceInvalidate -> ForceInvalidate -> ForceInvalidate)
-> (ForceInvalidate -> ForceInvalidate -> ForceInvalidate)
-> Ord ForceInvalidate
ForceInvalidate -> ForceInvalidate -> Bool
ForceInvalidate -> ForceInvalidate -> Ordering
ForceInvalidate -> ForceInvalidate -> ForceInvalidate
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ForceInvalidate -> ForceInvalidate -> ForceInvalidate
$cmin :: ForceInvalidate -> ForceInvalidate -> ForceInvalidate
max :: ForceInvalidate -> ForceInvalidate -> ForceInvalidate
$cmax :: ForceInvalidate -> ForceInvalidate -> ForceInvalidate
>= :: ForceInvalidate -> ForceInvalidate -> Bool
$c>= :: ForceInvalidate -> ForceInvalidate -> Bool
> :: ForceInvalidate -> ForceInvalidate -> Bool
$c> :: ForceInvalidate -> ForceInvalidate -> Bool
<= :: ForceInvalidate -> ForceInvalidate -> Bool
$c<= :: ForceInvalidate -> ForceInvalidate -> Bool
< :: ForceInvalidate -> ForceInvalidate -> Bool
$c< :: ForceInvalidate -> ForceInvalidate -> Bool
compare :: ForceInvalidate -> ForceInvalidate -> Ordering
$ccompare :: ForceInvalidate -> ForceInvalidate -> Ordering
$cp1Ord :: Eq ForceInvalidate
Ord, Int -> ForceInvalidate -> ShowS
[ForceInvalidate] -> ShowS
ForceInvalidate -> String
(Int -> ForceInvalidate -> ShowS)
-> (ForceInvalidate -> String)
-> ([ForceInvalidate] -> ShowS)
-> Show ForceInvalidate
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ForceInvalidate] -> ShowS
$cshowList :: [ForceInvalidate] -> ShowS
show :: ForceInvalidate -> String
$cshow :: ForceInvalidate -> String
showsPrec :: Int -> ForceInvalidate -> ShowS
$cshowsPrec :: Int -> ForceInvalidate -> ShowS
Show, ReadPrec [ForceInvalidate]
ReadPrec ForceInvalidate
Int -> ReadS ForceInvalidate
ReadS [ForceInvalidate]
(Int -> ReadS ForceInvalidate)
-> ReadS [ForceInvalidate]
-> ReadPrec ForceInvalidate
-> ReadPrec [ForceInvalidate]
-> Read ForceInvalidate
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ForceInvalidate]
$creadListPrec :: ReadPrec [ForceInvalidate]
readPrec :: ReadPrec ForceInvalidate
$creadPrec :: ReadPrec ForceInvalidate
readList :: ReadS [ForceInvalidate]
$creadList :: ReadS [ForceInvalidate]
readsPrec :: Int -> ReadS ForceInvalidate
$creadsPrec :: Int -> ReadS ForceInvalidate
Read, ForceInvalidate
ForceInvalidate -> ForceInvalidate -> Bounded ForceInvalidate
forall a. a -> a -> Bounded a
maxBound :: ForceInvalidate
$cmaxBound :: ForceInvalidate
minBound :: ForceInvalidate
$cminBound :: ForceInvalidate
Bounded, Int -> ForceInvalidate
ForceInvalidate -> Int
ForceInvalidate -> [ForceInvalidate]
ForceInvalidate -> ForceInvalidate
ForceInvalidate -> ForceInvalidate -> [ForceInvalidate]
ForceInvalidate
-> ForceInvalidate -> ForceInvalidate -> [ForceInvalidate]
(ForceInvalidate -> ForceInvalidate)
-> (ForceInvalidate -> ForceInvalidate)
-> (Int -> ForceInvalidate)
-> (ForceInvalidate -> Int)
-> (ForceInvalidate -> [ForceInvalidate])
-> (ForceInvalidate -> ForceInvalidate -> [ForceInvalidate])
-> (ForceInvalidate -> ForceInvalidate -> [ForceInvalidate])
-> (ForceInvalidate
    -> ForceInvalidate -> ForceInvalidate -> [ForceInvalidate])
-> Enum ForceInvalidate
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: ForceInvalidate
-> ForceInvalidate -> ForceInvalidate -> [ForceInvalidate]
$cenumFromThenTo :: ForceInvalidate
-> ForceInvalidate -> ForceInvalidate -> [ForceInvalidate]
enumFromTo :: ForceInvalidate -> ForceInvalidate -> [ForceInvalidate]
$cenumFromTo :: ForceInvalidate -> ForceInvalidate -> [ForceInvalidate]
enumFromThen :: ForceInvalidate -> ForceInvalidate -> [ForceInvalidate]
$cenumFromThen :: ForceInvalidate -> ForceInvalidate -> [ForceInvalidate]
enumFrom :: ForceInvalidate -> [ForceInvalidate]
$cenumFrom :: ForceInvalidate -> [ForceInvalidate]
fromEnum :: ForceInvalidate -> Int
$cfromEnum :: ForceInvalidate -> Int
toEnum :: Int -> ForceInvalidate
$ctoEnum :: Int -> ForceInvalidate
pred :: ForceInvalidate -> ForceInvalidate
$cpred :: ForceInvalidate -> ForceInvalidate
succ :: ForceInvalidate -> ForceInvalidate
$csucc :: ForceInvalidate -> ForceInvalidate
Enum, Typeable)