chore(qualifications): show qualifications on user profile page and send expired notifications
This commit is contained in:
Steffen Jost
parent
24837ec8ae
commit
86b5f0f175
@ -13,6 +13,7 @@ LmsQualificationValidUntil: Gültig bis
|
||||
TableQualificationLastRefresh: Zuletzt erneuert
|
||||
TableQualificationFirstHeld: Erstmalig
|
||||
TableQualificationBlockedDue: Suspendiert
|
||||
TableQualificationBlockedTooltip: Wann wurde die Qualifikation vorübergehend außer Kraft gesetzt und wer hat das veranlasst?
|
||||
LmsUser: Inhaber
|
||||
TableLmsEmail: E-Mail
|
||||
TableLmsIdent: Identifikation
|
||||
@ -49,8 +50,10 @@ LmsDirectUpload: Direkter Upload für automatisierte Systeme
|
||||
LmsErrorNoRefreshElearning: Fehler: E-Lernen wird nicht automatisch gestartet, da die Zeitspanne für den Erneurerungszeitraum nicht festgelegt wurde.
|
||||
MailSubjectQualificationRenewal qname@Text: Qualifikation #{qname} muss demnächst erneuert werden
|
||||
MailSubjectQualificationExpiry qname@Text: Qualifikation #{qname} läuft demnächst ab
|
||||
MailSubjectQualificationExpired qname@Text: Qualifikation #{qname} ist ab sofort ungültig
|
||||
MailBodyQualificationRenewal: Sie müssen diese Qualifikaton demnächst durch einen E-Lernen Kurs erneuern.
|
||||
MailBodyQualificationExpiry: Diese Qualifikaton läuft bald ab. Tätigkeiten, welche diese Qualifikation voraussetzen dürfen dann nicht länger ausgeübt werden!
|
||||
MailBodyQualificationExpired: Diese Qualifikaton is nun abgelaufen. Tätigkeiten, welche diese Qualifikation voraussetzen dürfen ab sofort nicht länger ausgeübt werden! Es ist möglich, dass die Qualifikation vorzeit ungültig wurde, z.B. wegen erfolgloser Teilnahme an einem verpflichtendem E-Lernen.
|
||||
LmsRenewalInstructions: Anweisungen zur Verlängerung finden Sie im angehängten PDF. Um Missbrauch zu verhindern wurde das PDF dem von Ihnen in FRADrive hinterlegten PDF-Passwort verschlüsselt. Falls kein PDF-Passwort hinterlegt wurde, ist das PDF-Passwort Ihre Fraport Ausweisnummer, inklusive Punkt und der Ziffer danach.
|
||||
LmsNoRenewal: Leider kann diese Qualifikation nicht alleine durch E-Lernen verlängert werden.
|
||||
LmsActNotify: Benachrichtigung E-Lernen erneut per Post oder E-Mail versenden
|
||||
|
||||
@ -13,6 +13,7 @@ LmsQualificationValidUntil: Valid until
|
||||
TableQualificationLastRefresh: Last renewed
|
||||
TableQualificationFirstHeld: First held
|
||||
TableQualificationBlockedDue: Suspended
|
||||
TableQualificationBlockedTooltip: When was the qualification temporarily suspended and who requested this?
|
||||
LmsUser: Licensee
|
||||
TableLmsEmail: Email
|
||||
TableLmsIdent: Identifier
|
||||
@ -49,8 +50,10 @@ LmsDirectUpload: Direct upload for automated Systems
|
||||
LmsErrorNoRefreshElearning: Error: E-learning will not be started automatically due to refresh-within time period not being set.
|
||||
MailSubjectQualificationRenewal qname@Text: Qualification #{qname} must be renewed shortly
|
||||
MailSubjectQualificationExpiry qname@Text: Qualification #{qname} expires soon
|
||||
MailSubjectQualificationExpired qname@Text: Qualification #{qname} is no longer valid
|
||||
MailBodyQualificationRenewal: You will soon need to renew this qualficiation by completing an e-learning course.
|
||||
MailBodyQualificationExpiry: This qualificaton expires soon. You may then no longer execute any duties that require this qualification as a precondition!
|
||||
MailBodyQualificationExpired: This qualificaton is now expired. You may no longer execute any duties that require this qualification as a precondition! It is possible that the qualification expired prematurely, e.g. due to a failed compulsory e-learning.
|
||||
LmsRenewalInstructions: Instruction on how to accomplish the renewal are enclosed in the attached PDF. In order to avoid misuse, the PDF is encrypted with your chosen FRADrive PDF-Password. If you have not yet chosen a PDF-Password yet, then the password is your Fraport id card number, inkluding the punctuation mark and the Digit thereafter.
|
||||
LmsNoRenewal: Unfortunately, this particular qualification cannot be renewed through E-learning only.
|
||||
LmsActNotify: Resend e-learning notification by post or email
|
||||
|
||||
@ -14,6 +14,7 @@ ProfileTutorialParticipations: Tutorien
|
||||
ProfileSubmissionGroups: Abgabegruppen
|
||||
ProfileSubmissions: Abgaben
|
||||
ProfileRemark: Hinweis
|
||||
ProfileQualifications: Eigene Qualifikationen
|
||||
PersonalInfoExamAchievementsWip: Die Anzeige von Prüfungsergebnissen wird momentan an dieser Stelle leider noch nicht unterstützt.
|
||||
PersonalInfoOwnTutorialsWip: Die Anzeige von Tutorien, zu denen Sie als Tutor eingetragen sind wird momentan an dieser Stelle leider noch nicht unterstützt.
|
||||
PersonalInfoTutorialsWip: Die Anzeige von Tutorien, zu denen Sie angemeldet sind wird momentan an dieser Stelle leider noch nicht unterstützt.
|
||||
|
||||
@ -14,6 +14,7 @@ ProfileTutorialParticipations: Tutorials
|
||||
ProfileSubmissionGroups: Submission groups
|
||||
ProfileSubmissions: Submissions
|
||||
ProfileRemark: Remarks
|
||||
ProfileQualifications: Owned Qualifications
|
||||
PersonalInfoExamAchievementsWip: The feature to display your exam achievements has not yet been implemented.
|
||||
PersonalInfoOwnTutorialsWip: The feature to display tutorials you have been assigned to as tutor has not yet been implemented.
|
||||
PersonalInfoTutorialsWip: The feature to display tutorials you have registered for has not yet been implemented.
|
||||
|
||||
@ -115,7 +115,7 @@ LmsUserlist
|
||||
failed Bool
|
||||
timestamp UTCTime default=now()
|
||||
UniqueLmsUserlist qualification ident
|
||||
deriving Generic
|
||||
deriving Generic Show
|
||||
|
||||
-- LmsResult stores LMS upload for later processing only
|
||||
LmsResult
|
||||
|
||||
@ -252,7 +252,7 @@ makeFoundation appSettings''@AppSettings{..} = do
|
||||
|
||||
runAppLoggingT tempFoundation $ do
|
||||
$logInfoS "InstanceID" $ UUID.toText appInstanceID
|
||||
$logDebugS "Configuration" $ tshowCrop appSettings''
|
||||
$logInfoS "Configuration" $ tshowCrop appSettings''
|
||||
$logDebugS "RTSFlags" . tshow =<< liftIO getRTSFlags
|
||||
|
||||
smtpPool <- for appSmtpConf $ \c -> do
|
||||
|
||||
@ -352,10 +352,10 @@ mkLmsTable (Entity qid quali) acts restrict cols psValidator = do
|
||||
dbtSorting = mconcat
|
||||
[ single $ sortUserNameLink queryUser
|
||||
, single $ sortUserEmail queryUser
|
||||
, single ("blocked-due" , SortColumn $ queryQualUser >>> (E.^. QualificationUserBlockedDue))
|
||||
, single ("valid-until" , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil))
|
||||
, single ("last-refresh", SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh))
|
||||
, single ("first-held" , SortColumn $ queryQualUser >>> (E.^. QualificationUserFirstHeld))
|
||||
, single ("blocked-due" , SortColumn $ queryQualUser >>> (E.^. QualificationUserBlockedDue))
|
||||
, single ("first-held" , SortColumn $ queryQualUser >>> (E.^. QualificationUserFirstHeld))
|
||||
, single ("lms-ident" , SortColumn $ queryLmsUser >>> (E.?. LmsUserIdent))
|
||||
, single ("lms-status" , SortColumn $ views (to queryLmsUser) (E.?. LmsUserStatus))
|
||||
, single ("lms-started" , SortColumn $ queryLmsUser >>> (E.?. LmsUserStarted))
|
||||
@ -477,7 +477,8 @@ postLmsR sid qsh = do
|
||||
, sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \( view $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> dayCell d
|
||||
, sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d
|
||||
, sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d
|
||||
, sortable (Just "blocked-due") (i18nCell MsgTableQualificationBlockedDue) $ \( view $ resultQualUser . _entityVal . _qualificationUserBlockedDue -> b) -> qualificationBlockedCell b
|
||||
, sortable (Just "blocked-due") (i18nCell MsgTableQualificationBlockedDue & cellTooltip MsgTableQualificationBlockedTooltip
|
||||
) $ \( view $ resultQualUser . _entityVal . _qualificationUserBlockedDue -> b) -> qualificationBlockedCell b
|
||||
, sortable (Just "lms-ident") (i18nLms MsgTableLmsIdent) $ \(preview $ resultLmsUser . _entityVal . _lmsUserIdent . _getLmsIdent -> lid) -> foldMap textCell lid
|
||||
, sortable (Just "lms-status") (i18nLms MsgTableLmsStatus) $ \(preview $ resultLmsUser . _entityVal . _lmsUserStatus -> status) -> foldMap lmsStatusCell $ join status
|
||||
, sortable (Just "lms-started") (i18nLms MsgTableLmsStarted) $ \(preview $ resultLmsUser . _entityVal . _lmsUserStarted -> d) -> foldMap dateTimeCell d
|
||||
|
||||
@ -647,6 +647,7 @@ makeProfileData (Entity uid User{..}) = do
|
||||
submissionTable <- mkSubmissionTable uid -- Tabelle mit allen Abgaben und Abgabe-Gruppen
|
||||
submissionGroupTable <- mkSubmissionGroupTable uid -- Tabelle mit allen Abgabegruppen
|
||||
correctionsTable <- mkCorrectionsTable uid -- Tabelle mit allen Korrektor-Aufgaben
|
||||
qualificationsTable <- mkQualificationsTable uid -- Tabelle mit allen Qualifikationen
|
||||
let examTable, ownTutorialTable, tutorialTable :: Widget
|
||||
examTable = i18n MsgPersonalInfoExamAchievementsWip
|
||||
ownTutorialTable = i18n MsgPersonalInfoOwnTutorialsWip
|
||||
@ -978,6 +979,52 @@ mkCorrectionsTable =
|
||||
in dbTableWidget' validator DBTable{..}
|
||||
|
||||
|
||||
|
||||
-- | Table listing all qualifications that the given user is enrolled in
|
||||
mkQualificationsTable :: UserId -> DB Widget
|
||||
mkQualificationsTable =
|
||||
let withType :: ((E.SqlExpr (Entity Qualification) `E.InnerJoin` E.SqlExpr (Entity QualificationUser)) -> a)
|
||||
-> ((E.SqlExpr (Entity Qualification) `E.InnerJoin` E.SqlExpr (Entity QualificationUser)) -> a)
|
||||
withType = id
|
||||
|
||||
validator = def -- TODO & defaultSorting [SortDescBy "valid-until"]
|
||||
|
||||
in \uid -> dbTableWidget' validator
|
||||
DBTable
|
||||
{ dbtIdent = "userQualifications" :: Text
|
||||
, dbtSQLQuery = \(quali `E.InnerJoin` quser) -> do
|
||||
E.on $ quali E.^. QualificationId E.==. quser E.^. QualificationUserQualification
|
||||
E.where_ $ quser E.^. QualificationUserUser E.==. E.val uid
|
||||
return (quali, quser)
|
||||
, dbtRowKey = \(_quali `E.InnerJoin` quser) -> quser E.^. QualificationUserId
|
||||
, dbtProj = dbtProjId
|
||||
, dbtColonnade = mconcat
|
||||
[ colSchool (_dbrOutput . _1 . _entityVal . _qualificationSchool)
|
||||
, sortable (Just "quali") (i18nCell MsgQualificationName) $ qualificationCell <$> view (_dbrOutput . _1 . _entityVal)
|
||||
, sortable (Just "blocked-due") (i18nCell MsgTableQualificationBlockedDue & cellTooltip MsgTableQualificationBlockedTooltip
|
||||
) $ qualificationBlockedCell <$> view (_dbrOutput . _2 . _entityVal . _qualificationUserBlockedDue )
|
||||
, sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ dayCell <$> view (_dbrOutput . _2 . _entityVal . _qualificationUserValidUntil )
|
||||
, sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh) $ dayCell <$> view (_dbrOutput . _2 . _entityVal . _qualificationUserLastRefresh)
|
||||
, sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ dayCell <$> view (_dbrOutput . _2 . _entityVal . _qualificationUserFirstHeld )
|
||||
]
|
||||
, dbtSorting = mconcat
|
||||
[ sortSchool $ to (\(quali `E.InnerJoin` _) -> quali E.^. QualificationSchool)
|
||||
, singletonMap "quali" $ SortColumn $ withType $ \(quali `E.InnerJoin` _) -> quali E.^. QualificationName
|
||||
, singletonMap "blocked-due" $ SortColumn $ withType $ \(_ `E.InnerJoin` quser) -> quser E.^. QualificationUserBlockedDue
|
||||
, singletonMap "valid-until" $ SortColumn $ withType $ \(_ `E.InnerJoin` quser) -> quser E.^. QualificationUserValidUntil
|
||||
, singletonMap "last-refresh" $ SortColumn $ withType $ \(_ `E.InnerJoin` quser) -> quser E.^. QualificationUserLastRefresh
|
||||
, singletonMap "first-held" $ SortColumn $ withType $ \(_ `E.InnerJoin` quser) -> quser E.^. QualificationUserFirstHeld
|
||||
]
|
||||
, dbtFilter = mempty
|
||||
, dbtFilterUI = mempty
|
||||
, dbtStyle = def
|
||||
, dbtParams = def
|
||||
, dbtCsvEncode = noCsvEncode
|
||||
, dbtCsvDecode = Nothing
|
||||
, dbtExtraReps = []
|
||||
}
|
||||
|
||||
|
||||
getAuthPredsR, postAuthPredsR :: Handler Html
|
||||
getAuthPredsR = postAuthPredsR
|
||||
postAuthPredsR = do
|
||||
|
||||
@ -268,17 +268,13 @@ courseCell Course{..} = anchorCell link name `mappend` desc
|
||||
|]
|
||||
|
||||
qualificationCell :: IsDBTable m a => Qualification -> DBCell m a
|
||||
qualificationCell Qualification{..} = anchorCell link name `mappend` desc
|
||||
qualificationCell Qualification{..} = anchorCell link name <> desc
|
||||
where
|
||||
link = QualificationR qualificationSchool qualificationShorthand
|
||||
name = citext2widget qualificationName
|
||||
desc = case qualificationDescription of
|
||||
Nothing -> mempty
|
||||
(Just descr) -> cell [whamlet|
|
||||
$newline never
|
||||
<div>
|
||||
^{modal "Beschreibung" (Right $ toWidget descr)}
|
||||
|]
|
||||
(Just descr) -> spacerCell <> markupCellLargeModal descr
|
||||
|
||||
sheetCell :: IsDBTable m a => CourseLink -> SheetName -> DBCell m a
|
||||
sheetCell crse shn =
|
||||
@ -323,4 +319,4 @@ lmsStatusCell ls = iconCell ic <> spacerCell <> dayCell (lmsStatusDay ls)
|
||||
|
||||
qualificationBlockedCell :: IsDBTable m a => Maybe QualificationBlocked -> DBCell m a
|
||||
qualificationBlockedCell Nothing = mempty
|
||||
qualificationBlockedCell (Just qb) = iconCell IconBlocked <> msgCell qb <> dayCell (qualificationBlockedDay qb)
|
||||
qualificationBlockedCell (Just qb) = msgCell qb <> spacerCell <> iconCell IconBlocked <> spacerCell <> dayCell (qualificationBlockedDay qb)
|
||||
|
||||
@ -368,7 +368,7 @@ determineCrontab = execWriterT $ do
|
||||
{ cronInitial = CronAsap -- time after scheduling
|
||||
, cronRepeat = CronRepeatScheduled $ cronCalendarAny { cronHour = cronMatchOne hour -- cronHour = CronMatchSome (impureNonNull $ Set.fromList [3,15] )
|
||||
, cronMinute = cronMatchOne 3
|
||||
, cronSecond = cronMatchOne 2
|
||||
, cronSecond = cronMatchOne 27
|
||||
}
|
||||
, cronRateLimit = nominalDay / 2 -- minimal time between two executions, before the second job is skipped
|
||||
, cronNotAfter = Left nominalDay -- maximal delay of an execution, before it is skipped entirely
|
||||
@ -380,7 +380,7 @@ determineCrontab = execWriterT $ do
|
||||
{ cronInitial = CronAsap -- time after scheduling
|
||||
, cronRepeat = CronRepeatScheduled $ cronCalendarAny { cronHour = cronMatchOne hour -- cronHour = CronMatchSome (impureNonNull $ Set.fromList [3,15] )
|
||||
, cronMinute = cronMatchOne 33
|
||||
, cronSecond = cronMatchOne 2
|
||||
, cronSecond = cronMatchOne 27
|
||||
}
|
||||
, cronRateLimit = nominalDay / 2 -- minimal time between two executions, before the second job is skipped
|
||||
, cronNotAfter = Left nominalDay -- maximal delay of an execution, before it is skipped entirely
|
||||
|
||||
@ -20,7 +20,7 @@ import qualified Database.Esqueleto.Utils as E
|
||||
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import Handler.Utils.DateTime
|
||||
import Handler.Utils.DateTime
|
||||
import Handler.Utils.LMS (randomLMSIdentBut, randomLMSpw, maxLmsUserIdentRetries)
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
@ -49,7 +49,7 @@ dispatchJobLmsEnqueue :: QualificationId -> JobHandler UniWorX
|
||||
dispatchJobLmsEnqueue qid = JobHandlerAtomic act
|
||||
where
|
||||
-- act :: YesodJobDB UniWorX ()
|
||||
act = do
|
||||
act = do
|
||||
quali <- getJust qid -- may throw an error, aborting the job
|
||||
let qshort = CI.original $ qualificationShorthand quali
|
||||
$logInfoS "lms" $ "Notifying about exipiring qualification " <> qshort
|
||||
@ -85,13 +85,13 @@ dispatchJobLmsEnqueueUser :: QualificationId -> UserId -> JobHandler UniWorX
|
||||
dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act
|
||||
where
|
||||
act :: YesodJobDB UniWorX ()
|
||||
act = do
|
||||
identsInUseVs <- E.select $ do
|
||||
act = do
|
||||
identsInUseVs <- E.select $ do
|
||||
lui <- E.from $
|
||||
( (E.^. LmsUserlistIdent) <$> E.from (E.table @LmsUserlist) )
|
||||
`E.union_`
|
||||
`E.union_`
|
||||
( (E.^. LmsResultIdent) <$> E.from (E.table @LmsResult) )
|
||||
`E.union_`
|
||||
`E.union_`
|
||||
( (E.^. LmsUserIdent) <$> E.from (E.table @LmsUser) )
|
||||
E.orderBy [E.asc lui]
|
||||
pure lui
|
||||
@ -111,7 +111,7 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act
|
||||
, lmsUserEnded = Nothing
|
||||
}
|
||||
-- startLmsUser :: YesodJobDB UniWorX (Maybe (Entity LmsUser))
|
||||
startLmsUser = do
|
||||
startLmsUser = do
|
||||
pw <- randomLMSpw
|
||||
maybeM (pure Nothing) (E.insertUniqueEntity . mkLmsUser pw) (randomLMSIdentBut identsInUse)
|
||||
inserted <- untilJustMaxM maxLmsUserIdentRetries startLmsUser
|
||||
@ -124,14 +124,21 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act
|
||||
|
||||
-- purge LmsIdent adter QualificationAuditDuration expired
|
||||
dispatchJobLmsDequeue :: QualificationId -> JobHandler UniWorX
|
||||
dispatchJobLmsDequeue qid = JobHandlerAtomic act
|
||||
dispatchJobLmsDequeue qid = JobHandlerAtomic act
|
||||
where
|
||||
act = do
|
||||
act = do
|
||||
quali <- getJust qid -- may throw an error, aborting the job
|
||||
let qshort = CI.original $ qualificationShorthand quali
|
||||
$logInfoS "lms" $ "Processing e-learning results for qualification " <> qshort
|
||||
now <- liftIO getCurrentTime
|
||||
-- purge LmsUsers
|
||||
-- TODO: notify expired used
|
||||
-- let nowaday = utctDay now
|
||||
-- forM_ (E.unValue . snd <$> delusersVals) $ \uid ->
|
||||
-- queueDBJob JobSendNotification
|
||||
-- { jRecipient = uid
|
||||
-- , jNotification = NotificationQualificationExpired { nQualification = qid, nExpiry = nowaday }
|
||||
-- }
|
||||
-- purge outdated LmsUsers
|
||||
case qualificationAuditDuration quali of
|
||||
Nothing -> return () -- no automatic removal
|
||||
(Just auditDuration) -> do
|
||||
@ -149,16 +156,14 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
|
||||
E.&&. laudit E.^. LmsAuditProcessed E.>=. E.val auditCutoff
|
||||
)
|
||||
pure (luser E.^. LmsUserIdent)
|
||||
let delusers = E.unValue <$> delusersVals
|
||||
numdel = length delusers
|
||||
let delusers = E.unValue <$> delusersVals
|
||||
numdel = length delusers
|
||||
when (numdel > 0) $ do
|
||||
$logInfoS "lms" $ "Deleting " <> tshow numdel <> " LmsIdents due to audit duration expiry for qualification " <> qshort
|
||||
deleteWhere [LmsUserQualification ==. qid, LmsUserIdent <-. delusers]
|
||||
deleteWhere [LmsUserlistQualification ==. qid, LmsUserlistIdent <-. delusers]
|
||||
deleteWhere [LmsResultQualification ==. qid, LmsResultIdent <-. delusers]
|
||||
deleteWhere [LmsAuditQualification ==. qid, LmsAuditIdent <-. delusers]
|
||||
|
||||
|
||||
|
||||
-- processes received results and lengthen qualifications, if applicable
|
||||
dispatchJobLmsResults :: QualificationId -> JobHandler UniWorX
|
||||
@ -167,18 +172,18 @@ dispatchJobLmsResults qid = JobHandlerAtomic act
|
||||
-- act :: YesodJobDB UniWorX ()
|
||||
act = hoist lift $ do
|
||||
quali <- getJust qid
|
||||
whenIsJust (qualificationValidDuration quali) $ \renewalMonths -> do
|
||||
-- otherwise there is nothing to do: we cannot renew s qualification without a specified validDuration
|
||||
whenIsJust (qualificationValidDuration quali) $ \renewalMonths -> do
|
||||
-- otherwise there is nothing to do: we cannot renew s qualification without a specified validDuration
|
||||
-- result :: [(Entity QualificationUser, Entity LmsUser, Entity LmsResult)]
|
||||
results <- E.select $ do
|
||||
(quser E.:& luser E.:& lresult) <- E.from $
|
||||
E.table @QualificationUser -- table not needed if renewal from lms completion day is used TODO: decide!
|
||||
`E.innerJoin` E.table @LmsUser
|
||||
`E.on` (\(quser E.:& luser) ->
|
||||
luser E.^. LmsUserUser E.==. quser E.^. QualificationUserUser
|
||||
`E.innerJoin` E.table @LmsUser
|
||||
`E.on` (\(quser E.:& luser) ->
|
||||
luser E.^. LmsUserUser E.==. quser E.^. QualificationUserUser
|
||||
E.&&. luser E.^. LmsUserQualification E.==. quser E.^. QualificationUserQualification)
|
||||
`E.innerJoin` E.table @LmsResult
|
||||
`E.on` (\(_ E.:& luser E.:& lresult) ->
|
||||
`E.innerJoin` E.table @LmsResult
|
||||
`E.on` (\(_ E.:& luser E.:& lresult) ->
|
||||
luser E.^. LmsUserIdent E.==. lresult E.^. LmsResultIdent
|
||||
E.&&. luser E.^. LmsUserQualification E.==. lresult E.^. LmsResultQualification)
|
||||
E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid
|
||||
@ -186,10 +191,10 @@ dispatchJobLmsResults qid = JobHandlerAtomic act
|
||||
E.&&. E.isNothing (luser E.^. LmsUserStatus) -- do not process learners already having a result
|
||||
E.&&. E.isNothing (luser E.^. LmsUserEnded) -- do not process closed learners
|
||||
return (quser, luser, lresult)
|
||||
now <- liftIO getCurrentTime
|
||||
now <- liftIO getCurrentTime
|
||||
forM_ results $ \(Entity quid QualificationUser{..}, Entity luid LmsUser{..}, Entity lrid LmsResult{..}) -> do
|
||||
-- three separate DB operations per result is not so nice. All within one transaction though.
|
||||
let nowadayP1 = succ $ utctDay now -- add one day to account for time synch problems
|
||||
let nowadayP1 = succ $ utctDay now -- add one day to account for time synch problems
|
||||
lmsUserStartedDay = utctDay lmsUserStarted
|
||||
saneDate = lmsResultSuccess `inBetween` (lmsUserStartedDay, min qualificationUserValidUntil nowadayP1)
|
||||
&& qualificationUserLastRefresh <= lmsUserStartedDay
|
||||
@ -202,7 +207,7 @@ dispatchJobLmsResults qid = JobHandlerAtomic act
|
||||
]
|
||||
update luid [ LmsUserStatus =. Just newStatus
|
||||
, LmsUserReceived =. Just lmsResultTimestamp
|
||||
]
|
||||
]
|
||||
return Nothing
|
||||
else do
|
||||
let errmsg = [st|LMS success with insane date #{tshow lmsResultSuccess} received for #{tshow lmsUserIdent}|]
|
||||
@ -210,8 +215,8 @@ dispatchJobLmsResults qid = JobHandlerAtomic act
|
||||
return $ Just errmsg
|
||||
|
||||
insert_ $ LmsAudit qid lmsUserIdent newStatus note lmsResultTimestamp now -- always log success, since this is only transmitted once
|
||||
delete lrid
|
||||
$logInfoS "LmsResult" [st|Processed #{tshow (length results)} LMS results|]
|
||||
delete lrid
|
||||
$logInfoS "LmsResult" [st|Processed #{tshow (length results)} LMS results|]
|
||||
|
||||
|
||||
-- processes received input and block qualifications, if applicable
|
||||
@ -220,7 +225,7 @@ dispatchJobLmsUserlist qid = JobHandlerAtomic act
|
||||
where
|
||||
act :: YesodJobDB UniWorX ()
|
||||
act = do
|
||||
now <- liftIO getCurrentTime
|
||||
now <- liftIO getCurrentTime
|
||||
-- result :: [(Entity LmsUser, Entity LmsUserlist)]
|
||||
results <- E.select $ do
|
||||
(luser E.:& lulist) <- E.from $
|
||||
@ -243,15 +248,21 @@ dispatchJobLmsUserlist qid = JobHandlerAtomic act
|
||||
{ jRecipient = lmsUserUser luser
|
||||
, jNotification = NotificationQualificationRenewal { nQualification = qid }
|
||||
}
|
||||
-- update luid [ LmsUserNotified =. Just now ] -- wird erst beim tatsächlichen senden gesetzt!
|
||||
let lReceived = lmsUserlistTimestamp lulist
|
||||
isBlocked = lmsUserlistFailed lulist
|
||||
update luid [LmsUserReceived =. Just lReceived]
|
||||
when isBlocked $ do
|
||||
let newStatus = LmsBlocked $ utctDay lReceived
|
||||
oldStatus = lmsUserStatus luser
|
||||
isBlocked = lmsUserlistFailed lulist
|
||||
update luid [LmsUserReceived =. Just lReceived] -- LmsUserNotfied is only updated upon sending notifications
|
||||
$logInfoS "LmsUserlist" $ tshow lulist
|
||||
when isBlocked $ do
|
||||
let blockedDay = utctDay lReceived
|
||||
newStatus = LmsBlocked blockedDay
|
||||
oldStatus = lmsUserStatus luser
|
||||
insert_ $ LmsAudit qid (lmsUserIdent luser) newStatus (Just $ "Old Status was " <> tshow oldStatus) lReceived now
|
||||
update luid [LmsUserStatus =. (oldStatus <> Just newStatus)]
|
||||
updateBy (UniqueQualificationUser qid (lmsUserUser luser)) [QualificationUserBlockedDue =. Just (QualificationBlockedLms (utctDay lReceived))]
|
||||
delete lulid
|
||||
update luid [LmsUserStatus =. (oldStatus <> Just newStatus)]
|
||||
updateBy (UniqueQualificationUser qid (lmsUserUser luser)) [QualificationUserBlockedDue =. Just (QualificationBlockedLms blockedDay)]
|
||||
queueDBJob JobSendNotification
|
||||
{ jRecipient = lmsUserUser luser
|
||||
, jNotification = NotificationQualificationExpired { nQualification = qid, nExpiry = blockedDay }
|
||||
}
|
||||
|
||||
delete lulid
|
||||
$logInfoS "LmsUserlist" [st|Processed LMS Userlist with ${tshow (length results)} entries|]
|
||||
|
||||
@ -301,6 +301,7 @@ determineNotificationCandidates = awaitForever $ \notif -> do
|
||||
|
||||
return (hasOverride, user)
|
||||
NotificationQualificationExpiry{} -> return mempty -- Not to be used with JobQueueNotification; recipients already known
|
||||
NotificationQualificationExpired{} -> return mempty -- Not to be used with JobQueueNotification; recipients already known
|
||||
NotificationQualificationRenewal{} -> return mempty -- Not to be used with JobQueueNotification; recipients already known
|
||||
|
||||
|
||||
@ -339,4 +340,5 @@ classifyNotification NotificationSubmissionUserCreated{} = return NTSub
|
||||
classifyNotification NotificationSubmissionUserDeleted{} = return NTSubmissionUserDeleted
|
||||
classifyNotification NotificationAllocationNewCourse{} = return NTAllocationNewCourse
|
||||
classifyNotification NotificationQualificationExpiry{} = return NTQualification
|
||||
classifyNotification NotificationQualificationExpired{} = return NTQualification
|
||||
classifyNotification NotificationQualificationRenewal{} = return NTQualification
|
||||
|
||||
@ -2,6 +2,7 @@
|
||||
|
||||
module Jobs.Handler.SendNotification.Qualification
|
||||
( dispatchNotificationQualificationExpiry
|
||||
, dispatchNotificationQualificationExpired
|
||||
, dispatchNotificationQualificationRenewal
|
||||
) where
|
||||
|
||||
@ -22,16 +23,15 @@ import Text.Hamlet
|
||||
|
||||
|
||||
dispatchNotificationQualificationExpiry :: QualificationId -> Day -> UserId -> Handler ()
|
||||
dispatchNotificationQualificationExpiry nQualification _nExpiry jRecipient = userMailT jRecipient $ do
|
||||
(recipient@User{..}, Qualification{..}, Entity _ QualificationUser{..}) <- liftHandler . runDB $ (,,)
|
||||
dispatchNotificationQualificationExpiry nQualification dExpiry jRecipient = userMailT jRecipient $ do
|
||||
(recipient@User{..}, Qualification{..}) <- liftHandler . runDB $ (,)
|
||||
<$> getJust jRecipient
|
||||
<*> getJust nQualification
|
||||
<*> getJustBy (UniqueQualificationUser nQualification jRecipient)
|
||||
|
||||
<*> getJust nQualification
|
||||
|
||||
encRecipient :: CryptoUUIDUser <- liftHandler $ encrypt jRecipient
|
||||
let entRecipient = Entity jRecipient recipient
|
||||
qname = CI.original qualificationName
|
||||
expiryDate <- formatTimeUser SelFormatDate qualificationUserValidUntil $ Just entRecipient
|
||||
expiryDate <- formatTimeUser SelFormatDate dExpiry $ Just entRecipient
|
||||
|
||||
$logDebugS "LMS" $ "Notify " <> tshow encRecipient <> " about expiry of qualification " <> qname
|
||||
|
||||
@ -43,6 +43,27 @@ dispatchNotificationQualificationExpiry nQualification _nExpiry jRecipient = use
|
||||
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
|
||||
|
||||
encRecipient :: CryptoUUIDUser <- liftHandler $ encrypt jRecipient
|
||||
let entRecipient = Entity jRecipient recipient
|
||||
qname = CI.original qualificationName
|
||||
expiryDate <- 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")
|
||||
|
||||
|
||||
-- NOTE: qualificationRenewal expects that LmsUser already exists for recipient
|
||||
dispatchNotificationQualificationRenewal :: QualificationId -> UserId -> Handler ()
|
||||
dispatchNotificationQualificationRenewal nQualification jRecipient = do
|
||||
@ -51,8 +72,8 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do
|
||||
<*> getJust nQualification
|
||||
<*> getJustBy (UniqueQualificationUser nQualification jRecipient)
|
||||
<*> getJustBy (UniqueLmsQualificationUser nQualification jRecipient)
|
||||
|
||||
encRecipient :: CryptoUUIDUser <- encrypt jRecipient
|
||||
|
||||
encRecipient :: CryptoUUIDUser <- encrypt jRecipient
|
||||
let entRecipient = Entity jRecipient recipient
|
||||
qname = CI.original qualificationName
|
||||
|
||||
@ -80,16 +101,16 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do
|
||||
, toMeta "url-text" lmsUrl
|
||||
, toMeta "url" lmsLogin
|
||||
]
|
||||
emailRenewal attachment
|
||||
| Text.null (CI.original userEmail) = do -- if neither email nor postal address is known, we must abort!
|
||||
emailRenewal attachment
|
||||
| Text.null (CI.original userEmail) = do -- if neither email nor postal address is known, we must abort!
|
||||
let msg = "Notify " <> tshow encRecipient <> " failed: no email nor address for user known!"
|
||||
$logErrorS "LMS" msg
|
||||
$logErrorS "LMS" msg
|
||||
return False
|
||||
| otherwise = do
|
||||
userMailT jRecipient $ do
|
||||
userMailT jRecipient $ do
|
||||
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
|
||||
setSubjectI $ MsgMailSubjectQualificationRenewal qname
|
||||
whenIsJust attachment $ \afile ->
|
||||
whenIsJust attachment $ \afile ->
|
||||
addPart (File { fileTitle = Text.unpack fileName
|
||||
, fileModified = now
|
||||
, fileContent = Just $ yield $ LBS.toStrict afile
|
||||
@ -100,22 +121,22 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do
|
||||
|
||||
notifyOk <- pdfRenewal pdfMeta >>= \case
|
||||
Right pdf | userPrefersLetter recipient -> -- userPrefersLetter is false if both userEmail and userPostAddress are null
|
||||
let printSender = Nothing
|
||||
in runDB (sendLetter printJobName pdf (Just jRecipient, printSender) Nothing (Just nQualification) (Just luid)) >>= \case
|
||||
let printSender = Nothing
|
||||
in runDB (sendLetter printJobName pdf (Just jRecipient, printSender) Nothing (Just nQualification) (Just luid)) >>= \case
|
||||
Left err -> do
|
||||
let msg = "Notify " <> tshow encRecipient <> ": PDF printing to send letter failed with error " <> cropText err
|
||||
let msg = "Notify " <> tshow encRecipient <> ": PDF printing to send letter failed with error " <> cropText err
|
||||
$logErrorS "LMS" msg
|
||||
return False
|
||||
Right (msg,_)
|
||||
Right (msg,_)
|
||||
| null msg -> return True
|
||||
| otherwise -> do
|
||||
| otherwise -> do
|
||||
$logWarnS "LMS" $ "PDF printing to send letter with lpr returned ExitSucces and the following message: " <> msg
|
||||
return True
|
||||
|
||||
Right pdf -> do
|
||||
attch <- case userPinPassword of
|
||||
attch <- case userPinPassword of
|
||||
Nothing -> return $ Just pdf -- attach unencrypted, since there is no password set
|
||||
Just passwd -> encryptPDF passwd pdf >>= \case
|
||||
Just passwd -> encryptPDF passwd pdf >>= \case
|
||||
Right encPdf -> return $ Just encPdf -- attach encrypted
|
||||
Left err -> do -- send email without attachment, so that the user is at least notified about the expiry
|
||||
let msg = "Notify " <> tshow encRecipient <> " PDF encryption failed with error: " <> cropText err
|
||||
@ -127,6 +148,5 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do
|
||||
let msg = "Notify " <> tshow encRecipient <> " PDF generation failed with error: " <> cropText err
|
||||
$logErrorS "LMS" msg
|
||||
emailRenewal Nothing
|
||||
|
||||
|
||||
when notifyOk $ runDB $ update luid [ LmsUserNotified =. Just now]
|
||||
|
||||
@ -144,6 +144,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 }
|
||||
| NotificationQualificationRenewal { nQualification :: QualificationId }
|
||||
deriving (Eq, Ord, Show, Read, Generic, Typeable)
|
||||
|
||||
|
||||
31
templates/mail/qualificationExpired.hamlet
Normal file
31
templates/mail/qualificationExpired.hamlet
Normal file
@ -0,0 +1,31 @@
|
||||
$newline never
|
||||
\<!doctype html>
|
||||
<html>
|
||||
<head>
|
||||
<meta charset="UTF-8">
|
||||
<style>
|
||||
h1 {
|
||||
font-size: 1.25em;
|
||||
font-variant: small-caps;
|
||||
font-weight: normal;
|
||||
}
|
||||
<body>
|
||||
<h1>
|
||||
_{SomeMessage $ MsgMailSubjectQualificationExpired qname}
|
||||
|
||||
<p>
|
||||
_{SomeMessage MsgMailBodyQualificationExpired}
|
||||
|
||||
<p>
|
||||
<dl>
|
||||
<dt>_{SomeMessage MsgQualificationName}
|
||||
<dd>
|
||||
<a href=@{QualificationR qualificationSchool qualificationShorthand}>
|
||||
#{qualificationName}
|
||||
<dt>_{SomeMessage MsgLmsUser}
|
||||
<dd>#{nameHtml userDisplayName userSurname}
|
||||
<dt>_{SomeMessage MsgLmsQualificationValidUntil}
|
||||
<dd>#{expiryDate}
|
||||
|
||||
|
||||
^{ihamletSomeMessage editNotifications}
|
||||
@ -146,6 +146,11 @@ $newline never
|
||||
<div .container>
|
||||
^{enrolledCoursesTable}
|
||||
|
||||
<div .container>
|
||||
<h2>_{MsgProfileQualifications}
|
||||
<div .container>
|
||||
^{qualificationsTable}
|
||||
|
||||
<div .container>
|
||||
<h2>_{MsgProfileCourseExamResults}
|
||||
<div .container>
|
||||
@ -171,7 +176,7 @@ $newline never
|
||||
<div .container>
|
||||
^{submissionTable}
|
||||
<em>_{MsgProfileRemark}
|
||||
_{MsgProfileGroupSubmissionDates}
|
||||
\ _{MsgProfileGroupSubmissionDates}
|
||||
|
||||
<div .container>
|
||||
<h2> _{MsgTableCorrector}
|
||||
@ -179,7 +184,7 @@ $newline never
|
||||
^{correctionsTable}
|
||||
|
||||
<em>_{MsgProfileRemark}
|
||||
_{MsgProfileCorrectorRemark}
|
||||
\ _{MsgProfileCorrectorRemark}
|
||||
<a href=@{CorrectionsR}>_{MsgProfileCorrections}
|
||||
|
||||
^{profileRemarks}
|
||||
|
||||
@ -505,7 +505,9 @@ fillDb = do
|
||||
qid_f <- insert' $ Qualification avn "F" "Vorfeldführerschein" f_descr (Just 24) (Just 6) (Just $ CalendarDiffDays 0 60) True
|
||||
qid_r <- insert' $ Qualification avn "R" "Rollfeldführerschein" r_descr (Just 24) (Just 6) (Just $ CalendarDiffDays 2 3) False
|
||||
qid_l <- insert' $ Qualification ifi "L" "Lehrbefähigung" l_descr Nothing (Just 6) Nothing True
|
||||
void . insert' $ QualificationUser jost qid_f (n_day 9) (n_day $ -1) (n_day $ -22) Nothing -- TODO: better dates!
|
||||
void . insert' $ QualificationUser jost qid_f (n_day 9) (n_day $ -1) (n_day $ -22) Nothing -- TODO: better dates!
|
||||
void . insert' $ QualificationUser jost qid_r (n_day 99) (n_day $ -11) (n_day $ -222) (Just $ QualificationBlockedLms $ n_day $ -5)-- TODO: better dates!
|
||||
void . insert' $ QualificationUser jost qid_l (n_day 999) (n_day $ -111) (n_day $ -2222) Nothing -- TODO: better dates!
|
||||
void . insert' $ QualificationUser gkleen qid_f (n_day $ -3) (n_day $ -4) (n_day $ -20) Nothing
|
||||
void . insert' $ QualificationUser maxMuster qid_f (n_day 0) (n_day $ -2) (n_day $ -8) Nothing
|
||||
void . insert' $ QualificationUser svaupel qid_f (n_day 1) (n_day $ -1) (n_day $ -2) Nothing
|
||||
|
||||
Loading…
Reference in New Issue
Block a user