fraport/fradrive-old
Archived
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix(notifications): fix #180 qualification expiry notification are sent only once

Browse Source
This commit is contained in:
Steffen Jost 2024-09-09 15:34:41 +02:00
parent ade27e6479
commit 74f7633837
3 changed files with 51 additions and 46 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
src/Handler/Qualification.hs
View File

@ -96,12 +96,12 @@ mkQualificationAllTable isAdmin = do
maybeCell (qualificationDescription quali) markupCellLargeModal maybeCell (qualificationDescription quali) markupCellLargeModal
, sortable Nothing (i18nCell MsgQualificationValidDuration & cellTooltip MsgTableDiffDaysTooltip) $ , sortable Nothing (i18nCell MsgQualificationValidDuration & cellTooltip MsgTableDiffDaysTooltip) $
foldMap (textCell . formatCalendarDiffDays . fromMonths) . view (resultAllQualification . _qualificationValidDuration) 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 -> , sortable (Just "qelearning") (i18nCell MsgTableLmsElearning & cellTooltip MsgQualificationElearningStart) $ \row ->
let elearnstart = row ^. resultAllQualification . _qualificationElearningStart let elearnstart = row ^. resultAllQualification . _qualificationElearningStart
reminder = row ^. resultAllQualification . _qualificationRefreshReminder reminder = row ^. resultAllQualification . _qualificationRefreshReminder
in tickmarkCell $ elearnstart && isJust reminder 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]) $ , sortable Nothing (i18nCell MsgQualificationRefreshReminder & cellTooltips [SomeMessage MsgQualificationRefreshReminderTooltip, SomeMessage MsgTableDiffDaysTooltip]) $
foldMap (textCell . formatCalendarDiffDays ) . view (resultAllQualification . _qualificationRefreshReminder) foldMap (textCell . formatCalendarDiffDays ) . view (resultAllQualification . _qualificationRefreshReminder)
, sortable (Just "noteexpiry") (i18nCell MsgQualificationExpiryNotification & cellTooltip MsgQualificationExpiryNotificationTooltip) , sortable (Just "noteexpiry") (i18nCell MsgQualificationExpiryNotification & cellTooltip MsgQualificationExpiryNotificationTooltip)

63
src/Jobs/Handler/LMS.hs
View File

@ -67,7 +67,7 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
let nowaday = utctDay now let nowaday = utctDay now
-- send second reminders first, before enqueing even more, but only for users with currently open LMS and still valid Qualificiations -- 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 let remindDate = addGregorianDurationClip remindPeriod nowaday
reminders <- E.select $ do reminders <- E.select $ do
(luser :& quser) <- E.from $ E.table @LmsUser `E.innerJoin` E.table @QualificationUser (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 } , jNotification = NotificationQualificationRenewal { nQualification = qid, nReminder = True }
} }
_ -> return () _ -> return ()
-- send initial reminders
ifNothingM (qualificationRefreshWithin quali) () $ \renewalPeriod -> do -- no refreshWithin, no first reminders whenIsJust (qualificationRefreshWithin quali) $ \renewalPeriod -> do -- no refreshWithin, no first reminders
let renewalDate = addGregorianDurationClip renewalPeriod nowaday let renewalDate = addGregorianDurationClip renewalPeriod nowaday
renewalUsers <- E.select $ do renewalUsers <- E.select $ do
quser <- E.from $ E.table @QualificationUser quser <- E.from $ E.table @QualificationUser
E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid
E.&&. quser E.^. QualificationUserScheduleRenewal E.&&. quser E.^. QualificationUserScheduleRenewal
E.&&. quser E.^. QualificationUserValidUntil E.<=. E.val renewalDate E.&&. quser E.^. QualificationUserValidUntil E.<=. E.val renewalDate
E.&&. (quser `qualificationValid` now) E.&&. (quser `qualificationValid` now)
E.&&. E.notExists (do E.&&. E.notExists (do
luser <- E.from $ E.table @LmsUser luser <- E.from $ E.table @LmsUser
E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid
E.&&. luser E.^. LmsUserUser E.==. quser E.^. QualificationUserUser E.&&. luser E.^. LmsUserUser E.==. quser E.^. QualificationUserUser
E.&&. E.isNothing (luser E.^. LmsUserEnded) E.&&. E.isNothing (luser E.^. LmsUserEnded)
) )
pure quser pure quser
let usr_job :: Entity QualificationUser -> Job let usr_job :: Entity QualificationUser -> Maybe Job
usr_job quser = usr_job quser =
let uid = quser ^. _entityVal . _qualificationUserUser let uid = quser ^. _entityVal . _qualificationUserUser
uex = quser ^. _entityVal . _qualificationUserValidUntil uex = quser ^. _entityVal . _qualificationUserValidUntil
in if qualificationElearningStart quali unf = quser ^. _entityVal . _qualificationUserLastNotified
then JobLmsEnqueueUser { jQualification = qid, jUser = uid } nfy_cutoff = addGregorianDurationClip renewalPeriod $ utctDay unf
else JobUserNotification { jRecipient = uid, jNotification = do_notify = uex > nfy_cutoff || (uex == nfy_cutoff && utctDayTime now >= utctDayTime unf)
NotificationQualificationExpiry { nQualification = qid, nExpiry = uex } in if
} | qualificationElearningStart quali -- repetition avoided since LmsUser does not exist
forM_ renewalUsers (queueDBJob . usr_job) -> Just $ JobLmsEnqueueUser { jQualification = qid, jUser = uid }
logInterface "LMS" (qshort <> "-enq") True (Just $ length renewalUsers) "" | 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 :: QualificationId -> UserId -> JobHandler UniWorX
dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act

