{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}

module Web.Spock.Internal.SessionVault where

#if MIN_VERSION_base(4,8,0)
#else
import Control.Applicative
#endif
import Control.Concurrent.STM (STM, atomically)
import Control.Monad
import Data.Hashable
import qualified Data.Text as T
import Focus as F
import qualified ListT as L
import qualified StmContainers.Map as STMMap
import Web.Spock.Internal.Types

class (Eq (SessionKey s), Hashable (SessionKey s)) => IsSession s where
  type SessionKey s :: *
  getSessionKey :: s -> SessionKey s

instance IsSession (Session conn sess st) where
  type SessionKey (Session conn sess st) = T.Text
  getSessionKey :: Session conn sess st -> SessionKey (Session conn sess st)
getSessionKey = Session conn sess st -> Text
Session conn sess st -> SessionKey (Session conn sess st)
forall conn sess st. Session conn sess st -> Text
sess_id

newtype SessionVault s = SessionVault {forall s. SessionVault s -> Map (SessionKey s) s
unSessionVault :: STMMap.Map (SessionKey s) s}

-- | Create a new session vault
newSessionVault :: STM (SessionVault s)
newSessionVault :: forall s. STM (SessionVault s)
newSessionVault = Map (SessionKey s) s -> SessionVault s
forall s. Map (SessionKey s) s -> SessionVault s
SessionVault (Map (SessionKey s) s -> SessionVault s)
-> STM (Map (SessionKey s) s) -> STM (SessionVault s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM (Map (SessionKey s) s)
forall key value. STM (Map key value)
STMMap.new

-- | Load a session
loadSession :: IsSession s => SessionKey s -> SessionVault s -> STM (Maybe s)
loadSession :: forall s.
IsSession s =>
SessionKey s -> SessionVault s -> STM (Maybe s)
loadSession SessionKey s
key (SessionVault Map (SessionKey s) s
smap) = SessionKey s -> Map (SessionKey s) s -> STM (Maybe s)
forall key value.
Hashable key =>
key -> Map key value -> STM (Maybe value)
STMMap.lookup SessionKey s
key Map (SessionKey s) s
smap

-- | Store a session, overwriting any previous values
storeSession :: IsSession s => s -> SessionVault s -> STM ()
storeSession :: forall s. IsSession s => s -> SessionVault s -> STM ()
storeSession s
v (SessionVault Map (SessionKey s) s
smap) = s -> SessionKey s -> Map (SessionKey s) s -> STM ()
forall key value.
Hashable key =>
value -> key -> Map key value -> STM ()
STMMap.insert s
v (s -> SessionKey s
forall s. IsSession s => s -> SessionKey s
getSessionKey s
v) Map (SessionKey s) s
smap

-- | Removea session
deleteSession :: IsSession s => SessionKey s -> SessionVault s -> STM ()
deleteSession :: forall s. IsSession s => SessionKey s -> SessionVault s -> STM ()
deleteSession SessionKey s
k (SessionVault Map (SessionKey s) s
smap) = SessionKey s -> Map (SessionKey s) s -> STM ()
forall key value. Hashable key => key -> Map key value -> STM ()
STMMap.delete SessionKey s
k Map (SessionKey s) s
smap

-- | Get all sessions as list
toList :: SessionVault s -> STM [s]
toList :: forall s. SessionVault s -> STM [s]
toList = ([(SessionKey s, s)] -> [s]) -> STM [(SessionKey s, s)] -> STM [s]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (((SessionKey s, s) -> s) -> [(SessionKey s, s)] -> [s]
forall a b. (a -> b) -> [a] -> [b]
map (SessionKey s, s) -> s
forall a b. (a, b) -> b
snd) (STM [(SessionKey s, s)] -> STM [s])
-> (SessionVault s -> STM [(SessionKey s, s)])
-> SessionVault s
-> STM [s]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ListT STM (SessionKey s, s) -> STM [(SessionKey s, s)]
forall (m :: * -> *) a. Monad m => ListT m a -> m [a]
L.toList (ListT STM (SessionKey s, s) -> STM [(SessionKey s, s)])
-> (SessionVault s -> ListT STM (SessionKey s, s))
-> SessionVault s
-> STM [(SessionKey s, s)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map (SessionKey s) s -> ListT STM (SessionKey s, s)
forall key value. Map key value -> ListT STM (key, value)
STMMap.listT (Map (SessionKey s) s -> ListT STM (SessionKey s, s))
-> (SessionVault s -> Map (SessionKey s) s)
-> SessionVault s
-> ListT STM (SessionKey s, s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SessionVault s -> Map (SessionKey s) s
forall s. SessionVault s -> Map (SessionKey s) s
unSessionVault

-- | Remove all sessions that do not match the predicate
filterSessions :: IsSession s => (s -> Bool) -> SessionVault s -> STM ()
filterSessions :: forall s. IsSession s => (s -> Bool) -> SessionVault s -> STM ()
filterSessions s -> Bool
cond SessionVault s
sv =
  do
    allVals <- SessionVault s -> STM [s]
forall s. SessionVault s -> STM [s]
toList SessionVault s
sv
    let deleteKeys =
          (s -> SessionKey s) -> [s] -> [SessionKey s]
forall a b. (a -> b) -> [a] -> [b]
map s -> SessionKey s
forall s. IsSession s => s -> SessionKey s
getSessionKey ([s] -> [SessionKey s]) -> [s] -> [SessionKey s]
forall a b. (a -> b) -> a -> b
$
            (s -> Bool) -> [s] -> [s]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (s -> Bool) -> s -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> Bool
cond) [s]
allVals
    forM_ deleteKeys $ flip deleteSession sv

-- | Perform action on all sessions
mapSessions :: IsSession s => (s -> STM s) -> SessionVault s -> STM ()
mapSessions :: forall s. IsSession s => (s -> STM s) -> SessionVault s -> STM ()
mapSessions s -> STM s
f sv :: SessionVault s
sv@(SessionVault Map (SessionKey s) s
smap) =
  do
    allVals <- SessionVault s -> STM [s]
forall s. SessionVault s -> STM [s]
toList SessionVault s
sv
    forM_ allVals $ \s
sess ->
      Focus s STM () -> SessionKey s -> Map (SessionKey s) s -> STM ()
forall key value result.
Hashable key =>
Focus value STM result -> key -> Map key value -> STM result
STMMap.focus ((s -> STM s) -> Focus s STM ()
forall (m :: * -> *) a. Monad m => (a -> m a) -> Focus a m ()
F.adjustM s -> STM s
f) (s -> SessionKey s
forall s. IsSession s => s -> SessionKey s
getSessionKey s
sess) Map (SessionKey s) s
smap

newStmSessionStore' :: IO (SessionStore (Session conn sess st) STM)
newStmSessionStore' :: forall conn sess st. IO (SessionStore (Session conn sess st) STM)
newStmSessionStore' =
  do
    vault <- STM (SessionVault (Session conn sess st))
-> IO (SessionVault (Session conn sess st))
forall a. STM a -> IO a
atomically STM (SessionVault (Session conn sess st))
forall s. STM (SessionVault s)
newSessionVault
    return $
      SessionStore
        { ss_runTx = atomically,
          ss_loadSession = flip loadSession vault,
          ss_deleteSession = flip deleteSession vault,
          ss_storeSession = flip storeSession vault,
          ss_toList = toList vault,
          ss_filterSessions = flip filterSessions vault,
          ss_mapSessions = flip mapSessions vault
        }

newStmSessionStore :: IO (SessionStoreInstance (Session conn sess st))
newStmSessionStore :: forall conn sess st.
IO (SessionStoreInstance (Session conn sess st))
newStmSessionStore = SessionStore (Session conn sess st) STM
-> SessionStoreInstance (Session conn sess st)
forall sess (tx :: * -> *).
(Monad tx, Functor tx, Applicative tx) =>
SessionStore sess tx -> SessionStoreInstance sess
SessionStoreInstance (SessionStore (Session conn sess st) STM
 -> SessionStoreInstance (Session conn sess st))
-> IO (SessionStore (Session conn sess st) STM)
-> IO (SessionStoreInstance (Session conn sess st))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (SessionStore (Session conn sess st) STM)
forall conn sess st. IO (SessionStore (Session conn sess st) STM)
newStmSessionStore'