{-|
Module : $Header$
Description : Abstract Manager class and Session Snaplet
Copyright : (c) Justus Adam, 2016
License : BSD3
Maintainer : dev@justus.science
Stability : experimental
Portability : POSIX
-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
module Snap.Snaplet.Session.Scoped
( HasManager, TheManager, toManager, Manages
, Manager, managerGetSession, managerSetSession, managerModifySession, managerCommit, managerLoad
, AccessSession, LocalSession, accessSession, AccessSessionLens, mkAccessSessionLens
, CanAccessSubsession
, initSessionSnaplet
, getSession, setSession, modifySession, loadSession, commitSession
) where
import ClassyPrelude
import Control.Lens
import Snap
-- | An abstract type for a session manager
--
-- Managers are responsible for storing the session state across requests and
-- optionally persistent
--
-- It should be noted that although an implementation for 'managerCommit' and
-- 'managerLoad' is not required it is useful for efficiency reasons.
--
-- The state of the manager is mutable within one request but reset for new requests.
-- Therefore managers should use mutable or persistent data structures like 'IORef' internally.
class Manager manager where
-- | Type of the session state inside the manager. In most cases this will
-- either be any type or a type constrained by some serialisation typeclass like
--
-- @
-- instance Serialize a => Manager (WritesToFileManager a) where
-- type Manages (WritesToFileManager a) = a
-- @
type Manages manager
-- | Obtain the full session state for the current client.
managerGetSession :: Handler v manager (Manages manager)
managerGetSession = managerModifySession id
-- | Replace the state of the current sessio with the provided one
managerSetSession :: Manages manager -> Handler v manager ()
managerSetSession = managerModifySession . const >=> const (return ())
-- | Indicate to the manager that cached mutations on state should be persisted.
--
-- This method is entirely optional, however it is recommended
-- for managers where mutating the persistent state is expensive to
-- cache mutations in the manager data structure and persist them once commit
-- is called.
managerCommit :: Handler v manager ()
managerCommit = return ()
-- | Again optional. Users can use this method to indicate to the manager that
-- the session should be established (cookie read for instance) and the state
-- cached into the manager data structure.
managerLoad :: Handler v manager ()
managerLoad = return ()
-- | Applies a function to the (cached) session state
managerModifySession :: (Manages manager -> Manages manager) -> Handler v manager (Manages manager)
managerModifySession f = managerGetSession >>= \sess -> managerSetSession (f sess) >> return sess
{-# MINIMAL managerGetSession, managerSetSession | managerModifySession #-}
-- | Class providing access to a Snaplet managing session state
class Manager (TheManager a) => HasManager a where
-- | Type of the manager, since this is defined in terms of the 'Manager' typeclass
type TheManager a
-- | Like 'HasHeist', a lens to get to the manager snaplet.
toManager :: SnapletLens (Snaplet a) (TheManager a)
-- | This is provided for convenience. Snaplets which use part of the state can
-- use this shorthand in the type signature.
--
-- * 'base' is the (internal) type of your root snaplet
-- * 'snaplet' is the (internal) type of the snaplet that wants to access the session
-- * 't' is the type the (local) session data
--
-- If, for instance, our Snaplet was called 'Files' and it needed a HashSet as state
-- and the global Snaplet type was unknown you could write the following:
--
-- @
-- initFiles :: (CanAccessSubsession b Files HashSet) => SnapletInit b Files
-- @
type CanAccessSubsession base snaplet t = (HasManager base, AccessSession (Manages (TheManager base)) snaplet, LocalSession snaplet ~ t)
-- | This is just type hacking to line up lenses. Use 'mkAccessSessionLens'
-- to turn a regular lens into this type.
newtype AccessSessionLens t a b = ASLens { getASLens :: t -> Lens' a b }
-- | Use this function to create an 'AccessSessionLens'. 't' is only used to line up types.
mkAccessSessionLens :: Lens' a b -> AccessSessionLens t a b
mkAccessSessionLens = ASLens . const
-- | A reference to a LocalSession session state from the global session state ('base').
-- You have to implement this class for your subsnaplet ('t') to get access to a part of the global session state.
class AccessSession base t where
type LocalSession t
accessSession :: AccessSessionLens t base (LocalSession t)
-- | Initialize a session managing Snaplet from a manager. For an example manager see
-- 'Snap.Snaplet.Session.Scoped.InMemory'
initSessionSnaplet :: Manager a => a -> SnapletInit b a
initSessionSnaplet man = makeSnaplet "session-manager" "manages typed sessions" Nothing $ return man
getFullSession :: forall s v. HasManager s => Handler s v (Manages (TheManager s))
getFullSession = withTop' (toManager :: SnapletLens (Snaplet s) (TheManager s)) managerGetSession
-- | Tells the session state manager to load the session.
loadSession :: forall s v. HasManager s => Handler s v ()
loadSession = withTop' (toManager :: SnapletLens (Snaplet s) (TheManager s)) managerLoad
-- | Tells the session manager to persist any changes.
-- Should be called at the end of a request cycle.
commitSession :: forall s v. HasManager s => Handler s v ()
commitSession = withTop' (toManager :: SnapletLens (Snaplet s) (TheManager s)) managerCommit
-- | Obtain the LocalSession session for the current snaplet.
getSession :: forall s t. (HasManager s, AccessSession (Manages (TheManager s)) t) => Handler s t (LocalSession t)
getSession = do
fs <- getFullSession
return $ fs^.getASLens accessSession (error "Do not evaluate!" :: t)
modifyFullSession :: forall s v. HasManager s => (Manages (TheManager s) -> Manages (TheManager s)) -> Handler s v (Manages (TheManager s))
modifyFullSession f = withTop' (toManager :: SnapletLens (Snaplet s) (TheManager s)) $ managerModifySession f
-- | Set the LocalSession part of the session state to a new value
setSession :: forall s t. (HasManager s, AccessSession (Manages (TheManager s)) t) => LocalSession t -> Handler s t ()
setSession inner = void $ modifyFullSession (getASLens accessSession (error "Do not evaluate!" :: t) .~ inner)
-- | Modify the LocalSession session state with a function, returns the altered LocalSession state
--
-- @
-- setSession v = modifySession (const v)
-- getSession = modifySession id
-- @
modifySession :: forall s t. (HasManager s, AccessSession (Manages (TheManager s)) t) => (LocalSession t -> LocalSession t) -> Handler s t (Manages (TheManager s))
modifySession f = modifyFullSession (getASLens accessSession (error "Do not evaluate!" :: t) %~ f)