refactor(lms): send user notifications only after lms acknowleged e-learning
This commit is contained in:
Steffen Jost
parent
4419245e17
commit
bd539358bd
@ -23,12 +23,14 @@ TableLmsDelete: Löschen?
|
||||
TableLmsStaff: Interner Mitarbeiter?
|
||||
TableLmsStarted: Begonnen
|
||||
TableLmsReceived: Letzte Rückmeldung
|
||||
TableLmsNotified: Versand Benachrichtigung
|
||||
TableLmsEnded: Beended
|
||||
TableLmsStatus: Status E-Lernen
|
||||
TableLmsSuccess: Bestanden
|
||||
TableLmsFailed: Gesperrt
|
||||
FilterLmsValid: Aktuell gültig
|
||||
FilterLmsRenewal: Erneuerung anstehend
|
||||
FilterLmsNotified: Benachrichtigt
|
||||
CsvColumnLmsIdent: E-Lernen Identifikator, einzigartig pro Qualifikation und Teilnehmer
|
||||
CsvColumnLmsPin: PIN des E-Lernen Zugangs
|
||||
CsvColumnLmsResetPin: Wird die PIN bei der nächsten Synchronisation zurückgesetzt?
|
||||
|
||||
@ -23,12 +23,14 @@ TableLmsDelete: Delete?
|
||||
TableLmsStaff: Staff?
|
||||
TableLmsStarted: Started
|
||||
TableLmsReceived: Last update
|
||||
TableLmsNotified: Notification sent
|
||||
TableLmsEnded: Ended
|
||||
TableLmsStatus: Status e-learning
|
||||
TableLmsSuccess: Completed
|
||||
TableLmsFailed: Blocked
|
||||
FilterLmsValid: Currently valid
|
||||
FilterLmsRenewal: Renewal due
|
||||
FilterLmsNotified: Notified
|
||||
CsvColumnLmsIdent: E-learning identifier, unique for each qualification and user
|
||||
CsvColumnLmsPin: PIN for e-learning access
|
||||
CsvColumnLmsResetPin: Will the e-learning PIN be reset upon next synchronisation?
|
||||
|
||||
@ -100,6 +100,7 @@ LmsUser
|
||||
--toDelete encoded by Handler.Utils.LMS.lmsUserToDelete
|
||||
started UTCTime default=now()
|
||||
received UTCTime Maybe -- last acknowledgement by LMS
|
||||
notified UTCTime Maybe -- last notified by FRADrive
|
||||
ended UTCTime Maybe -- ident was deleted from LMS
|
||||
-- Primary ident -- newtype Key LmsUserId = LmsUserKey { unLmsUser :: Text } -- change LmsIdent -> Text. Do we want this?
|
||||
UniqueLmsIdent ident -- idents must be unique accross all qualifications, since idents are global within LMS!
|
||||
|
||||
@ -343,6 +343,7 @@ mkLmsTable (Entity qid quali) acts restrict cols psValidator = do
|
||||
, single ("lms-started" , SortColumn $ queryLmsUser >>> (E.?. LmsUserStarted))
|
||||
, single ("lms-datepin" , SortColumn $ queryLmsUser >>> (E.?. LmsUserDatePin))
|
||||
, single ("lms-received", SortColumn $ queryLmsUser >>> (E.?. LmsUserReceived))
|
||||
, single ("lms-notified", SortColumn $ queryLmsUser >>> (E.?. LmsUserNotified))
|
||||
, single ("lms-ended" , SortColumn $ queryLmsUser >>> (E.?. LmsUserEnded))
|
||||
]
|
||||
dbtFilter = mconcat
|
||||
@ -356,12 +357,19 @@ mkLmsTable (Entity qid quali) acts restrict cols psValidator = do
|
||||
E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday
|
||||
| otherwise -> E.true
|
||||
)
|
||||
, single ("lms-notified", FilterColumn $ \(view (to queryLmsUser) -> luser) criterion ->
|
||||
case getLast criterion of
|
||||
Just True -> E.isJust $ luser E.?. LmsUserNotified
|
||||
Just False -> E.isNothing $ luser E.?. LmsUserNotified
|
||||
Nothing -> E.true
|
||||
)
|
||||
]
|
||||
dbtFilterUI mPrev = mconcat
|
||||
[ fltrUserNameEmailHdrUI MsgLmsUser mPrev
|
||||
, prismAForm (singletonFilter "lms-ident" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent)
|
||||
, prismAForm (singletonFilter "lms-ident" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent)
|
||||
-- , prismAForm (singletonFilter "lms-status" . maybePrism _PathPiece) mPrev $ aopt (selectField' (Just $ SomeMessage MsgTableNoFilter) $ return (optionsPairs [(MsgTableLmsSuccess,"success"::Text),(MsgTableLmsFailed,"blocked")])) (fslI MsgTableLmsStatus)
|
||||
, prismAForm (singletonFilter "validity" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid)
|
||||
, prismAForm (singletonFilter "validity" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid)
|
||||
, prismAForm (singletonFilter "lms-notified" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsNotified)
|
||||
, if isNothing mbRenewal then mempty
|
||||
else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal)
|
||||
]
|
||||
@ -446,6 +454,7 @@ postLmsR sid qsh = do
|
||||
, sortable (Just "lms-started") (i18nLms MsgTableLmsStarted) $ \(preview $ resultLmsUser . _entityVal . _lmsUserStarted -> d) -> foldMap dateTimeCell d
|
||||
, sortable (Just "lms-datepin") (i18nLms MsgTableLmsDatePin) $ \(preview $ resultLmsUser . _entityVal . _lmsUserDatePin -> d) -> foldMap dateTimeCell d
|
||||
, sortable (Just "lms-received") (i18nLms MsgTableLmsReceived) $ \(preview $ resultLmsUser . _entityVal . _lmsUserReceived -> d) -> foldMap dateTimeCell $ join d
|
||||
, sortable (Just "lms-notified") (i18nLms MsgTableLmsNotified) $ \(preview $ resultLmsUser . _entityVal . _lmsUserNotified -> d) -> foldMap dateTimeCell $ join d
|
||||
, sortable (Just "lms-ended") (i18nLms MsgTableLmsEnded) $ \(preview $ resultLmsUser . _entityVal . _lmsUserEnded -> d) -> foldMap dateTimeCell $ join d
|
||||
]
|
||||
where
|
||||
|
||||
@ -23,17 +23,20 @@ import Handler.Utils.LMS (randomLMSIdent, randomLMSpw, maxLmsUserIdentRetries)
|
||||
|
||||
|
||||
dispatchJobLmsQualificationsEnqueue :: JobHandler UniWorX
|
||||
dispatchJobLmsQualificationsEnqueue = JobHandlerAtomic act
|
||||
where
|
||||
act :: YesodJobDB UniWorX ()
|
||||
act = do
|
||||
qids <- E.select $ do
|
||||
q <- E.from $ E.table @Qualification
|
||||
E.where_ $ E.isJust (q E.^. QualificationRefreshWithin)
|
||||
-- E.&&. q E.^. QualificationElearningStart -- checked later, since we need to send out notifications regardless
|
||||
pure $ q E.^. QualificationId
|
||||
forM_ qids $ \(E.unValue -> qid) ->
|
||||
queueDBJob $ JobLmsEnqueue qid
|
||||
dispatchJobLmsQualificationsEnqueue = JobHandlerAtomic $ fetchRefreshQualifications JobLmsEnqueue
|
||||
|
||||
dispatchJobLmsQualificationsDequeue :: JobHandler UniWorX
|
||||
dispatchJobLmsQualificationsDequeue = JobHandlerAtomic $ fetchRefreshQualifications JobLmsDequeue
|
||||
|
||||
-- execute given job for all qualifications that allow refreshs
|
||||
fetchRefreshQualifications :: (QualificationId -> Job) -> YesodJobDB UniWorX ()
|
||||
fetchRefreshQualifications qidJob = do
|
||||
qids <- E.select $ do
|
||||
q <- E.from $ E.table @Qualification
|
||||
E.where_ $ E.isJust (q E.^. QualificationRefreshWithin)
|
||||
pure $ q E.^. QualificationId
|
||||
forM_ qids $ \(E.unValue -> qid) ->
|
||||
queueDBJob $ qidJob qid
|
||||
|
||||
|
||||
-- | enlist expiring qualification holders to e-learning
|
||||
@ -43,7 +46,7 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act
|
||||
where
|
||||
-- act :: YesodJobDB UniWorX ()
|
||||
act = do
|
||||
$logInfoS "lms" $ "Start e-learning users for qualification " <> tshow qid <> "."
|
||||
$logInfoS "lms" $ "Notifying about exipiring qualification " <> tshow qid <> "."
|
||||
quali <- getJust qid -- may throw an error, aborting the job
|
||||
now <- liftIO getCurrentTime
|
||||
case qualificationRefreshWithin quali of
|
||||
@ -94,6 +97,7 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act
|
||||
, lmsUserStatus = Nothing
|
||||
, lmsUserStarted = now
|
||||
, lmsUserReceived = Nothing
|
||||
, lmsUserNotified = Nothing
|
||||
, lmsUserEnded = Nothing
|
||||
}
|
||||
-- startLmsUser :: YesodJobDB UniWorX (Maybe (Entity LmsUser))
|
||||
@ -101,41 +105,27 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act
|
||||
inserted <- untilJustMaxM maxLmsUserIdentRetries startLmsUser
|
||||
case inserted of
|
||||
Nothing -> $logErrorS "LMS" $ "Generating and inserting fresh LmsIdent failed for uid " <> tshow uid <> " and qid " <> tshow qid <> "!"
|
||||
(Just _) -> queueDBJob JobSendNotification { jRecipient = uid, jNotification =
|
||||
NotificationQualificationRenewal { nQualification = qid }
|
||||
}
|
||||
(Just _) -> return () -- lmsUser started, but not yet notified
|
||||
|
||||
|
||||
dispatchJobLmsQualificationsDequeue :: JobHandler UniWorX
|
||||
dispatchJobLmsQualificationsDequeue = JobHandlerAtomic act
|
||||
where
|
||||
act :: YesodJobDB UniWorX ()
|
||||
act = do
|
||||
qids <- E.select $ do
|
||||
q <- E.from $ E.table @Qualification
|
||||
E.where_ $ E.isJust (q E.^. QualificationRefreshWithin)
|
||||
-- E.&&. q E.^. QualificationElearningStart -- checked later, since we need to send out notifications regardless
|
||||
pure $ q E.^. QualificationId
|
||||
forM_ qids $ \(E.unValue -> qid) ->
|
||||
queueDBJob $ JobLmsEnqueue qid
|
||||
|
||||
-- process all received input and renew qualifications
|
||||
dispatchJobLmsDequeue :: QualificationId -> JobHandler UniWorX
|
||||
dispatchJobLmsDequeue qid = JobHandlerAtomic act
|
||||
-- wenn bestanden: qualification verlängern
|
||||
-- wenn Aufbewahrungszeit abgelaufen: LmsIdent löschen (verhindert verfrühten neustart)
|
||||
where
|
||||
act = do
|
||||
$logInfoS "lms" $ "Process e-learning results for qualification " <> tshow qid <> "."
|
||||
$logInfoS "lms" $ "Processing e-learning results for qualification " <> tshow qid <> "."
|
||||
quali <- getJust qid -- may throw an error, aborting the job
|
||||
case qualificationRefreshWithin quali of
|
||||
Nothing -> return () -- no automatic scheduling for this qid
|
||||
Nothing -> return () -- no automatic scheduling for this qid (usually job is not scheduled for these qualifications, see above)
|
||||
(Just renewalPeriod) -> do
|
||||
now_day <- utctDay <$> liftIO getCurrentTime
|
||||
let renewalDate = addGregorianDurationClip renewalPeriod now_day
|
||||
|
||||
-- CONTINUE HERE:
|
||||
-- CONTINUE HERE: TODO
|
||||
-- select users that need renewal due to success
|
||||
-- delete users after audit period has expired
|
||||
-- delete users after audit period has expired!!!
|
||||
|
||||
renewalUsers <- E.select $ do
|
||||
(quser E.:& luser) <- E.from $ E.table @QualificationUser `E.innerJoin` E.table @LmsUser
|
||||
@ -150,7 +140,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
|
||||
pure (quser, luser)
|
||||
let usr_job (quser, luser) =
|
||||
let vold = quser ^. _entityVal . _qualificationUserValidUntil
|
||||
pmonth = fromMonths $ fromMaybe 0 $ qualificationValidDuration quali -- TODO: decide how to deal with qualification that have infinite validity?!
|
||||
pmonth = fromMonths $ fromMaybe 0 $ qualificationValidDuration quali -- TODO: decide how to deal with qualifications that have infinite validity?!
|
||||
vnew = addGregorianDurationClip pmonth vold
|
||||
lmsstatus = luser ^. _entityVal . _lmsUserStatus
|
||||
in case lmsstatus of
|
||||
@ -159,6 +149,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
|
||||
forM_ renewalUsers usr_job
|
||||
|
||||
|
||||
-- just processes received input, but does not affect any exisitng qualifications yet
|
||||
dispatchJobLmsResults :: QualificationId -> JobHandler UniWorX
|
||||
dispatchJobLmsResults qid = JobHandlerAtomic act
|
||||
where
|
||||
@ -192,11 +183,13 @@ dispatchJobLmsResults qid = JobHandlerAtomic act
|
||||
delete lrid
|
||||
$logInfoS "LmsResult" [st|Processed #{tshow (length results)} LMS results|]
|
||||
|
||||
|
||||
-- just processes received input, but does not affect any exisitng qualifications yet
|
||||
dispatchJobLmsUserlist :: QualificationId -> JobHandler UniWorX
|
||||
dispatchJobLmsUserlist qid = JobHandlerAtomic act
|
||||
where
|
||||
-- act :: YesodJobDB UniWorX ()
|
||||
act = hoist lift $ do
|
||||
act :: YesodJobDB UniWorX ()
|
||||
act = do
|
||||
now <- liftIO getCurrentTime
|
||||
-- result :: [(Entity LmsUser, Entity LmsUserlist)]
|
||||
results <- E.select $ do
|
||||
@ -209,12 +202,17 @@ dispatchJobLmsUserlist qid = JobHandlerAtomic act
|
||||
return (luser, lulist)
|
||||
forM_ results $ \case
|
||||
(Entity luid luser, Nothing)
|
||||
| isJust $ lmsUserReceived luser
|
||||
| isJust $ lmsUserReceived luser -- mark all unreported users as ended
|
||||
, isNothing $ lmsUserEnded luser ->
|
||||
update luid [LmsUserEnded =. Just now]
|
||||
| otherwise -> return () -- likely not yet started
|
||||
| otherwise -> return () -- users likely not yet started
|
||||
|
||||
(Entity luid luser, Just (Entity lulid lulist)) -> do
|
||||
when (isNothing $ lmsUserNotified luser) $ -- notify users that lms is available
|
||||
queueDBJob JobSendNotification
|
||||
{ jRecipient = lmsUserUser luser
|
||||
, jNotification = NotificationQualificationRenewal { nQualification = qid }
|
||||
}
|
||||
let lReceived = lmsUserlistTimestamp lulist
|
||||
isBlocked = lmsUserlistFailed lulist
|
||||
newStatus = LmsBlocked $ utctDay lReceived
|
||||
|
||||
@ -49,7 +49,7 @@ dispatchNotificationQualificationExpiry nQualification _nExpiry jRecipient = use
|
||||
-- NOTE: qualificationRenewal expects that LmsUser already exists for recipient
|
||||
dispatchNotificationQualificationRenewal :: QualificationId -> UserId -> Handler ()
|
||||
dispatchNotificationQualificationRenewal nQualification jRecipient = do
|
||||
(recipient@User{..}, Qualification{..}, Entity _ QualificationUser{..}, Entity _ LmsUser{..}) <- runDB $ (,,,)
|
||||
(recipient@User{..}, Qualification{..}, Entity _ QualificationUser{..}, Entity luid LmsUser{..}) <- runDB $ (,,,)
|
||||
<$> getJust jRecipient
|
||||
<*> getJust nQualification
|
||||
<*> getJustBy (UniqueQualificationUser nQualification jRecipient)
|
||||
@ -120,5 +120,9 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do
|
||||
|
||||
editNotifications <- mkEditNotifications jRecipient
|
||||
addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/qualificationRenewal.hamlet")
|
||||
-- if we reach the end, mark the user as notified
|
||||
-- TODO: defer this until the print job is marked as sent?
|
||||
runDB $
|
||||
update luid [ LmsUserNotified =. Just now]
|
||||
|
||||
|
||||
@ -522,11 +522,11 @@ fillDb = do
|
||||
void . insert' $ LmsUserlist qid_f (LmsIdent "hijklmn") False now
|
||||
void . insert' $ LmsUserlist qid_f (LmsIdent "abcdefg") True now
|
||||
void . insert' $ LmsUserlist qid_f (LmsIdent "ijk" ) False now
|
||||
void . insert' $ LmsUser qid_f jost (LmsIdent "ijk" ) "123" False now Nothing now Nothing Nothing
|
||||
void . insert' $ LmsUser qid_f svaupel (LmsIdent "abcdefg") "abc" False now (Just $ LmsSuccess $ n_day 1) now (Just now) Nothing
|
||||
void . insert' $ LmsUser qid_f gkleen (LmsIdent "hijklmn") "@#!" True now (Just $ LmsBlocked $ utctDay now) now (Just now) Nothing
|
||||
void . insert' $ LmsUser qid_f tinaTester (LmsIdent "qwvu") "45678" True now (Just $ LmsSuccess $ n_day (-2)) now Nothing Nothing
|
||||
void . insert' $ LmsUser qid_f maxMuster (LmsIdent "xyz") "a1b2c3" False now (Just $ LmsBlocked $ n_day (-1)) now (Just $ n_day' (-2)) (Just $ n_day' (-1))
|
||||
void . insert' $ LmsUser qid_f jost (LmsIdent "ijk" ) "123" False now Nothing now Nothing Nothing Nothing
|
||||
void . insert' $ LmsUser qid_f svaupel (LmsIdent "abcdefg") "abc" False now (Just $ LmsSuccess $ n_day 1) now (Just now) Nothing Nothing
|
||||
void . insert' $ LmsUser qid_f gkleen (LmsIdent "hijklmn") "@#!" True now (Just $ LmsBlocked $ utctDay now) now (Just now) Nothing Nothing
|
||||
void . insert' $ LmsUser qid_f tinaTester (LmsIdent "qwvu") "45678" True now (Just $ LmsSuccess $ n_day (-2)) now Nothing (Just $ n_day' (-1)) Nothing
|
||||
void . insert' $ LmsUser qid_f maxMuster (LmsIdent "xyz") "a1b2c3" False now (Just $ LmsBlocked $ n_day (-1)) now (Just $ n_day' (-2)) (Just $ n_day' (-2)) (Just $ n_day' (-1))
|
||||
|
||||
void . insert $ PrintJob "TestJob1" "job1" "No Text herein." (n_day' (-1)) Nothing Nothing (Just svaupel) Nothing (Just qid_f)
|
||||
void . insert $ PrintJob "TestJob2" "job2" "No Text herein." (n_day' (-1)) Nothing (Just jost) (Just svaupel) Nothing (Just qid_f)
|
||||
|
||||
Reference in New Issue
Block a user