refactor(qualifications): notification mechanic tied to button only for all invalid qualifications
This commit is contained in:
parent
539593fe2d
commit
4c5ce11b09
@ -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?
|
||||
|
||||
@ -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?
|
||||
|
||||
@ -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
|
||||
|
||||
@ -131,6 +131,7 @@ fakeQualificationUsers (Entity qid Qualification{qualificationRefreshWithin}) (u
|
||||
qualificationUserLastRefresh = qualificationUserFirstHeld
|
||||
qualificationUserBlockedDue = Nothing
|
||||
qualificationUserScheduleRenewal = True
|
||||
qualificationUserLastNotified = now
|
||||
_ <- upsert QualificationUser{..}
|
||||
[ QualificationUserValidUntil =. qualificationUserValidUntil
|
||||
, QualificationUserLastRefresh =. qualificationUserLastRefresh
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
, ..
|
||||
}
|
||||
(
|
||||
|
||||
@ -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 ]
|
||||
|
||||
@ -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|]
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user