module Yesod.Session.Storage.Save
( save
) where
import Internal.Prelude
import Control.Monad.Trans.Maybe (MaybeT (MaybeT), runMaybeT)
import Data.Map.Strict qualified as Map
import Session.Key
import Session.Timing.Options
import Session.Timing.Time
import Time
import Yesod.Core (SessionMap)
import Yesod.Session.Options
import Yesod.Session.SessionType
import Yesod.Session.Storage.Operation
save
:: Monad tx
=> Options tx m
-> (forall a. StorageOperation a -> tx a)
-> SessionKeyManager tx
-> UTCTime
-> SessionMap
-> Maybe Session
-> tx (Maybe Session)
save :: forall (tx :: * -> *) (m :: * -> *).
Monad tx =>
Options tx m
-> (forall a. StorageOperation a -> tx a)
-> SessionKeyManager tx
-> UTCTime
-> SessionMap
-> Maybe Session
-> tx (Maybe Session)
save Options tx m
options forall a. StorageOperation a -> tx a
storage SessionKeyManager tx
sessionKeyManager UTCTime
now SessionMap
newInfo Maybe Session
oldSessionMaybe =
[tx (Maybe (Maybe Session))] -> tx (Maybe (Maybe Session))
forall (m :: * -> *) a. Monad m => [m (Maybe a)] -> m (Maybe a)
asumM
[ MaybeT tx (Maybe Session) -> tx (Maybe (Maybe Session))
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT tx (Maybe Session) -> tx (Maybe (Maybe Session)))
-> MaybeT tx (Maybe Session) -> tx (Maybe (Maybe Session))
forall a b. (a -> b) -> a -> b
$ do
Bool -> MaybeT tx ()
forall (m :: * -> *). Monad m => Bool -> MaybeT m ()
guardMaybeT (Bool -> MaybeT tx ()) -> Bool -> MaybeT tx ()
forall a b. (a -> b) -> a -> b
$ Maybe Session -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Session
oldSessionMaybe
Bool -> MaybeT tx ()
forall (m :: * -> *). Monad m => Bool -> MaybeT m ()
guardMaybeT (Bool -> MaybeT tx ()) -> Bool -> MaybeT tx ()
forall a b. (a -> b) -> a -> b
$ SessionMap -> Bool
forall k a. Map k a -> Bool
Map.null SessionMap
newInfo
Maybe Session -> MaybeT tx (Maybe Session)
forall a. a -> MaybeT tx a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Session
forall a. Maybe a
Nothing
, MaybeT tx (Maybe Session) -> tx (Maybe (Maybe Session))
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT tx (Maybe Session) -> tx (Maybe (Maybe Session)))
-> MaybeT tx (Maybe Session) -> tx (Maybe (Maybe Session))
forall a b. (a -> b) -> a -> b
$ do
NominalDiffTime
res <- Maybe NominalDiffTime -> MaybeT tx NominalDiffTime
forall (m :: * -> *) a. Monad m => Maybe a -> MaybeT m a
assertJust Options tx m
options.timing.resolution
Session
old <- Maybe Session -> MaybeT tx Session
forall (m :: * -> *) a. Monad m => Maybe a -> MaybeT m a
assertJust Maybe Session
oldSessionMaybe
Bool -> MaybeT tx ()
forall (m :: * -> *). Monad m => Bool -> MaybeT m ()
guardMaybeT (Bool -> MaybeT tx ()) -> Bool -> MaybeT tx ()
forall a b. (a -> b) -> a -> b
$ Session
old.map SessionMap -> SessionMap -> Bool
forall a. Eq a => a -> a -> Bool
== SessionMap
newInfo
Bool -> MaybeT tx ()
forall (m :: * -> *). Monad m => Bool -> MaybeT m ()
guardMaybeT (Bool -> MaybeT tx ()) -> Bool -> MaybeT tx ()
forall a b. (a -> b) -> a -> b
$ UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
now Session
old.time.accessed NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
< NominalDiffTime
res
Maybe Session -> MaybeT tx (Maybe Session)
forall a. a -> MaybeT tx a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Session
forall a. Maybe a
Nothing
, MaybeT tx (Maybe Session) -> tx (Maybe (Maybe Session))
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT tx (Maybe Session) -> tx (Maybe (Maybe Session)))
-> MaybeT tx (Maybe Session) -> tx (Maybe (Maybe Session))
forall a b. (a -> b) -> a -> b
$ do
Session
oldSession <- Maybe Session -> MaybeT tx Session
forall (m :: * -> *) a. Monad m => Maybe a -> MaybeT m a
assertJust Maybe Session
oldSessionMaybe
let newSession :: Session
newSession =
Session
{ $sel:key:Session :: SessionKey
key = Session
oldSession.key
, $sel:map:Session :: SessionMap
map = SessionMap
newInfo
, $sel:time:Session :: Time UTCTime
time = Time {$sel:created:Time :: UTCTime
created = Session
oldSession.time.created, $sel:accessed:Time :: UTCTime
accessed = UTCTime
now}
}
tx () -> MaybeT tx ()
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (tx () -> MaybeT tx ()) -> tx () -> MaybeT tx ()
forall a b. (a -> b) -> a -> b
$ StorageOperation () -> tx ()
forall a. StorageOperation a -> tx a
storage (StorageOperation () -> tx ()) -> StorageOperation () -> tx ()
forall a b. (a -> b) -> a -> b
$ Session -> StorageOperation ()
forall result. (result ~ ()) => Session -> StorageOperation result
ReplaceSession Session
newSession
Maybe Session -> MaybeT tx (Maybe Session)
forall a. a -> MaybeT tx a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Session -> MaybeT tx (Maybe Session))
-> Maybe Session -> MaybeT tx (Maybe Session)
forall a b. (a -> b) -> a -> b
$ Session -> Maybe Session
forall a. a -> Maybe a
Just Session
newSession
]
tx (Maybe (Maybe Session))
-> tx (Maybe Session) -> tx (Maybe Session)
forall (m :: * -> *) a. Monad m => m (Maybe a) -> m a -> m a
`orElseM` do
SessionKey
sessionKey <- SessionKeyManager tx
sessionKeyManager.new
let newSession :: Session
newSession =
Session
{ $sel:key:Session :: SessionKey
key = SessionKey
sessionKey
, $sel:map:Session :: SessionMap
map = SessionMap
newInfo
, $sel:time:Session :: Time UTCTime
time = Time {$sel:created:Time :: UTCTime
created = UTCTime
now, $sel:accessed:Time :: UTCTime
accessed = UTCTime
now}
}
StorageOperation () -> tx ()
forall a. StorageOperation a -> tx a
storage (StorageOperation () -> tx ()) -> StorageOperation () -> tx ()
forall a b. (a -> b) -> a -> b
$ Session -> StorageOperation ()
forall result. (result ~ ()) => Session -> StorageOperation result
InsertSession Session
newSession
Maybe Session -> tx (Maybe Session)
forall a. a -> tx a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Session -> tx (Maybe Session))
-> Maybe Session -> tx (Maybe Session)
forall a b. (a -> b) -> a -> b
$ Session -> Maybe Session
forall a. a -> Maybe a
Just Session
newSession
orElseM :: Monad m => m (Maybe a) -> m a -> m a
m (Maybe a)
a orElseM :: forall (m :: * -> *) a. Monad m => m (Maybe a) -> m a -> m a
`orElseM` m a
b = m (Maybe a)
a m (Maybe a) -> (Maybe a -> m a) -> m a
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m a -> (a -> m a) -> Maybe a -> m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m a
b a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
asumM :: Monad m => [m (Maybe a)] -> m (Maybe a)
asumM :: forall (m :: * -> *) a. Monad m => [m (Maybe a)] -> m (Maybe a)
asumM = \case [] -> Maybe a -> m (Maybe a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing; m (Maybe a)
x : [m (Maybe a)]
xs -> m (Maybe a)
x m (Maybe a) -> (Maybe a -> m (Maybe a)) -> m (Maybe a)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m (Maybe a) -> (a -> m (Maybe a)) -> Maybe a -> m (Maybe a)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([m (Maybe a)] -> m (Maybe a)
forall (m :: * -> *) a. Monad m => [m (Maybe a)] -> m (Maybe a)
asumM [m (Maybe a)]
xs) (Maybe a -> m (Maybe a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> m (Maybe a)) -> (a -> Maybe a) -> a -> m (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe a
forall a. a -> Maybe a
Just)
guardMaybeT :: Monad m => Bool -> MaybeT m ()
guardMaybeT :: forall (m :: * -> *). Monad m => Bool -> MaybeT m ()
guardMaybeT = \case Bool
True -> () -> MaybeT m ()
forall a. a -> MaybeT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (); Bool
False -> m (Maybe ()) -> MaybeT m ()
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (Maybe () -> m (Maybe ())
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ()
forall a. Maybe a
Nothing)
assertJust :: Monad m => Maybe a -> MaybeT m a
assertJust :: forall (m :: * -> *) a. Monad m => Maybe a -> MaybeT m a
assertJust = m (Maybe a) -> MaybeT m a
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (m (Maybe a) -> MaybeT m a)
-> (Maybe a -> m (Maybe a)) -> Maybe a -> MaybeT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe a -> m (Maybe a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure