fix(notifications): fix #180 qualification expiry notification are sent only once
This commit is contained in:
parent
ade27e6479
commit
74f7633837
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user