{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE CPP #-}
module Web.Spock.Internal.SessionVault where

import Web.Spock.Internal.Types

#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 Focus as F
import qualified ListT as L
import qualified StmContainers.Map as STMMap
import qualified Data.Text as T

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 -> SessionKey (Session conn sess st)
forall conn sess st. Session conn sess st -> SessionId
sess_id

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

-- | Create a new session vault
newSessionVault :: STM (SessionVault s)
newSessionVault :: 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 :: 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.
(Eq key, 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 :: s -> SessionVault s -> STM ()
storeSession s
v (SessionVault Map (SessionKey s) s
smap) = s -> SessionKey s -> Map (SessionKey s) s -> STM ()
forall key value.
(Eq key, 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 :: 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.
(Eq key, 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 :: 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 :: (s -> Bool) -> SessionVault s -> STM ()
filterSessions s -> Bool
cond SessionVault s
sv =
    do [s]
allVals <- SessionVault s -> STM [s]
forall s. SessionVault s -> STM [s]
toList SessionVault s
sv
       let deleteKeys :: [SessionKey s]
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
       [SessionKey s] -> (SessionKey s -> STM ()) -> STM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [SessionKey s]
deleteKeys ((SessionKey s -> STM ()) -> STM ())
-> (SessionKey s -> STM ()) -> STM ()
forall a b. (a -> b) -> a -> b
$ (SessionKey s -> SessionVault s -> STM ())
-> SessionVault s -> SessionKey s -> STM ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip SessionKey s -> SessionVault s -> STM ()
forall s. IsSession s => SessionKey s -> SessionVault s -> STM ()
deleteSession SessionVault s
sv

-- | Perform action on all sessions
mapSessions :: IsSession s => (s -> STM s) -> SessionVault s -> STM ()
mapSessions :: (s -> STM s) -> SessionVault s -> STM ()
mapSessions s -> STM s
f sv :: SessionVault s
sv@(SessionVault Map (SessionKey s) s
smap) =
    do [s]
allVals <- SessionVault s -> STM [s]
forall s. SessionVault s -> STM [s]
toList SessionVault s
sv
       [s] -> (s -> STM ()) -> STM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [s]
allVals ((s -> STM ()) -> STM ()) -> (s -> STM ()) -> STM ()
forall a b. (a -> b) -> a -> b
$ \s
sess ->
           Focus s STM () -> SessionKey s -> Map (SessionKey s) s -> STM ()
forall key value result.
(Eq key, 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' :: IO (SessionStore (Session conn sess st) STM)
newStmSessionStore' =
  do SessionVault (Session conn sess st)
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
     SessionStore (Session conn sess st) STM
-> IO (SessionStore (Session conn sess st) STM)
forall (m :: * -> *) a. Monad m => a -> m a
return (SessionStore (Session conn sess st) STM
 -> IO (SessionStore (Session conn sess st) STM))
-> SessionStore (Session conn sess st) STM
-> IO (SessionStore (Session conn sess st) STM)
forall a b. (a -> b) -> a -> b
$
         SessionStore :: forall sess (tx :: * -> *).
(forall a. tx a -> IO a)
-> (SessionId -> tx (Maybe sess))
-> (SessionId -> tx ())
-> (sess -> tx ())
-> tx [sess]
-> ((sess -> Bool) -> tx ())
-> ((sess -> tx sess) -> tx ())
-> SessionStore sess tx
SessionStore
         { ss_runTx :: forall a. STM a -> IO a
ss_runTx = forall a. STM a -> IO a
atomically
         , ss_loadSession :: SessionId -> STM (Maybe (Session conn sess st))
ss_loadSession = (SessionId
 -> SessionVault (Session conn sess st)
 -> STM (Maybe (Session conn sess st)))
-> SessionVault (Session conn sess st)
-> SessionId
-> STM (Maybe (Session conn sess st))
forall a b c. (a -> b -> c) -> b -> a -> c
flip SessionId
-> SessionVault (Session conn sess st)
-> STM (Maybe (Session conn sess st))
forall s.
IsSession s =>
SessionKey s -> SessionVault s -> STM (Maybe s)
loadSession SessionVault (Session conn sess st)
vault
         , ss_deleteSession :: SessionId -> STM ()
ss_deleteSession = (SessionId -> SessionVault (Session conn sess st) -> STM ())
-> SessionVault (Session conn sess st) -> SessionId -> STM ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip SessionId -> SessionVault (Session conn sess st) -> STM ()
forall s. IsSession s => SessionKey s -> SessionVault s -> STM ()
deleteSession SessionVault (Session conn sess st)
vault
         , ss_storeSession :: Session conn sess st -> STM ()
ss_storeSession = (Session conn sess st
 -> SessionVault (Session conn sess st) -> STM ())
-> SessionVault (Session conn sess st)
-> Session conn sess st
-> STM ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Session conn sess st
-> SessionVault (Session conn sess st) -> STM ()
forall s. IsSession s => s -> SessionVault s -> STM ()
storeSession SessionVault (Session conn sess st)
vault
         , ss_toList :: STM [Session conn sess st]
ss_toList = SessionVault (Session conn sess st) -> STM [Session conn sess st]
forall s. SessionVault s -> STM [s]
toList SessionVault (Session conn sess st)
vault
         , ss_filterSessions :: (Session conn sess st -> Bool) -> STM ()
ss_filterSessions = ((Session conn sess st -> Bool)
 -> SessionVault (Session conn sess st) -> STM ())
-> SessionVault (Session conn sess st)
-> (Session conn sess st -> Bool)
-> STM ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Session conn sess st -> Bool)
-> SessionVault (Session conn sess st) -> STM ()
forall s. IsSession s => (s -> Bool) -> SessionVault s -> STM ()
filterSessions SessionVault (Session conn sess st)
vault
         , ss_mapSessions :: (Session conn sess st -> STM (Session conn sess st)) -> STM ()
ss_mapSessions = ((Session conn sess st -> STM (Session conn sess st))
 -> SessionVault (Session conn sess st) -> STM ())
-> SessionVault (Session conn sess st)
-> (Session conn sess st -> STM (Session conn sess st))
-> STM ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Session conn sess st -> STM (Session conn sess st))
-> SessionVault (Session conn sess st) -> STM ()
forall s. IsSession s => (s -> STM s) -> SessionVault s -> STM ()
mapSessions SessionVault (Session conn sess st)
vault
         }

newStmSessionStore :: IO (SessionStoreInstance (Session conn sess st))
newStmSessionStore :: 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'