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 a session to the database
--
-- Return value of 'Nothing' indicates that no changes were made.
-- 'Just' is returned when a session was saved, either by an insert
-- or a replace operation.
save
  :: Monad tx
  => Options tx m
  -> (forall a. StorageOperation a -> tx a)
  -> SessionKeyManager tx
  -> UTCTime
  -- ^ The current time
  -> SessionMap
  -- ^ The new session data to be saved
  -> Maybe Session
  -- ^ What's in the database
  -> 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
        -- 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.
        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