From 4c5ce11b09f54926835ce10c084e4b3324ba0ddd Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 8 May 2023 17:19:46 +0000 Subject: [PATCH] refactor(qualifications): notification mechanic tied to button only for all invalid qualifications --- .../categories/qualification/de-de-formal.msg | 1 + .../categories/qualification/en-eu.msg | 1 + models/lms.model | 1 + src/Handler/LMS/Fake.hs | 1 + src/Handler/Qualification.hs | 6 +- src/Handler/Utils/Qualification.hs | 3 +- src/Handler/Utils/Users.hs | 2 + src/Jobs/Handler/LMS.hs | 35 ++++++++---- .../Handler/SendNotification/Qualification.hs | 57 ++++++++++++------- src/Jobs/Types.hs | 2 +- src/Utils/Print.hs | 5 +- test/Database/Fill.hs | 30 +++++----- 12 files changed, 92 insertions(+), 52 deletions(-) diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index eae8b0e69..71549a505 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -19,6 +19,7 @@ TableQualificationSapExport: SAP TableQualificationSapExportTooltip: Wird die Qualifikation an das SAP übermittelt? Betrifft nur Benutzer mit Fraport Personalnummer. LmsQualificationValidUntil: Gültig bis TableQualificationLastRefresh: Zuletzt erneuert +TableQualificationLastNotified: Letzte Benachrichtigung TableQualificationFirstHeld: Erstmalig TableQualificationBlockedDue: Entzogen TableQualificationBlockedTooltip: Wann wurde die Qualifikation vorübergehend außer Kraft gesetzt und warum wurde dies veranlasst? diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg index 77a2dfbb5..674a34804 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/messages/uniworx/categories/qualification/en-eu.msg @@ -19,6 +19,7 @@ TableQualificationSapExport: Sent to SAP TableQualificationSapExportTooltip: Is this qualification transmitted to SAP? Only applies to qualification holder having a Fraport AG personnel number. LmsQualificationValidUntil: Valid until TableQualificationLastRefresh: Last renewed +TableQualificationLastNotified: Last notified TableQualificationFirstHeld: First held TableQualificationBlockedDue: Revoked TableQualificationBlockedTooltip: Why and when was this qualification temporarily suspended? diff --git a/models/lms.model b/models/lms.model index f96aca375..4f841f984 100644 --- a/models/lms.model +++ b/models/lms.model @@ -62,6 +62,7 @@ QualificationUser firstHeld Day -- first time the qualification was earned, should never change blockedDue QualificationBlocked Maybe -- isJust means that the qualification is currently revoked scheduleRenewal Bool default=true -- if false, no automatic renewal is scheduled and the qualification expires + lastNotified UTCTime default=now() -- last notficiation about being invalid -- temporärer Entzug vorsehen -- SAP Schnittstelle muss dann angepasst werden -- Begründungsfeld vorsehen UniqueQualificationUser qualification user diff --git a/src/Handler/LMS/Fake.hs b/src/Handler/LMS/Fake.hs index c3693e544..e0550e574 100644 --- a/src/Handler/LMS/Fake.hs +++ b/src/Handler/LMS/Fake.hs @@ -131,6 +131,7 @@ fakeQualificationUsers (Entity qid Qualification{qualificationRefreshWithin}) (u qualificationUserLastRefresh = qualificationUserFirstHeld qualificationUserBlockedDue = Nothing qualificationUserScheduleRenewal = True + qualificationUserLastNotified = now _ <- upsert QualificationUser{..} [ QualificationUserValidUntil =. qualificationUserValidUntil , QualificationUserLastRefresh =. qualificationUserLastRefresh diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 2a5e2c0b8..52e3f43ee 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -339,7 +339,8 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do , single $ sortUserEmail queryUser , single $ sortUserMatriclenr queryUser , single ("valid-until" , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil)) - , single ("last-refresh" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh)) + , single ("last-refresh" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh)) + , single ("last-notified" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastNotified)) , single ("blocked-due" , SortColumnNeverNull $ queryQualUser >>> (E.^. QualificationUserBlockedDue)) -- , single ("lms-started" , SortColumn $ queryLmsUser >>> (E.?. LmsUserStarted)) -- , single ("lms-status" , SortColumn $ views (to queryLmsUser) (E.?. LmsUserStatus)) @@ -520,7 +521,8 @@ postQualificationR sid qsh = do -- $ \(preview $ resultLmsUser . _entityVal . _lmsUserStarted -> d) -> foldMap dateTimeCell d -- , sortable (Just "lms-status") (i18nCell MsgTableLmsStatus) $ \(preview $ resultLmsUser . _entityVal . _lmsUserStatus -> status) -> foldMap lmsStatusCell $ join status , sortable (Just "lms-status-plus")(i18nCell MsgTableLmsStatus & cellTooltipWgt Nothing (lmsStatusInfoCell isAdmin auditMonths)) - $ \(preview $ resultLmsUser . _entityVal -> lu) -> foldMap (lmsStatusPlusCell linkLmsUser) lu + $ \(preview $ resultLmsUser . _entityVal -> lu) -> foldMap (lmsStatusPlusCell linkLmsUser) lu + , sortable (Just "last-notified") (i18nCell MsgTableQualificationLastNotified) $ \( view $ resultQualUser . _entityVal . _qualificationUserLastNotified -> d) -> dateTimeCell d ] psValidator = def & defaultSorting [SortDescBy "last-refresh"] tbl <- mkQualificationTable isAdmin qent acts colChoices psValidator diff --git a/src/Handler/Utils/Qualification.hs b/src/Handler/Utils/Qualification.hs index c259e9867..6964073c5 100644 --- a/src/Handler/Utils/Qualification.hs +++ b/src/Handler/Utils/Qualification.hs @@ -14,7 +14,7 @@ import Database.Persist.Sql (updateWhereCount) import qualified Database.Esqueleto.Experimental as E -- might need TypeApplications Lang-Pragma import qualified Database.Esqueleto.Utils as E - +import Handler.Utils.DateTime (toMidnight) ------------------ -- SQL Snippets -- @@ -57,6 +57,7 @@ upsertQualificationUser qualificationUserQualification qualificationUserLastRef { qualificationUserFirstHeld = qualificationUserLastRefresh , qualificationUserBlockedDue = Nothing , qualificationUserScheduleRenewal = fromMaybe True mbScheduleRenewal + , qualificationUserLastNotified = toMidnight qualificationUserLastRefresh , .. } ( diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index f583e65b1..087a543a7 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -827,6 +827,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.<&> (qualificationUser E.^. QualificationUserFirstHeld) E.<&> (qualificationUser E.^. QualificationUserBlockedDue) E.<&> (qualificationUser E.^. QualificationUserScheduleRenewal) + E.<&> (qualificationUser E.^. QualificationUserLastNotified) ) (\current excluded -> [ QualificationUserValidUntil E.=. combineWith current excluded E.greatest QualificationUserValidUntil @@ -834,6 +835,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do , QualificationUserFirstHeld E.=. combineWith current excluded E.least QualificationUserFirstHeld , QualificationUserBlockedDue E.=. combineWith current excluded E.greatest QualificationUserBlockedDue -- Tested: PostgreSQL GREATEST/LEAST ignores NULL values , QualificationUserScheduleRenewal E.=. combineWith current excluded E.greatest QualificationUserScheduleRenewal + , QualificationUserLastNotified E.=. combineWith current excluded E.greatest QualificationUserLastNotified ] ) deleteWhere [ QualificationUserUser ==. oldUserId ] diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 074a3b866..eb92356ac 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -145,7 +145,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act -- end users that expired by doing nothing expiredLearners <- E.select $ do (quser :& luser) <- E.from $ - E.table @QualificationUser + E.table @QualificationUser `E.innerJoin` E.table @LmsUser `E.on` (\(quser :& luser) -> luser E.^. LmsUserUser E.==. quser E.^. QualificationUserUser @@ -158,13 +158,23 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act E.set luser [LmsUserStatus E.=. E.justVal (LmsExpired nowaday)] E.where_ $ (luser E.^. LmsUserId) `E.in_` E.valList (E.unValue <$> expiredLearners) $logInfoS "LMS" $ "Expired lms users " <> tshow nrExpired <> " for qualification " <> qshort - -- TODO: notify expired used - -- - -- forM_ expiredLearners $ \uid -> - -- queueDBJob JobSendNotification - -- { jRecipient = uid - -- , jNotification = NotificationQualificationExpired { nQualification = qid, nExpiry = nowaday } - -- } + + notifyInvalidDrivers <- E.select $ do + quser <- E.from $ E.table @QualificationUser + E.where_ $ E.not_ (validQualification nowaday quser) + E.&&. (( E.isNothing (quser E.^. QualificationUserBlockedDue) + E.&&. (E.day (quser E.^. QualificationUserLastNotified) E.<. quser E.^. QualificationUserValidUntil) + ) E.||. ( + E.isJust (quser E.^. QualificationUserBlockedDue) + E.&&. (E.day (quser E.^. QualificationUserLastNotified) E.<. ((quser E.^. QualificationUserBlockedDue) E.->. "day" :: E.SqlExpr (E.Value Day))) + )) + pure (quser E.^. QualificationUserUser) + + forM_ notifyInvalidDrivers $ \(E.Value uid) -> + queueDBJob JobSendNotification + { jRecipient = uid + , jNotification = NotificationQualificationExpired { nQualification = qid } + } -- purge outdated LmsUsers case qualificationAuditDuration quali of @@ -306,10 +316,11 @@ dispatchJobLmsUserlist qid = JobHandlerAtomic act } update luid [LmsUserStatus =. newStatus] void $ qualificationUserBlocking qid [lmsUserUser luser] $ Just $ mkQualificationBlocked QualificationBlockFailedELearning lmsMsgDay - queueDBJob JobSendNotification - { jRecipient = lmsUserUser luser - , jNotification = NotificationQualificationExpired { nQualification = qid, nExpiry = lmsMsgDay } - } + -- DEACTIVATED FOR NOW; UPON REACTIVATION: DELAY Sending to check for unblocking a few hours later! + -- queueDBJob JobSendNotification + -- { jRecipient = lmsUserUser luser + -- , jNotification = NotificationQualificationExpired { nQualification = qid } + -- } delete lulid $logInfoS "LmsUserlist" [st|Processed LMS Userlist with ${tshow (length results)} entries|] diff --git a/src/Jobs/Handler/SendNotification/Qualification.hs b/src/Jobs/Handler/SendNotification/Qualification.hs index 32a3d942d..6c438ded8 100644 --- a/src/Jobs/Handler/SendNotification/Qualification.hs +++ b/src/Jobs/Handler/SendNotification/Qualification.hs @@ -42,25 +42,44 @@ dispatchNotificationQualificationExpiry nQualification dExpiry jRecipient = user addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/qualificationExpiry.hamlet") -dispatchNotificationQualificationExpired :: QualificationId -> Day -> UserId -> Handler () -dispatchNotificationQualificationExpired nQualification dExpired jRecipient = userMailT jRecipient $ do - (recipient@User{..}, Qualification{..}) <- liftHandler . runDB $ (,) - <$> getJust jRecipient - <*> getJust nQualification +dispatchNotificationQualificationExpired :: QualificationId -> UserId -> Handler () +dispatchNotificationQualificationExpired nQualification jRecipient = do + encRecipient :: CryptoUUIDUser <- encrypt jRecipient + dbRes <- runDB $ (,,) + <$> get jRecipient + <*> get nQualification + <*> getBy (UniqueQualificationUser nQualification jRecipient) - encRecipient :: CryptoUUIDUser <- liftHandler $ encrypt jRecipient - let entRecipient = Entity jRecipient recipient - qname = CI.original qualificationName - expiryDate <- fmap Just $ formatTimeUser SelFormatDate dExpired $ Just entRecipient - - $logDebugS "LMS" $ "Notify " <> tshow encRecipient <> " about expired qualification " <> qname - - replaceMailHeader "Auto-Submitted" $ Just "auto-generated" - setSubjectI $ MsgMailSubjectQualificationExpired qname - - editNotifications <- mkEditNotifications jRecipient - - addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/qualificationExpired.hamlet") + case dbRes of + ( Just User{..}, Just Qualification{..}, Just (Entity quId QualificationUser{..})) -> do + urender <- getUrlRender + let expDay = maybe qualificationUserValidUntil (min qualificationUserValidUntil . qualificationBlockedDay) qualificationUserBlockedDue + qname = CI.original qualificationName + qshort = CI.original qualificationShorthand + letter = LetterExpireQualificationF + { leqfHolderUUID = encRecipient + , leqfHolderID = jRecipient + , leqfHolderDN = userDisplayName + , leqfHolderSN = userSurname + , leqfExpiry = Just expDay + , leqfId = nQualification + , leqfName = qname + , leqfShort = qshort + , leqfSchool = qualificationSchool + , leqfUrl = pure . urender $ ForProfileDataR encRecipient + } + if expDay > utctDay qualificationUserLastNotified + then do + notifyOk <- sendEmailOrLetter jRecipient letter + if notifyOk + then do + now <- liftIO getCurrentTime + runDB $ update quId [QualificationUserLastNotified =. now] + $logInfoS "LMS" $ "Notified " <> tshow encRecipient <> " about expired qualification " <> qname + else + $logErrorS "LMS" $ "Failed to notify " <> tshow encRecipient <> " about expired qualification " <> qname + else $logErrorS "LMS" $ "Suppressed repeated notification " <> tshow encRecipient <> " about expired qualification " <> qname + _ -> $logErrorS "LMS" $ "Failed to notify " <> tshow encRecipient <> " about expired qualification " <> tshow nQualification -- NOTE: Renewal expects that LmsUser already exists for recipient @@ -75,7 +94,7 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do case query of (Just User{userDisplayName, userSurname}, Just Qualification{..}, Just (Entity _ QualificationUser{..}), Just(Entity luid LmsUser{..})) -> do let qname = CI.original qualificationName - let letter = LetterRenewQualificationF + letter = LetterRenewQualificationF { lmsLogin = lmsUserIdent , lmsPin = lmsUserPin , qualHolderID = jRecipient diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index 410a2d960..85fbaded8 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -142,7 +142,7 @@ data Notification | NotificationSubmissionUserCreated { nUser :: UserId, nSubmission :: SubmissionId } | NotificationSubmissionUserDeleted { nUser :: UserId, nSheet :: SheetId, nSubmission :: SubmissionId } | NotificationQualificationExpiry { nQualification :: QualificationId, nExpiry :: Day } - | NotificationQualificationExpired { nQualification :: QualificationId, nExpiry :: Day } + | NotificationQualificationExpired { nQualification :: QualificationId } | NotificationQualificationRenewal { nQualification :: QualificationId } deriving (Eq, Ord, Show, Read, Generic) diff --git a/src/Utils/Print.hs b/src/Utils/Print.hs index 4682e2296..c2a8d198d 100644 --- a/src/Utils/Print.hs +++ b/src/Utils/Print.hs @@ -305,8 +305,9 @@ sendEmailOrLetter recipient letter = do -- $logErrorS "LETTER" msg -- return False -- - -- (False, _) -> do -- send Email - -- if attachPDFLetter + -- (False, _) | attachPDFLetter letter -> do -- send Email, with pdf attached + -- (False, _) -> -- send Email, render letter directly to html + -- (True , postal) -> -- send printed letter -- let (preferPost, postal) = getPostalPreferenceAndAddress rcvrUsr -- mailBody <- getMailBody letter formatter diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index d165ed9fc..c26576ef1 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -691,23 +691,23 @@ fillDb = do qid_f <- insert' $ Qualification avn "F" "Vorfeldführerschein" f_descr (Just 24) (Just 6) (Just $ CalendarDiffDays 0 60) True (Just AvsLicenceVorfeld) $ Just "F4466" qid_r <- insert' $ Qualification avn "R" "Rollfeldführerschein" r_descr (Just 12) (Just 6) (Just $ CalendarDiffDays 2 3) False (Just AvsLicenceRollfeld) $ Just "R2801" qid_l <- insert' $ Qualification ifi "L" "Lehrbefähigung" l_descr Nothing (Just 6) Nothing True Nothing Nothing - void . insert' $ QualificationUser jost qid_f (n_day 9) (n_day $ -1) (n_day $ -22) (Just $ QualificationBlocked (n_day $ -5) "LMS") True -- TODO: better dates! - void . insert' $ QualificationUser jost qid_r (n_day 99) (n_day $ -11) (n_day $ -222) Nothing True -- TODO: better dates! - void . insert' $ QualificationUser jost qid_l (n_day 999) (n_day $ -111) (n_day $ -2222) Nothing True -- TODO: better dates! - void . insert' $ QualificationUser gkleen qid_f (n_day $ -3) (n_day $ -4) (n_day $ -20) Nothing True - void . insert' $ QualificationUser maxMuster qid_f (n_day 0) (n_day $ -2) (n_day $ -8) Nothing False - void . insert' $ QualificationUser svaupel qid_f (n_day 1) (n_day $ -1) (n_day $ -2) Nothing True - void . insert' $ QualificationUser sbarth qid_f (n_day 400) (n_day $ -40) (n_day $ -1200) Nothing True - void . insert' $ QualificationUser tinaTester qid_f (n_day 3) (n_day $ -60) (n_day $ -250) (Just $ QualificationBlocked (n_day $ -7) "Some long explanation for the block!") False - void . insert' $ QualificationUser tinaTester qid_r (n_day 3) (n_day $ -60) (n_day $ -250) Nothing False - void . insert' $ QualificationUser gkleen qid_r (n_day $ -7) (n_day $ -2) (n_day $ -9) Nothing True - void . insert' $ QualificationUser maxMuster qid_r (n_day 1) (n_day $ -1) (n_day $ -2) Nothing False - -- void . insert' $ QualificationUser fhamann qid_r (n_day $ -3) (n_day $ -1) (n_day $ -2) Nothing True - void . insert' $ QualificationUser svaupel qid_l (n_day 1) (n_day $ -1) (n_day $ -2) Nothing True - void . insert' $ QualificationUser gkleen qid_l (n_day 9) (n_day $ -1) (n_day $ -7) Nothing True + void . insert' $ QualificationUser jost qid_f (n_day 9) (n_day $ -1) (n_day $ -22) (Just $ QualificationBlocked (n_day $ -5) "LMS") True (n_day' $ -9) -- TODO: better dates! + void . insert' $ QualificationUser jost qid_r (n_day 99) (n_day $ -11) (n_day $ -222) Nothing True (n_day' $ -9) -- TODO: better dates! + void . insert' $ QualificationUser jost qid_l (n_day 999) (n_day $ -111) (n_day $ -2222) Nothing True (n_day' $ -9) -- TODO: better dates! + void . insert' $ QualificationUser gkleen qid_f (n_day $ -3) (n_day $ -4) (n_day $ -20) Nothing True (n_day' $ -9) + void . insert' $ QualificationUser maxMuster qid_f (n_day 0) (n_day $ -2) (n_day $ -8) Nothing False (n_day' $ -1) + void . insert' $ QualificationUser svaupel qid_f (n_day 1) (n_day $ -1) (n_day $ -2) Nothing True (n_day' $ -9) + void . insert' $ QualificationUser sbarth qid_f (n_day 400) (n_day $ -40) (n_day $ -1200) Nothing True (n_day' $ -2) + void . insert' $ QualificationUser tinaTester qid_f (n_day 3) (n_day $ -60) (n_day $ -250) (Just $ QualificationBlocked (n_day $ -7) "Some long explanation for the block!") False (n_day' $ -9) + void . insert' $ QualificationUser tinaTester qid_r (n_day 3) (n_day $ -60) (n_day $ -250) Nothing False (n_day' $ -3) + void . insert' $ QualificationUser gkleen qid_r (n_day $ -7) (n_day $ -2) (n_day $ -9) Nothing True (n_day' $ -4) + void . insert' $ QualificationUser maxMuster qid_r (n_day 1) (n_day $ -1) (n_day $ -2) Nothing False (n_day' $ -6) + -- void . insert' $ QualificationUser fhamann qid_r (n_day $ -3) (n_day $ -1) (n_day $ -2) Nothing True (n_day' $ -9) + void . insert' $ QualificationUser svaupel qid_l (n_day 1) (n_day $ -1) (n_day $ -2) Nothing True (n_day' $ -7) + void . insert' $ QualificationUser gkleen qid_l (n_day 9) (n_day $ -1) (n_day $ -7) Nothing True (n_day' $ -8) qidfUsers <- Set.fromAscList . fmap (qualificationUserUser . entityVal) <$> selectList [QualificationUserQualification ==. qid_f] [Asc QualificationUserUser] - insertMany_ [QualificationUser uid qid_f (n_day 42) (n_day $ -42) (n_day $ -365) Nothing True | Entity uid _ <- take 200 matUsers, uid `Set.notMember` qidfUsers] + insertMany_ [QualificationUser uid qid_f (n_day 42) (n_day $ -42) (n_day $ -365) Nothing True (n_day' $ -11)| Entity uid _ <- take 200 matUsers, uid `Set.notMember` qidfUsers] void . insert' $ LmsResult qid_f (LmsIdent "hijklmn") (n_day (-1)) now void . insert' $ LmsResult qid_f (LmsIdent "opqgrs" ) (n_day (-2)) now void . insert' $ LmsResult qid_f (LmsIdent "pqgrst" ) (n_day (-3)) now