30
src/Jobs/Handler/SendNotification/Qualification.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022-23 Steffen Jost <jost@tcs.ifi.lmu.de> -- SPDX-FileCopyrightText: 2022-24 Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
-- --
-- SPDX-License-Identifier: AGPL-3.0-or-later -- SPDX-License-Identifier: AGPL-3.0-or-later
@ -22,24 +22,22 @@ import Text.Hamlet
dispatchNotificationQualificationExpiry :: QualificationId -> Day -> UserId -> Handler () dispatchNotificationQualificationExpiry :: QualificationId -> Day -> UserId -> Handler ()
dispatchNotificationQualificationExpiry nQualification dExpiry jRecipient = userMailT jRecipient $ do dispatchNotificationQualificationExpiry nQualification dExpiry jRecipient = do
(recipient@User{..}, Qualification{..}) <- liftHandler . runDB $ (,) now <- liftIO getCurrentTime
encRecipient :: CryptoUUIDUser <- liftHandler $ encrypt jRecipient
(recipient@User{..}, Qualification{..}) <- runDB $ (,)
<$> getJust jRecipient <$> getJust jRecipient
<*> getJust nQualification <*> getJust nQualification
encRecipient :: CryptoUUIDUser <- liftHandler $ encrypt jRecipient
let entRecipient = Entity jRecipient recipient let entRecipient = Entity jRecipient recipient
qname = CI.original qualificationName qname = CI.original qualificationName
expiryDate <- formatTimeUser SelFormatDate dExpiry $ Just entRecipient userMailT jRecipient $ do
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
replaceMailHeader "Auto-Submitted" $ Just "auto-generated" editNotifications <- mkEditNotifications jRecipient
setSubjectI $ MsgMailSubjectQualificationExpiry qname addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/qualificationExpiry.hamlet")
runDB $ updateBy (UniqueQualificationUser nQualification jRecipient) [QualificationUserLastNotified =. now]
editNotifications <- mkEditNotifications jRecipient $logDebugS "LMS" $ "Notified " <> tshow encRecipient <> " about soonish expiry of qualification " <> qname
addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/qualificationExpiry.hamlet")
dispatchNotificationQualificationExpired :: QualificationId -> UserId -> Handler () dispatchNotificationQualificationExpired :: QualificationId -> UserId -> Handler ()
@ -81,7 +79,7 @@ dispatchNotificationQualificationExpired nQualification jRecipient = do
$logInfoS "LMS" $ "Notified " <> tshow encRecipient <> " about expired qualification " <> qname $logInfoS "LMS" $ "Notified " <> tshow encRecipient <> " about expired qualification " <> qname
else else
$logErrorS "LMS" $ "Failed to notify " <> tshow encRecipient <> " about expired qualification " <> qname $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 _ -> $logErrorS "LMS" $ "Failed to notify " <> tshow encRecipient <> " about expired qualification " <> tshow nQualification