diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index eb35d0c2c..50000ac1f 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -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 diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg index 934be1526..384930a47 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/messages/uniworx/categories/qualification/en-eu.msg @@ -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 diff --git a/messages/uniworx/categories/settings/personal_settings/de-de-formal.msg b/messages/uniworx/categories/settings/personal_settings/de-de-formal.msg index 86078f85d..47fa3871f 100644 --- a/messages/uniworx/categories/settings/personal_settings/de-de-formal.msg +++ b/messages/uniworx/categories/settings/personal_settings/de-de-formal.msg @@ -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. diff --git a/messages/uniworx/categories/settings/personal_settings/en-eu.msg b/messages/uniworx/categories/settings/personal_settings/en-eu.msg index 926c06664..1067e3107 100644 --- a/messages/uniworx/categories/settings/personal_settings/en-eu.msg +++ b/messages/uniworx/categories/settings/personal_settings/en-eu.msg @@ -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. diff --git a/models/lms.model b/models/lms.model index 4c4469a1c..dc96f6d03 100644 --- a/models/lms.model +++ b/models/lms.model @@ -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 diff --git a/src/Application.hs b/src/Application.hs index 29aadb760..628614d0c 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -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 diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 6d533ee8a..116d864e0 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -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 diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 3b79e91f7..e953e9d47 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -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 diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index d977e4de2..cb29b328b 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -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 -
- ^{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) diff --git a/src/Jobs/Crontab.hs b/src/Jobs/Crontab.hs index c78c8b7af..7796954ab 100644 --- a/src/Jobs/Crontab.hs +++ b/src/Jobs/Crontab.hs @@ -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 diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 36e39274c..a97ef7a72 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -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|] diff --git a/src/Jobs/Handler/QueueNotification.hs b/src/Jobs/Handler/QueueNotification.hs index ea9a0adb2..bf6f76b5f 100644 --- a/src/Jobs/Handler/QueueNotification.hs +++ b/src/Jobs/Handler/QueueNotification.hs @@ -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 diff --git a/src/Jobs/Handler/SendNotification/Qualification.hs b/src/Jobs/Handler/SendNotification/Qualification.hs index 07051aaa3..b958fb40f 100644 --- a/src/Jobs/Handler/SendNotification/Qualification.hs +++ b/src/Jobs/Handler/SendNotification/Qualification.hs @@ -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] - \ No newline at end of file diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index e332e7e20..d72dc487d 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -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) diff --git a/templates/mail/qualificationExpired.hamlet b/templates/mail/qualificationExpired.hamlet new file mode 100644 index 000000000..6db513766 --- /dev/null +++ b/templates/mail/qualificationExpired.hamlet @@ -0,0 +1,31 @@ +$newline never +\ + + + +