From 74f7633837870448f7cab1013719f42ab49941fe Mon Sep 17 00:00:00 2001 From: Steffen Date: Mon, 9 Sep 2024 15:34:41 +0200 Subject: [PATCH] fix(notifications): fix #180 qualification expiry notification are sent only once --- src/Handler/Qualification.hs | 4 +- src/Jobs/Handler/LMS.hs | 63 ++++++++++--------- .../Handler/SendNotification/Qualification.hs | 30 +++++---- 3 files changed, 51 insertions(+), 46 deletions(-) diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index c9e7839b1..4d35ca154 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -96,12 +96,12 @@ mkQualificationAllTable isAdmin = do maybeCell (qualificationDescription quali) markupCellLargeModal , sortable Nothing (i18nCell MsgQualificationValidDuration & cellTooltip MsgTableDiffDaysTooltip) $ foldMap (textCell . formatCalendarDiffDays . fromMonths) . view (resultAllQualification . _qualificationValidDuration) + , sortable Nothing (i18nCell MsgQualificationRefreshWithin & cellTooltips [SomeMessage MsgQualificationRefreshWithinTooltip , SomeMessage MsgTableDiffDaysTooltip]) $ + foldMap (textCell . formatCalendarDiffDays ) . view (resultAllQualification . _qualificationRefreshWithin) , sortable (Just "qelearning") (i18nCell MsgTableLmsElearning & cellTooltip MsgQualificationElearningStart) $ \row -> let elearnstart = row ^. resultAllQualification . _qualificationElearningStart reminder = row ^. resultAllQualification . _qualificationRefreshReminder in tickmarkCell $ elearnstart && isJust reminder - , sortable Nothing (i18nCell MsgQualificationRefreshWithin & cellTooltips [SomeMessage MsgQualificationRefreshWithinTooltip , SomeMessage MsgTableDiffDaysTooltip]) $ - foldMap (textCell . formatCalendarDiffDays ) . view (resultAllQualification . _qualificationRefreshWithin) , sortable Nothing (i18nCell MsgQualificationRefreshReminder & cellTooltips [SomeMessage MsgQualificationRefreshReminderTooltip, SomeMessage MsgTableDiffDaysTooltip]) $ foldMap (textCell . formatCalendarDiffDays ) . view (resultAllQualification . _qualificationRefreshReminder) , sortable (Just "noteexpiry") (i18nCell MsgQualificationExpiryNotification & cellTooltip MsgQualificationExpiryNotificationTooltip) diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 59872428f..53467898f 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -67,7 +67,7 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act now <- liftIO getCurrentTime let nowaday = utctDay now -- send second reminders first, before enqueing even more, but only for users with currently open LMS and still valid Qualificiations - ifNothingM (qualificationRefreshReminder quali) () $ \remindPeriod -> do + whenIsJust (qualificationRefreshReminder quali) $ \remindPeriod -> do let remindDate = addGregorianDurationClip remindPeriod nowaday reminders <- E.select $ do (luser :& quser) <- E.from $ E.table @LmsUser `E.innerJoin` E.table @QualificationUser @@ -91,33 +91,40 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act , jNotification = NotificationQualificationRenewal { nQualification = qid, nReminder = True } } _ -> return () - - ifNothingM (qualificationRefreshWithin quali) () $ \renewalPeriod -> do -- no refreshWithin, no first reminders - let renewalDate = addGregorianDurationClip renewalPeriod nowaday - renewalUsers <- E.select $ do - quser <- E.from $ E.table @QualificationUser - E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid - E.&&. quser E.^. QualificationUserScheduleRenewal - E.&&. quser E.^. QualificationUserValidUntil E.<=. E.val renewalDate - E.&&. (quser `qualificationValid` now) - E.&&. E.notExists (do - luser <- E.from $ E.table @LmsUser - E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid - E.&&. luser E.^. LmsUserUser E.==. quser E.^. QualificationUserUser - E.&&. E.isNothing (luser E.^. LmsUserEnded) - ) - pure quser - let usr_job :: Entity QualificationUser -> Job - usr_job quser = - let uid = quser ^. _entityVal . _qualificationUserUser - uex = quser ^. _entityVal . _qualificationUserValidUntil - in if qualificationElearningStart quali - then JobLmsEnqueueUser { jQualification = qid, jUser = uid } - else JobUserNotification { jRecipient = uid, jNotification = - NotificationQualificationExpiry { nQualification = qid, nExpiry = uex } - } - forM_ renewalUsers (queueDBJob . usr_job) - logInterface "LMS" (qshort <> "-enq") True (Just $ length renewalUsers) "" + -- send initial reminders + whenIsJust (qualificationRefreshWithin quali) $ \renewalPeriod -> do -- no refreshWithin, no first reminders + let renewalDate = addGregorianDurationClip renewalPeriod nowaday + renewalUsers <- E.select $ do + quser <- E.from $ E.table @QualificationUser + E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid + E.&&. quser E.^. QualificationUserScheduleRenewal + E.&&. quser E.^. QualificationUserValidUntil E.<=. E.val renewalDate + E.&&. (quser `qualificationValid` now) + E.&&. E.notExists (do + luser <- E.from $ E.table @LmsUser + E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid + E.&&. luser E.^. LmsUserUser E.==. quser E.^. QualificationUserUser + E.&&. E.isNothing (luser E.^. LmsUserEnded) + ) + pure quser + let usr_job :: Entity QualificationUser -> Maybe Job + usr_job quser = + let uid = quser ^. _entityVal . _qualificationUserUser + uex = quser ^. _entityVal . _qualificationUserValidUntil + unf = quser ^. _entityVal . _qualificationUserLastNotified + nfy_cutoff = addGregorianDurationClip renewalPeriod $ utctDay unf + do_notify = uex > nfy_cutoff || (uex == nfy_cutoff && utctDayTime now >= utctDayTime unf) + in if + | qualificationElearningStart quali -- repetition avoided since LmsUser does not exist + -> Just $ JobLmsEnqueueUser { jQualification = qid, jUser = uid } + | do_notify -- repetition avoided by QualificationUserLastNotified + -> Just $ JobUserNotification + { jRecipient = uid + , jNotification = NotificationQualificationExpiry { nQualification = qid, nExpiry = uex } + } + | otherwise -> Nothing + forM_ renewalUsers (flip whenIsJust queueDBJob . usr_job) + logInterface "LMS" (qshort <> "-enq") True (Just $ length renewalUsers) "" dispatchJobLmsEnqueueUser :: QualificationId -> UserId -> JobHandler UniWorX dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act diff --git a/src/Jobs/Handler/SendNotification/Qualification.hs b/src/Jobs/Handler/SendNotification/Qualification.hs index a03383d9b..ecd749288 100644 --- a/src/Jobs/Handler/SendNotification/Qualification.hs +++ b/src/Jobs/Handler/SendNotification/Qualification.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-23 Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -22,24 +22,22 @@ import Text.Hamlet dispatchNotificationQualificationExpiry :: QualificationId -> Day -> UserId -> Handler () -dispatchNotificationQualificationExpiry nQualification dExpiry jRecipient = userMailT jRecipient $ do - (recipient@User{..}, Qualification{..}) <- liftHandler . runDB $ (,) +dispatchNotificationQualificationExpiry nQualification dExpiry jRecipient = do + now <- liftIO getCurrentTime + encRecipient :: CryptoUUIDUser <- liftHandler $ encrypt jRecipient + (recipient@User{..}, Qualification{..}) <- runDB $ (,) <$> getJust jRecipient <*> getJust nQualification - - encRecipient :: CryptoUUIDUser <- liftHandler $ encrypt jRecipient let entRecipient = Entity jRecipient recipient qname = CI.original qualificationName - expiryDate <- formatTimeUser SelFormatDate dExpiry $ Just entRecipient - - $logDebugS "LMS" $ "Notify " <> tshow encRecipient <> " about expiry of qualification " <> qname - - replaceMailHeader "Auto-Submitted" $ Just "auto-generated" - setSubjectI $ MsgMailSubjectQualificationExpiry qname - - editNotifications <- mkEditNotifications jRecipient - - addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/qualificationExpiry.hamlet") + userMailT jRecipient $ do + expiryDate <- formatTimeUser SelFormatDate dExpiry $ Just entRecipient + replaceMailHeader "Auto-Submitted" $ Just "auto-generated" + setSubjectI $ MsgMailSubjectQualificationExpiry qname + editNotifications <- mkEditNotifications jRecipient + addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/qualificationExpiry.hamlet") + runDB $ updateBy (UniqueQualificationUser nQualification jRecipient) [QualificationUserLastNotified =. now] + $logDebugS "LMS" $ "Notified " <> tshow encRecipient <> " about soonish expiry of qualification " <> qname dispatchNotificationQualificationExpired :: QualificationId -> UserId -> Handler () @@ -81,7 +79,7 @@ dispatchNotificationQualificationExpired nQualification jRecipient = do $logInfoS "LMS" $ "Notified " <> tshow encRecipient <> " about expired qualification " <> qname else $logErrorS "LMS" $ "Failed to notify " <> tshow encRecipient <> " about expired qualification " <> qname - else $logInfoS "LMS" $ "Suppressed repeated notification " <> tshow encRecipient <> " about expired qualification " <> qname + else $logInfoS "LMS" $ "Suppressed repeated notification " <> tshow encRecipient <> " about expired qualification " <> qname -- should no longer happen to using quserToNotify filter in Jobs.Handler.Lms, but sometimes does after restarts _ -> $logErrorS "LMS" $ "Failed to notify " <> tshow encRecipient <> " about expired qualification " <> tshow nQualification