diff --git a/models/invitations b/models/invitations index c1d15148c..c915d08e4 100644 --- a/models/invitations +++ b/models/invitations @@ -2,4 +2,5 @@ Invitation email UserEmail for Value data Value + expiresAt UTCTime Maybe UniqueInvitation email for \ No newline at end of file diff --git a/src/Handler/Utils/Invitations.hs b/src/Handler/Utils/Invitations.hs index 94740d96c..00b266b0f 100644 --- a/src/Handler/Utils/Invitations.hs +++ b/src/Handler/Utils/Invitations.hs @@ -175,7 +175,7 @@ sinkInvitations :: forall junction. -- updated, instead. -- -- For new junctions an invitation is sent by e-mail. -sinkInvitations InvitationConfig{..} = determineExists .| C.foldMap pure >>= lift . sinkInvitations' +sinkInvitations InvitationConfig{..} = determineExists .| sinkInvitations' where determineExists :: Conduit (Invitation' junction) (YesodJobDB UniWorX) @@ -201,13 +201,9 @@ sinkInvitations InvitationConfig{..} = determineExists .| C.foldMap pure >>= lif JSON.Success dbData -> return dbData JSON.Error str -> fail $ "Could not decode invitationData: " <> str - sinkInvitations' :: [Invitation' junction] - -> YesodJobDB UniWorX () - sinkInvitations' new = do - when (is _Nothing (ephemeralInvitation @junction)) $ do - insertMany_ $ map (\(email, fid, dat) -> Invitation email (invRef @junction fid) (toJSON $ dat ^. _invitationDBData)) new - -- forM_ existing $ \(iid, oldDat) -> update iid [ InvitationData =. toJSON (dat ^. _invitationDBData) ] - forM_ new $ \(jInvitee, fid, dat) -> do + sinkInvitations' :: Sink (Invitation' junction) (YesodJobDB UniWorX) () + sinkInvitations' = do + C.mapM_ $ \(jInvitee, fid, dat) -> do app <- getYesod let mr = renderMessage app $ NonEmpty.toList appLanguages ur <- getUrlRenderParams @@ -224,6 +220,13 @@ sinkInvitations InvitationConfig{..} = determineExists .| C.foldMap pure >>= lif jInvitationSubject <- fmap mr . mapReaderT liftHandlerT $ invitationSubject fEnt dat let jInvitationExplanation = invitationExplanation fEnt dat (toHtml . mr) ur + when (is _Nothing (ephemeralInvitation @junction)) $ insert_ $ Invitation + { invitationEmail = jInvitee + , invitationFor = invRef @junction fid + , invitationData = toJSON $ dat ^. _invitationDBData + , invitationExpiresAt = tokenExpiresAt token + } + queueDBJob JobInvitation{..} sinkInvitationsF :: forall junction mono. @@ -245,9 +248,9 @@ sourceInvitations :: forall junction. -> Source (YesodDB UniWorX) (UserEmail, InvitationDBData junction) sourceInvitations forKey = selectSource [InvitationFor ==. invRef @junction forKey] [] .| C.mapM decode where - decode (Entity _ (Invitation email _ invitationData)) + decode (Entity _ (Invitation{invitationEmail, invitationData})) = case fromJSON invitationData of - JSON.Success dbData -> return (email, dbData) + JSON.Success dbData -> return (invitationEmail, dbData) JSON.Error str -> fail $ "Could not decode invitationData: " <> str sourceInvitationsList :: forall junction. diff --git a/src/Jobs.hs b/src/Jobs.hs index ba9296216..56a65ae22 100644 --- a/src/Jobs.hs +++ b/src/Jobs.hs @@ -66,6 +66,7 @@ import Jobs.Handler.SendCourseCommunication import Jobs.Handler.Invitation import Jobs.Handler.SendPasswordReset import Jobs.Handler.TransactionLog +import Jobs.Handler.PruneInvitations import Jobs.HealthReport diff --git a/src/Jobs/Crontab.hs b/src/Jobs/Crontab.hs index 8d07f908e..121e11360 100644 --- a/src/Jobs/Crontab.hs +++ b/src/Jobs/Crontab.hs @@ -12,6 +12,8 @@ import Data.Semigroup (Max(..)) import Data.Time.Zones +import Handler.Utils.DateTime + import Control.Monad.Trans.Writer (WriterT, execWriterT) import Control.Monad.Writer.Class (MonadWriter(..)) @@ -44,6 +46,16 @@ determineCrontab = execWriterT $ do , cronRateLimit = appJobCronInterval , cronNotAfter = Right CronNotScheduled } + + oldestInvitationMUTC <- lift $ preview (_head . _entityVal . _invitationExpiresAt . _Just) <$> selectList [InvitationExpiresAt !=. Nothing] [Asc InvitationExpiresAt, LimitTo 1] + whenIsJust oldestInvitationMUTC $ \oldestInvUTC -> tell $ HashMap.singleton + (JobCtlQueue JobPruneInvitations) + Cron + { cronInitial = CronTimestamp $ utcToLocalTime oldestInvUTC + , cronRepeat = CronRepeatOnChange + , cronRateLimit = nominalDay + , cronNotAfter = Right CronNotScheduled + } tell . flip foldMap universeF $ \kind -> case appHealthCheckInterval kind of diff --git a/src/Jobs/Handler/PruneInvitations.hs b/src/Jobs/Handler/PruneInvitations.hs new file mode 100644 index 000000000..c9456454c --- /dev/null +++ b/src/Jobs/Handler/PruneInvitations.hs @@ -0,0 +1,13 @@ +module Jobs.Handler.PruneInvitations + ( dispatchJobPruneInvitations + ) where + +import Import + +import Database.Persist.Sql (deleteWhereCount) + +dispatchJobPruneInvitations :: Handler () +dispatchJobPruneInvitations = do + now <- liftIO getCurrentTime + n <- runDB $ deleteWhereCount [ InvitationExpiresAt <. Just now ] + $logInfoS "PruneInvitations" [st|Deleted #{n} expired invitations|] \ No newline at end of file diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index ad667cd75..040a1b2f1 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -49,6 +49,7 @@ data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notifica | JobSendPasswordReset { jRecipient :: UserId } | JobTruncateTransactionLog + | JobPruneInvitations | JobDeleteTransactionLogIPs deriving (Eq, Ord, Show, Read, Generic, Typeable) data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId } diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index d72fdac3e..83bff05d0 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -149,6 +149,8 @@ makeLenses_ ''Occurrences makeLenses_ ''PredDNF +makeLenses_ ''Invitation + makeLenses_ ''ExamBonusRule makeLenses_ ''ExamGradingRule makeLenses_ ''ExamResult