diff --git a/CHANGELOG.md b/CHANGELOG.md index d1129dc3f..c258f366f 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,101 @@ All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines. +## [27.4.33](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/t27.4.32...t27.4.33) (2023-09-20) + + +### Bug Fixes + +* **time:** midnight timezone conversion bug eliminated ([dfa07a9](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/dfa07a95eb29f1fceec258a466e1e7c779ff6e5c)) + +## [27.4.32](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/t27.4.31...t27.4.32) (2023-09-19) + + +### Bug Fixes + +* **lms:** ensure lms uniqueness across all qualifications ([b85c8bd](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/b85c8bd74f8db526fb1cbb43ff12a24b93c07eb3)) +* **lms:** simultaneous block/unblock lets unblock win in all situations ([ecd1a0f](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ecd1a0fc210d1340bff5c79d8bb676a47654b509)) + +## [27.4.31](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/t27.4.30...t27.4.31) (2023-09-13) + +## [27.4.30](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/t27.4.29...t27.4.30) (2023-09-11) + + +### Bug Fixes + +* **lms:** reset e-learning more lenient ([8b0737e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/8b0737e2aabc7153ae3a3df4f97f86ffc8592e7a)) + +## [27.4.29](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/t27.4.28...t27.4.29) (2023-09-07) + + +### Bug Fixes + +* **build:** v2 ([ac77aa1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ac77aa176a3c3977c4a802e5ed534fa2850528fe)) + +## [27.4.28](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/t27.4.27...t27.4.28) (2023-09-07) + +## [27.4.27](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/t27.4.26...t27.4.27) (2023-09-07) + +## [27.4.26](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/t27.4.25...t27.4.26) (2023-09-04) + + +### Bug Fixes + +* **lms:** accept success for no-status learners and print several more debug messages processing reports ([a7ed659](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/a7ed659866de1d4a178bbe4e8f9cd8fbc629c724)) + +## [27.4.25](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/t27.4.24...t27.4.25) (2023-09-01) + + +### Bug Fixes + +* **build:** add missing file ([1fd24f6](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/1fd24f608dc9202fa98f52f7908f4be908a18efc)) + +## [27.4.24](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/t27.4.23...t27.4.24) (2023-08-30) + + +### Bug Fixes + +* **lms:** filter by status ([a74c3d8](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/a74c3d80cada4f9d224365727dab9676cc905f54)) +* **lms:** negate learner locking condition ([a452b03](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/a452b032c43dbdfd086ffa4793c83ecc32c450f8)) + +## [27.4.23](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/t27.4.22...t27.4.23) (2023-08-29) + +## [27.4.22](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/t27.4.21...t27.4.22) (2023-08-29) + + +### Bug Fixes + +* **build:** refix test commits somehow ([34ada53](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/34ada53de0cc5804468791854e824b730fcc84de)) + +## [27.4.21](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/t27.4.20...t27.4.21) (2023-07-26) + + +### Bug Fixes + +* **apc:** apc cannot distinguish ij from ji, partial fix only. Needs new font ([b4ba0a3](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/b4ba0a30dc7c513bb9e3c567ca771d5d75de4343)) +* **block:** negate condition to test ([9cf7f39](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/9cf7f3965aa95f0b8f2a1574dbad90c0257edafd)) +* **qualification:** new block/unblock mechanism working now ([5397c7b](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/5397c7be353fc1b1e8310f66b49a9b93ee890253)) +* **users:** fix [#112](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/112) and also add some convenience ([35096ac](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/35096ace01a2bc2a2d666794bb1ff92f52b3edec)) +* **users:** fix [#112](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/112) working now ([88bf21c](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/88bf21c9c5de3755ea6591c97dc1f99a928914d5)) + +## [27.4.20](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/t27.4.19...t27.4.20) (2023-07-18) + + +### Bug Fixes + +* **build:** prevent migration on non-existing table ([5bb49cd](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/5bb49cd88941e510a50759efaad88690f841ca47)) + +## [27.4.19](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/t27.4.18-2...t27.4.19) (2023-07-17) + + +### Bug Fixes + +* **build:** major qualfication block quirks fixed ([ab48e40](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ab48e40ac7e5024b7847b3995e6ae16d1c401c60)) +* **build:** minor ([f9930f2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/f9930f2a00d1e0f0af9b7f2af7c387bcc09cef5a)) +* **db:** migration qualification block ([3d59527](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/3d595271d979f29ed8bbc546f495e5ad1deae5ca)) +* **job:** fix [#95](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/95) by implementing queued job deletion for admins ([5b9a554](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/5b9a5545457dbe506d20f7362fb6e0d6bae4f7f4)) +* **test:** LmsStatus is no longer a semigroup ([bf8cd4f](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/bf8cd4fa899bccd4a37906a4d899aca6ca25d726)) + ## [27.4.18](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.14...v27.4.18) (2023-07-17) ## [27.4.17](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.14...v27.4.17) (2023-07-17) diff --git a/messages/uniworx/categories/admin/de-de-formal.msg b/messages/uniworx/categories/admin/de-de-formal.msg index 28803d6c4..2bb340724 100644 --- a/messages/uniworx/categories/admin/de-de-formal.msg +++ b/messages/uniworx/categories/admin/de-de-formal.msg @@ -98,6 +98,8 @@ TestDownloadFromDatabase: Generierung während Download aus Datenbank ProblemsHeading: Problemübersicht ProblemsHeadingDrivers: Fahrberechtigungen +ProblemsHeadingNotifications: Benachrichtigungen +ProblemsHeadingMisc: Allgemein ProblemsAvsProblem: Synchronisation mit AVS/MoBaKo komplett fehlgeschlagen ProblemsDriverSynch n@Int: #{tshow n} Diskrepanzen zwischen AVS und FRADrive ProblemsDriverSynch0: Alle Sperrungen von Vorfeld-Fahrberechtigungen 'F' sind im AVS eingetragen @@ -106,9 +108,10 @@ ProblemsDriverSynch1up: Alle gültigen Vorfeld-Fahrberechtigungen 'F' sind im AV ProblemsDriverSynch2: Alle gültigen Rollfeld-Fahrberechtigungen 'R' sind im AVS eingetragen ProblemsRDriversHaveFs: Alle Inhaber einer Rollfeld-Fahrberechtigung besitzen auch eine gültige Vorfeld-Fahrberechtigung ProblemsDriversHaveAvsIds: Alle Inhaber einer Fahrberechtigung konnten einer AVS Identifikationsnummer zugeordnet werden -ProblemsHeadingUsers: Allgemein ProblemsUsersAreReachable: Für alle Benutzer ist eine E-Mail oder postalische Adresse bekannt ProblemsNoStalePrintJobs n@Integer: Alle Briefversandaufträge der vergangenen #{show n} Tage wurden von der Druckerei bestätigt +ProblemsNoBadAPCIds: Alle kürzlich empfangenen Druckauftragsbestätigungen waren gültig +ProblemsNoAvsSynchProblems: Synchronisation mit Ausweisverwaltungssystem (AVS) meldete keine Probleme ProblemsUnreachableHeading: Unerreichbare Benutzer ProblemsUnreachableBody: Benutzer ohne E-Mail oder Postadresse, welche z.B. bei ablaufenden Berechtigungen nicht benachrichtigt werden können: ProblemsRWithoutFHeading: Fahrer mit R ohne F @@ -116,3 +119,4 @@ ProblemsRWithoutFBody: Diese Fahrer sind wegen einer ungültigen Vorfeld-Fahrber ProblemsNoAvsIdHeading: Fahrer ohne AVS-Id ProblemsNoAvsIdBody: Fahrer mit gültiger Fahrberechtigung in FRADrive, welche trotzdem nicht fahren dürfen, da die Fahrberechtigung aufgrund einer unbekannten AVS Id nicht an die Ausweisstelle übermittelt werden konnte: ProblemsAvsSynchHeading: Synchronisation AVS Fahrberechtigungen +ProblemsAvsErrorHeading: Fehlermeldungen \ No newline at end of file diff --git a/messages/uniworx/categories/admin/en-eu.msg b/messages/uniworx/categories/admin/en-eu.msg index f320c1a3d..4d973593a 100644 --- a/messages/uniworx/categories/admin/en-eu.msg +++ b/messages/uniworx/categories/admin/en-eu.msg @@ -98,6 +98,8 @@ TestDownloadFromDatabase: Generate while streaming from database ProblemsHeading: Overview Problems ProblemsHeadingDrivers: Driving Licences +ProblemsHeadingNotifications: User communication +ProblemsHeadingMisc: Miscellaneous ProblemsAvsProblem: Synchronisation with AVS/MoBaKo failed entirely ProblemsDriverSynch n: #{tshow n} mismatches between AVS and FRADrive ProblemsDriverSynch0: All revocations of apron driving licences 'F' were successfully registered with AVS @@ -106,9 +108,10 @@ ProblemsDriverSynch1up: All valid apron driving licences 'F' were successfully r ProblemsDriverSynch2: All valid maneuvering area driving licences 'R' were successfully registered with AVS ProblemsRDriversHaveFs: All driving licence 'R' holders also have a valid 'F' licence ProblemsDriversHaveAvsIds: All driving licence holder could be matched with their AVS id -ProblemsHeadingUsers: Miscellaneous ProblemsUsersAreReachable: Either Email or postal address is known for all users ProblemsNoStalePrintJobs n: All requests for letter mailing within the last #{show n} days were acknowledged as printed by the airport printing center +ProblemsNoBadAPCIds: All recently received print job ids from Airport Print Center were legit +ProblemsNoAvsSynchProblems: AVS synchronisation had not problems ProblemsUnreachableHeading: Unreachable Users ProblemsUnreachableBody: Users without Email nor postal address, who thus cannot be notified about expiring qualifications: ProblemsRWithoutFHeading: Drivers having 'R' but not 'F' @@ -116,3 +119,4 @@ ProblemsRWithoutFBody: Drivers without apron driving licence are prohibited from ProblemsNoAvsIdHeading: Drivers without AVS id ProblemsNoAvsIdBody: Drivers having a valid apron driving licence within FRADrive only, but who may not drive since a missing AVS id prevents communication of the driving licence to AVS: ProblemsAvsSynchHeading: Synchronisation AVS Driving Licences +ProblemsAvsErrorHeading: Error Log \ No newline at end of file diff --git a/messages/uniworx/categories/avs/de-de-formal.msg b/messages/uniworx/categories/avs/de-de-formal.msg index 84c10e982..bd5c01716 100644 --- a/messages/uniworx/categories/avs/de-de-formal.msg +++ b/messages/uniworx/categories/avs/de-de-formal.msg @@ -34,4 +34,6 @@ TableAvsActiveCards: Gültige Ausweise AvsCardColorGreen: Grün AvsCardColorBlue: Blau AvsCardColorRed: Rot -AvsCardColorYellow: Gelb \ No newline at end of file +AvsCardColorYellow: Gelb +LastAvsSynchronisation: Letzte AVS-Synchronisation +LastAvsSynchError: Letzte AVS-Fehlermeldung diff --git a/messages/uniworx/categories/avs/en-eu.msg b/messages/uniworx/categories/avs/en-eu.msg index 5cd51c3c3..ec7288d7d 100644 --- a/messages/uniworx/categories/avs/en-eu.msg +++ b/messages/uniworx/categories/avs/en-eu.msg @@ -34,4 +34,6 @@ TableAvsActiveCards: Valid Cards AvsCardColorGreen: Green AvsCardColorBlue: Blue AvsCardColorRed: Red -AvsCardColorYellow: Yellow \ No newline at end of file +AvsCardColorYellow: Yellow +LastAvsSynchronisation: Last AVS synchronisation +LastAvsSynchError: Last AVS Error \ No newline at end of file diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index 997f6e531..6ec90ad28 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -8,10 +8,11 @@ QualificationDescription: Beschreibung QualificationValidIndicator: Gültigkeit QualificationValidDuration: Gültigkeitsdauer QualificationAuditDuration: Aufbewahrung Audit Log +QualificationAuditDurationTooltip: Optionaler Zeitraum zur Löschung von E‑Learning Daten. Hiweis: Der E‑Learning Server kann seine anonymisierten Daten schon früher löschen. QualificationRefreshWithin: Erneurerungszeitraum -QualificationRefreshWithinTooltip: Optionaler Zeitraum vor Ablauf für automatischen Start des E‑Learnings und Versand einer Benachrichtigung per Brief oder Email +QualificationRefreshWithinTooltip: Optionaler Zeitraum vor Ablauf für automatischen Start des E‑Learnings und Versand einer Benachrichtigung per Brief oder Email. QualificationRefreshReminder: 2. Erinnerung -QualificationRefreshReminderTooltip: Optionaler Zeitraum vor Ablauf zur Versendung einer zweiten Erinnerung per Brief oder Email mit identischen Zugangsdaten, sofern in diesem Zeitraum vor Ablauf noch keine Ablaufbenachrichtigung versendet wurde +QualificationRefreshReminderTooltip: Optionaler Zeitraum vor Ablauf zur Versendung einer zweiten Erinnerung per Brief oder Email mit identischen Zugangsdaten, sofern in diesem Zeitraum vor Ablauf noch keine Ablaufbenachrichtigung versendet wurde. QualificationElearningStart: Wird das E‑Learning automatisch gestartet? QualificationExpiryNotification: Ungültigkeitsbenachrichtigung? QualificationExpiryNotificationTooltip: Nutzer werden benachrichtigt, wenn die Qualifikation ungültig wird, sofern der jeweilige Nutzer in seinen Benutzereinstellungen diese Art Benachrichtigung aktiviert hat. @@ -26,14 +27,17 @@ LmsQualificationValidUntil: Gültig bis TableQualificationLastRefresh: Zuletzt erneuert TableQualificationLastNotified: Letzte Benachrichtigung TableQualificationFirstHeld: Erstmalig -TableQualificationBlockedDue: Entzogen +TableQualificationBlockedDue: Entzug TableQualificationBlockedTooltip: Wann wurde die Qualifikation vorübergehend außer Kraft gesetzt und warum wurde dies veranlasst? -TableQualificationBlockedTooltipSimple: Wann wurde die Qualifikation aus besonderem Grund wiederrufen? +TableQualificationBlockedTooltipSimple: Falls die Qualifikation aus besonderem Grund vorzeitig widerrufen wurde, so wird das Datum des Widerrufs angezeigt +InfoQualificationBlockStatus: Besteht aktuell ein Entzug? Falsch bedeutet, dass ein Entzug zuletzt aufgehoben wurde +InfoQualificationBlockFrom: Datum der letzten Änderungen eines Entzugs oder der Aufhebung eines Entzugs TableQualificationNoRenewal: Auslaufend TableQualificationNoRenewalTooltip: Es wird keine Benachrichtigung mehr versendet, wenn diese Qualifikation ablaufen sollte. Die Qualifikation kann noch weiterhin gültig sein. QualificationScheduleRenewalTooltip: Wird eine Benachrichtigung versendet, falls diese Qualikation bald ablaufen sollte? QualificationUserNoRenewal: Läuft ohne Benachrichtigung aus QualificationUserNone: Für diese Person sind keine Qualifikationen registriert. +QualificationGrantReason: Erteilungsbegründung QualificationBlockReason: Entzugsbegründung QualificationBlockNotify: Benachrichtigung verschicken QualificationBlockRemoveSupervisor: Alle Ansprechpartner löschen @@ -46,6 +50,7 @@ TableLmsElearning: E‑Learning TableLmsPin: E‑Learning Passwort TableLmsResetPin: E-Learning Passwort zurücksetzen? TableLmsDatePin: E-Learning Passwort erstellt +TableLmsDate: Datum TableLmsDelete: Löschen? TableLmsStaff: Interner Mitarbeiter? TableLmsStarted: Begonnen @@ -57,11 +62,12 @@ TableLmsStatus: Status E‑Learning TableLmsStatusTooltip mbMonth@(Maybe Int): Zeigt #{maybeToMessage "bis zu " (fmap (flip pluralDEeN "Monat") mbMonth) " nach Abschluss"} den letzten Zustand eines E‑Learnings an: TableLmsStatusDay: Datum letzte Statusänderung E‑Learning TableLmsSuccess: Bestanden -TableLmsFailed: Gesperrt +TableLmsLock: Gesperrt +TableLmsResetTries: E‑Learning Versuche zurücksetzen LmsStatusBlocked: Durchgefallen wegen zu vieler Fehlversuche LmsStatusExpired: Durchgefallen nach Fristablauf LmsStatusSuccess: E#{nonBreakableDash}Learning bestanden -LmsStatusPlanned: E#{nonBreakableDash}Learning wird gerade eröffnet (nur für Admin sichtbar) +LmsStatusPlanned: E#{nonBreakableDash}Learning wird gerade noch eröffnet (nur für Admin sichtbar) LmsStatusDelay: Hinweis: Statusänderung können in seltenen Fällen mehrere Stunden bis zur Anzeige benötigen. FilterLmsValid: Aktuell gültig FilterLmsRenewal: Erneuerung anstehend @@ -69,17 +75,23 @@ FilterLmsNotified: Benachrichtigt FilterLmsNotificationDue: Benachrichtigung erforderlich CsvColumnLmsIdent: E‑Learning Identifikator, einzigartig pro Qualifikation und Teilnehmer CsvColumnLmsPin: Passwort E#{nonBreakableDash}Learning Zugang -CsvColumnLmsResetPin: Wird das E-Learning Passwort bei der nächsten Synchronisation zurückgesetzt? +CsvColumnLmsResetPin: Wird das E‑Learning Passwort bei der nächsten Synchronisation zurückgesetzt? CsvColumnLmsDelete: Wird der Identifikator in der E‑Learning Plattform bei der nächsten Synchronisation gelöscht? CsvColumnLmsStaff: Handelt es sich um einen internen Mitarbeiter? (Aus historischen Gründen, wird momentan ignoriert.) -CsvColumnLmsSuccess: Zeitstempel der erfolgreichen Teilnahme (UTC) -CsvColumnLmsFailed: User was blocked by LMS, usually due to too many attempts +CsvColumnLmsSuccess: Zeitstempel der erfolgreichen Teilnahme +CsvColumnLmsDate: Datum des E‑Learning Ereignisses +CsvColumnLmsResetTries: Anzahl der bisher verbrauchten E‑Learning Prüfungsversuche zurücksetzen +CsvColumnLmsLock: E‑Learning Login gesperrt +CsvColumnLmsResult !ident-ok: LMS Status LmsUserlistInsert: Neuer LMS User -LmsUserlistUpdate: LMS User aktualisierung +LmsUserlistUpdate: LMS User Aktualisierung LmsResultInsert: Neues LMS Ergebnis -LmsResultUpdate: LMS Ergebnis aktualisierung -LmsResultCsvExceptionDuplicatedKey: CSV Import fand uneindeutigen Schlüssel -LmsUserlistCsvExceptionDuplicatedKey: CSV Import fand uneindeutigen Schlüssel +LmsResultUpdate: LMS Ergebnis Aktualisierung +LmsReportInsert: Neues LMS Ereignis +LmsReportUpdate: LMS Ereignis Aktualisierung +LmsResultCsvExceptionDuplicatedKey: CSV-Import LmsResult fand uneindeutigen Schlüssel +LmsUserlistCsvExceptionDuplicatedKey: CSV-Import LmsUserlist fand uneindeutigen Schlüssel +LmsReportCsvExceptionDuplicatedKey: CSV-Import LmsReport fand uneindeutigen Schlüssel LmsDirectUpload: Direkter Upload für automatisierte Systeme LmsErrorNoRefreshElearning: Fehler: E‑Learning wird nicht automatisch gestartet, da die Zeitspanne für den Erneurerungszeitraum nicht festgelegt wurde. MailSubjectQualificationRenewal qname@Text: Qualifikation #{qname} muss demnächst erneuert werden @@ -101,17 +113,25 @@ QualificationActGrant: Qualifikation vergeben QualificationActGrantWarning: Diese Funktion ist nur für seltene Ausnahmefälle vorgesehen! Ein Entzug wird ggf. aufgehoben. QualificationStatusBlock l@QualificationShorthand n@Int m@Int: #{n}/#{m} #{l} entzogen QualificationStatusUnblock l@QualificationShorthand n@Int m@Int: #{n}/#{m} #{l} reaktiviert +LmsInactive: Aktuell kein E‑Learning aktiv LmsRenewalInstructions: Weitere Anweisungen zur Verlängerung finden Sie im angehängten PDF. Um Missbrauch zu verhindern wurde das PDF mit dem im FRADrive hinterlegten PDF-Passwort des Prüflings verschlüsselt. Falls kein PDF-Passwort manuell hinterlegt wurde, ist das PDF-Passwort die Flughafen Ausweisnummer, inklusive Punkt und der Ziffer danach. LmsNoRenewal: Leider kann diese Qualifikation nicht alleine durch E‑Learning verlängert werden. LmsRenewalReminder: Erinnerung LmsActNotify: Benachrichtigung E‑Learning erneut per Post oder E-Mail versenden LmsActRenewPin: Neues zufällige E‑Learning Passwort zuweisen LmsActRenewNotify: Neue zufällige E‑Learning Passwort zuweisen und Benachrichtigung per Post oder E-Mail versenden -LmsActRestart: E-Learning neu starten -LmsActRestartWarning: Das vorhandene E-Learning wird sofort komplett gelöscht! Für Inhaber einer gültigen Fahrlizenz werden später Benutzer und Passwort neu vergeben und es wird eine neue Benachrichtigung versendet werden. -LmsActRestartFeedback n@Int m@Int: #{n}/#{m} E-Learning wurden neu gestartet. +LmsActReset: E‑Learning Fehlversuche zurücksetzen und entsperren +LmsActResetInfo: E‑Learning Login und Passwort bleiben unverändert, eine neue Benachrichtigung ist nicht notwendig. Nur möglich für bereits gesperrte Lerner. Es kann bis zu 2 Stunden dauern, bis das LMS die Anfrage umgesetzt hat. +LmsActResetFeedback n@Int m@Int: Für #{n}/#{m} E‑Learning Nutzer wurden alle Fehlversuche zurückgesetzt. +LmsActRestart: E‑Learning komplett neu starten +LmsActRestartWarning: Das vorhandene E‑Learning wird komplett gelöscht! Für Inhaber einer gültigen Fahrlizenz werden später Benutzer und Passwort neu vergeben und es sollte eine neue Benachrichtigung versendet werden. Hinweis: Es kann mehrere Stunden dauern, bis das LMS diese Anfrage umgesetzt hat. +LmsActRestartFeedback n@Int m@Int: #{n}/#{m} E‑Learning Nutzer wurden komplett neu gestartet mit neuem Login und Passwort. LmsActRestartExtend: Gültig bis ggf. erhöhen für die nächsten # Tage LmsActRestartUnblock: Entzug ggf. aufheben +LmsStateOpen: E‑Learning offen +LmsStatusLocked: E‑Learning gesperrt, wird ggf. bald geöffnet +LmsStatusUnlocked: E‑Learning offen, wird ggf. bald gesperrt +LmsStatusResetTries: Fehlversuche werden demnächst zurückgesetzt LmsStatusNotificationSent: Anmeldedaten wurden an Prüfling oder Ansprechpartner per Post oder E#{nonBreakableDash}Mail versendet; E#{nonBreakableDash}Learning ist derzeit offen LmsNotificationSend n@Int: E‑Learning Benachrichtigungen an #{n} #{pluralDE n "Prüfling" "Prüflinge"} werden per Post oder E-Mail versendet. LmsPinRenewal n@Int: E‑Learning Passwort ausgetauscht für #{n} #{pluralDE n "Prüfling" "Prüflinge"}. diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg index 2c730c639..e4db425e1 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/messages/uniworx/categories/qualification/en-eu.msg @@ -8,10 +8,11 @@ QualificationDescription: Description QualificationValidIndicator: Validity QualificationValidDuration: Validity period QualificationAuditDuration: Audit log keept +QualificationAuditDurationTooltip: Optional period for deletion of e‑learning data. Note that the e‑learning server may delete its anonymised data earlier. QualificationRefreshWithin: Refresh within -QualificationRefreshWithinTooltip: Optional period before expiry to start e‑learning and send a notification by post or email +QualificationRefreshWithinTooltip: Optional period before expiry to start e‑learning and send a notification by post or email. QualificationRefreshReminder: 2. Reminder -QualificationRefreshReminderTooltip: Optional period before expiry to send a second notification by post or email once more, provided that no renewal notification was sent in this period before expiry +QualificationRefreshReminderTooltip: Optional period before expiry to send a second notification by post or email once more, provided that no renewal notification was sent in this period before expiry. QualificationElearningStart: Is e‑learning automatically started? QualificationExpiryNotification: Invalidity notification? QualificationExpiryNotificationTooltip: Qualification holder are notfied upon invalidity, provided they have activated such notification in their user settings. @@ -26,14 +27,17 @@ LmsQualificationValidUntil: Valid until TableQualificationLastRefresh: Last renewed TableQualificationLastNotified: Last notified TableQualificationFirstHeld: First held -TableQualificationBlockedDue: Revoked +TableQualificationBlockedDue: Revocations TableQualificationBlockedTooltip: Why and when was this qualification temporarily suspended? -TableQualificationBlockedTooltipSimple: When was this qualification revoked due to extraordinary reasons? +TableQualificationBlockedTooltipSimple: If a date is shown, this qualification has been revoked on that date due to extraordinary reasons TableQualificationNoRenewal: Discontinued +InfoQualificationBlockStatus: Is the qualification currently revoked? False indicates, that a revocation had been lifted +InfoQualificationBlockFrom: Date of last revocation or lifting of a revocation TableQualificationNoRenewalTooltip: No renewal notifications will be send for this qualification upon expiry. The qualification may still be valid. QualificationScheduleRenewalTooltip: Will there be a notification, if this qualification is about to expire soon? QualificationUserNoRenewal: Expires without further notification QualificationUserNone: No registered qualifications for this person. +QualificationGrantReason: Reason for granting QualificationBlockReason: Reason for revoking QualificationBlockNotify: Send notification QualificationBlockRemoveSupervisor: Remove all supervisors @@ -46,6 +50,7 @@ TableLmsPin: E‑learning password TableLmsElearning: E‑learning TableLmsResetPin: Reset E‑learning password? TableLmsDatePin: E‑learning password created +TableLmsDate: Date TableLmsDelete: Delete? TableLmsStaff: Staff? TableLmsStarted: Started @@ -57,11 +62,12 @@ TableLmsStatus: Status e‑learning TableLmsStatusTooltip mbMonth: Shows #{maybeToMessage "for up to " (fmap (flip pluralENsN "month") mbMonth) " after closure"} the last e#{nonBreakableDash}learning status change: TableLmsStatusDay: Date of last e‑learning status change TableLmsSuccess: Completed -TableLmsFailed: Blocked +TableLmsLock: Locked +TableLmsResetTries: Reset e‑learning attempts LmsStatusBlocked: Failed after too many attempts LmsStatusExpired: Failed due to expiry LmsStatusSuccess: Passed -LmsStatusPlanned: E#{nonBreakableDash}learning is about to be opened (visible to Admins only) +LmsStatusPlanned: E#{nonBreakableDash}learning is about to be opened soon (visible to Admins only) LmsStatusDelay: Note that status changes may occassionaly require more than a hour to be displayed here. FilterLmsValid: Currently valid FilterLmsRenewal: Renewal due @@ -70,16 +76,22 @@ FilterLmsNotificationDue: Notification due CsvColumnLmsIdent: E#{nonBreakableDash}learning identifier, unique for each qualification and user CsvColumnLmsPin: Password e#{nonBreakableDash}learning access CsvColumnLmsResetPin: Will the e#{nonBreakableDash}learning password be reset upon next synchronisation? -CsvColumnLmsDelete: Will the identifier be deleted from the E‑learning platfrom upon next synchronisation? +CsvColumnLmsDelete: Will the identifier be deleted from the e‑learning platfrom upon next synchronisation? CsvColumnLmsStaff: Is the user an internal staff member? (Legacy, currently ignored) CsvColumnLmsSuccess: Timestamp of successful completion (UTC) -CsvColumnLmsFailed: Blockier durch LMS, üblicherweise wegen zu vieler Fehlversuche +CsvColumnLmsResetTries: Reset number of used up e‑learning exam attempts +CsvColumnLmsDate: Date of e‑learning event +CsvColumnLmsResult: LMS Status +CsvColumnLmsLock: E‑learning login is not permitted LmsUserlistInsert: New LMS user LmsUserlistUpdate: Update of LMS user LmsResultInsert: New LMS result LmsResultUpdate: Update of LMS result -LmsResultCsvExceptionDuplicatedKey: CSV import with ambiguous key -LmsUserlistCsvExceptionDuplicatedKey: CSV import with ambiguous key +LmsReportInsert: New LMS event +LmsReportUpdate: Update of LMS event +LmsResultCsvExceptionDuplicatedKey: CSV import LmsResult with ambiguous key +LmsUserlistCsvExceptionDuplicatedKey: CSV import LmsUserlist with ambiguous key +LmsReportCsvExceptionDuplicatedKey: CSV Import LmsReport with ambiguous key 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: Qualification #{qname} must be renewed shortly @@ -101,17 +113,25 @@ QualificationActGrant: Grant qualification QualificationActGrantWarning: Use with caution in rare exceptional cases only! Any revocation will be undone. QualificationStatusBlock l n m: #{n}/#{m} #{l} revoked QualificationStatusUnblock l n m: #{n}/#{m} #{l} reactivated +LmsInactive: Currently no active 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 the FRADrive PDF-password of the examinee. If no PDF-password had been chosen yet, then the password is the Fraport id card number of the examinee, including the punctuation mark and the digit thereafter. LmsNoRenewal: Unfortunately, this particular qualification cannot be renewed through e‑learning only. LmsRenewalReminder: Reminder LmsActNotify: Resend e‑learning notification by post or email LmsActRenewPin: Randomly replace e‑learning password LmsActRenewNotify: Randomly replace e‑learning password and re-send notification by post or email -LmsActRestart: Restart e-learning -LmsActRestartWarning: The existing e-learning will be erased immediately! For drivers with a valid licence, user and password will later be generated anew and a notification will be queued as usual. +LmsActReset: Reset and unlock e‑learning +LmsActResetInfo: E‑learning login and password remain unchanged; a notification is thus not necessary. This is only possible for already failed learners. Note that the reset procedure may take up to 2 hours. +LmsActResetFeedback n@Int m@Int: For #{n}/#{m} learners all failures were erased, preserving login credentials. +LmsActRestart: Restart e‑learning +LmsActRestartWarning: The existing e‑learning will be erased immediately! For drivers with a valid licence, user and password will later be generated anew and a notification will be queued as usual, which may take several hours. LmsActRestartExtend: Ensure validity for the next # days LmsActRestartUnblock: Undo any revocations -LmsActRestartFeedback n@Int m@Int: #{n}/#{m} e-learnings were restarted. +LmsActRestartFeedback n@Int m@Int: #{n}/#{m} e-learnings were completely restarted with new login credentials. +LmsStateOpen: E‑learning open +LmsStatusLocked: E‑learning locked, may be opened soon +LmsStatusUnlocked: E‑learning still open, may be locked soon +LmsStatusResetTries: Failed attempts will be soon reset LmsStatusNotificationSent: E‑learning password has been sent to examinee or supervisor by letter post or by email; e‑learning is currently open LmsNotificationSend n: E‑learning notifications will be sent to #{n} #{pluralENs n "examinee"} by letter post or by email. LmsPinRenewal n: E‑learning password replaced randomly for #{n} #{pluralENs n "examinee"}. diff --git a/messages/uniworx/categories/settings/de-de-formal.msg b/messages/uniworx/categories/settings/de-de-formal.msg index 966a96328..028c2085f 100644 --- a/messages/uniworx/categories/settings/de-de-formal.msg +++ b/messages/uniworx/categories/settings/de-de-formal.msg @@ -94,8 +94,6 @@ TokensLastReset: Tokens zuletzt invalidiert ProfileNever: Nie ProfileLdapPrimaryKey: LDAP-Primärschlüssel ProfileLastLdapSynchronisation: Letzte LDAP-Synchronisation -ProfileLastAvsSynchronisation: Letzte AVS-Synchronisation -ProfileLastAvsSynchError: Letzte AVS-Fehlermeldung NotificationSettingsUpdate: Benachrichtigungs-Einstellungen erfolgreich gespeichert NotificationSettingsHeading displayName@Text: Benachrichtigungs-Einstellungen für #{displayName} diff --git a/messages/uniworx/categories/settings/en-eu.msg b/messages/uniworx/categories/settings/en-eu.msg index af8288459..5fa8840f5 100644 --- a/messages/uniworx/categories/settings/en-eu.msg +++ b/messages/uniworx/categories/settings/en-eu.msg @@ -94,8 +94,6 @@ TokensLastReset: Tokens last reset ProfileNever: Never ProfileLdapPrimaryKey: LDAP primary key ProfileLastLdapSynchronisation: Last LDAP synchronisation -ProfileLastAvsSynchronisation: Last AVS synchronisation -ProfileLastAvsSynchError: Last AVS Error NotificationSettingsUpdate: Successfully updated notification settings NotificationSettingsHeading displayName: Notification settings for #{displayName} diff --git a/messages/uniworx/utils/navigation/menu/de-de-formal.msg b/messages/uniworx/utils/navigation/menu/de-de-formal.msg index bd12272a8..5ea9b7e59 100644 --- a/messages/uniworx/utils/navigation/menu/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/menu/de-de-formal.msg @@ -120,18 +120,23 @@ MenuLanguage: Sprache MenuQualifications: Qualifikationen MenuLms !ident-ok: E‑Learning MenuLmsEdit: Bearbeiten E‑Learning -MenuLmsUser: Benutzer Qualifikationen -MenuLmsUsers: Export E‑Learning Benutzer -MenuLmsUserlist: Melden E‑Learning Benutzer -MenuLmsResult: Melden Ergebnisse E‑Learning +MenuLmsUser: Benutzerqualifikationen +MenuLmsUserSchool: Bereichs Benutzerqualifikationen +MenuLmsUserAll: Alle Benutzerqualifikationen +MenuLmsUsers: Veralteter Export E‑Learning Benutzer +MenuLmsUserlist: Veraltetes Melden E‑Learning Benutzer +MenuLmsResult: Veralteter Melden Ergebnisse E‑Learning MenuLmsUpload: Hochladen MenuLmsDirectUpload: Direkter Upload MenuLmsDirectDownload: Direkter Download MenuLmsFake: Testnutzer generieren +MenuLmsLearners: Export Benutzer E‑Learning +MenuLmsReport: Ergebnisse E‑Learning MenuSap: SAP Schnittstelle MenuAvs: AVS Schnittstelle +MenuAvsSynchError: AVS Problemübersicht MenuLdap: LDAP Schnittstelle MenuApc: Druckerei MenuPrintSend: Manueller Briefversand diff --git a/messages/uniworx/utils/navigation/menu/en-eu.msg b/messages/uniworx/utils/navigation/menu/en-eu.msg index 1a7dd4dc0..b4a66104d 100644 --- a/messages/uniworx/utils/navigation/menu/en-eu.msg +++ b/messages/uniworx/utils/navigation/menu/en-eu.msg @@ -119,20 +119,25 @@ MenuCourseEventEdit: Edit course type occurrence MenuLanguage: Language MenuQualifications: Qualifications -MenuLms: E‑Learning -MenuLmsEdit: Edit E‑Learning +MenuLms: E‑learning +MenuLmsEdit: Edit e‑learning MenuLmsUser: User Qualifications -MenuLmsUsers: Download E‑Learning Users -MenuLmsUserlist: Upload E‑Learning Users -MenuLmsResult: Upload E‑Learning Results +MenuLmsUserSchool: Institute User Qualifications +MenuLmsUserAll: All User Qualifications +MenuLmsUsers: Legacy download e‑learning users +MenuLmsUserlist: Legacy upload e‑learning users +MenuLmsResult: Legacy upload r‑learning results MenuLmsUpload: Upload MenuLmsDirectUpload: Direct Upload MenuLmsDirectDownload: Direct Download -MenuLmsFake: Generate test users +MenuLmsFake: Generate Test Users +MenuLmsLearners: E‑learning Users +MenuLmsReport: E‑learning Results MenuSap: SAP Interface MenuAvs: AVS Interface +MenuAvsSynchError: AVS Problem Overview MenuLdap: LDAP Interface MenuApc: Printing MenuPrintSend: Send Letter diff --git a/messages/uniworx/utils/table_column/de-de-formal.msg b/messages/uniworx/utils/table_column/de-de-formal.msg index 16d43de61..fdf42b885 100644 --- a/messages/uniworx/utils/table_column/de-de-formal.msg +++ b/messages/uniworx/utils/table_column/de-de-formal.msg @@ -85,4 +85,6 @@ TableJobLockTime: Bearbeitung seit TableJobLockInstance: Bearbeiter TableJobCreationInstance: Ersteller ActJobDelete: Job entfernen -TableJobActDeleteFeedback n@Int m@Int: #{n}/#{m} Jobs entfernt \ No newline at end of file +TableJobActDeleteFeedback n@Int m@Int: #{n}/#{m} Jobs entfernt +TableFilterComma: Es können mehrere alternative Suchkriterien mit Komma getrennt angegeben werden, wovon mindestens eines erfüllt werden muss. +TableFilterCommaPlus: Mehrere alternative Suchkriterien mit Komma trennen. Mindestens ein Suchkriterium muss erfüllt werden, zusätzlich zu allen Suchkriterien mit vorangestelltem Plus-Symbol. \ No newline at end of file diff --git a/messages/uniworx/utils/table_column/en-eu.msg b/messages/uniworx/utils/table_column/en-eu.msg index 17fbfe79a..b4fe83d34 100644 --- a/messages/uniworx/utils/table_column/en-eu.msg +++ b/messages/uniworx/utils/table_column/en-eu.msg @@ -85,4 +85,6 @@ TableJobLockTime: Lock time TableJobLockInstance: Worker TableJobCreationInstance: Creator ActJobDelete: Delete job -TableJobActDeleteFeedback n@Int m@Int: #{n}/#{m} queued jobs deleted \ No newline at end of file +TableJobActDeleteFeedback n@Int m@Int: #{n}/#{m} queued jobs deleted +TableFilterComma: Separate multiple alternative filter criteria by comma, at least one of which must be fulfilled. +TableFilterCommaPlus: Separate multiple alternative filter criteria by comma, at least one of which must be fulfilled in addition to all criteria preceded by a plus symbol. \ No newline at end of file diff --git a/models/lms.model b/models/lms.model index f8233b4ef..616940762 100644 --- a/models/lms.model +++ b/models/lms.model @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Sarah Vaupel ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-23 Sarah Vaupel ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -40,12 +40,20 @@ Qualification -- - PinReset==1 mit bestehendem Passwort kann problemlos erneut gesendet werden -- - Flag "interner Mitarbeiter" wird von Know-How ignoriert / nicht ausgewertet (legacy) -QualificationPrecondition +QualificationPrecondition -- NOTE: this can only be enforced through a background job adding or removing qualifications qualification QualificationId OnDeleteCascade OnUpdateCascade -- AND: not unique, ie. qualification can have multiple required preconditions required [QualificationId] -- OR : alternatives, any one will suffice - continuous Bool -- expiring precondition removes qualification + continuous Bool -- expiring precondition blocks qualification deriving Generic +-- Maybe an alternative for online qualification validity checking, transitivity through recursive CTEs? (already available in our version) +-- QualificationRequirement +-- qualification QualificationId OnDeleteCascade OnUpdateCascade +-- requirement QualificationId OnDeleteCascade OnUpdateCascade +-- group Text -- OR: several requirements within the same group are considered equivalent +-- UniqueQualificationRequirement qualification requirement +-- + -- TODO: connect Qualification with Exams! QualificationEdit @@ -60,14 +68,21 @@ QualificationUser validUntil Day -- addGregorianMonthsRollOver (toInteger renewalMonths) qualificationUserValidUntil lastRefresh Day -- lastRefresh > validUntil possible, if Qualification^elearningOnly == False 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 + -- Reasons and temporary revocations are implemented through QualificationUserBlock + -- TODO: adjust SAP interface to transmit end dates UniqueQualificationUser qualification user deriving Generic +QualificationUserBlock + qualificationUser QualificationUserId OnDeleteCascade OnUpdateCascade + unblock Bool + from UTCTime + reason Text + blocker UserId Maybe + deriving Eq Ord Read Show Generic + -- LMS Interface Tables, need regular processing by background jobs, per QualificationId: -- -- 1. Daily Job: Add to LmsUser daily all qualification holders with @@ -106,19 +121,29 @@ LmsUser user UserId OnDeleteCascade OnUpdateCascade ident LmsIdent -- must be unique accross all LMS courses! pin Text - resetPin Bool default=false -- should pin be reset? + resetPin Bool default=false -- should pin be reset? datePin UTCTime default=now() -- time pin was created - status LmsStatus Maybe -- open, success or failure; status should never change unless isNothing; isJust indicates lms is finished and user shall be deleted from LMS + status LmsStatus Maybe -- Nothing=open, LmsSuccess, LmsBlocked or LmsExpired; status should never change unless isNothing; isJust indicates lms is finished and user shall be deleted from LMS --toDelete encoded by Handler.Utils.LMS.lmsUserToDelete + statusDay UTCTime Maybe -- last status change; should be isJust iff isJust status; modelling as a separate table too bothersome, unlike qualification block 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? + resetTries Bool default=false -- V2 should e-learning exam tries be reset? + locked Bool default=false -- V2 last returned lock status + -- Primary ident -- newtype Key LmsUserId = LmsUserKey { unLmsUser :: Text } -- change LmsIdent -> Text. Do we want this? No. UniqueLmsIdent ident -- idents must be unique accross all qualifications, since idents are global within LMS! UniqueLmsQualificationUser qualification user -- each user may be enrolled at most once per course deriving Generic +-- LmsUserStatus +-- lmsUser LmsUserId OnDeleteCascade OnUpdateCascade +-- result LmsStatus -- data LmsStatus = LmsBlocked | LmsExpired | LmsSuccess +-- day Day +-- UniqueLmsUserStatus lmsUser -- enforcing uniqueness prohibits history +-- deriving Generic + -- LmsUserlist stores LMS upload for later processing only LmsUserlist qualification QualificationId OnDeleteCascade OnUpdateCascade @@ -136,3 +161,13 @@ LmsResult timestamp UTCTime default=now() UniqueLmsResult qualification ident -- required by DBTable deriving Generic + +LmsReport + qualification QualificationId OnDeleteCascade OnUpdateCascade + ident LmsIdent + date UTCTime Maybe -- BEWARE: timezone is local as submitted by LMS + result LmsState -- (0|1|2) 0=LmsFailed[too many tries], 1=LmsOpen, 2=LmsPassed[success] + lock Bool -- (0|1) + timestamp UTCTime default=now() + UniqueLmsReport qualification ident -- required by DBTable + deriving Generic \ No newline at end of file diff --git a/models/print.model b/models/print.model index 69adcc7ba..ee3f1ea7c 100644 --- a/models/print.model +++ b/models/print.model @@ -16,4 +16,16 @@ PrintJob lmsUser LmsIdent Maybe OnDeleteCascade OnUpdateCascade -- allows tracking if recipient has been notified; must be unique -- UniquePrintJobLmsUser lmsUser -- Note that in fact multiple print jobs per LMS user are possible! -- UniquePrintJobApcIdent apcIdent -- TODO: not yet enforced, since LmsIdent is currently used + deriving Generic + +PrintAcknowledge -- just to store acknowledging requests to be evaluated by a background job later on + apcIdent Text + timestamp UTCTime default=now() + processed Bool + deriving Generic + +PrintAckIdAlias + needle Text + replacement Text + priority Int deriving Generic \ No newline at end of file diff --git a/nix/docker/version.json b/nix/docker/version.json index 3a246763d..665027c0b 100644 --- a/nix/docker/version.json +++ b/nix/docker/version.json @@ -1,3 +1,3 @@ { - "version": "27.4.18" + "version": "27.4.33" } diff --git a/package-lock.json b/package-lock.json index 53d8cf06a..ede5cb103 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.18", + "version": "27.4.33", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 598fd4194..666282fb3 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.18", + "version": "27.4.33", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index eab21aa3e..b67586386 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 27.4.18 +version: 27.4.33 dependencies: - base - yesod diff --git a/routes b/routes index a0fa1e4ae..7a68b54e3 100644 --- a/routes +++ b/routes @@ -75,6 +75,7 @@ /admin/problems/no-avs-id ProblemWithoutAvsId GET /admin/problems/r-without-f ProblemFbutNoR GET /admin/problems/avs ProblemAvsSynchR GET POST +/admin/problems/avs/errors ProblemAvsErrorR GET /print PrintCenterR GET POST !system-printer /print/acknowledge/#Day/#Int/#Int PrintAckR GET POST !system-printer @@ -261,29 +262,38 @@ !/#UUID CryptoUUIDDispatchR GET !free -- just redirect -- !/*{CI FilePath} CryptoFileNameDispatchR GET !free -- Disabled until preliminary check for valid cID exists -/qualification QualificationAllR GET !free -/qualification/#SchoolId QualificationSchoolR GET !free -/qualification/#SchoolId/#QualificationShorthand QualificationR GET POST !free -/qualifications/sap/direct QualificationSAPDirectR GET -- !token -- SAP EXPORT -- TODO reinstate token requirement --- /qualification/CryptoUUIDUser/ -- maybe distingquish via URL +/qualification QualificationAllR GET !free +/qualification/#SchoolId QualificationSchoolR GET !free +/qualification/#SchoolId/#QualificationShorthand QualificationR GET POST !free +-- /qualification/#SchoolId/#QualificationShorthand/#CryptoUUIDUser QualificationUserR GET -- see LmsUserR +/qualifications/sap/direct QualificationSAPDirectR GET -- !token -- SAP EXPORT -- TODO reinstate token requirement + -- LMS -/lms LmsAllR GET POST -/lms/#SchoolId LmsSchoolR GET -/lms/#SchoolId/#QualificationShorthand LmsR GET POST -/lms/#SchoolId/#QualificationShorthand/edit LmsEditR GET POST -/lms/#SchoolId/#QualificationShorthand/users LmsUsersR GET -/lms/#SchoolId/#QualificationShorthand/users/direct LmsUsersDirectR GET !token -- LMS -/lms/#SchoolId/#QualificationShorthand/userlist LmsUserlistR GET POST -/lms/#SchoolId/#QualificationShorthand/userlist/upload LmsUserlistUploadR GET POST !development -/lms/#SchoolId/#QualificationShorthand/userlist/direct LmsUserlistDirectR POST !token -- LMS -/lms/#SchoolId/#QualificationShorthand/result LmsResultR GET POST -/lms/#SchoolId/#QualificationShorthand/result/upload LmsResultUploadR GET POST !development -/lms/#SchoolId/#QualificationShorthand/result/direct LmsResultDirectR POST !token -- LMS -/lms/#SchoolId/#QualificationShorthand/ident/#LmsIdent LmsIdentR GET -- redirect to LmsR with filter-parameter -/lmsuser/#CryptoUUIDUser LmsUserR GET - - +/lms LmsAllR GET POST +/lms/#SchoolId LmsSchoolR GET +/lms/#SchoolId/#QualificationShorthand LmsR GET POST +/lms/#SchoolId/#QualificationShorthand/edit LmsEditR GET POST +-- old V1 LMS Interface +/lms/#SchoolId/#QualificationShorthand/users LmsUsersR GET +/lms/#SchoolId/#QualificationShorthand/users/direct LmsUsersDirectR GET !token -- LMS +/lms/#SchoolId/#QualificationShorthand/userlist LmsUserlistR GET POST +/lms/#SchoolId/#QualificationShorthand/userlist/upload LmsUserlistUploadR GET POST !development +/lms/#SchoolId/#QualificationShorthand/userlist/direct LmsUserlistDirectR POST !token -- LMS, also remove JobLmsUserlist constructor +/lms/#SchoolId/#QualificationShorthand/result LmsResultR GET POST +/lms/#SchoolId/#QualificationShorthand/result/upload LmsResultUploadR GET POST !development +/lms/#SchoolId/#QualificationShorthand/result/direct LmsResultDirectR POST !token -- LMS, also remove JobLmsResults constructor +-- new V2 LMS Interface +/lms/#SchoolId/#QualificationShorthand/learners LmsLearnersR GET +/lms/#SchoolId/#QualificationShorthand/learners/direct LmsLearnersDirectR GET !token -- LMS +/lms/#SchoolId/#QualificationShorthand/report LmsReportR GET POST +/lms/#SchoolId/#QualificationShorthand/report/upload LmsReportUploadR GET POST !development +/lms/#SchoolId/#QualificationShorthand/report/direct LmsReportDirectR POST !token -- LMS +-- other lms routes +/lms/#SchoolId/#QualificationShorthand/ident/#LmsIdent LmsIdentR GET -- redirect to LmsR with filter-parameter +/lms/#SchoolId/#QualificationShorthand/user/#CryptoUUIDUser LmsUserR GET +/lmsuser/#CryptoUUIDUser LmsUserAllR GET +/lmsuser/#CryptoUUIDUser/#SchoolId LmsUserSchoolR GET /api ApiDocsR GET !free /swagger SwaggerR GET !free diff --git a/src/Audit/Types.hs b/src/Audit/Types.hs index 4ba414ea8..8360410a8 100644 --- a/src/Audit/Types.hs +++ b/src/Audit/Types.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel +-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen ,Sarah Vaupel ,,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -180,20 +180,33 @@ data Transaction { transactionOldUserIdent , transactionNewUserIdent :: UserIdent } - + | TransactionLmsStart + { transactionQualification :: QualificationId + , transactionLmsIdent :: LmsIdent + , transactionLmsUser :: UserId + , transactionLmsUserKey :: LmsUserId + } + | TransactionLmsReset + { transactionQualification :: QualificationId + , transactionLmsUser :: UserId + , transactionLmsReset :: Bool + , transactionLmsResetExtend :: Maybe Integer + , transactionLmsResetUnblock :: Maybe Bool + , transactionLmsResetNotify :: Maybe Bool + } | TransactionLmsBlocked { transactionQualification :: QualificationId , transactionLmsIdent :: LmsIdent - , transactionLmsDay :: Day - , transactionLmsUser :: Maybe UserId + , transactionLmsDay :: UTCTime + , transactionLmsUser :: UserId , transactionNote :: Maybe Text , transactionReceived :: UTCTime -- when was the csv file received? } | TransactionLmsSuccess { transactionQualification :: QualificationId , transactionLmsIdent :: LmsIdent - , transactionLmsDay :: Day - , transactionLmsUser :: Maybe UserId + , transactionLmsDay :: UTCTime + , transactionLmsUser :: UserId , transactionNote :: Maybe Text , transactionReceived :: UTCTime -- when was the csv file received? } @@ -211,9 +224,9 @@ data Transaction } | TransactionQualificationUserBlocking { transactionUser :: UserId -- qualification holder that is updated - -- , transactionQualificationUser :: QualificationUserId -- not neccessary due to UniqueQualificationUser + -- , transactionQualificationUser :: QualificationUserId -- not neccessary due to UniqueQualificationUser , transactionQualification :: QualificationId - , transactionQualificationBlock :: Maybe QualificationBlocked -- Nothing indicates unblocking + , transactionQualificationBlock :: QualificationUserBlock -- TODO -- } deriving (Eq, Ord, Read, Show, Generic) diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 144eb99a6..bac61ff27 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -14,12 +14,15 @@ module Database.Esqueleto.Utils , strConcat, substring , (=?.), (?=.) , (=~.), (~=.) + , (>~.), (<~.) , or, and , any, all , subSelectAnd, subSelectOr , mkExactFilter, mkExactFilterWith , mkExactFilterLast, mkExactFilterLastWith + , mkExactFilterMaybeLast , mkContainsFilter, mkContainsFilterWith + , mkContainsFilterWithSet, mkContainsFilterWithComma, mkContainsFilterWithCommaPlus , mkDayFilter, mkDayFilterFrom, mkDayFilterTo , mkExistsFilter , anyFilter, allFilter @@ -60,6 +63,7 @@ import qualified Database.Esqueleto.PostgreSQL as E import qualified Database.Esqueleto.Internal.Internal as E import Database.Esqueleto.Utils.TH +import qualified Data.Text as Text import qualified Data.Text.Lazy as Lazy (Text) import qualified Data.ByteString.Lazy as Lazy (ByteString) @@ -75,6 +79,10 @@ import qualified Data.Text.Lazy.Builder as Text.Builder import Data.Monoid (Last(..)) +import Utils (commaSeparatedText) +-- import Utils.Set (concatMapSet) + + {-# ANN any ("HLint: ignore Use any" :: String) #-} {-# ANN all ("HLint: ignore Use all" :: String) #-} @@ -134,6 +142,17 @@ infixl 4 ~=. (~=.) :: PersistField typ => E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value typ) -> E.SqlExpr (E.Value Bool) (~=.) a b = E.isNothing a E.||. (a E.==. E.just b) +-- | like (>.), but also succeeds if the right-hand side is NULL +infixl 4 >~. +(>~.) :: PersistField typ => E.SqlExpr (E.Value typ) -> E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value Bool) +(>~.) a b = E.isNothing b E.||. (E.just a E.>. b) + +-- | like (<.), but also succeeds if the right-hand side is NULL +infixl 4 <~. +(<~.) :: PersistField typ => E.SqlExpr (E.Value typ) -> E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value Bool) +(<~.) a b = E.isNothing b E.||. (E.just a E.<. b) + + -- | Negation of `isNothing` which is missing isJust :: PersistField typ => E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value Bool) isJust = E.not_ . E.isNothing @@ -280,9 +299,20 @@ mkExactFilterLastWith :: (PersistField b) -> Last a -- ^ needle -> E.SqlExpr (E.Value Bool) mkExactFilterLastWith cast lenslike row criterias - | Last (Just crit) <- criterias = lenslike row E.==. E.val (cast crit) + | Last (Just crit) <- criterias = lenslike row E.==. E.val (cast crit) | otherwise = true +-- | like `mkExactFilterLast` but deals with Nothing being a filter criterion as well +mkExactFilterMaybeLast :: PersistField a + => (t -> E.SqlExpr (E.Value (Maybe a))) -- ^ getter from query to searched element + -> t -- ^ query row + -> Last (Maybe a) -- ^ needle + -> E.SqlExpr (E.Value Bool) +mkExactFilterMaybeLast lenslike row criterias + | Last (Just Nothing) <- criterias = E.isNothing $ lenslike row + | Last (Just crit) <- criterias = lenslike row E.==. E.val crit + | otherwise = true + -- | generic filter creation for dbTable -- Given a lens-like function, make filter searching for needles in String-like elements -- (Keep Set here to ensure that there are no duplicates) @@ -304,6 +334,44 @@ mkContainsFilterWith cast lenslike row criterias | Set.null criterias = true | otherwise = any (hasInfix $ lenslike row) (E.val . cast <$> Set.toList criterias) +-- | like `mkContainsFilterWith` but allows conversion to produce multiple needles +mkContainsFilterWithSet :: (E.SqlString b, Ord b, Ord a) + => (a -> Set.Set b) + -> (t -> E.SqlExpr (E.Value b)) -- ^ getter from query to searched element + -> t -- ^ query row + -> Set.Set a -- ^ needle collection + -> E.SqlExpr (E.Value Bool) +mkContainsFilterWithSet cast lenslike row criterias + | Set.null criterias = true + | otherwise = any (hasInfix $ lenslike row) (E.val <$> Set.toList (foldMap cast criterias)) + +-- | like `mkContainsFilterWithSet` but fixed to comma separated Texts +mkContainsFilterWithComma :: (E.SqlString b, Ord b) + => (Text -> b) + -> (t -> E.SqlExpr (E.Value b)) -- ^ getter from query to searched element + -> t -- ^ query row + -> Set.Set Text -- ^ needle collection + -> E.SqlExpr (E.Value Bool) +mkContainsFilterWithComma cast lenslike row (foldMap commaSeparatedText -> criterias) + | Set.null criterias = true + | otherwise = any (hasInfix $ lenslike row) (E.val . cast <$> Set.toList criterias) + +-- | like `mkContainsFilterWithComma` but enforced the existence of all Texts prefixed with + +mkContainsFilterWithCommaPlus :: (E.SqlString b, Ord b) + => (Text -> b) + -> (t -> E.SqlExpr (E.Value b)) -- ^ getter from query to searched element + -> t -- ^ query row + -> Set.Set Text -- ^ needle collection + -> E.SqlExpr (E.Value Bool) +mkContainsFilterWithCommaPlus cast lenslike row (foldMap commaSeparatedText -> criterias) + | Set.null criterias = true + | Set.null compulsories = cond_optional + | Set.null alternatives = cond_compulsory + | otherwise = cond_compulsory E.&&. cond_optional + where + (Set.mapMonotonic (Text.stripStart . Text.drop 1) -> compulsories, alternatives) = Set.partition (Text.isPrefixOf "+") criterias + cond_compulsory = all (hasInfix $ lenslike row) (E.val . cast <$> Set.toList compulsories) + cond_optional = any (hasInfix $ lenslike row) (E.val . cast <$> Set.toList alternatives) mkDayFilter :: (t -> E.SqlExpr (E.Value UTCTime)) -- ^ getter from query to searched element -> t -- ^ query row @@ -483,7 +551,7 @@ max, min :: PersistField a max a b = bool a b $ b E.>. a min a b = bool a b $ b E.<. a --- these alternatives for max/min ought to be more efficient; note that NULL is avoided by greatest/least +-- these alternatives for max/min ought to be more efficient; note that NULL is avoided by PostgreSQL greatest/least greatest :: PersistField a => E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value a) greatest a b = E.unsafeSqlFunction "GREATEST" $ E.toArgList (a,b) diff --git a/src/Foundation/I18n.hs b/src/Foundation/I18n.hs index 4651944ad..1271b4da4 100644 --- a/src/Foundation/I18n.hs +++ b/src/Foundation/I18n.hs @@ -248,9 +248,16 @@ mkMessageVariant ''UniWorX ''ButtonMessage "messages/button" "de" mkMessageVariant ''UniWorX ''FrontendMessage "messages/frontend" "de-de-formal" embedRenderMessage ''UniWorX ''AvsLicence id -- required by UniWorXAvsMessages + mkMessageAddition ''UniWorX "Qualification" "messages/uniworx/categories/qualification" "de-de-formal" mkMessageAddition ''UniWorX "Avs" "messages/uniworx/categories/avs" "de-de-formal" +embedRenderMessage ''UniWorX ''LmsStatus (uncurry ((<>) . (<> "Status")) . Text.splitAt 3) + +instance RenderMessage UniWorX (Maybe LmsStatus) where -- useful for Filter with optionsFinite + renderMessage f ls (Just s) = renderMessage f ls s + renderMessage f ls Nothing = renderMessage f ls MsgLmsStateOpen + instance RenderMessage UniWorX AvsDataCardColor where renderMessage _foundation _ls (AvsCardColorMisc t) = Text.cons '*' t renderMessage f ls AvsCardColorGrün = renderMessage f ls MsgAvsCardColorGreen diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 9f4ef54bd..1dbc9384a 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -121,6 +121,7 @@ breadcrumb ProblemUnreachableR = i18nCrumb MsgProblemsUnreachableHeading $ Just breadcrumb ProblemWithoutAvsId = i18nCrumb MsgProblemsNoAvsIdHeading $ Just AdminProblemsR breadcrumb ProblemFbutNoR = i18nCrumb MsgProblemsRWithoutFHeading $ Just AdminProblemsR breadcrumb ProblemAvsSynchR = i18nCrumb MsgProblemsAvsSynchHeading $ Just AdminProblemsR +breadcrumb ProblemAvsErrorR = i18nCrumb MsgProblemsAvsErrorHeading $ Just ProblemAvsSynchR breadcrumb PrintCenterR = i18nCrumb MsgMenuApc Nothing breadcrumb PrintSendR = i18nCrumb MsgMenuPrintSend $ Just PrintCenterR @@ -186,8 +187,17 @@ breadcrumb (LmsUserlistDirectR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Jus breadcrumb (LmsResultR ssh qsh) = i18nCrumb MsgMenuLmsResult $ Just $ LmsR ssh qsh breadcrumb (LmsResultUploadR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsResultR ssh qsh breadcrumb (LmsResultDirectR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsResultR ssh qsh -- never displayed +-- v2 +breadcrumb (LmsLearnersR ssh qsh) = i18nCrumb MsgMenuLmsLearners $ Just $ LmsR ssh qsh +breadcrumb (LmsLearnersDirectR ssh qsh) = i18nCrumb MsgMenuLmsLearners $ Just $ LmsLearnersR ssh qsh -- never displayed, TypedContent +breadcrumb (LmsReportR ssh qsh) = i18nCrumb MsgMenuLmsReport $ Just $ LmsR ssh qsh +breadcrumb (LmsReportUploadR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsReportR ssh qsh +breadcrumb (LmsReportDirectR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsReportR ssh qsh -- never displayed +-- breadcrumb (LmsIdentR ssh qsh _ ) = breadcrumb $ LmsR ssh qsh -- just a redirect -breadcrumb (LmsUserR _) = i18nCrumb MsgMenuLmsUser $ Just LmsAllR +breadcrumb (LmsUserR ssh _qsh u ) = i18nCrumb MsgMenuLmsUser $ Just $ LmsUserSchoolR u ssh +breadcrumb (LmsUserSchoolR u _ ) = i18nCrumb MsgMenuLmsUserSchool $ Just $ LmsUserAllR u +breadcrumb (LmsUserAllR _ ) = i18nCrumb MsgMenuLmsUserAll $ Just LmsAllR -- breadcrumb (LmsFakeR ssh qsh) = i18nCrumb MsgMenuLmsFake $ Just $ LmsR ssh qsh -- TODO: remove in production breadcrumb ProfileR = i18nCrumb MsgBreadcrumbProfile Nothing @@ -2336,24 +2346,37 @@ pageActions ParticipantsListR = return ] pageActions (LmsR sid qsh) = return [ NavPageActionPrimary + { navLink = defNavLink MsgMenuLmsLearners $ LmsLearnersR sid qsh + , navChildren = + [ defNavLink MsgMenuLmsDirectDownload $ LmsLearnersDirectR sid qsh + ] + } + , NavPageActionPrimary + { navLink = defNavLink MsgMenuLmsReport $ LmsReportR sid qsh + , navChildren = + [ defNavLink MsgMenuLmsUpload $ LmsReportUploadR sid qsh + , defNavLink MsgMenuLmsDirectUpload $ LmsReportDirectR sid qsh + ] + } + , NavPageActionSecondary { navLink = defNavLink MsgMenuLmsUsers $ LmsUsersR sid qsh - , navChildren = - [ defNavLink MsgMenuLmsDirectDownload $ LmsUsersDirectR sid qsh - ] + -- , navChildren = + -- [ defNavLink MsgMenuLmsDirectDownload $ LmsUsersDirectR sid qsh + -- ] } - , NavPageActionPrimary + , NavPageActionSecondary { navLink = defNavLink MsgMenuLmsUserlist $ LmsUserlistR sid qsh - , navChildren = - [ defNavLink MsgMenuLmsUpload $ LmsUserlistUploadR sid qsh - , defNavLink MsgMenuLmsDirectUpload $ LmsUserlistDirectR sid qsh - ] + -- , navChildren = + -- [ defNavLink MsgMenuLmsUpload $ LmsUserlistUploadR sid qsh + -- , defNavLink MsgMenuLmsDirectUpload $ LmsUserlistDirectR sid qsh + -- ] } - , NavPageActionPrimary + , NavPageActionSecondary { navLink = defNavLink MsgMenuLmsResult $ LmsResultR sid qsh - , navChildren = - [ defNavLink MsgMenuLmsUpload $ LmsResultUploadR sid qsh - , defNavLink MsgMenuLmsDirectUpload $ LmsResultDirectR sid qsh - ] + -- , navChildren = + -- [ defNavLink MsgMenuLmsUpload $ LmsResultUploadR sid qsh + -- , defNavLink MsgMenuLmsDirectUpload $ LmsResultDirectR sid qsh + -- ] } , NavPageActionSecondary { navLink = defNavLink MsgMenuLmsEdit $ LmsEditR sid qsh diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 943748605..0340bc41f 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -45,11 +45,13 @@ getAdminProblemsR = do cutOffPrintDays = 7 cutOffPrintJob = addLocalDays (-cutOffPrintDays) now - (usersAreReachable, driversHaveAvsIds, rDriversHaveFs, noStalePrintJobs) <- runDB $ (,,,) + (usersAreReachable, driversHaveAvsIds, rDriversHaveFs, noStalePrintJobs, noBadAPCids, noAvsSynchProblems) <- runDB $ (,,,,,) <$> areAllUsersReachable - <*> allDriversHaveAvsId nowaday - <*> allRDriversHaveFs nowaday - <*> (not <$> exists [PrintJobAcknowledged ==. Nothing, PrintJobCreated <=. cutOffPrintJob]) + <*> allDriversHaveAvsId now + <*> allRDriversHaveFs now + <*> (not <$> exists [PrintJobAcknowledged ==. Nothing, PrintJobCreated <=. cutOffPrintJob]) + <*> (not <$> exists [PrintAcknowledgeProcessed ==. False]) + <*> (not <$> exists [UserAvsLastSynchError !=. Nothing]) diffLics <- try retrieveDifferingLicences >>= \case -- (Left (UnsupportedContentType "text/html" resp)) -> Left $ text2widget "Html received" (Left e) -> return $ Left $ text2widget $ tshow (e :: SomeException) @@ -105,9 +107,8 @@ getProblemUnreachableR = do getProblemFbutNoR :: Handler Html getProblemFbutNoR = do - now <- liftIO getCurrentTime - let nowaday = utctDay now - rnofs <- runDB $ E.select $ retrieveDriversRWithoutF nowaday + now <- liftIO getCurrentTime + rnofs <- runDB $ E.select $ retrieveDriversRWithoutF now siteLayoutMsg MsgProblemsRWithoutFHeading $ do setTitleI MsgProblemsRWithoutFHeading [whamlet| @@ -121,9 +122,8 @@ getProblemFbutNoR = do getProblemWithoutAvsId :: Handler Html getProblemWithoutAvsId = do - now <- liftIO getCurrentTime - let nowaday = utctDay now - rnofs <- runDB $ E.select $ retrieveDriversWithoutAvsId nowaday + now <- liftIO getCurrentTime + rnofs <- runDB $ E.select $ retrieveDriversWithoutAvsId now siteLayoutMsg MsgProblemsNoAvsIdHeading $ do setTitleI MsgProblemsNoAvsIdHeading [whamlet| @@ -172,7 +172,7 @@ retrieveUnreachableUsers = do hasInvalidEmail = isNothing . getEmailAddress . entityVal -allDriversHaveAvsId :: Day -> DB Bool +allDriversHaveAvsId :: UTCTime -> DB Bool -- allDriversHaveAvsId = fmap isNothing . E.selectOne . retrieveDriversWithoutAvsId allDriversHaveAvsId = E.selectNotExists . retrieveDriversWithoutAvsId @@ -197,8 +197,8 @@ retrieveDriversWithoutAvsId' nowaday = do -} -- | Returns users at most once, even if they own multiple avs-related licences, but no AvsID is known -retrieveDriversWithoutAvsId :: Day -> E.SqlQuery (E.SqlExpr (Entity User)) -retrieveDriversWithoutAvsId nowaday = do +retrieveDriversWithoutAvsId :: UTCTime -> E.SqlQuery (E.SqlExpr (Entity User)) +retrieveDriversWithoutAvsId now = do usr <- E.from $ E.table @User E.where_ $ E.exists (do -- a valid avs licence @@ -207,7 +207,7 @@ retrieveDriversWithoutAvsId nowaday = do `E.on` (\(qual :& qualUsr) -> qual E.^. QualificationId E.==. qualUsr E.^. QualificationUserQualification)) E.where_ $ -- is avs licence E.isJust (qual E.^. QualificationAvsLicence) - E.&&. (qualUsr & validQualification nowaday) -- currently valid + E.&&. (qualUsr & validQualification now) -- currently valid E.&&. -- matches user (qualUsr E.^. QualificationUserUser E.==. usr E.^. UserId) ) @@ -219,13 +219,13 @@ retrieveDriversWithoutAvsId nowaday = do return usr -allRDriversHaveFs :: Day -> DB Bool +allRDriversHaveFs :: UTCTime -> DB Bool -- allRDriversHaveFs = fmap isNothing . E.selectOne . retrieveDriversRWithoutF allRDriversHaveFs = E.selectNotExists . retrieveDriversRWithoutF -- | Returns users at most once, even if they own multiple avs-related licences, but no AvsID is known -retrieveDriversRWithoutF :: Day -> E.SqlQuery (E.SqlExpr (Entity User)) -retrieveDriversRWithoutF nowaday = do +retrieveDriversRWithoutF :: UTCTime -> E.SqlQuery (E.SqlExpr (Entity User)) +retrieveDriversRWithoutF now = do usr <- E.from $ E.table @User let hasValidQual lic = do (qual :& qualUsr) <- E.from (E.table @Qualification @@ -233,7 +233,7 @@ retrieveDriversRWithoutF nowaday = do `E.on` (\(qual :& qualUsr) -> qual E.^. QualificationId E.==. qualUsr E.^. QualificationUserQualification)) E.where_ $ (qual E.^. QualificationAvsLicence E.==. E.justVal lic) -- matches licence E.&&. (qualUsr E.^. QualificationUserUser E.==. usr E.^. UserId) -- matches user - E.&&. (qualUsr & validQualification nowaday) -- currently valid + E.&&. (qualUsr & validQualification now) -- currently valid E.where_ $ E.exists (hasValidQual AvsLicenceRollfeld) E.&&. E.notExists (hasValidQual AvsLicenceVorfeld) return usr diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index 2b85dd7a3..e7b4fda22 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -11,6 +11,7 @@ module Handler.Admin.Avs ( getAdminAvsR, postAdminAvsR , getAdminAvsUserR , getProblemAvsSynchR, postProblemAvsSynchR + , getProblemAvsErrorR ) where import Import @@ -79,7 +80,7 @@ makeAvsPersonForm tmpl = identifyForm FIDAvsQueryPerson . validateForm validateA validateAvsQueryPerson :: FormValidator AvsQueryPerson Handler () validateAvsQueryPerson = do AvsQueryPerson{..} <- State.get - guardValidation MsgAvsQueryEmpty $ + guardValidation MsgAvsQueryEmpty $ is _Just avsPersonQueryCardNo || is _Just avsPersonQueryFirstName || is _Just avsPersonQueryLastName || @@ -111,7 +112,7 @@ makeAvsContactForm tmpl = identifyForm FIDAvsQueryContact . validateForm validat where parseAvsIds :: Text -> AvsQueryContact parseAvsIds txt = AvsQueryContact $ Set.fromList ids - where + where nonemptys = filter (not . Text.null) $ Text.strip <$> Text.split (==',') txt ids = mapMaybe (fmap AvsObjPersonId . readMay) nonemptys unparseAvsIds :: AvsQueryContact -> Text @@ -156,7 +157,7 @@ postAdminAvsR = do Left err -> let msg = tshow err in return $ Just [whamlet|

Error:

#{msg}|] Right (AvsResponsePerson pns) -> return $ Just [whamlet|
    - $forall p <- pns + $forall p <- pns
  • #{decodeUtf8 (Pretty.encodePretty (toJSON p))} |] mbPerson <- formResultMaybe presult procFormPerson @@ -169,7 +170,7 @@ postAdminAvsR = do Left err -> let msg = tshow err in return $ Just [whamlet|

    Error:

    #{msg}|] Right (AvsResponseStatus pns) -> return $ Just [whamlet|
      - $forall p <- pns + $forall p <- pns
    • #{decodeUtf8 (Pretty.encodePretty (toJSON p))} |] mbStatus <- formResultMaybe sresult procFormStatus @@ -182,7 +183,7 @@ postAdminAvsR = do Left err -> let msg = tshow err in return $ Just [whamlet|

      Error:

      #{msg}|] Right (AvsResponseContact pns) -> return $ Just [whamlet|
        - $forall AvsDataContact{..} <- pns + $forall AvsDataContact{..} <- pns
        • AvsId: #{tshow avsContactPersonID} @@ -242,7 +243,7 @@ postAdminAvsR = do ((setLicRes, setLicWgt), setLicEnctype) <- runFormPost $ identifyForm FIDAvsSetLicence $ \html -> flip (renderAForm FormStandard) html $ (,) <$> areq intField (fslI MsgAvsPersonId) Nothing <*> areq (selectField $ return avsLicenceOptions) (fslI MsgAvsLicence) (Just AvsLicenceVorfeld) - let procFormSetLic (aid, lic) = do + let procFormSetLic (aid, lic) = do res <- try $ setLicenceAvs (AvsPersonId aid) lic case res of (Right True) -> @@ -327,7 +328,7 @@ instance Finite ButtonAvsImportUnknown nullaryPathPiece ''ButtonAvsImportUnknown camelToPathPiece embedRenderMessage ''UniWorX ''ButtonAvsImportUnknown id instance Button UniWorX ButtonAvsImportUnknown where - btnClasses BtnAvsImportUnknown = [BCIsButton, BCPrimary] + btnClasses BtnAvsImportUnknown = [BCIsButton, BCPrimary] data ButtonAvsRevokeUnknown = BtnAvsRevokeUnknown deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic) @@ -349,13 +350,14 @@ nullaryPathPiece ''LicenceTableAction $ camelToPathPiece' 2 embedRenderMessage ''UniWorX ''LicenceTableAction id data LicenceTableActionData = LicenceTableChangeAvsData - | LicenceTableRevokeFDriveData + | LicenceTableRevokeFDriveData { licenceTableChangeFDriveQId :: QualificationId , licenceTableChangeFDriveReason :: Text , licenceTableChangeFDriveNotify :: Bool } - | LicenceTableGrantFDriveData + | LicenceTableGrantFDriveData { licenceTableChangeFDriveQId :: QualificationId + , licenceTableChangeFDriveReason :: Text , licenceTableChangeFDriveEnd :: Day , licenceTableChangeFDriveRenew :: Maybe Bool } @@ -364,12 +366,12 @@ data LicenceTableActionData = LicenceTableChangeAvsData postProblemAvsSynchR, getProblemAvsSynchR :: Handler Html postProblemAvsSynchR = getProblemAvsSynchR -getProblemAvsSynchR = do +getProblemAvsSynchR = do let catchAllAvs' r = flip catch (\err -> addMessageModal Error (i18n MsgAvsCommunicationError) (Right (text2widget $ tshow (err :: SomeException))) >> redirect r) catchAllAvs = catchAllAvs' ProblemAvsSynchR -- == current route; use only in conditions that are not repeated upon reload; do not call redirect within catchAllAvs actions! (AvsLicenceDifferences{..}, apidStatus) <- catchAllAvs' AdminR retrieveDifferingLicencesStatus - -- + -- unknownLicenceOwners' <- whenNonEmpty avsLicenceDiffRevokeAll $ \neZeros -> runDB $ E.select $ do (toZero :& usrAvs) <- X.from $ @@ -381,7 +383,7 @@ getProblemAvsSynchR = do numUnknownLicenceOwners = length unknownLicenceOwners (btnImportUnknownWgt, btnImportUnknownRes) <- runButtonFormHash unknownLicenceOwners FIDBtnAvsImportUnknown - ifMaybeM btnImportUnknownRes () $ \BtnAvsImportUnknown -> do + ifMaybeM btnImportUnknownRes () $ \BtnAvsImportUnknown -> do res <- catchAllAvs $ forM (take 500 unknownLicenceOwners) $ try . upsertAvsUserById -- TODO: turn this into a background job let procRes (Right _) = (Sum 1, mempty :: Set.Set AvsPersonId, mempty :: Set.Set AvsPersonId, mempty) --TODO: continue here! @@ -389,7 +391,7 @@ getProblemAvsSynchR = do --procRes (Left (AvsUserUnknownByAvs api)) = (Sum 0, mempty, Set.singleton api, mempty) procRes (Left (err :: SomeException)) = (Sum 0, mempty, mempty, Set.singleton $ tshow err) (Sum oks, ambis, unkns, errs) = foldMap procRes res - ms = if oks == numUnknownLicenceOwners then Success else Warning + ms = if oks == numUnknownLicenceOwners then Success else Warning unless (null ambis) $ addMessageModal Error (i18n $ MsgAvsImportAmbiguous $ length ambis) (Right (text2widget $ tshow ambis)) unless (null unkns) $ addMessageModal Error (i18n $ MsgAvsImportUnknowns $ length unkns) (Right (text2widget $ tshow unkns)) unless (null errs) $ addMessageModal Error (i18n MsgAvsCommunicationError) (Right (text2widget $ tshow errs )) @@ -398,12 +400,12 @@ getProblemAvsSynchR = do (btnRevokeUnknownWgt, btnRevokeUnknownRes) <- runButtonFormHash unknownLicenceOwners FIDBtnAvsRevokeUnknown let revokeUnknownExecWgt = btnRevokeUnknownWgt - revokeUnknownSafetyWgt = [whamlet| + revokeUnknownSafetyWgt = [whamlet|
          ^{modalBtn} - |] + |] modalBtn = btnModal MsgBtnAvsRevokeUnknown (btnClasses BtnAvsRevokeUnknown) (Right youSureWgt) youSureWgt = [whamlet|

          @@ -411,133 +413,144 @@ getProblemAvsSynchR = do

          ^{revokeUnknownExecWgt} |] - + ifMaybeM btnRevokeUnknownRes () $ \BtnAvsRevokeUnknown -> do let revokes = Set.map (AvsPersonLicence AvsNoLicence) $ Set.fromList unknownLicenceOwners no_revokes = Set.size revokes oks <- catchAllAvs $ setLicencesAvs revokes - if oks < no_revokes + if oks < no_revokes then addMessageI Error MsgRevokeUnknownLicencesFail - else addMessageI Info MsgRevokeUnknownLicencesOk - redirect ProblemAvsSynchR + else addMessageI Info MsgRevokeUnknownLicencesOk + redirect ProblemAvsSynchR -- licence differences - ((tres0,tb0),(tres1up,tb1up),(tres1down,tb1down),(tres2,tb2)) <- runDB $ (,,,) - <$> mkLicenceTable apidStatus "avsLicDiffRevokeVorfeld" AvsLicenceVorfeld avsLicenceDiffRevokeAll - <*> mkLicenceTable apidStatus "avsLicDiffGrantVorfeld" AvsNoLicence avsLicenceDiffGrantVorfeld - <*> mkLicenceTable apidStatus "avsLicDiffRevokeRollfeld" AvsLicenceRollfeld avsLicenceDiffRevokeRollfeld - <*> mkLicenceTable apidStatus "avsLicDiffGrantRollfeld" AvsNoLicence avsLicenceDiffGrantRollfeld - + ((tres0,tb0),(tres1up,tb1up),(tres1down,tb1down),(tres2,tb2)) <- runDB $ (,,,) + <$> mkLicenceTable apidStatus "avsLicDiffRevokeVorfeld" AvsLicenceVorfeld avsLicenceDiffRevokeAll + <*> mkLicenceTable apidStatus "avsLicDiffGrantVorfeld" AvsNoLicence avsLicenceDiffGrantVorfeld + <*> mkLicenceTable apidStatus "avsLicDiffRevokeRollfeld" AvsLicenceRollfeld avsLicenceDiffRevokeRollfeld + <*> mkLicenceTable apidStatus "avsLicDiffGrantRollfeld" AvsNoLicence avsLicenceDiffGrantRollfeld + now <- liftIO getCurrentTime - let nowaday = utctDay now + let nowaday = utctDay now procRes :: AvsLicence -> (LicenceTableActionData, Set AvsPersonId) -> Handler () - procRes aLic (LicenceTableChangeAvsData , apids) = do + procRes aLic (LicenceTableChangeAvsData , apids) = do oks <- catchAllAvs $ setLicencesAvs $ Set.map (AvsPersonLicence aLic) apids let no_req = Set.size apids mkind = if oks < no_req || no_req < 0 then Warning else Success - addMessageI mkind $ MsgAvsSetLicences aLic oks no_req + addMessageI mkind $ MsgAvsSetLicences aLic oks no_req redirect ProblemAvsSynchR -- reload to update all tables - procRes alic (LicenceTableRevokeFDriveData{..}, apids) = do + procRes alic (LicenceTableRevokeFDriveData{..}, apids) = do oks <- runDB $ do qId <- getKeyBy404 $ UniqueQualificationAvsLicence $ Just alic - if qId /= licenceTableChangeFDriveQId + if qId /= licenceTableChangeFDriveQId then return (-1) else do uids <- view _userAvsUser <<$>> selectList [UserAvsPersonId <-. Set.toList apids] [] - qualificationUserBlocking licenceTableChangeFDriveQId uids licenceTableChangeFDriveNotify $ - Just $ QualificationBlocked - { qualificationBlockedDay = nowaday - , qualificationBlockedReason = licenceTableChangeFDriveReason - } + qualificationUserBlocking licenceTableChangeFDriveQId uids False Nothing (Left licenceTableChangeFDriveReason) licenceTableChangeFDriveNotify if | oks < 0 -> addMessageI Error $ MsgRevokeFraDriveLicencesError alic | oks > 0, oks == length apids -> addMessageI Success $ MsgRevokeFraDriveLicences alic oks | otherwise -> addMessageI Warning $ MsgRevokeFraDriveLicences alic oks - redirect ProblemAvsSynchR -- must be outside runDB + redirect ProblemAvsSynchR -- must be outside runDB procRes _alic (LicenceTableGrantFDriveData{..}, apids ) = do - (n, Qualification{qualificationShorthand}) <- runDB $ do - uids <- view _userAvsUser <<$>> selectList [UserAvsPersonId <-. Set.toList apids] [] + (n, Qualification{qualificationShorthand}) <- runDB $ do + uids <- view _userAvsUser <<$>> selectList [UserAvsPersonId <-. Set.toList apids] [] -- addMessage Info $ text2Html $ "UIDs: " <> tshow uids -- DEBUG + void $ qualificationUserBlocking licenceTableChangeFDriveQId uids True Nothing (Left licenceTableChangeFDriveReason) False forM_ uids $ upsertQualificationUser licenceTableChangeFDriveQId nowaday licenceTableChangeFDriveEnd licenceTableChangeFDriveRenew (length uids,) <$> get404 licenceTableChangeFDriveQId addMessageI (bool Success Warning $ null apids) $ MsgSetFraDriveLicences (citext2string qualificationShorthand) n - redirect ProblemAvsSynchR -- must be outside runDB - + redirect ProblemAvsSynchR -- must be outside runDB + formResult tres2 $ procRes AvsLicenceRollfeld formResult tres1down $ procRes AvsLicenceVorfeld - formResult tres1up $ procRes AvsLicenceVorfeld + formResult tres1up $ procRes AvsLicenceVorfeld formResult tres0 $ procRes AvsNoLicence - + siteLayoutMsg MsgAvsTitleLicenceSynch $ do setTitleI MsgAvsTitleLicenceSynch $(i18nWidgetFile "avs-synchronisation") -type LicenceTableExpr = ( E.SqlExpr (Entity UserAvs) - `E.InnerJoin` E.SqlExpr (Entity User) +type LicenceTableExpr = ( E.SqlExpr (Entity UserAvs) + `E.InnerJoin` E.SqlExpr (Entity User) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity QualificationUser)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity Qualification)) - ) + `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity QualificationUserBlock)) + ) queryUserAvs :: LicenceTableExpr -> E.SqlExpr (Entity UserAvs) -queryUserAvs = $(E.sqlIJproj 2 1) . $(E.sqlLOJproj 3 1) +queryUserAvs = $(E.sqlIJproj 2 1) . $(E.sqlLOJproj 4 1) queryUser :: LicenceTableExpr -> E.SqlExpr (Entity User) -queryUser = $(E.sqlIJproj 2 2) . $(E.sqlLOJproj 3 1) +queryUser = $(E.sqlIJproj 2 2) . $(E.sqlLOJproj 4 1) queryQualUser :: LicenceTableExpr -> E.SqlExpr (Maybe (Entity QualificationUser)) -queryQualUser = $(E.sqlLOJproj 3 2) +queryQualUser = $(E.sqlLOJproj 4 2) queryQualification :: LicenceTableExpr -> E.SqlExpr (Maybe (Entity Qualification)) -queryQualification = $(E.sqlLOJproj 3 3) +queryQualification = $(E.sqlLOJproj 4 3) -type LicenceTableData = DBRow (Entity UserAvs, Entity User, Maybe (Entity QualificationUser), Maybe (Entity Qualification)) +queryQualBlock :: LicenceTableExpr -> E.SqlExpr (Maybe (Entity QualificationUserBlock)) +queryQualBlock = $(E.sqlLOJproj 4 4) -resultUserAvs :: Lens' LicenceTableData (Entity UserAvs) +type LicenceTableData = DBRow (Entity UserAvs, Entity User, Maybe (Entity QualificationUser), Maybe (Entity Qualification), Maybe (Entity QualificationUserBlock)) + +resultUserAvs :: Lens' LicenceTableData (Entity UserAvs) resultUserAvs = _dbrOutput . _1 -resultUser :: Lens' LicenceTableData (Entity User) +resultUser :: Lens' LicenceTableData (Entity User) resultUser = _dbrOutput . _2 -resultQualUser :: Traversal' LicenceTableData (Entity QualificationUser) +resultQualUser :: Traversal' LicenceTableData (Entity QualificationUser) resultQualUser = _dbrOutput . _3 . _Just resultQualification :: Traversal' LicenceTableData (Entity Qualification) resultQualification = _dbrOutput . _4 . _Just -instance HasEntity LicenceTableData User where +resultQualBlock :: Traversal' LicenceTableData (Entity QualificationUserBlock) +resultQualBlock = _dbrOutput . _5 . _Just + +instance HasEntity LicenceTableData User where hasEntity = resultUser -instance HasUser LicenceTableData where - hasUser = resultUser . _entityVal +instance HasUser LicenceTableData where + hasUser = resultUser . _entityVal +-- instance HasQualificationUser LicenceTableData where -- Not possible, since not all rows have a QualificationUser +-- hasQualificationUser = resultQualUser . _entityVal mkLicenceTable :: AvsPersonIdMapPersonCard -> Text -> AvsLicence -> Set AvsPersonId -> DB (FormResult (LicenceTableActionData, Set AvsPersonId), Widget) -mkLicenceTable apidStatus dbtIdent aLic apids = do +mkLicenceTable apidStatus dbtIdent aLic apids = do currentRoute <- fromMaybe (error "mkLicenceTable called from 404-handler") <$> liftHandler getCurrentRoute avsQualifications <- selectList [QualificationAvsLicence !=. Nothing] [] now <- liftIO getCurrentTime - let nowaday = utctDay now - -- fltrLic qual = if + + let nowaday = utctDay now + avsQids = entityKey <$> avsQualifications + -- fltrLic qual = if -- | aLic == AvsNoLicence -> E.isNothing (qual E.?. QualificationId) E.||. E.isJust (E.joinV $ qual E.?. QualificationAvsLicence) -- could be R, F, both or none at all, but has licence in AVS -- | otherwise -> E.isNothing (qual E.?. QualificationId) E.||. (E.val aLic E.=?. E.joinV (qual E.?. QualificationAvsLicence)) -- if we suggest granting that licence, this join should deliver a value too fltrLic qual = E.isNothing (qual E.?. QualificationId) E.||. E.isJust (E.joinV $ qual E.?. QualificationAvsLicence) - -- TODO: user holding multiple qualifications may appear multiple times in to-delete-in-avs table, which is kinda ugly. Solution: - dbtSQLQuery = \(usrAvs `E.InnerJoin` user `E.LeftOuterJoin` qualUser `E.LeftOuterJoin` qual) -> do + -- TODO: user holding multiple qualifications may appear multiple times in to-delete-in-avs table, which is kinda ugly. Solution: + dbtSQLQuery = \(usrAvs `E.InnerJoin` user `E.LeftOuterJoin` qualUser `E.LeftOuterJoin` qual `E.LeftOuterJoin` qblock) -> do + E.on $ qblock E.?. QualificationUserBlockQualificationUser E.==. qualUser E.?. QualificationUserId + E.&&. qblock `isLatestBlockBefore` E.val now E.on $ qual E.?. QualificationId E.==. qualUser E.?. QualificationUserQualification E.on $ user E.^. UserId E.=?. qualUser E.?. QualificationUserUser E.on $ user E.^. UserId E.==. usrAvs E.^. UserAvsUser - E.where_ $ fltrLic qual E.&&. (usrAvs E.^. UserAvsPersonId `E.in_` E.vals apids) - return (usrAvs, user, qualUser, qual) + E.where_ $ fltrLic qual + E.&&. (usrAvs E.^. UserAvsPersonId `E.in_` E.vals apids) + return (usrAvs, user, qualUser, qual, qblock) dbtRowKey = queryUserAvs >>> (E.^. UserAvsPersonId) -- ) &&& (queryQualification >>> (E.?. QualificationId)) -- WHY IS THIS AN ERROR? -- Not sure what changes here: - dbtProj = dbtProjId -- Simple $ \(userAvs, user, qualUsr, quali) -> return (userAvs, user, qualUsr, quali) + dbtProj = dbtProjId -- Simple $ \(userAvs, user, qualUsr, quali) -> return (userAvs, user, qualUsr, quali) dbtColonnade = mconcat [ dbSelect (applying _2) id $ return . view (resultUserAvs . _userAvsPersonId) -- (\DBRow{dbrOutput=(_,_,apid,_)} -> return apid -- return . view resultAvsPID) -- does not type due to traversal , colUserNameLink AdminUserR - , sortable (Just "avspersonno") (i18nCell MsgAvsPersonNo) $ \(view resultUserAvs -> a) -> avsPersonNoLinkedCell a - -- , colUserCompany + , sortable (Just "avspersonno") (i18nCell MsgAvsPersonNo) $ \(view resultUserAvs -> a) -> avsPersonNoLinkedCell a + -- , colUserCompany , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \(view (resultUser . _entityKey) -> uid) -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX" companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId @@ -549,48 +562,49 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do icnSuper = text2markup " " <> icon IconSupervisor pure $ toWgt $ mconcat companies , sortable (Just "qualification") (i18nCell MsgTableQualifications) $ \(preview resultQualification -> q) -> cellMaybe lmsShortCell q - , sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) (cellMaybe (qualificationValidIconCell nowaday) . preview resultQualUser) - , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \(preview $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> cellMaybe dayCell d - , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \(preview $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> cellMaybe dayCell d , sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \(preview $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> cellMaybe dayCell d - , sortable (Just "blocked-due") (i18nCell MsgTableQualificationBlockedDue & cellTooltip MsgTableQualificationBlockedTooltip - ) $ \(preview $ resultQualUser . _entityVal . _qualificationUserBlockedDue -> b) -> cellMaybe qualificationBlockedCell b + , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \(preview $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> cellMaybe dayCell d + -- , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \(preview $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> cellMaybe dayCell d + , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \row -> + cellMaybe (qualificationValidUntilCell nowaday (row ^? resultQualBlock)) (row ^? resultQualUser) + , sortable (Just "blocked") (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltip) $ \row -> + cellMaybe (qualificationValidReasonCell' Nothing True nowaday (row ^? resultQualBlock)) (row ^? resultQualUser) , sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip ) $ \(preview $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> cellMaybe (flip ifIconCell IconNoNotification . not) b , sortable Nothing (i18nCell MsgTableAvsActiveCards) $ \(view $ resultUserAvs . _userAvsPersonId -> apid) -> foldMap avsPersonCardCell $ Map.lookup apid apidStatus ] dbtSorting = mconcat - [ single $ sortUserNameLink queryUser - , single ("avspersonno" , SortColumn $ queryUserAvs >>> (E.^. UserAvsNoPerson)) - , single ("qualification" , SortColumn $ queryQualification >>> (E.?. QualificationShorthand)) + [ single $ sortUserNameLink queryUser + , single ("avspersonno" , SortColumn $ queryUserAvs >>> (E.^. UserAvsNoPerson)) + , single ("qualification" , SortColumn $ queryQualification >>> (E.?. QualificationShorthand)) , single $ sortUserCompany queryUser - , 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 ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.?. QualificationUserScheduleRenewal)) - , single ("validity" , SortColumn $ queryQualUser >>> validQualification' nowaday) - ] + , single ("valid-until" , SortColumn $ queryQualUser >>> (E.?. QualificationUserValidUntil)) + , single ("last-refresh" , SortColumn $ queryQualUser >>> (E.?. QualificationUserLastRefresh)) + , single ("first-held" , SortColumn $ queryQualUser >>> (E.?. QualificationUserFirstHeld)) + , single ("blocked" , SortColumnNeverNull $ queryQualBlock >>> (E.?. QualificationUserBlockFrom)) + , single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.?. QualificationUserScheduleRenewal)) + -- , single ("validity" , SortColumn $ queryQualUser >>> (E.?. QualificationUserValidUntil)) + ] dbtFilter = mconcat [ single $ fltrUserNameEmail queryUser - , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification' nowaday)) -- why does this not work? - , single ( "user-company", FilterColumn . E.mkExistsFilter $ \row criterion -> - E.from $ \(usrComp `E.InnerJoin` comp) -> do + , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification' now)) + , single ( "user-company", FilterColumn . E.mkExistsFilter $ \row criterion -> + E.from $ \(usrComp `E.InnerJoin` comp) -> do let testname = (E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf` (E.explicitUnsafeCoerceSqlExprValue "citext" (comp E.^. CompanyName) :: E.SqlExpr (E.Value (CI Text))) testnumber nr = E.val nr E.==. comp E.^. CompanyAvsId testcrit = maybe testname testnumber $ readMay $ CI.original criterion E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId E.&&. testcrit - ) + ) ] dbtFilterUI mPrev = mconcat [ fltrUserNameEmailHdrUI MsgLmsUser mPrev , prismAForm (singletonFilter "validity" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid) , prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany) ] - + qualOpt :: Entity Qualification -> Handler (Option QualificationId) qualOpt (Entity qualId qual) = do cQualId :: CryptoUUIDQualification <- encrypt qualId @@ -598,22 +612,42 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do { optionDisplay = CI.original $ qualificationName qual , optionInternalValue = qualId , optionExternalValue = tshow cQualId - } + } aLicQid = fmap entityKey . headMay $ filter ((== Just aLic) . qualificationAvsLicence . entityVal) avsQualifications + + -- Block identical to Handler/Qualifications TODO: refactor + getBlockReasons unblk = E.select $ do + (quser :& qblock) <- X.from $ E.table @QualificationUser + `E.innerJoin` E.table @QualificationUserBlock + `X.on` (\(quser :& qblock) -> quser E.^. QualificationUserId E.==. qblock E.^. QualificationUserBlockQualificationUser) + E.where_ $ ((quser E.^. QualificationUserQualification) `E.in_` E.valList avsQids) + E.&&. unblk (qblock E.^. QualificationUserBlockUnblock) + E.groupBy (qblock E.^. QualificationUserBlockReason) + let countRows' :: E.SqlExpr (E.Value Int64) = E.countRows + E.orderBy [E.desc countRows'] + E.limit 7 + pure (qblock E.^. QualificationUserBlockReason) + mkOption :: E.Value Text -> Option Text + mkOption (E.unValue -> t) = Option{ optionDisplay = t, optionInternalValue = t, optionExternalValue = toPathPiece t } + suggestionsBlock :: HandlerFor UniWorX (OptionList Text) + suggestionsBlock = mkOptionList . fmap mkOption <$> runDB (getBlockReasons E.not_) + suggestionsUnblock = mkOptionList . fmap mkOption <$> runDB (getBlockReasons id) + acts :: Map LicenceTableAction (AForm Handler LicenceTableActionData) acts = mconcat [ singletonMap LicenceTableChangeAvs $ pure LicenceTableChangeAvsData , if aLic == AvsNoLicence then singletonMap LicenceTableRevokeFDrive $ LicenceTableRevokeFDriveData <$> apreq (selectField . fmap mkOptionList $ mapM qualOpt avsQualifications) (fslI MsgQualificationName) aLicQid - <*> apreq textField (fslI MsgQualificationBlockReason) Nothing - <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockNotify) (Just False) + <*> apreq (textField & cfStrip & addDatalist suggestionsBlock) (fslI MsgQualificationBlockReason) Nothing + <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockNotify) (Just False) - else singletonMap LicenceTableGrantFDrive $ LicenceTableGrantFDriveData + else singletonMap LicenceTableGrantFDrive $ LicenceTableGrantFDriveData <$> apreq (selectField . fmap mkOptionList $ mapM qualOpt avsQualifications) (fslI MsgQualificationName) aLicQid + <*> apreq (textField & cfStrip & addDatalist suggestionsUnblock) (fslI MsgQualificationGrantReason) Nothing <*> apreq dayField (fslI MsgLmsQualificationValidUntil) Nothing -- apreq?! <*> aopt (convertField not not (boolField . Just $ SomeMessage MsgBoolIrrelevant)) (fslI MsgQualificationUserNoRenewal) Nothing - ] + ] dbtParams = DBParamsForm { dbParamsFormMethod = POST , dbParamsFormAction = Just $ SomeRoute currentRoute @@ -630,11 +664,11 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do dbtCsvEncode = noCsvEncode dbtCsvDecode = Nothing dbtExtraReps = [] - dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } + dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } validator = def & defaultSorting [SortAscBy "user-name"] postprocess :: FormResult (First LicenceTableActionData, DBFormResult AvsPersonId Bool LicenceTableData) -- == DBFormResult (Map AvsPersonId (LicenceTableData, Bool -> Bool)) -> FormResult ( LicenceTableActionData, Set AvsPersonId) - postprocess inp = do + postprocess inp = do (First (Just act), usrMap) <- inp let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap return (act, usrSet) @@ -646,17 +680,17 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do getAdminAvsUserR :: CryptoUUIDUser -> Handler Html getAdminAvsUserR uuid = do uid <- decrypt uuid - Entity{entityVal=UserAvs{..}} <- runDB $ getBy404 $ UniqueUserAvsUser uid + Entity{entityVal=UserAvs{..}} <- runDB $ getBy404 $ UniqueUserAvsUser uid mAvsQuery <- getsYesod $ view _appAvsQuery resWgt <- case mAvsQuery of Nothing -> return [whamlet|Error: AVS interface configuration is incomplete.|] -- should never occur after initilisation - Just AvsQuery{..} -> do + Just AvsQuery{..} -> do mbContact <- avsQueryContact $ AvsQueryContact $ Set.singleton $ AvsObjPersonId userAvsPersonId - mbDataPerson <- lookupAvsUser userAvsPersonId + mbDataPerson <- lookupAvsUser userAvsPersonId return [whamlet|

          - Vorläufige Admin Ansicht AVS Daten. - Ansicht zeigt aktuelle Daten. + Vorläufige Admin Ansicht AVS Daten. + Ansicht zeigt aktuelle Daten. Es erfolgte damit aber noch kein Update der FRADrive Daten.

          @@ -664,28 +698,94 @@ getAdminAvsUserR uuid = do (bevorzugt)
          $case mbContact - $of Left err + $of Left err Fehler: #{tshow err} $of Right contactInfo - #{decodeUtf8 (Pretty.encodePretty (toJSON contactInfo))} + #{decodeUtf8 (Pretty.encodePretty (toJSON contactInfo))}
          PersonStatus und mehrere PersonSearch
          (benötigt mehrere AVS Abfragen)
          $maybe dataPerson <- mbDataPerson #{decodeUtf8 (Pretty.encodePretty (toJSON dataPerson))} - $nothing - Keine Daten erhalten. + $nothing + Keine Daten erhalten.

          Provisorische formatierte Ansicht -

          - Generisch formatierte Ansicht, die zeigt, in welche Richtung die Endansicht gehen könnte. +

          + Generisch formatierte Ansicht, die zeigt, in welche Richtung die Endansicht gehen könnte. In der Endansicht wären nur ausgewählte Felder mit besserer Bennenung in einer manuell gewählten Reihenfolge sichtbar. -

          +

          ^{foldMap jsonWidget mbContact} -

          +

          ^{foldMap jsonWidget mbDataPerson} - |] + |] let heading = [whamlet|_{MsgAvsPersonNo} #{userAvsNoPerson}|] - siteLayout heading $ do + siteLayout heading $ do setTitle $ toHtml $ show userAvsNoPerson resWgt + +instance HasEntity (DBRow (Entity UserAvs, Entity User)) User where + hasEntity = _dbrOutput . _2 + +instance HasUser (DBRow (Entity UserAvs, Entity User)) where + hasUser = _dbrOutput . _2 . _entityVal + +getProblemAvsErrorR :: Handler Html +getProblemAvsErrorR = do + let + avsSyncErrDBTable = DBTable{..} + where + dbtIdent :: Text + dbtIdent = "avs-errors" + dbtSQLQuery (usravs `E.InnerJoin` user) = do + E.on $ usravs E.^. UserAvsUser E.==. user E.^. UserId + E.where_ $ E.isJust $ usravs E.^. UserAvsLastSynchError + return (usravs, user) + qerryUsrAvs :: (E.SqlExpr (Entity UserAvs) `E.InnerJoin` E.SqlExpr (Entity User)) -> E.SqlExpr (Entity UserAvs) + qerryUsrAvs = $(E.sqlIJproj 2 1) + qerryUser :: (E.SqlExpr (Entity UserAvs) `E.InnerJoin` E.SqlExpr (Entity User)) -> E.SqlExpr (Entity User) + qerryUser = $(E.sqlIJproj 2 2) + reserrUsrAvs :: Lens' (DBRow (Entity UserAvs, Entity User)) (Entity UserAvs) + reserrUsrAvs = _dbrOutput . _1 + -- reserrUser :: Lens' (DBRow (Entity UserAvs, Entity User)) (Entity User) + -- reserrUser = _dbrOutput . _2 + dbtRowKey = qerryUsrAvs >>> (E.^. UserAvsId) + dbtProj = dbtProjId + dbtColonnade = dbColonnade $ mconcat + [ colUserNameModalHdr MsgLmsUser AdminUserR + , sortable (Just "avs-nr") (i18nCell MsgAvsPersonNo) + $ avsPersonNoLinkedCell . view reserrUsrAvs + , sortable Nothing (i18nCell MsgAvsPersonId) + $ numCell . view (reserrUsrAvs . _entityVal . _userAvsPersonId . _AvsPersonId) + , sortable (Just "avs-last-synch") (i18nCell MsgLastAvsSynchronisation) + $ dateTimeCell . view (reserrUsrAvs . _entityVal . _userAvsLastSynch) + , sortable (Just "avs-last-error") (i18nCell MsgLastAvsSynchError) + $ cellMaybe textCell . view (reserrUsrAvs . _entityVal . _userAvsLastSynchError) + ] + dbtSorting = mconcat + [ single (sortUserNameLink qerryUser) + , single ("avs-nr" , SortColumn $ qerryUsrAvs >>> (E.^. UserAvsNoPerson)) + , single ("avs-last-synch", SortColumnNullsInv $ qerryUsrAvs >>> (E.^. UserAvsLastSynch)) + , single ("avs-last-error", SortColumn $ qerryUsrAvs >>> (E.^. UserAvsLastSynchError)) + ] + dbtFilter = mconcat + [ single $ fltrUserNameEmail qerryUser + , single ("avs-last-error", FilterColumn $ E.mkContainsFilterWithCommaPlus Just $ views (to qerryUsrAvs) (E.^. UserAvsLastSynchError)) + ] + dbtFilterUI mPrev = mconcat + [ fltrUserNameEmailHdrUI MsgLmsUser mPrev + , prismAForm (singletonFilter "avs-last-error" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgLastAvsSynchError) + ] + dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } + dbtParams = def + dbtCsvEncode = Nothing + dbtCsvDecode = Nothing + dbtExtraReps = [] + avsSyncErrDBTableValidator = def & defaultSorting [SortDescBy "avs-last-synch"] + mkAvsSynchErrorTable :: DB (Any, Widget) + mkAvsSynchErrorTable = dbTable avsSyncErrDBTableValidator avsSyncErrDBTable + avsSyncErrTbl <- runDB (snd <$> mkAvsSynchErrorTable) + siteLayoutMsg MsgMenuAvsSynchError $ do + setTitleI MsgMenuAvsSynchError + [whamlet|^{avsSyncErrTbl}|] + \ No newline at end of file diff --git a/src/Handler/Admin/Test.hs b/src/Handler/Admin/Test.hs index 906c941bf..1969f8717 100644 --- a/src/Handler/Admin/Test.hs +++ b/src/Handler/Admin/Test.hs @@ -115,6 +115,8 @@ postAdminTestR = do , formAttrs = [("uw-async-form", "")] } + now <- liftIO getCurrentTime + $logInfoS "TEST" $ "Admin Test Page was retrieved at " <> tshow now <> "." -- to ensure that we can read the right log. let demoFormAction (_i,_b,_d) = addMessage Info "All ok." ((demoResult, formWidget),formEnctype) <- runFormPost $ makeDemoForm 7 diff --git a/src/Handler/Course/List.hs b/src/Handler/Course/List.hs index f6c63d741..513e63f87 100644 --- a/src/Handler/Course/List.hs +++ b/src/Handler/Course/List.hs @@ -105,7 +105,7 @@ colSchoolShort = sortable (Just "schoolshort") (i18nCell MsgFilterCourseSchoolSh in anchorCell (TermSchoolCourseListR courseTerm courseSchool) [whamlet|_{schoolShorthand}|] colRegistered :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) -colRegistered = sortable (Just "registered") (i18nCell MsgFilterRegistered) $ views resultIsRegistered tickmarkCell +colRegistered = sortable (Just "registered") (i18nCell MsgFilterRegistered) $ views resultIsRegistered ((spacerCell <>) . tickmarkCell) makeCourseTable :: (ToSortable h, Functor h) diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs index 250bc640f..c2056d6c8 100644 --- a/src/Handler/Course/Users.hs +++ b/src/Handler/Course/Users.hs @@ -18,7 +18,8 @@ import Import import Utils.Form import Handler.Utils import Handler.Utils.Course -import qualified Database.Esqueleto.Utils as E +import qualified Database.Esqueleto.Utils as E +import qualified Database.Esqueleto.PostgreSQL as E import Database.Esqueleto.Utils.TH import Handler.Course.Register (deregisterParticipant) @@ -87,7 +88,7 @@ userTableQuery cid ((user `E.InnerJoin` participant) `E.LeftOuterJoin` note `E.L E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid return (user, participant, note E.?. CourseUserNoteId, subGroup) -type UserTableQualifications = [(Entity Qualification, Entity QualificationUser)] +type UserTableQualifications = [(Entity Qualification, Entity QualificationUser, Maybe (Entity QualificationUserBlock))] type UserTableData = DBRow ( Entity User , Entity CourseParticipant @@ -131,7 +132,9 @@ _userSheets = _dbrOutput . _7 -- last part: ([Entity Qualification] -> f [Entity Qualification]) -> UserTableQualfications -> f UserTableQualifications _userQualifications :: Getter UserTableData [Entity Qualification] -_userQualifications = _dbrOutput . _8 . to (fmap fst) +_userQualifications = _dbrOutput . _8 . to (fmap fst3) +-- _userQualifications = _dbrOutput . _8 . each . _1 -- TODO: how to make this work + _userCourseQualifications :: Lens' UserTableData UserTableQualifications _userCourseQualifications = _dbrOutput . _8 @@ -182,18 +185,17 @@ colUserSheets shns = cap (Sortable Nothing caption) $ foldMap userSheetCol shns Just (preview _grading -> Just grading', Just points) -> i18nCell . bool MsgTableNotPassed MsgTablePassed $ Just True == gradingPassed grading' points _other -> mempty -colUserQualifications :: forall m c. IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c) -colUserQualifications = sortable (Just "qualifications") (i18nCell MsgTableQualifications) $ - \(view _userCourseQualifications -> qualis) -> - (cellAttrs <>~ [("class", "list--inline list--comma-separated list--iconless")]) . listCell qualis $ qualificationValidUntilCell - -colUserQualificationBlocked :: forall m c. IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c) -colUserQualificationBlocked = sortable (Just "qualification-block") (i18nCell MsgTableQualificationBlockedDue) $ - \(view _userCourseQualifications -> qualis) -> - let blocks = qualificationUserBlockedDue . entityVal . snd <$> qualis - --blocks = qaulis <$> view (_2 . _entityVal . _qualificationUserBlockedDue) - in (cellAttrs <>~ [("class", "list--inline list--comma-separated list--iconless")]) . listCell blocks $ qualificationBlockedCell +colUserQualifications :: forall m c. IsDBTable m c => Day -> Colonnade Sortable UserTableData (DBCell m c) +colUserQualifications cutoff = sortable (Just "qualifications") (i18nCell MsgTableQualifications) $ + let qualNamedValidCell (q,qu,qb) = textCell ((q ^. hasQualification . _qualificationShorthand . _CI) <> ": ") <> qualificationValidUntilCell cutoff qb qu + in \(view _userCourseQualifications -> qualis) -> + (cellAttrs <>~ [("class", "list--inline list--comma-separated list--iconless")]) . listCell qualis $ qualNamedValidCell +colUserQualificationBlocked :: forall m c. IsDBTable m c => Bool -> Day -> Colonnade Sortable UserTableData (DBCell m c) +colUserQualificationBlocked isAdmin cutoff = sortable (Just "qualification-block") (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltipSimple) $ + let qualNamedReasonCell (q,qu,qb) = textCell ((q ^. hasQualification . _qualificationShorthand . _CI) <> ": ") <> qualificationValidReasonCell' Nothing isAdmin cutoff qb qu + in \(view _userCourseQualifications -> qualis) -> + (cellAttrs <>~ [("class", "list--inline list--comma-separated list--iconless")]) . listCell qualis $ qualNamedReasonCell data UserTableCsv = UserTableCsv { csvUserSurname :: UserSurname @@ -417,13 +419,14 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do , submission ) ) - qualis <- E.select . E.from $ \(qualification `E.InnerJoin` qualificationUser) -> do - E.on $ qualification E.^. QualificationId E.==. qualificationUser E.^. QualificationUserQualification + qualis <- E.select . E.from $ \(qualification `E.InnerJoin` qualificationUser `E.LeftOuterJoin` qualificationBlock) -> do + E.on $ qualificationUser E.^. QualificationUserId E.=?. qualificationBlock E.?. QualificationUserBlockQualificationUser + E.&&. qualificationBlock `isLatestBlockBefore` E.now_ + E.on $ qualificationUser E.^. QualificationUserQualification E.==. qualification E.^. QualificationId E.where_ $ qualificationUser E.^. QualificationUserUser E.==. E.val (entityKey user) - E.&&. qualification E.^. QualificationId `E.in_` E.valList cqids - + E.&&. qualification E.^. QualificationId `E.in_` E.valList cqids E.orderBy [E.asc $ qualification E.^. QualificationShorthand] -- we should sort by CourseQualificationSortOrder instead, but since we have not seen a course with multiple qualifications yet, we take a shortcut here - return (qualification, qualificationUser) + return (qualification, qualificationUser, qualificationBlock) let regGroups = setOf (folded . _entityVal . _tutorialRegGroup . _Just) tutorials tuts' = filter (\(Entity tutId _) -> any ((== tutId) . tutorialParticipantTutorial . entityVal) tuts'') tutorials @@ -624,6 +627,8 @@ courseUserDeregisterForm _cid = wFormToAForm . pure . pure $ CourseUserDeregiste getCUsersR, postCUsersR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCUsersR = postCUsersR postCUsersR tid ssh csh = do + now <- liftIO getCurrentTime + let nowaday = utctDay now showSex <- getShowSex (course@(Entity cid Course{..}), numParticipants, (participantRes,participantTable)) <- runDB $ do mayRegister <- hasWriteAccessTo $ CourseR tid ssh csh CAddUserR @@ -656,7 +661,7 @@ postCUsersR tid ssh csh = do , guardOn showSex . cap' $ colUserSex' , pure . cap' $ colUserEmail , pure . cap' $ colUserMatriclenr - , pure . cap' $ colUserQualifications + , pure . cap' $ colUserQualifications nowaday , guardOn hasSubmissionGroups $ cap' colUserSubmissionGroup , guardOn hasTutorials . cap' $ colUserTutorials tid ssh csh , guardOn hasExams . cap' $ colUserExams tid ssh csh @@ -734,8 +739,7 @@ postCUsersR tid ssh csh = do redirect $ CourseR tid ssh csh CUsersR (CourseUserRegisterExamData{..}, selectedUsers) -> do Sum nrReg <- fmap mconcat . runDB . forM (Set.toList selectedUsers) $ \uid -> maybeT (return mempty) $ do - guardM . lift $ exists [ CourseParticipantUser ==. uid, CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive ] - now <- liftIO getCurrentTime + guardM . lift $ exists [ CourseParticipantUser ==. uid, CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive ] let (exam, mOccurrence) = registerExam mExamReg <- lift $ insertUnique ExamRegistration { examRegistrationExam = exam @@ -759,8 +763,7 @@ postCUsersR tid ssh csh = do Just _ -> addMessageI Success $ MsgCourseUsersSubmissionGroupSetNew nrSet redirect $ CourseR tid ssh csh CUsersR - (CourseUserReRegisterData, selectedUsers) -> do - now <- liftIO getCurrentTime + (CourseUserReRegisterData, selectedUsers) -> do Sum nrSet <- runDB . flip foldMapM selectedUsers $ \uid -> maybeT (return mempty) $ do didUpdate <- lift $ updateWhereCount [ CourseParticipantUser ==. uid diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 2c886be11..d85b32ec4 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -12,13 +12,21 @@ module Handler.LMS , getLmsR , postLmsR , getLmsIdentR , getLmsEditR , postLmsEditR + -- V1 , getLmsUsersR , getLmsUsersDirectR , getLmsUserlistR , postLmsUserlistR , getLmsUserlistUploadR , postLmsUserlistUploadR, postLmsUserlistDirectR , getLmsResultR , postLmsResultR , getLmsResultUploadR , postLmsResultUploadR , postLmsResultDirectR + -- V1 + , getLmsLearnersR , getLmsLearnersDirectR + , getLmsReportR , postLmsReportR + , getLmsReportUploadR , postLmsReportUploadR , postLmsReportDirectR + -- , getLmsFakeR , postLmsFakeR , getLmsUserR + , getLmsUserSchoolR + , getLmsUserAllR ) where @@ -42,11 +50,14 @@ import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.PostgreSQL as E import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH -import Database.Persist.Sql (deleteWhereCount) - +import Database.Persist.Sql (deleteWhereCount, updateWhereCount) +-- V1 import Handler.LMS.Users as Handler.LMS import Handler.LMS.Userlist as Handler.LMS import Handler.LMS.Result as Handler.LMS +-- V2 +import Handler.LMS.Learners as Handler.LMS +import Handler.LMS.Report as Handler.LMS import Handler.LMS.Fake as Handler.LMS -- TODO: remove in production! @@ -142,11 +153,15 @@ mkLmsAllTable isAdmin = do in anchorCell (LmsR (qualificationSchool quali) qsh) $ toWgt qnm , sortable Nothing (i18nCell MsgQualificationDescription) $ \(view resultAllQualification -> quali) -> maybeCell (qualificationDescription quali) markupCellLargeModal - , sortable Nothing (i18nCell MsgQualificationValidDuration & cellTooltip MsgTableDiffDaysTooltip) $ + , sortable Nothing (i18nCell MsgQualificationValidDuration & cellTooltip MsgTableDiffDaysTooltip) $ foldMap (textCell . formatCalendarDiffDays . fromMonths) . view (resultAllQualification . _qualificationValidDuration) - , sortable Nothing (i18nCell MsgQualificationRefreshWithin & cellTooltip MsgTableDiffDaysTooltip) $ + , sortable Nothing (i18nCell MsgQualificationRefreshWithin & cellTooltips [SomeMessage MsgQualificationRefreshWithinTooltip , SomeMessage MsgTableDiffDaysTooltip]) $ foldMap (textCell . formatCalendarDiffDays ) . view (resultAllQualification . _qualificationRefreshWithin) -- , sortable Nothing (i18nCell MsgQualificationRefreshWithin) $ foldMap textCell . view (resultAllQualification . _qualificationRefreshWithin . to formatCalendarDiffDays) -- does not work, since there is a maybe in between + , sortable Nothing (i18nCell MsgQualificationRefreshReminder & cellTooltips [SomeMessage MsgQualificationRefreshReminderTooltip, SomeMessage MsgTableDiffDaysTooltip]) $ + foldMap (textCell . formatCalendarDiffDays ) . view (resultAllQualification . _qualificationRefreshReminder) + , sortable Nothing (i18nCell MsgQualificationAuditDuration & cellTooltips [SomeMessage MsgQualificationAuditDurationTooltip, SomeMessage MsgTableDiffDaysTooltip]) $ + foldMap (textCell . formatCalendarDiffDays . fromMonths) . view (resultAllQualification . _qualificationAuditDuration) , sortable (Just "qelearning") (i18nCell MsgTableLmsElearning & cellTooltip MsgQualificationElearningStart) $ tickmarkCell . view (resultAllQualification . _qualificationElearningStart) , sortable Nothing (i18nCell MsgTableQualificationIsAvsLicence & cellTooltip MsgTableQualificationIsAvsLicenceTooltip) @@ -207,11 +222,13 @@ data LmsTableCsv = LmsTableCsv -- L..T..C.. -> ltc.. , ltcValidUntil :: Day , ltcLastRefresh :: Day , ltcFirstHeld :: Day - , ltcBlockedDue :: Maybe QualificationBlocked - , ltcLmsIdent :: Maybe LmsIdent + , ltcBlockStatus :: Maybe Bool + , ltcBlockFrom :: Maybe UTCTime + , ltcLmsIdent :: LmsIdent , ltcLmsStatus :: Maybe LmsStatus - , ltcLmsStarted :: Maybe UTCTime - , ltcLmsDatePin :: Maybe UTCTime + , ltcLmsStatusDay :: Maybe UTCTime + , ltcLmsStarted :: UTCTime + , ltcLmsDatePin :: UTCTime , ltcLmsReceived :: Maybe UTCTime , ltcLmsNotified :: Maybe UTCTime , ltcLmsEnded :: Maybe UTCTime @@ -225,14 +242,16 @@ ltcExample = LmsTableCsv , ltcEmail = "m.mustermann@example.com" , ltcCompany = Just "Example Brothers LLC, SecondaryJobs Inc" , ltcCompanyNumbers = CsvSemicolonList [27,69] - , ltcValidUntil = compDay + , ltcValidUntil = succ compDay , ltcLastRefresh = compDay - , ltcFirstHeld = compDay - , ltcBlockedDue = Nothing - , ltcLmsIdent = Nothing - , ltcLmsStatus = Nothing - , ltcLmsStarted = Just compTime - , ltcLmsDatePin = Nothing + , ltcFirstHeld = pred $ pred compDay + , ltcBlockStatus = Nothing + , ltcBlockFrom = Nothing + , ltcLmsIdent = LmsIdent "abcdefgh" + , ltcLmsStatus = Just LmsSuccess + , ltcLmsStatusDay = Just compTime + , ltcLmsStarted = compTime + , ltcLmsDatePin = compTime , ltcLmsReceived = Nothing , ltcLmsNotified = Nothing , ltcLmsEnded = Nothing @@ -269,8 +288,11 @@ instance CsvColumnsExplained LmsTableCsv where , ('ltcValidUntil , SomeMessage MsgLmsQualificationValidUntil) , ('ltcLastRefresh , SomeMessage MsgTableQualificationLastRefresh) , ('ltcFirstHeld , SomeMessage MsgTableQualificationFirstHeld) + , ('ltcBlockStatus , SomeMessage MsgInfoQualificationBlockStatus) + , ('ltcBlockFrom , SomeMessage MsgInfoQualificationBlockFrom) , ('ltcLmsIdent , SomeMessage MsgTableLmsIdent) , ('ltcLmsStatus , SomeMessage MsgTableLmsStatus) + , ('ltcLmsStatusDay , SomeMessage MsgTableLmsStatusDay) , ('ltcLmsStarted , SomeMessage MsgTableLmsStarted) , ('ltcLmsDatePin , SomeMessage MsgTableLmsDatePin) , ('ltcLmsReceived , SomeMessage MsgTableLmsReceived) @@ -278,21 +300,25 @@ instance CsvColumnsExplained LmsTableCsv where ] -type LmsTableExpr = E.SqlExpr (Entity QualificationUser) - `E.InnerJoin` E.SqlExpr (Entity User) - `E.InnerJoin` E.SqlExpr (Entity LmsUser) +type LmsTableExpr = ( E.SqlExpr (Entity QualificationUser) + `E.InnerJoin` E.SqlExpr (Entity User) + `E.InnerJoin` E.SqlExpr (Entity LmsUser) + ) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity QualificationUserBlock)) queryQualUser :: LmsTableExpr -> E.SqlExpr (Entity QualificationUser) -queryQualUser = $(sqlIJproj 3 1) +queryQualUser = $(sqlIJproj 3 1) . $(sqlLOJproj 2 1) queryUser :: LmsTableExpr -> E.SqlExpr (Entity User) -queryUser = $(sqlIJproj 3 2) +queryUser = $(sqlIJproj 3 2) . $(sqlLOJproj 2 1) queryLmsUser :: LmsTableExpr -> E.SqlExpr (Entity LmsUser) -queryLmsUser = $(sqlIJproj 3 3) +queryLmsUser = $(sqlIJproj 3 3) . $(sqlLOJproj 2 1) + +queryQualBlock :: LmsTableExpr -> E.SqlExpr (Maybe (Entity QualificationUserBlock)) +queryQualBlock = $(sqlLOJproj 2 2) -type LmsTableData = DBRow (Entity QualificationUser, Entity User, Entity LmsUser, E.Value (Maybe [Maybe UTCTime]), [Entity UserCompany]) +type LmsTableData = DBRow (Entity QualificationUser, Entity User, Entity LmsUser, Maybe (Entity QualificationUserBlock), E.Value (Maybe [Maybe UTCTime]), [Entity UserCompany]) resultQualUser :: Lens' LmsTableData (Entity QualificationUser) resultQualUser = _dbrOutput . _1 @@ -303,11 +329,14 @@ resultUser = _dbrOutput . _2 resultLmsUser :: Lens' LmsTableData (Entity LmsUser) resultLmsUser = _dbrOutput . _3 +resultQualBlock :: Traversal' LmsTableData (Entity QualificationUserBlock) +resultQualBlock = _dbrOutput . _4 . _Just + resultPrintAck :: Traversal' LmsTableData [Maybe UTCTime] -resultPrintAck = _dbrOutput . _4 . _unValue . _Just +resultPrintAck = _dbrOutput . _5 . _unValue . _Just resultCompanyUser :: Lens' LmsTableData [Entity UserCompany] -resultCompanyUser = _dbrOutput . _5 +resultCompanyUser = _dbrOutput . _6 instance HasEntity LmsTableData User where hasEntity = resultUser @@ -315,9 +344,16 @@ instance HasEntity LmsTableData User where instance HasUser LmsTableData where hasUser = resultUser . _entityVal +instance HasEntity LmsTableData QualificationUser where + hasEntity = resultQualUser + +instance HasQualificationUser LmsTableData where + hasQualificationUser = resultQualUser . _entityVal + data LmsTableAction = LmsActNotify | LmsActRenewNotify | LmsActRenewPin + | LmsActReset | LmsActRestart deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) @@ -329,9 +365,15 @@ embedRenderMessage ''UniWorX ''LmsTableAction id data LmsTableActionData = LmsActNotifyData | LmsActRenewNotifyData | LmsActRenewPinData -- no longer used + | LmsActResetData + { lmsActRestartExtend :: Maybe Integer + , lmsActRestartUnblock :: Maybe Bool + , lmsActRestartNotify :: Maybe Bool + } | LmsActRestartData { lmsActRestartExtend :: Maybe Integer , lmsActRestartUnblock :: Maybe Bool + , lmsActRestartNotify :: Maybe Bool } deriving (Eq, Ord, Read, Show, Generic) @@ -345,22 +387,33 @@ isRenewPinAct LmsActRenewNotifyData = True isRenewPinAct LmsActRenewPinData = True isRenewPinAct _ = False +isResetAct :: LmsTableActionData -> Bool +isResetAct LmsActResetData{} = True +isResetAct _ = False + +isResetRestartAct :: LmsTableActionData -> Bool +isResetRestartAct LmsActRestartData{} = True +isResetRestartAct other = isResetAct other + + lmsTableQuery :: QualificationId -> LmsTableExpr -> E.SqlQuery ( E.SqlExpr (Entity QualificationUser) , E.SqlExpr (Entity User) , E.SqlExpr (Entity LmsUser) + , E.SqlExpr (Maybe (Entity QualificationUserBlock)) , E.SqlExpr (E.Value (Maybe [Maybe UTCTime])) -- outer maybe indicates, whether a printJob exists, inner maybe indicates all acknowledged printJobs ) -lmsTableQuery qid (qualUser `E.InnerJoin` user `E.InnerJoin` lmsUser) = do +lmsTableQuery qid (qualUser `E.InnerJoin` user `E.InnerJoin` lmsUser `E.LeftOuterJoin` qualBlock) = do -- RECALL: another outer join on PrintJob did not work out well, since -- - E.distinctOn [E.don $ printJob E.?. PrintJobLmsUser] $ do -- types, but destroys the ability to sort interactively, since distinctOn requires sorting; - -- - using noExsists on printJob join condition works, but only deliver single value; - -- experiments with separate sub-query showed that we would need two subsqueries to learn whether the request was indeed the latest + -- - using notExists on printJob join condition works, but only delivers single value, while aggregation can deliver all; + -- experiments with separate sub-query showed that we would need two subqueries to learn whether the request was indeed the latest + E.on $ qualUser E.^. QualificationUserId E.=?. qualBlock E.?. QualificationUserBlockQualificationUser + E.&&. qualBlock `isLatestBlockBefore` E.now_ E.on $ user E.^. UserId E.==. lmsUser E.^. LmsUserUser E.&&. E.val qid E.==. lmsUser E.^. LmsUserQualification -- NOTE: condition was once erroneously placed in where-clause, which does not work E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser - E.where_ $ E.val qid E.==. qualUser E.^. QualificationUserQualification - -- TODO: decide whether to use subSelect or LeftOuterJoin and delete the other! + E.where_ $ E.val qid E.==. qualUser E.^. QualificationUserQualification -- Letztes Datum anzeigen, wenn mehrere, dann diese in klickbaren Tooltip verstecken! let printAcknowledged = E.subSelectMaybe . E.from $ \pj -> do E.where_ $ E.isJust (pj E.^. PrintJobLmsUser) @@ -368,7 +421,7 @@ lmsTableQuery qid (qualUser `E.InnerJoin` user `E.InnerJoin` lmsUser) = do let pjOrder = [E.desc $ pj E.^. PrintJobCreated, E.desc $ pj E.^. PrintJobAcknowledged] -- latest created comes first! This is assumed to be the case later on! pure $ --(E.arrayAggWith E.AggModeAll (pj E.^. PrintJobCreated ) pjOrder, -- return two aggregates only works with select, the restricted typr of subSelect does not seem to support this! E.arrayAggWith E.AggModeAll (pj E.^. PrintJobAcknowledged) pjOrder - return (qualUser, user, lmsUser, printAcknowledged) + return (qualUser, user, lmsUser, qualBlock, printAcknowledged) mkLmsTable :: ( Functor h, ToSortable h @@ -386,28 +439,26 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do cmpMap <- memcachedBy (Just . Right $ 5 * diffMinute) ("CompanyDictionary"::Text) $ do cmps <- selectList [] [] -- [Asc CompanyShorthand] return $ Map.fromList $ fmap (\Entity{..} -> (entityKey, entityVal)) cmps - let - nowaday = utctDay now - -- mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday + let csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName) dbtIdent :: Text dbtIdent = "lms" dbtSQLQuery = lmsTableQuery qid dbtRowKey = queryUser >>> (E.^. UserId) - dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr, printAcks) -> do + dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr, qUsrBlock, printAcks) -> do cmpUsr <- selectList [UserCompanyUser ==. entityKey usr] [Asc UserCompanyCompany] - return (qualUsr, usr, lmsUsr, printAcks, cmpUsr) + return (qualUsr, usr, lmsUsr, qUsrBlock, printAcks, cmpUsr) dbtColonnade = cols cmpMap dbtSorting = mconcat [ single $ sortUserNameLink queryUser , single $ sortUserEmail queryUser , single $ sortUserMatriclenr queryUser - , single ("valid-until" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserValidUntil)) - , single ("validity" , SortColumn $ queryQualUser >>> validQualification nowaday) - , single ("last-refresh" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserLastRefresh)) - , single ("first-held" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserFirstHeld)) - , single ("blocked-due" , SortColumnNeverNull$ queryQualUser >>> (E.^. QualificationUserBlockedDue)) - , single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal)) + , single ("valid-until" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserValidUntil)) + -- , single ("validity" , SortColumn $ queryQualUser >>> validQualification nowaday) + , single ("last-refresh" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserLastRefresh)) + , single ("first-held" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserFirstHeld)) + , single ("blocked" , SortColumnNeverNull$ queryQualBlock >>> (E.?. QualificationUserBlockFrom)) + , single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal)) , single ("ident" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserIdent)) , single ("pin" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserPin)) , single ("status" , SortColumnNullsInv $ views (to queryLmsUser) (E.^. LmsUserStatus)) @@ -416,7 +467,7 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do , single ("received" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserReceived)) , single ("notified" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserNotified)) -- cannot include printJob acknowledge date , single ("ended" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserEnded)) - , single ( "user-company" , SortColumn $ \row -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do + , single ("user-company", SortColumn $ \row -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId E.orderBy [E.asc (comp E.^. CompanyName)] @@ -425,10 +476,10 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do ] dbtFilter = mconcat [ single $ fltrUserNameEmail queryUser - , single ("ident" , FilterColumn . E.mkContainsFilterWith LmsIdent $ views (to queryLmsUser) (E.^. LmsUserIdent)) - -- , single ("status" , FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) ((E.>=. E.val nowaday) . (E.^. LmsUserStatus))) -- LmsStatus cannot be filtered easily within the DB + , single ("ident" , FilterColumn . E.mkContainsFilterWithCommaPlus LmsIdent $ views (to queryLmsUser) (E.^. LmsUserIdent)) + , single ("status" , FilterColumn . E.mkExactFilterMaybeLast $ views (to queryLmsUser) (E.^. LmsUserStatus)) -- , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) ((E.>=. E.val nowaday) . (E.^. QualificationUserValidUntil))) - , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification nowaday)) + , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification now)) -- , single ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion -> -- if | Just renewal <- mbRenewal -- , Just True <- getLast criterion -> quser E.^. QualificationUserValidUntil E.<=. E.val renewal @@ -471,7 +522,7 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do , prismAForm (singletonFilter "ident" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent) , prismAForm (singletonFilter "validity" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid) , prismAForm (singletonFilter "notified" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsNotified) - -- , prismAForm (singletonFilter "status" . maybePrism _PathPiece) mPrev $ aopt (selectField' (Just $ SomeMessage MsgTableNoFilter) $ return (optionsPairs [(MsgTableLmsSuccess,"success"::Text),(MsgTableLmsFailed,"blocked")])) (fslI MsgTableLmsStatus) + , prismAForm (singletonFilter "status" . maybePrism _PathPiece) mPrev $ aopt (hoistField liftHandler (selectField optionsFinite) :: (Field _ (Maybe LmsStatus))) (fslI MsgTableLmsStatus) -- , if isNothing mbRenewal then mempty -- else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal) ] @@ -495,14 +546,16 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do <*> view (resultQualUser . _entityVal . _qualificationUserValidUntil) <*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh) <*> view (resultQualUser . _entityVal . _qualificationUserFirstHeld) - <*> view (resultQualUser . _entityVal . _qualificationUserBlockedDue) - <*> preview (resultLmsUser . _entityVal . _lmsUserIdent) - <*> (join . preview (resultLmsUser . _entityVal . _lmsUserStatus)) - <*> preview (resultLmsUser . _entityVal . _lmsUserStarted) - <*> preview (resultLmsUser . _entityVal . _lmsUserDatePin) - <*> (join . preview (resultLmsUser . _entityVal . _lmsUserReceived)) - <*> (join . preview (resultLmsUser . _entityVal . _lmsUserNotified)) -- TODO: only exports last email date / print job sending date, not print acknowledge - <*> (join . preview (resultLmsUser . _entityVal . _lmsUserEnded)) + <*> preview (resultQualBlock . _entityVal . _qualificationUserBlockUnblock . _not) + <*> preview (resultQualBlock . _entityVal . _qualificationUserBlockFrom) + <*> view (resultLmsUser . _entityVal . _lmsUserIdent) + <*> view (resultLmsUser . _entityVal . _lmsUserStatus) + <*> view (resultLmsUser . _entityVal . _lmsUserStatusDay) + <*> view (resultLmsUser . _entityVal . _lmsUserStarted) + <*> view (resultLmsUser . _entityVal . _lmsUserDatePin) + <*> view (resultLmsUser . _entityVal . _lmsUserReceived) + <*> view (resultLmsUser . _entityVal . _lmsUserNotified) -- TODO: only exports last email date / print job sending date, not print acknowledge + <*> view (resultLmsUser . _entityVal . _lmsUserEnded) getCompanies cmps = case mapMaybe (flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) cmps of [] -> pure Nothing somecmps -> pure $ Just $ intercalate ", " $ fmap (view (_companyName . _CI)) somecmps @@ -548,7 +601,9 @@ postLmsR sid qsh = do isAdmin <- hasReadAccessTo AdminR now <- liftIO getCurrentTime let nowaday = utctDay now - msgRestartWarning <- messageIconI Warning IconWarning MsgLmsActRestartWarning + msgResetInfo <- messageIconI Info IconNotificationNonactive MsgLmsActResetInfo + msgRestartWarning <- messageIconI Warning IconWarning MsgLmsActRestartWarning + ((lmsRes, lmsTable), Entity qid quali) <- runDB $ do qent <- getBy404 $ SchoolQualificationShort sid qsh let acts :: Map LmsTableAction (AForm Handler LmsTableActionData) @@ -556,15 +611,20 @@ postLmsR sid qsh = do [ singletonMap LmsActNotify $ pure LmsActNotifyData , singletonMap LmsActRenewNotify $ pure LmsActRenewNotifyData -- , singletonMap LmsActRenewPin $ pure LmsActRenewPinData + , singletonMap LmsActReset $ LmsActResetData + <$> aopt intField (fslI MsgLmsActRestartExtend) Nothing + <*> aopt checkBoxField (fslI MsgLmsActRestartUnblock) Nothing + <*> aopt checkBoxField (fslI MsgLmsActNotify) Nothing + <* aformMessage msgResetInfo , singletonMap LmsActRestart $ LmsActRestartData <$> aopt intField (fslI MsgLmsActRestartExtend) Nothing <*> aopt checkBoxField (fslI MsgLmsActRestartUnblock) Nothing + <*> aopt checkBoxField (fslI MsgLmsActNotify) Nothing -- <*> aopt (commentField MsgQualificationActBlockSupervisor) (fslI MsgMessageWarning) Nothing <* aformMessage msgRestartWarning - ] - -- lmsStatusLink = toMaybe isAdmin LmsUserR + ] colChoices cmpMap = mconcat - [ if not isAdmin then mempty else dbSelectIf (applying _2) id (return . view (resultUser . _entityKey)) (\r -> isJust $ r ^? resultLmsUser) -- TODO: refactor using function "is" + [ if not isAdmin then mempty else dbSelect (applying _2) id (return . view (resultUser . _entityKey)) , colUserNameModalHdr MsgLmsUser AdminUserR , colUserEmail , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultCompanyUser -> cmps) -> @@ -577,12 +637,12 @@ postLmsR sid qsh = do (\(cmpName, cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> cs in wgtCell companies , colUserMatriclenr - , sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser) - , 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 "validity") (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser) , sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d - , sortable (Just "blocked-due") (i18nCell MsgTableQualificationBlockedDue & cellTooltip MsgTableQualificationBlockedTooltip - ) $ \( view $ resultQualUser . _entityVal . _qualificationUserBlockedDue -> b) -> qualificationBlockedCell b + , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d + , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \( view $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> dayCell d + , sortable (Just "blocked") (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltip) $ \row -> + qualificationValidReasonCell' (Just $ LmsUserR sid qsh) isAdmin nowaday (row ^? resultQualBlock) row , sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip ) $ \( view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification , sortable (Just "ident") (i18nCell MsgTableLmsIdent) $ \(view $ resultLmsUser . _entityVal . _lmsUserIdent . _getLmsIdent -> lid) -> textCell lid @@ -647,34 +707,50 @@ postLmsR sid qsh = do formResult lmsRes $ \case _ | not isAdmin -> addMessageI Error MsgUnauthorized -- only admins can use the form on this page - (LmsActRestartData{..}, selectedUsers) -> do + (action, selectedUsers) | isResetRestartAct action -> do let usersList = Set.toList selectedUsers - delUsers <- runDB $ do - when (lmsActRestartUnblock == Just True) $ do - unblockUsers <- view (_entityVal . _qualificationUserUser) <<$>> selectList - [ QualificationUserQualification ==. qid - , QualificationUserUser <-. usersList - , QualificationUserBlockedDue !=. Nothing - ] [] - void $ qualificationUserBlocking qid unblockUsers False Nothing + numUsers = Set.size selectedUsers + isReset = isResetAct action + actRestartExtend = action & lmsActRestartExtend + actRestartUnblock = action & lmsActRestartUnblock + actRestartNotify = action & lmsActRestartNotify - whenIsJust lmsActRestartExtend $ \extDays -> do + chgUsers <- runDB $ do + when (actRestartUnblock == Just True) $ do + oks <- qualificationUserBlocking qid usersList True Nothing (Left $ bool "Manueller LMS Neustart" "Manuelle LMS Zurücksetzung" isReset) (fromMaybe True actRestartNotify) + addMessageI Success $ MsgQualificationStatusUnblock qsh oks numUsers + + whenIsJust actRestartExtend $ \extDays -> do let cutoff = addDays extDays nowaday shortUsers <- view (_entityVal . _qualificationUserUser) <<$>> selectList [ QualificationUserQualification ==. qid - , QualificationUserUser <-. usersList - , QualificationUserBlockedDue ==. Nothing + , QualificationUserUser <-. usersList , QualificationUserValidUntil <. cutoff - ] [] + ] [] forM_ shortUsers $ upsertQualificationUser qid nowaday cutoff Nothing - fromIntegral <$> deleteWhereCount [LmsUserQualification ==. qid, LmsUserUser <-. usersList] + fromIntegral <$> (if isReset + then updateWhereCount ([LmsUserQualification ==. qid, LmsUserUser <-. usersList, LmsUserResetTries ==. False] -- , LmsUserLocked ==. True] -- needs to be locked for reset, but this is counter-intuitive for users; should be harmles, but delays reset until lock is effective + ++ ([LmsUserStatus ==. Just LmsBlocked] ||. [LmsUserStatus ==. Just LmsExpired])) [LmsUserResetTries =. True] + else deleteWhereCount [LmsUserQualification ==. qid, LmsUserUser <-. usersList] + ) - forM_ selectedUsers $ \uid -> - queueJob' $ JobLmsEnqueueUser { jQualification = qid, jUser = uid } - let numUsers = length selectedUsers - mStatus = bool Success Warning $ delUsers < numUsers - addMessageI mStatus $ MsgLmsActRestartFeedback delUsers numUsers + unless isReset $ + forM_ selectedUsers $ \uid -> + queueJob' $ JobLmsEnqueueUser { jQualification = qid, jUser = uid } + + runDB $ forM_ selectedUsers $ \uid -> + audit $ TransactionLmsReset + { transactionQualification = qid + , transactionLmsUser = uid + , transactionLmsReset = isReset + , transactionLmsResetExtend = actRestartExtend + , transactionLmsResetUnblock = actRestartUnblock + , transactionLmsResetNotify = actRestartNotify + } + + let mStatus = bool Success Warning $ chgUsers < numUsers + addMessageI mStatus $ bool MsgLmsActRestartFeedback MsgLmsActResetFeedback isReset chgUsers numUsers reloadKeepGetParams $ LmsR sid qsh (action, selectedUsers) | isRenewPinAct action || isNotifyAct action -> do @@ -710,12 +786,20 @@ getLmsIdentR :: SchoolId -> QualificationShorthand -> LmsIdent -> Handler Html getLmsIdentR sid qid ident = redirect (LmsR sid qid, [("lms-ident", toPathPiece ident)]) -- intended to be viewed primarily in a modal, wie lmsStatusCell -getLmsUserR :: CryptoUUIDUser -> Handler Html -getLmsUserR uuid = do +getLmsUserAllR :: CryptoUUIDUser -> Handler Html +getLmsUserAllR = viewLmsUserR Nothing Nothing + +getLmsUserSchoolR :: CryptoUUIDUser -> SchoolId -> Handler Html +getLmsUserSchoolR uuid sid = viewLmsUserR (Just sid) Nothing uuid + +getLmsUserR :: SchoolId -> QualificationShorthand -> CryptoUUIDUser -> Handler Html +getLmsUserR sid qsh = viewLmsUserR (Just sid) (Just qsh) + +viewLmsUserR :: Maybe SchoolId -> Maybe QualificationShorthand -> CryptoUUIDUser -> Handler Html +viewLmsUserR msid mqsh uuid = do uid <- decrypt uuid - now <- liftIO getCurrentTime - let nowaday = utctDay now - (user@User{userDisplayName}, quals) <- runDB $ do + now <- liftIO getCurrentTime + (user@User{userDisplayName}, quals, qblocks) <- runDB $ do usr <- get404 uid qs <- Ex.select $ do (qual :& qualUsr :& lmsUsr) <- @@ -728,12 +812,27 @@ getLmsUserR uuid = do `Ex.on` (\(qual :& _ :& lmsUsr) -> lmsUsr E.?. LmsUserUser E.?=. Ex.val uid E.&&. lmsUsr E.?. LmsUserQualification E.?=. qual Ex.^. QualificationId ) - Ex.where_ $ E.isJust (qualUsr E.?. QualificationUserUser) - E.||. E.isJust ( lmsUsr E.?. LmsUserUser) + Ex.where_ $ E.and $ + (E.isJust (qualUsr E.?. QualificationUserUser) E.||. E.isJust ( lmsUsr E.?. LmsUserUser)) : catMaybes + [ (qual E.^. QualificationSchool E.==.) . E.val <$> msid + , (qual E.^. QualificationShorthand E.==.) . E.val <$> mqsh + ] Ex.orderBy [Ex.asc $ qual E.^. QualificationShorthand] - pure (qual, qualUsr, lmsUsr, validQualification' nowaday qualUsr) - return (usr,qs) - + pure (qual, qualUsr, lmsUsr, validQualification' now qualUsr) + bs :: Map.Map QualificationUserId [(Entity QualificationUserBlock, Ex.Value (Maybe UserDisplayName))] + <- foldMapM (\(_, mbqu, _, _) -> case mbqu of + Nothing -> pure mempty + Just (Entity quid _) -> do + blocks <- Ex.select $ do + (qBlock :& qbUsr) <- Ex.from $ Ex.table @QualificationUserBlock + `Ex.leftJoin` Ex.table @User + `Ex.on` (\(qBlock :& qbUsr) -> qBlock Ex.^. QualificationUserBlockBlocker Ex.==. qbUsr Ex.?. UserId) + Ex.where_ $ qBlock Ex.^. QualificationUserBlockQualificationUser Ex.==. Ex.val quid + Ex.orderBy [Ex.desc (qBlock Ex.^. QualificationUserBlockFrom)] + pure (qBlock, qbUsr Ex.?. UserDisplayName) + return $ Map.singleton quid blocks + ) qs + return (usr, qs, Map.filter notNull bs) let heading = [whamlet|_{MsgMenuLmsUser} ^{userWidget user}|] siteLayout heading $ do setTitle $ toHtml userDisplayName diff --git a/src/Handler/LMS/Fake.hs b/src/Handler/LMS/Fake.hs index e0550e574..cd7392760 100644 --- a/src/Handler/LMS/Fake.hs +++ b/src/Handler/LMS/Fake.hs @@ -128,8 +128,7 @@ fakeQualificationUsers (Entity qid Qualification{qualificationRefreshWithin}) (u qualificationUserQualification = qid qualificationUserValidUntil = addDays expOffset expiryNotifyDay qualificationUserFirstHeld = addGregorianMonthsClip (-24) qualificationUserValidUntil - qualificationUserLastRefresh = qualificationUserFirstHeld - qualificationUserBlockedDue = Nothing + qualificationUserLastRefresh = qualificationUserFirstHeld qualificationUserScheduleRenewal = True qualificationUserLastNotified = now _ <- upsert QualificationUser{..} diff --git a/src/Handler/LMS/Learners.hs b/src/Handler/LMS/Learners.hs new file mode 100644 index 000000000..19b5d0ca7 --- /dev/null +++ b/src/Handler/LMS/Learners.hs @@ -0,0 +1,213 @@ +-- SPDX-FileCopyrightText: 2023 Steffen Jost +-- +-- SPDX-License-Identifier: AGPL-3.0-or-later + +{-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances + +module Handler.LMS.Learners + ( getLmsLearnersR + , getLmsLearnersDirectR + ) + where + + +import Import + +import Handler.Utils +import Handler.Utils.Csv +import Handler.Utils.LMS + +import qualified Data.Map as Map +import qualified Data.Csv as Csv +import qualified Data.Conduit.List as C +-- import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma +import qualified Database.Esqueleto.Legacy as E +import qualified Database.Esqueleto.Utils as E + +data LmsUserTableCsv = LmsUserTableCsv -- for csv export only + { csvLUTident :: LmsIdent + , csvLUTpin :: Text + , csvLUTresetPin, csvLUTdelete, csvLUTstaff -- V1 + , csvLUTresetTries, csvLUTlock :: LmsBool -- V2 + } + deriving Generic +makeLenses_ ''LmsUserTableCsv + +-- | Mundane conversion needed for direct download without dbTable only +lmsUser2csv :: UTCTime -> LmsUser -> LmsUserTableCsv +lmsUser2csv cutoff lu@LmsUser{..} = LmsUserTableCsv + { csvLUTident = lmsUserIdent + , csvLUTpin = lmsUserPin + , csvLUTresetPin = LmsBool lmsUserResetPin + , csvLUTdelete = LmsBool (lmsUserToDelete cutoff lu) + , csvLUTstaff = LmsBool (lmsUserStaff lu) + , csvLUTresetTries= LmsBool (lmsUserToResetTries lu) -- TODO: verify this works as intended! + , csvLUTlock = LmsBool (lmsUserToLock lu) + } + +-- csv without headers +instance Csv.ToRecord LmsUserTableCsv +instance Csv.FromRecord LmsUserTableCsv + +-- csv with headers +lmsUserTableCsvHeader :: Csv.Header +lmsUserTableCsvHeader = Csv.header [ csvLmsIdent, csvLmsPin, csvLmsResetPin, csvLmsDelete, csvLmsStaff, csvLmsResetTries, csvLmsLock ] + +instance ToNamedRecord LmsUserTableCsv where + toNamedRecord LmsUserTableCsv{..} = Csv.namedRecord + [ csvLmsIdent Csv..= csvLUTident + , csvLmsPin Csv..= csvLUTpin + , csvLmsResetPin Csv..= csvLUTresetPin + , csvLmsDelete Csv..= csvLUTdelete + , csvLmsStaff Csv..= csvLUTstaff + , csvLmsResetTries Csv..= csvLUTresetTries + , csvLmsLock Csv..= csvLUTlock + ] +instance FromNamedRecord LmsUserTableCsv where + parseNamedRecord (lsfHeaderTranslate -> csv) + = LmsUserTableCsv + <$> csv Csv..: csvLmsIdent + <*> csv Csv..: csvLmsPin + <*> csv Csv..: csvLmsResetPin + <*> csv Csv..: csvLmsDelete + <*> csv Csv..: csvLmsStaff + <*> csv Csv..: csvLmsResetTries + <*> csv Csv..: csvLmsLock + +instance CsvColumnsExplained LmsUserTableCsv where + csvColumnsExplanations _ = mconcat + [ single csvLmsIdent MsgCsvColumnLmsIdent + , single csvLmsPin MsgCsvColumnLmsPin + , single csvLmsResetPin MsgCsvColumnLmsResetPin + , single csvLmsDelete MsgCsvColumnLmsDelete + , single csvLmsStaff MsgCsvColumnLmsStaff + , single csvLmsResetTries MsgCsvColumnLmsResetTries + , single csvLmsLock MsgCsvColumnLmsLock + ] + where + single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget + single k v = singletonMap k [whamlet|_{v}|] + + + +mkUserTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget) +mkUserTable _sid qsh qid = do + cutoff <- liftHandler lmsDeletionDate + dbtCsvName <- csvFilenameLmsUser qsh + let dbtCsvSheetName = dbtCsvName + let + userDBTable = DBTable{..} + where + dbtSQLQuery lmsuser = do + E.where_ $ lmsuser E.^. LmsUserQualification E.==. E.val qid + E.&&. E.isNothing (lmsuser E.^. LmsUserEnded) + return lmsuser + dbtRowKey = (E.^. LmsUserId) + dbtProj = dbtProjId + dbtColonnade = dbColonnade $ mconcat + [ sortable (Just csvLmsIdent) (i18nCell MsgTableLmsIdent) $ \(view $ _dbrOutput . _entityVal . _lmsUserIdent . _getLmsIdent -> ident) -> textCell ident + , sortable (Just csvLmsPin) (i18nCell MsgTableLmsPin & cellAttrs <>~ [("uw-hide-column-default-hidden",mempty)] + ) $ \(view $ _dbrOutput . _entityVal . _lmsUserPin -> pin ) -> textCell pin + , sortable (Just csvLmsResetPin) (i18nCell MsgTableLmsResetPin) $ \(view $ _dbrOutput . _entityVal . _lmsUserResetPin -> reset) -> ifIconCell reset IconReset + , sortable (Just csvLmsDelete) (i18nCell MsgTableLmsDelete) $ \(view $ _dbrOutput . _entityVal . _lmsUserToDelete cutoff -> del ) -> ifIconCell del IconRemoveUser + , sortable Nothing (i18nCell MsgTableLmsStaff) $ \(view $ _dbrOutput . _entityVal . _lmsUserStaff -> staff) -> ifIconCell staff IconOK + , sortable (Just csvLmsResetTries)(i18nCell MsgTableLmsResetTries) $ \(view $ _dbrOutput . _entityVal . _lmsUserToResetTries -> reset) -> ifIconCell reset IconResetTries + , sortable (Just csvLmsLock) (i18nCell MsgTableLmsLock) $ \(view $ _dbrOutput . _entityVal . _lmsUserToLock -> lock ) -> ifIconCell lock IconLocked + ] + dbtSorting = Map.fromList + [ (csvLmsIdent , SortColumn (E.^. LmsUserIdent)) + , (csvLmsPin , SortColumn (E.^. LmsUserPin)) + , (csvLmsResetPin , SortColumn (E.^. LmsUserResetPin)) + , (csvLmsDelete , SortColumn (lmsUserToDeleteExpr cutoff)) + -- , (csvLmsStaff , E.false) -- currently always false + , (csvLmsResetTries , SortColumn lmsUserToResetTriesExpr) + , (csvLmsLock , SortColumn lmsUserToLockExpr) + ] + dbtFilter = Map.fromList + [ (csvLmsIdent , FilterColumn $ E.mkContainsFilterWithCommaPlus LmsIdent (E.^. LmsUserIdent )) + , (csvLmsResetPin , FilterColumn $ E.mkExactFilterLast (E.^. LmsUserResetPin)) + ] + dbtFilterUI = \mPrev -> mconcat + [ prismAForm (singletonFilter csvLmsIdent . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent & setTooltip MsgTableFilterCommaPlus) + , prismAForm (singletonFilter csvLmsResetPin . maybePrism _PathPiece) mPrev $ aopt (hoistField lift (boolField . Just $ SomeMessage MsgBoolIrrelevant)) (fslI MsgTableLmsResetPin) + ] + dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } + dbtParams = def + dbtIdent :: Text + dbtIdent = "lms-user" + dbtCsvEncode = Just DBTCsvEncode {..} + where + dbtCsvExportForm = pure () + dbtCsvNoExportData = Just id + dbtCsvExampleData = Nothing + dbtCsvHeader = const $ return lmsUserTableCsvHeader + dbtCsvDoEncode = \() -> C.map (doEncode' . view _2) + doEncode' = LmsUserTableCsv + <$> view (_dbrOutput . _entityVal . _lmsUserIdent) + <*> view (_dbrOutput . _entityVal . _lmsUserPin) + <*> view (_dbrOutput . _entityVal . _lmsUserResetPin . _lmsBool) + <*> view (_dbrOutput . _entityVal . _lmsUserToDelete cutoff . _lmsBool) + <*> view (_dbrOutput . _entityVal . to lmsUserStaff . _lmsBool) + <*> view (_dbrOutput . _entityVal . to lmsUserToResetTries . _lmsBool) + <*> view (_dbrOutput . _entityVal . to lmsUserToLock . _lmsBool) + + dbtCsvDecode = Nothing + dbtExtraReps = [] + + userDBTableValidator = def + & defaultSorting [SortAscBy csvLmsIdent] + dbTable userDBTableValidator userDBTable + +getLmsLearnersR :: SchoolId -> QualificationShorthand -> Handler Html +getLmsLearnersR sid qsh = do + lmsTable <- runDB $ do + qid <- getKeyBy404 $ SchoolQualificationShort sid qsh + view _2 <$> mkUserTable sid qsh qid + siteLayoutMsg MsgMenuLmsLearners $ do + setTitleI MsgMenuLmsLearners + lmsTable + +getLmsLearnersDirectR :: SchoolId -> QualificationShorthand -> Handler TypedContent +getLmsLearnersDirectR sid qsh = do + $logInfoS "LMS" $ "Direct Download Users for " <> tshow qsh <> " at " <> tshow sid + cutoff <- lmsDeletionDate + lms_users <- runDB $ do + qid <- getKeyBy404 $ SchoolQualificationShort sid qsh + selectList [ LmsUserQualification ==. qid + , LmsUserEnded ==. Nothing + -- , LmsUserReceived ==. Nothing ||. LmsUserResetPin ==. True ||. LmsUserStatus !=. Nothing -- send delta only NOTE: know-how no longer expects delta + ] [Asc LmsUserStarted, Asc LmsUserIdent] + + {- To avoid exporting unneeded columns, we would need an SqlSelect instance for LmsUserTableCsv; probably not worth it + Ex.select $ do + lmsuser <- Ex.from $ Ex.table @LmsUser + Ex.where_ $ lmsuser Ex.^. LmsUserQualification Ex.==. Ex.val qid + Ex.&&. Ex.isNothing (lmsuser Ex.^. LmsUserEnded) + pure $ LmsUserTableCsv + { csvLUTident = lmsuser Ex.^. LmsUserIdent + , csvLUTpin = lmsuser Ex.^. LmsUserPin + , csvLUTresetPin = LmsBool . Ex.unValue $ lmsuser Ex.^. LmsUserResetPin + , csvLUTdelete = LmsBool . Ex.unValue $ Ex.isNothing (lmsuser Ex.^. LmsUserEnded) Ex.&&. Ex.not_ (Ex.isNothing $ lmsuser Ex.^. LmsUserStatus) + , csvLUTstaff = LmsBool False + } + -} + LmsConf{..} <- getsYesod $ view _appLmsConf + let --csvRenderedData = toNamedRecord . lmsUser2csv . entityVal <$> lms_users + --csvRenderedHeader = lmsUserTableCsvHeader + --cvsRendered = CsvRendered {..} + csvRendered = toCsvRendered lmsUserTableCsvHeader $ lmsUser2csv cutoff . entityVal <$> lms_users + fmtOpts = (review csvPreset CsvPresetRFC) + { csvIncludeHeader = lmsDownloadHeader + , csvDelimiter = lmsDownloadDelimiter + , csvUseCrLf = lmsDownloadCrLf + } + csvOpts = def { csvFormat = fmtOpts } + csvSheetName <- csvFilenameLmsUser "t" -- DEBUG UNDO ME BEFORE PRODUCTION qsh + let nr = length lms_users + msg = "Success. LMS Users download file " <> csvSheetName <> " containing " <> tshow nr <> " rows" + $logInfoS "LMS" msg + addHeader "Content-Disposition" $ "attachment; filename=\"" <> csvSheetName <> "\"" + csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered + +-- direct Download see: +-- https://ersocon.net/blog/2017/2/22/creating-csv-files-in-yesod diff --git a/src/Handler/LMS/Report.hs b/src/Handler/LMS/Report.hs new file mode 100644 index 000000000..c95f13a1f --- /dev/null +++ b/src/Handler/LMS/Report.hs @@ -0,0 +1,334 @@ +-- SPDX-FileCopyrightText: 2023 Steffen Jost ,Steffen Jost +-- +-- SPDX-License-Identifier: AGPL-3.0-or-later + +{-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances + +module Handler.LMS.Report + ( getLmsReportR, postLmsReportR + , getLmsReportUploadR, postLmsReportUploadR + , postLmsReportDirectR + ) + where + +import Import + +import Handler.Utils +import Handler.Utils.Csv +import Handler.Utils.LMS + +import qualified Data.Map as Map +import qualified Data.Csv as Csv +import qualified Data.Conduit.List as C +import qualified Database.Esqueleto.Legacy as E +import qualified Database.Esqueleto.Utils as E + +import Jobs.Queue + + +data LmsReportTableCsv = LmsReportTableCsv + { csvLRident :: LmsIdent + , csvLRdate :: Maybe LmsTimestamp + , csvLRresult :: LmsState + , csvLRlock :: LmsBool + } + deriving Generic +makeLenses_ ''LmsReportTableCsv + +-- csv without headers +instance Csv.ToRecord LmsReportTableCsv -- default suffices +instance Csv.FromRecord LmsReportTableCsv -- default suffices + +-- csv with headers +lmsReportTableCsvHeader :: Csv.Header +lmsReportTableCsvHeader = Csv.header [ csvLmsIdent, csvLmsDate, csvLmsResult, csvLmsLock ] + +instance ToNamedRecord LmsReportTableCsv where + toNamedRecord LmsReportTableCsv{..} = Csv.namedRecord + [ csvLmsIdent Csv..= csvLRident + , csvLmsDate Csv..= csvLRdate + , csvLmsResult Csv..= csvLRresult + , csvLmsLock Csv..= csvLRlock + ] + +instance FromNamedRecord LmsReportTableCsv where + parseNamedRecord (lsfHeaderTranslate -> csv) + = LmsReportTableCsv + <$> csv Csv..: csvLmsIdent + <*> csv Csv..: csvLmsDate + <*> csv Csv..: csvLmsResult + <*> csv Csv..: csvLmsLock + +instance CsvColumnsExplained LmsReportTableCsv where + csvColumnsExplanations _ = mconcat + [ single csvLmsIdent MsgCsvColumnLmsIdent + , single csvLmsDate MsgCsvColumnLmsDate + , single csvLmsResult MsgCsvColumnLmsResult + , single csvLmsLock MsgCsvColumnLmsLock + ] + where + single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget + single k v = singletonMap k [whamlet|_{v}|] + +data LmsReportCsvActionClass = LmsReportInsert | LmsReportUpdate + deriving (Eq, Ord, Read, Show, Generic, Enum, Bounded) +embedRenderMessage ''UniWorX ''LmsReportCsvActionClass id + +-- By coincidence the action type is identical to LmsReportTableCsv +data LmsReportCsvAction = LmsReportInsertData { lmsReportCsvIdent :: LmsIdent, lmsReportCsvDate :: Maybe UTCTime, lmsReportCsvResult :: LmsState, lmsReportCsvLock :: Bool } + | LmsReportUpdateData { lmsReportCsvIdent :: LmsIdent, lmsReportCsvDate :: Maybe UTCTime, lmsReportCsvResult :: LmsState, lmsReportCsvLock :: Bool } + deriving (Eq, Ord, Read, Show, Generic) + +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece'' 2 1 -- LmsReportInsertData -> insert + , fieldLabelModifier = camelToPathPiece' 2 -- lmsReportCsvIdent -> csv-ident + , sumEncoding = TaggedObject "action" "data" + } ''LmsReportCsvAction + +data LmsReportCsvException + = LmsReportCsvExceptionDuplicatedKey -- TODO: this is not used anywhere?! + deriving (Show, Generic) + +instance Exception LmsReportCsvException +embedRenderMessage ''UniWorX ''LmsReportCsvException id + +mkReportTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget) +mkReportTable sid qsh qid = do + now <- liftIO getCurrentTime + dbtCsvName <- csvFilenameLmsReport qsh + let dbtCsvSheetName = dbtCsvName + let + reportDBTable = DBTable{..} + where + dbtSQLQuery lmsReport = do + E.where_ $ lmsReport E.^. LmsReportQualification E.==. E.val qid + return lmsReport + dbtRowKey = (E.^. LmsReportId) + dbtProj = dbtProjId + dbtColonnade = dbColonnade $ mconcat + [ sortable (Just csvLmsIdent) (i18nCell MsgTableLmsIdent) $ \(view $ _dbrOutput . _entityVal . _lmsReportIdent . _getLmsIdent -> ident) -> textCell ident + , sortable (Just csvLmsDate) (i18nCell MsgTableLmsDate) $ \(view $ _dbrOutput . _entityVal . _lmsReportDate -> d) -> cellMaybe dateTimeCell d + , sortable (Just csvLmsResult) (i18nCell MsgTableLmsStatus) $ \(view $ _dbrOutput . _entityVal . _lmsReportResult -> s) -> lmsStateCell s + , sortable (Just csvLmsLock) (i18nCell MsgTableLmsLock) $ \(view $ _dbrOutput . _entityVal . _lmsReportLock -> b) -> ifIconCell b IconLocked + , sortable (Just csvLmsTimestamp) (i18nCell MsgTableLmsReceived)$ \(view $ _dbrOutput . _entityVal . _lmsReportTimestamp -> t) -> dateTimeCell t + ] + dbtSorting = Map.fromList + [ (csvLmsIdent , SortColumn (E.^. LmsReportIdent)) + , (csvLmsDate , SortColumn (E.^. LmsReportDate)) + , (csvLmsResult , SortColumn (E.^. LmsReportResult)) + , (csvLmsLock , SortColumn (E.^. LmsReportLock)) + , (csvLmsTimestamp, SortColumn (E.^. LmsReportTimestamp)) + ] + dbtFilter = Map.fromList + [ (csvLmsIdent , FilterColumn $ E.mkContainsFilterWithCommaPlus LmsIdent (E.^. LmsReportIdent)) + , (csvLmsDate , FilterColumn $ E.mkExactFilter (E.^. LmsReportDate)) + ] + dbtFilterUI = \mPrev -> mconcat + [ prismAForm (singletonFilter csvLmsIdent . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent & setTooltip MsgTableFilterCommaPlus) + , prismAForm (singletonFilter csvLmsSuccess . maybePrism _PathPiece) mPrev $ aopt (hoistField lift dayField) (fslI MsgTableLmsDate) + ] + dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } + dbtParams = def + dbtIdent :: Text + dbtIdent = "lms-report" + dbtCsvEncode = Just DBTCsvEncode + { dbtCsvExportForm = pure () + , dbtCsvDoEncode = \() -> C.map (doEncode' . view _2) + , dbtCsvName + , dbtCsvSheetName + , dbtCsvNoExportData = Just id + , dbtCsvHeader = const $ return lmsReportTableCsvHeader + , dbtCsvExampleData = Just + [ LmsReportTableCsv + { csvLRident = LmsIdent lid + , csvLRdate = Just $ LmsTimestamp $ addLocalDays (fromIntegral $ -dos) now + , csvLRresult = toEnum $ dos `mod` succ (fromEnum (maxBound :: LmsState)) + , csvLRlock = LmsBool $ even dos + } + | (lid,dos) <- zip ["abcdefgh", "12345678", "ident8ch", "x2!y3-z4"] [(1::Int)..] + ] + } + where + doEncode' = LmsReportTableCsv + <$> view (_dbrOutput . _entityVal . _lmsReportIdent) + <*> preview (_dbrOutput . _entityVal . _lmsReportDate . _Just . _lmsTimestamp) + <*> view (_dbrOutput . _entityVal . _lmsReportResult) + <*> view (_dbrOutput . _entityVal . _lmsReportLock . _lmsBool) + dbtCsvDecode = Just DBTCsvDecode -- Just save to DB; Job will process data later + { dbtCsvRowKey = \LmsReportTableCsv{..} -> + fmap E.Value . MaybeT . getKeyBy $ UniqueLmsReport qid csvLRident + , dbtCsvComputeActions = \case -- purpose is to show a diff to the user first + DBCsvDiffNew{dbCsvNewKey = Nothing, dbCsvNew = LmsReportTableCsv{..}} -> do + yield $ LmsReportInsertData + { lmsReportCsvIdent = csvLRident + , lmsReportCsvDate = csvLRdate <&> lms2timestamp + , lmsReportCsvResult = csvLRresult + , lmsReportCsvLock = csvLRlock & lms2bool + } + DBCsvDiffNew{dbCsvNewKey = Just _, dbCsvNew = _} -> error "UniqueLmsReport was found, but the key no longer exists." -- TODO: how can this ever happen? Check Pagination-Code + DBCsvDiffExisting{dbCsvNew = LmsReportTableCsv{..}, dbCsvOld} -> do + let resultTime = csvLRdate <&> lms2timestamp + when (resultTime > dbCsvOld ^. _dbrOutput . _entityVal . _lmsReportDate) $ + yield $ LmsReportUpdateData + { lmsReportCsvIdent = csvLRident + , lmsReportCsvDate = resultTime + , lmsReportCsvResult = csvLRresult + , lmsReportCsvLock = csvLRlock & lms2bool + } + DBCsvDiffMissing{} -> return () -- no deletion + , dbtCsvClassifyAction = \case + LmsReportInsertData{} -> LmsReportInsert + LmsReportUpdateData{} -> LmsReportUpdate + , dbtCsvCoarsenActionClass = \case + LmsReportInsert -> DBCsvActionNew + LmsReportUpdate -> DBCsvActionExisting + , dbtCsvValidateActions = return () -- no validation, since this is an automatic upload, i.e. no user to review error + , dbtCsvExecuteActions = do + C.mapM_ $ \actionData -> do + eanow <- liftIO getCurrentTime + void $ upsert + LmsReport + { lmsReportQualification = qid + , lmsReportIdent = lmsReportCsvIdent actionData + , lmsReportDate = lmsReportCsvDate actionData + , lmsReportResult = lmsReportCsvResult actionData + , lmsReportLock = lmsReportCsvLock actionData + , lmsReportTimestamp = eanow + } + [ LmsReportDate =. lmsReportCsvDate actionData + , LmsReportResult =. lmsReportCsvResult actionData + , LmsReportLock =. lmsReportCsvLock actionData + , LmsReportTimestamp =. eanow + ] + -- audit $ Transaction.. (add to Audit.Types) + lift . queueDBJob $ JobLmsReports qid + return $ LmsReportR sid qsh + , dbtCsvRenderKey = const $ \case + LmsReportInsertData{..} -> do -- TODO: i18n + [whamlet| + $newline never + Insert: Ident #{getLmsIdent lmsReportCsvIdent} # + has status #{show lmsReportCsvResult} # + $if lmsReportCsvLock + and is locked # + $maybe d <- lmsReportCsvDate + on ^{formatTimeW SelFormatDateTime d} + |] + LmsReportUpdateData{..} -> do -- TODO: i18n + [whamlet| + $newline never + Update: Ident #{getLmsIdent lmsReportCsvIdent} # + has status #{show lmsReportCsvResult} # + $if lmsReportCsvLock + and is locked # + $maybe d <- lmsReportCsvDate + on ^{formatTimeW SelFormatDateTime d} + |] + , dbtCsvRenderActionClass = toWidget <=< ap getMessageRender . pure + , dbtCsvRenderException = ap getMessageRender . pure :: LmsReportCsvException -> DB Text + } + dbtExtraReps = [] + + reportDBTableValidator = def + & defaultSorting [SortAscBy csvLmsIdent] + dbTable reportDBTableValidator reportDBTable + +getLmsReportR, postLmsReportR :: SchoolId -> QualificationShorthand -> Handler Html +getLmsReportR = postLmsReportR +postLmsReportR sid qsh = do + let directUploadLink = LmsReportUploadR sid qsh + lmsTable <- runDB $ do + qid <- getKeyBy404 $ SchoolQualificationShort sid qsh + view _2 <$> mkReportTable sid qsh qid + siteLayoutMsg MsgMenuLmsReport $ do + setTitleI MsgMenuLmsReport + $(widgetFile "lms-report") + + +-- Direct File Upload/Download + +saveReportCsv :: UTCTime -> QualificationId -> Int -> LmsReportTableCsv -> JobDB Int +saveReportCsv now qid i LmsReportTableCsv{..} = do + void $ upsert + LmsReport + { lmsReportQualification = qid + , lmsReportIdent = csvLRident + , lmsReportDate = csvLRdate <&> lms2timestamp + , lmsReportResult = csvLRresult + , lmsReportLock = csvLRlock & lms2bool + , lmsReportTimestamp = now + } + [ LmsReportDate =. (csvLRdate <&> lms2timestamp) + , LmsReportResult =. csvLRresult + , LmsReportLock =. (csvLRlock & lms2bool) + , LmsReportTimestamp =. now + ] + return $ succ i + +makeReportUploadForm :: Form FileInfo +makeReportUploadForm = renderAForm FormStandard $ fileAFormReq "Report CSV" + +getLmsReportUploadR, postLmsReportUploadR :: SchoolId -> QualificationShorthand -> Handler Html +getLmsReportUploadR = postLmsReportUploadR +postLmsReportUploadR sid qsh = do + now <- liftIO getCurrentTime + ((report,widget), enctype) <- runFormPost makeReportUploadForm + case report of + FormSuccess file -> do + -- content <- fileSourceByteString file + -- return $ Just (fileName file, content) + (nr, qid) <- runDBJobs $ do + qid <- getKeyBy404 $ SchoolQualificationShort sid qsh + nr <- runConduit $ fileSource file + .| decodeCsv + .| foldMC (saveReportCsv now qid) 0 + return (nr, qid) + addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file <> pack (" mit " <> show nr <> " Zeilen") + -- redirect $ LmsReportR sid qsh + getLmsReportR sid qsh <* queueJob' (JobLmsReports qid) -- show uploaded data before processing + + FormFailure errs -> do + forM_ errs $ addMessage Error . toHtml + redirect $ LmsReportUploadR sid qsh + FormMissing -> + siteLayoutMsg MsgMenuLmsReport $ do + setTitleI MsgMenuLmsUpload + [whamlet|$newline never +

          + ^{widget} +

          + + |] + + +postLmsReportDirectR :: SchoolId -> QualificationShorthand -> Handler Html +postLmsReportDirectR sid qsh = do + (_params, files) <- runRequestBody + (status, msg) <- case files of + [(fhead,file)] -> do + now <- liftIO getCurrentTime + lmsDecoder <- getLmsCsvDecoder + runDBJobs $ do + qid <- getKeyBy404 $ SchoolQualificationShort sid qsh + enr <- try $ runConduit $ fileSource file + .| lmsDecoder + .| foldMC (saveReportCsv now qid) 0 + case enr of + Left (e :: SomeException) -> do -- catch all to avoid ok220 in case of any error + $logWarnS "LMS" $ "Report upload failed parsing: " <> tshow e + return (badRequest400, "Exception: " <> tshow e) + Right nr -> do + let msg = "Success. LMS Report upload file " <> fileName file <> " containing " <> tshow nr <> " rows for " <> fhead <> ". " + $logInfoS "LMS" msg + when (nr > 0) $ queueDBJob $ JobLmsReports qid + return (ok200, msg) + [] -> do + let msg = "Report upload file missing." + $logWarnS "LMS" msg + return (badRequest400, msg) + _other -> do + let msg = "Report upload received multiple files; all ignored." + $logWarnS "LMS" msg + return (badRequest400, msg) + sendResponseStatus status msg -- must be outside of runDB; otherwise transaction is rolled back + diff --git a/src/Handler/LMS/Userlist.hs b/src/Handler/LMS/Userlist.hs index cb8618b6d..6304c5be7 100644 --- a/src/Handler/LMS/Userlist.hs +++ b/src/Handler/LMS/Userlist.hs @@ -54,7 +54,7 @@ instance FromNamedRecord LmsUserlistTableCsv where instance CsvColumnsExplained LmsUserlistTableCsv where csvColumnsExplanations _ = mconcat [ single csvLmsIdent MsgCsvColumnLmsIdent - , single csvLmsBlocked MsgCsvColumnLmsFailed + , single csvLmsBlocked MsgCsvColumnLmsLock ] where single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget @@ -97,7 +97,7 @@ mkUserlistTable sid qsh qid = do dbtProj = dbtProjId dbtColonnade = dbColonnade $ mconcat [ sortable (Just csvLmsIdent) (i18nCell MsgTableLmsIdent) $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> textCell $ lmsUserlistIdent & getLmsIdent - , sortable (Just csvLmsBlocked) (i18nCell MsgTableLmsFailed) $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> ifIconCell lmsUserlistFailed IconBlocked + , sortable (Just csvLmsBlocked) (i18nCell MsgTableLmsLock) $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> ifIconCell lmsUserlistFailed IconBlocked , sortable (Just csvLmsTimestamp) (i18nCell MsgTableLmsReceived) $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> dateTimeCell lmsUserlistTimestamp ] dbtSorting = Map.fromList @@ -111,7 +111,7 @@ mkUserlistTable sid qsh qid = do ] dbtFilterUI = \mPrev -> mconcat [ prismAForm (singletonFilter csvLmsIdent . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent) - , prismAForm (singletonFilter csvLmsBlocked . maybePrism _PathPiece) mPrev $ aopt (hoistField lift checkBoxField) (fslI MsgTableLmsFailed) + , prismAForm (singletonFilter csvLmsBlocked . maybePrism _PathPiece) mPrev $ aopt (hoistField lift checkBoxField) (fslI MsgTableLmsLock) ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtParams = def diff --git a/src/Handler/LMS/Users.hs b/src/Handler/LMS/Users.hs index 395ad5d54..389ad16f6 100644 --- a/src/Handler/LMS/Users.hs +++ b/src/Handler/LMS/Users.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Steffen Jost +-- SPDX-FileCopyrightText: 2022-23 Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -32,8 +32,8 @@ data LmsUserTableCsv = LmsUserTableCsv -- for csv export only deriving Generic makeLenses_ ''LmsUserTableCsv --- | Mundane conversion needed for direct download without dbTable onlu -lmsUser2csv :: Day -> LmsUser -> LmsUserTableCsv +-- | Mundane conversion needed for direct download without dbTable only +lmsUser2csv :: UTCTime -> LmsUser -> LmsUserTableCsv lmsUser2csv cutoff lu@LmsUser{..} = LmsUserTableCsv { csvLUTident = lmsUserIdent , csvLUTpin = lmsUserPin diff --git a/src/Handler/PrintCenter.hs b/src/Handler/PrintCenter.hs index 0d2455400..083d8572d 100644 --- a/src/Handler/PrintCenter.hs +++ b/src/Handler/PrintCenter.hs @@ -27,12 +27,16 @@ import Database.Esqueleto.Utils.TH import Utils.Print -- import Data.Aeson (encode) -import qualified Data.Text as Text +-- import qualified Data.Text as Text -- import qualified Data.Set as Set import Handler.Utils -- import Handler.Utils.Csv -- import qualified Data.Csv as Csv +import qualified Data.CaseInsensitive as CI + +import Jobs.Queue + -- avoids repetition of local definitions single :: (k,a) -> Map k a @@ -219,32 +223,32 @@ mkPJTable = do , single ("lmsid" , SortColumn $ queryPrintJob >>> (E.^. PrintJobLmsUser)) ] dbtFilter = mconcat - [ single ("name" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobName)) - , single ("apcid" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobApcIdent)) - , single ("filename" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobFilename)) - , single ("created" , FilterColumn . E.mkDayFilter $ views (to queryPrintJob) (E.^. PrintJobCreated)) - --, single ("created" , FilterColumn . E.mkDayBetweenFilter $ views (to queryPrintJob) (E.^. PrintJobCreated)) - , single ("recipient" , FilterColumn . E.mkContainsFilterWith Just $ views (to queryRecipient) (E.?. UserDisplayName)) - , single ("sender" , FilterColumn . E.mkContainsFilterWith Just $ views (to querySender) (E.?. UserDisplayName)) - , single ("course" , FilterColumn . E.mkContainsFilterWith Just $ views (to queryCourse) (E.?. CourseName)) - , single ("qualification", FilterColumn . E.mkContainsFilterWith Just $ views (to queryQualification) (E.?. QualificationName)) - , single ("lmsid" , FilterColumn . E.mkContainsFilterWith Just $ views (to queryPrintJob) (E.^. PrintJobLmsUser)) + [ single ("name" , FilterColumn . E.mkContainsFilterWithCommaPlus id $ views (to queryPrintJob) (E.^. PrintJobName)) + , single ("apcid" , FilterColumn . E.mkContainsFilterWithComma id $ views (to queryPrintJob) (E.^. PrintJobApcIdent)) + , single ("filename" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobFilename)) + , single ("created" , FilterColumn . E.mkDayFilter $ views (to queryPrintJob) (E.^. PrintJobCreated)) + --, single ("created" , FilterColumn . E.mkDayBetweenFilter $ views (to queryPrintJob) (E.^. PrintJobCreated)) + , single ("recipient" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to queryRecipient) (E.?. UserDisplayName)) + , single ("sender" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to querySender) (E.?. UserDisplayName)) + , single ("course" , FilterColumn . E.mkContainsFilterWith (Just . CI.mk) $ views (to queryCourse) (E.?. CourseName)) + , single ("qualification", FilterColumn . E.mkContainsFilterWith (Just . CI.mk) $ views (to queryQualification) (E.?. QualificationName)) + , single ("lmsid" , FilterColumn . E.mkContainsFilterWithCommaPlus (Just . LmsIdent) $ views (to queryPrintJob) (E.^. PrintJobLmsUser)) , single ("acknowledged" , FilterColumn . E.mkExactFilterLast $ views (to queryPrintJob) (E.isJust . (E.^. PrintJobAcknowledged))) ] dbtFilterUI mPrev = mconcat - [ prismAForm (singletonFilter "name" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintJobName) + [ prismAForm (singletonFilter "name" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintJobName & setTooltip MsgTableFilterCommaPlus) , prismAForm (singletonFilter "filename" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintJobFilename) , prismAForm (singletonFilter "created" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift dayField) (fslI MsgPrintJobCreated) --, prismAForm (singletonFilter "created" . maybePrism _PathPiece) mPrev ((,) <$> aopt (hoistField lift dayField) (fslI MsgPrintJobCreated) -- <*> aopt (hoistField lift dayField) (fslI MsgPrintJobCreated) -- ) - , prismAForm (singletonFilter "recipient" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintRecipient) - , prismAForm (singletonFilter "sender" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintSender) + , prismAForm (singletonFilter "recipient" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintRecipient & setTooltip MsgTableFilterCommaPlus) + , prismAForm (singletonFilter "sender" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintSender & setTooltip MsgTableFilterCommaPlus) , prismAForm (singletonFilter "course" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintCourse) , prismAForm (singletonFilter "qualification". maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintQualification) - , prismAForm (singletonFilter "lmsid" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintLmsUser) - , prismAForm (singletonFilter "apcid" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintJobApcAcknowledge) + , prismAForm (singletonFilter "lmsid" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintLmsUser & setTooltip MsgTableFilterCommaPlus) + , prismAForm (singletonFilter "apcid" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintJobApcAcknowledge & setTooltip MsgTableFilterComma) , prismAForm (singletonFilter "acknowledged" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgPrintJobAcknowledged) ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout} @@ -409,7 +413,7 @@ postPrintAckR ackDay numAck chksm = do now <- liftIO getCurrentTime E.updateCount $ \pj -> do let pjDay = E.day $ pj E.^. PrintJobCreated - E.set pj [ PrintJobAcknowledged E.=. E.just (E.val now) ] + E.set pj [ PrintJobAcknowledged E.=. E.justVal now ] E.where_ $ E.isNothing (pj E.^. PrintJobAcknowledged) E.&&. (pjDay E.==. E.val ackDay) -- Ex.updateCount $ do @@ -434,45 +438,30 @@ postPrintAckR ackDay numAck chksm = do -- | length v >= 1 = v Csv..! 0 -- | otherwise = pure "ERROR" +saveApcident :: UTCTime -> Natural -> Text -> JobDB Natural +saveApcident t i apci = insert_ (PrintAcknowledge apci t False) >> return (succ i) + postPrintAckDirectR :: Handler Html -postPrintAckDirectR = do +postPrintAckDirectR = do + now <- liftIO getCurrentTime (_params, files) <- runRequestBody (status, msg) <- case files of - [(fhead,file)] -> do - runDB $ do + [(_fhead,file)] -> do + runDBJobs $ do enr <- try $ runConduit $ fileSource file -- .| decodeCsvPositional Csv.NoHeader -- decode by separator position .| decodeUtf8C -- no CSV, just convert each line to a single text .| linesUnboundedC - .| sinkList + .| foldMC (saveApcident now) 0 case enr of Left (e :: SomeException) -> do -- catch all to avoid ok220 in case of any error $logWarnS "APC" $ "Result upload failed parsing: " <> tshow e return (badRequest400, "Error: " <> tshow e) - Right (fmap Text.strip -> reqIds) -> do -- inside conduit? - let nrReq = length reqIds - now <- liftIO getCurrentTime - nrApcIds <- updateWhereCount - [PrintJobAcknowledged ==. Nothing, PrintJobApcIdent <-. reqIds] - [PrintJobAcknowledged =. Just now] - nrOk <- if nrApcIds <= 0 && nrReq > 0 - then updateWhereCount -- for downwards compatibility only - [PrintJobAcknowledged ==. Nothing, PrintJobLmsUser <-. (Just . LmsIdent . dropPrefixText "lms-" <$> reqIds)] - [PrintJobAcknowledged =. Just now] - else return nrApcIds - if | nrReq <= 0 -> do - let msg = "Error: No print job was acknowledged as printed, but " <> tshow nrReq <> " were requested to be, for file " <> fhead - $logErrorS "APC" msg - return (badRequest400, msg) - | nrReq == fromIntegral nrOk -> do - let msg = "Success: " <> tshow nrOk <> " print jobs were acknowledged as printed, for file " <> fhead - $logInfoS "APC" msg - return (ok200, msg) - | otherwise -> do - forM_ reqIds $ \t -> $logInfoS "APC" $ "Received APC Identifier: \"" <> t <> "\"" - let msg = "Warning: Only " <> tshow nrOk <> " print jobs out of " <> tshow nrReq <> " were acknowledged as printed, for file " <> fhead - $logWarnS "APC" msg - return (ok200, msg) + Right nr -> do + let msg = "Success: received " <> tshow nr <> " APC identifiers to be processed later." + $logInfoS "LMS" msg + when (nr > 0) $ queueDBJob JobPrintAck + return (ok200, msg) [] -> do let msg = "Error: No file received. A file of lms identifiers must be supplied for print job acknowledging." $logWarnS "APC" msg diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index e0358449a..5c2acdd0a 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -570,6 +570,7 @@ getForProfileDataR cID = do makeProfileData :: Entity User -> DB Widget makeProfileData (Entity uid User{..}) = do + now <- liftIO getCurrentTime avsId <- entityVal <<$>> getBy (UniqueUserAvsUser uid) -- avsCards <- maybe (pure mempty) (\a -> selectList [UserAvsCardPersonId ==. userAvsPersonId a] []) avsId functions <- Map.fromListWith Set.union . map (\(Entity _ UserFunction{..}) -> (userFunctionFunction, Set.singleton userFunctionSchool)) <$> selectList [UserFunctionUser ==. uid] [] @@ -614,7 +615,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 + qualificationsTable <- mkQualificationsTable now uid -- Tabelle mit allen Qualifikationen let examTable, ownTutorialTable, tutorialTable :: Widget examTable = i18n MsgPersonalInfoExamAchievementsWip ownTutorialTable = i18n MsgPersonalInfoOwnTutorialsWip @@ -949,39 +950,39 @@ mkCorrectionsTable = -- | Table listing all qualifications that the given user is enrolled in -mkQualificationsTable :: UserId -> DB Widget +mkQualificationsTable :: UTCTime -> 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) + let withType :: ((E.SqlExpr (Entity Qualification) `E.InnerJoin` E.SqlExpr (Entity QualificationUser) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity QualificationUserBlock))) -> a) + -> ((E.SqlExpr (Entity Qualification) `E.InnerJoin` E.SqlExpr (Entity QualificationUser) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity QualificationUserBlock))) -> a) withType = id - - validator = def -- TODO & defaultSorting [SortDescBy "valid-until"] - - in \uid -> dbTableWidget' validator + validator = def & defaultSorting [SortAscBy "valid-until", SortAscBy "quali"] + in \now 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 + , dbtSQLQuery = \(quali `E.InnerJoin` quser `E.LeftOuterJoin` qblock) -> do + E.on $ quser E.^. QualificationUserId E.=?. qblock E.?. QualificationUserBlockQualificationUser + E.&&. qblock `isLatestBlockBefore` E.val now + E.on $ quser E.^. QualificationUserQualification E.==. quali E.^. QualificationId + E.where_ $ quser E.^. QualificationUserUser E.==. E.val uid + return (quali, quser, qblock) + , dbtRowKey = \(_quali `E.InnerJoin` quser `E.LeftOuterJoin` _qblock) -> quser E.^. QualificationUserId , dbtProj = dbtProjId , dbtColonnade = mconcat [ colSchool (_dbrOutput . _1 . _entityVal . _qualificationSchool) , sortable (Just "quali") (i18nCell MsgQualificationName) $ qualificationDescrCell <$> 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 ) + , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh) $ dayCell <$> view (_dbrOutput . _2 . _entityVal . _qualificationUserLastRefresh) + , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ dayCell <$> view (_dbrOutput . _2 . _entityVal . _qualificationUserValidUntil ) + , sortable (Just "blocked") (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltipSimple) $ \row -> + qualificationValidReasonCell False (utctDay now) (row ^? _dbrOutput . _3 . _Just . _entityVal) (row ^. _dbrOutput . _2 . _entityVal) ] , 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 + [ sortSchool $ to (\(quali `E.InnerJoin` _ `E.LeftOuterJoin` _) -> quali E.^. QualificationSchool) + , singletonMap "quali" $ SortColumn $ withType $ \(quali `E.InnerJoin` _ `E.LeftOuterJoin` _) -> quali E.^. QualificationName + , singletonMap "blocked" $ SortColumn $ withType $ \(_ `E.InnerJoin` _ `E.LeftOuterJoin` qblock) -> qblock E.?. QualificationUserBlockFrom + , singletonMap "valid-until" $ SortColumn $ withType $ \(_ `E.InnerJoin` quser `E.LeftOuterJoin` _) -> quser E.^. QualificationUserValidUntil + , singletonMap "last-refresh" $ SortColumn $ withType $ \(_ `E.InnerJoin` quser `E.LeftOuterJoin` _) -> quser E.^. QualificationUserLastRefresh + , singletonMap "first-held" $ SortColumn $ withType $ \(_ `E.InnerJoin` quser `E.LeftOuterJoin` _) -> quser E.^. QualificationUserFirstHeld ] , dbtFilter = mempty , dbtFilterUI = mempty diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 7d53bac9c..7abf93a93 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -27,9 +27,10 @@ import qualified Data.Text as T import qualified Data.CaseInsensitive as CI import qualified Data.Conduit.List as C import Database.Persist.Sql (updateWhereCount) +import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma import qualified Database.Esqueleto.Legacy as E --- import qualified Database.Esqueleto.PostgreSQL as E +import qualified Database.Esqueleto.PostgreSQL as E import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH @@ -79,7 +80,7 @@ mkQualificationAllTable isAdmin = do Ex.where_ $ filterSvs quser cactive = Ex.subSelectCount $ do quser <- Ex.from $ Ex.table @QualificationUser - Ex.where_ $ filterSvs quser Ex.&&. validQualification (utctDay now) quser + Ex.where_ $ filterSvs quser Ex.&&. validQualification now quser return (quali, cactive, cusers) dbtRowKey = (Ex.^. QualificationId) dbtProj = dbtProjId @@ -96,11 +97,11 @@ mkQualificationAllTable isAdmin = do maybeCell (qualificationDescription quali) markupCellLargeModal , sortable Nothing (i18nCell MsgQualificationValidDuration & cellTooltip MsgTableDiffDaysTooltip) $ foldMap (textCell . formatCalendarDiffDays . fromMonths) . view (resultAllQualification . _qualificationValidDuration) - , sortable Nothing (i18nCell MsgQualificationRefreshWithin & cellTooltip MsgQualificationRefreshWithinTooltip) $ + , sortable Nothing (i18nCell MsgQualificationRefreshWithin & cellTooltips [SomeMessage MsgQualificationRefreshWithinTooltip , SomeMessage MsgTableDiffDaysTooltip]) $ foldMap (textCell . formatCalendarDiffDays ) . view (resultAllQualification . _qualificationRefreshWithin) - , sortable Nothing (i18nCell MsgQualificationRefreshReminder & cellTooltip MsgQualificationRefreshReminderTooltip) $ - foldMap (textCell . formatCalendarDiffDays ) . view (resultAllQualification . _qualificationRefreshReminder) - , sortable (Just "qelearning") (i18nCell MsgTableLmsElearning & cellTooltip MsgQualificationElearningStart) + , sortable Nothing (i18nCell MsgQualificationRefreshReminder & cellTooltips [SomeMessage MsgQualificationRefreshReminderTooltip, SomeMessage MsgTableDiffDaysTooltip]) $ + foldMap (textCell . formatCalendarDiffDays ) . view (resultAllQualification . _qualificationRefreshReminder) + , sortable (Just "qelearning") (i18nCell MsgTableLmsElearning & cellTooltip MsgQualificationElearningStart) $ tickmarkCell . view (resultAllQualification . _qualificationElearningStart) , sortable (Just "noteexpiry") (i18nCell MsgQualificationExpiryNotification & cellTooltip MsgQualificationExpiryNotificationTooltip) $ tickmarkCell . view (resultAllQualification . _qualificationExpiryNotification) @@ -155,10 +156,11 @@ data QualificationTableCsv = QualificationTableCsv -- Q..T..C.. -> qtc.. , qtcCompanyNumbers :: CsvSemicolonList Int , qtcValidUntil :: Day , qtcLastRefresh :: Day - , qtcBlocked :: Maybe Day + , qtcBlockStatus :: Maybe Bool + , qtcBlockFrom :: Maybe UTCTime , qtcScheduleRenewal:: Bool , qtcLmsStatusTxt :: Maybe Text - , qtcLmsStatusDay :: Maybe Day + , qtcLmsStatusDay :: Maybe UTCTime } deriving Generic makeLenses_ ''QualificationTableCsv @@ -171,10 +173,11 @@ qtcExample = QualificationTableCsv , qtcCompanyNumbers = CsvSemicolonList [27,69] , qtcValidUntil = compDay , qtcLastRefresh = compDay - , qtcBlocked = Nothing + , qtcBlockStatus = Nothing + , qtcBlockFrom = Nothing , qtcScheduleRenewal= True , qtcLmsStatusTxt = Just "Success" - , qtcLmsStatusDay = Just compDay + , qtcLmsStatusDay = Just compTime } where compTime :: UTCTime @@ -204,7 +207,9 @@ instance CsvColumnsExplained QualificationTableCsv where , ('qtcCompany , SomeMessage MsgTableCompanies) , ('qtcCompanyNumbers , SomeMessage MsgTableCompanyNos) , ('qtcValidUntil , SomeMessage MsgLmsQualificationValidUntil) - , ('qtcLastRefresh , SomeMessage MsgTableQualificationLastRefresh) + , ('qtcLastRefresh , SomeMessage MsgTableQualificationLastRefresh) + , ('qtcBlockStatus , SomeMessage MsgInfoQualificationBlockStatus) + , ('qtcBlockFrom , SomeMessage MsgInfoQualificationBlockFrom) , ('qtcScheduleRenewal, SomeMessage MsgQualificationScheduleRenewalTooltip) , ('qtcLmsStatusTxt , SomeMessage MsgTableLmsStatus) , ('qtcLmsStatusDay , SomeMessage MsgTableLmsStatusDay) @@ -213,19 +218,22 @@ instance CsvColumnsExplained QualificationTableCsv where type QualificationTableExpr = ( E.SqlExpr (Entity QualificationUser) `E.InnerJoin` E.SqlExpr (Entity User) - ) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity LmsUser)) + ) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity LmsUser)) + `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity QualificationUserBlock)) queryQualUser :: QualificationTableExpr -> E.SqlExpr (Entity QualificationUser) -queryQualUser = $(sqlIJproj 2 1) . $(sqlLOJproj 2 1) +queryQualUser = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1) queryUser :: QualificationTableExpr -> E.SqlExpr (Entity User) -queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 2 1) +queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 3 1) queryLmsUser :: QualificationTableExpr -> E.SqlExpr (Maybe (Entity LmsUser)) -queryLmsUser = $(sqlLOJproj 2 2) +queryLmsUser = $(sqlLOJproj 3 2) +queryQualBlock :: QualificationTableExpr -> E.SqlExpr (Maybe (Entity QualificationUserBlock)) +queryQualBlock = $(sqlLOJproj 3 3) -type QualificationTableData = DBRow (Entity QualificationUser, Entity User, Maybe (Entity LmsUser), [Entity UserCompany]) +type QualificationTableData = DBRow (Entity QualificationUser, Entity User, Maybe (Entity LmsUser), Maybe (Entity QualificationUserBlock), [Entity UserCompany]) resultQualUser :: Lens' QualificationTableData (Entity QualificationUser) resultQualUser = _dbrOutput . _1 @@ -236,8 +244,11 @@ resultUser = _dbrOutput . _2 resultLmsUser :: Traversal' QualificationTableData (Entity LmsUser) resultLmsUser = _dbrOutput . _3 . _Just +resultQualBlock :: Traversal' QualificationTableData (Entity QualificationUserBlock) +resultQualBlock = _dbrOutput . _4 . _Just + resultCompanyUser :: Lens' QualificationTableData [Entity UserCompany] -resultCompanyUser = _dbrOutput . _4 +resultCompanyUser = _dbrOutput . _5 instance HasEntity QualificationTableData User where @@ -246,6 +257,16 @@ instance HasEntity QualificationTableData User where instance HasUser QualificationTableData where hasUser = resultUser . _entityVal +instance HasEntity QualificationTableData QualificationUser where + hasEntity = resultQualUser + +instance HasQualificationUser QualificationTableData where + hasQualificationUser = resultQualUser . _entityVal + +-- instance HasEntity QualificationUserBlock where +-- hasQualificationUserBlock = resultQualBlock + + data QualificationTableAction = QualificationActExpire | QualificationActUnexpire @@ -274,10 +295,10 @@ data QualificationTableActionData | QualificationActUnexpireData | QualificationActBlockSupervisorData | QualificationActBlockData { qualTableActBlockReason :: Text, qualTableActNotify :: Bool, qualTableActRemoveSupervisors :: Bool } - | QualificationActUnblockData + | QualificationActUnblockData { qualTableActBlockReason :: Text, qualTableActNotify :: Bool} | QualificationActRenewData | QualificationActGrantData { qualTableActGrantUntil :: Day } - deriving (Eq, Ord, Read, Show, Generic) + deriving (Eq, Ord, Show, Generic) isExpiryAct :: QualificationTableActionData -> Bool isExpiryAct QualificationActExpireData = True @@ -287,7 +308,7 @@ isExpiryAct _ = False isBlockAct :: QualificationTableActionData -> Bool isBlockAct QualificationActBlockSupervisorData = True isBlockAct QualificationActBlockData{} = True -isBlockAct QualificationActUnblockData = True +isBlockAct QualificationActUnblockData{} = True isBlockAct _ = False blockActRemoveSupervisors :: QualificationTableActionData -> Bool @@ -295,17 +316,35 @@ blockActRemoveSupervisors QualificationActBlockSupervisorData = True blockActRemoveSupervisors QualificationActBlockData{qualTableActRemoveSupervisors=res} = res blockActRemoveSupervisors _ = False +-- qualificationTableQuery :: QualificationId -> (_ -> E.SqlExpr (E.Value Bool)) -> QualificationTableExpr +-- -> E.SqlQuery ( E.SqlExpr (Entity QualificationUser) +-- , E.SqlExpr (Entity User) +-- , E.SqlExpr (Maybe (Entity LmsUser)) +-- ) +-- qualificationTableQuery qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUse) = do +-- E.on $ user E.^. UserId E.=?. lmsUser E.?. LmsUserUser +-- E.&&. E.val qid E.=?. lmsUser E.?. LmsUserQualification -- NOTE: condition was once erroneously placed in where-clause, which does not work +-- E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser +-- E.where_ $ fltr qualUser E.&&. (E.val qid E.==. qualUser E.^. QualificationUserQualification) +-- return (qualUser, user, lmsUser) + qualificationTableQuery :: QualificationId -> (_ -> E.SqlExpr (E.Value Bool)) -> QualificationTableExpr -> E.SqlQuery ( E.SqlExpr (Entity QualificationUser) , E.SqlExpr (Entity User) , E.SqlExpr (Maybe (Entity LmsUser)) + , E.SqlExpr (Maybe (Entity QualificationUserBlock)) ) -qualificationTableQuery qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser) = do +qualificationTableQuery qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser `E.LeftOuterJoin` qualBlock) = do + -- E.distinctOnOrderBy will not work: sorting with dbTable should work, except that columns contained in distinctOnOrderBy cannot be sorted inversely by user; but PostgreSQL leftJoin with distinct filters too many results, see SQL Example lead/lag under jost/misc DevOps + -- + E.on $ qualBlock E.?. QualificationUserBlockQualificationUser E.?=. qualUser E.^. QualificationUserId + E.&&. qualBlock `isLatestBlockBefore` E.now_ E.on $ user E.^. UserId E.=?. lmsUser E.?. LmsUserUser E.&&. E.val qid E.=?. lmsUser E.?. LmsUserQualification -- NOTE: condition was once erroneously placed in where-clause, which does not work E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser - E.where_ $ fltr qualUser E.&&. (E.val qid E.==. qualUser E.^. QualificationUserQualification) - return (qualUser, user, lmsUser) + E.where_ $ fltr qualUser + E.&&. (E.val qid E.==. qualUser E.^. QualificationUserQualification) + return (qualUser, user, lmsUser, qualBlock) mkQualificationTable :: @@ -334,33 +373,34 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do fltrSvs = if isAdmin then const E.true else \quser -> quser E.^. QualificationUserUser `Ex.in_` E.vals svs dbtSQLQuery = qualificationTableQuery qid fltrSvs dbtRowKey = queryUser >>> (E.^. UserId) - dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr) -> do + dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr, qUsrBlock) -> do -- cmps <- E.select . E.from $ \(usrComp `E.InnerJoin` comp) -> do -- E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId -- E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val (entityKey usr) -- E.orderBy [E.asc (comp E.^. CompanyName)] -- return (comp E.^. CompanyName, comp E.^. CompanyAvsId, usrComp E.^. UserCompanySupervisor) cmpUsr <- selectList [UserCompanyUser ==. entityKey usr] [Asc UserCompanyCompany] - return (qualUsr, usr, lmsUsr, cmpUsr) + return (qualUsr, usr, lmsUsr, qUsrBlock, cmpUsr) dbtColonnade = cols cmpMap dbtSorting = mconcat [ single $ sortUserNameLink queryUser , single $ sortUserEmail queryUser , single $ sortUserMatriclenr queryUser - , single ("valid-until" , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil)) + , single ("first-held" , SortColumn $ queryQualUser >>> (E.^. QualificationUserFirstHeld)) , single ("last-refresh" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh)) , single ("last-notified" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastNotified)) - , single ("blocked-due" , SortColumnNeverNull $ queryQualUser >>> (E.^. QualificationUserBlockedDue)) + , single ("valid-until" , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil)) + , single ("blocked" , SortColumnNeverNull $ queryQualBlock >>> (E.?. QualificationUserBlockFrom)) , single ("lms-status-plus",SortColumnNeverNull $ \row -> E.coalesce [E.explicitUnsafeCoerceSqlExprValue "timestamp" $ (queryLmsUser row E.?. LmsUserStatus) E.#>>. "{day}" , queryLmsUser row E.?. LmsUserStarted]) , single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal)) - , single ( "user-company" , SortColumn $ \row -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do + , single ("user-company" , SortColumn $ \row -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId E.orderBy [E.asc (comp E.^. CompanyName)] return (comp E.^. CompanyName) ) - , single ("validity", SortColumn $ queryQualUser >>> validQualification nowaday) + -- , single ("validity", SortColumn $ queryQualUser >>> validQualification now) ] dbtFilter = mconcat [ single $ fltrUserNameEmail queryUser @@ -389,7 +429,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId E.&&. testcrit ) - , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification nowaday)) + , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification now)) , single ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion -> if | Just renewal <- mbRenewal , Just True <- getLast criterion -> quser E.^. QualificationUserValidUntil E.<=. E.val renewal @@ -397,13 +437,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do | otherwise -> E.true ) , single ("tobe-notified", FilterColumn $ \(queryQualUser -> quser) criterion -> - if | Just True <- getLast criterion -> - (( 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.<. E.day' ((quser E.^. QualificationUserBlockedDue) E.->>. "day")) - )) + if | Just True <- getLast criterion -> quser `quserToNotify` now | otherwise -> E.true ) ] @@ -437,7 +471,8 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do <*> (view resultCompanyUser >>= getCompanyNos) <*> view (resultQualUser . _entityVal . _qualificationUserValidUntil) <*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh) - <*> preview (resultQualUser . _entityVal . _qualificationUserBlockedDue . _Just . _qualificationBlockedDay) + <*> preview (resultQualBlock. _entityVal . _qualificationUserBlockUnblock . _not) + <*> preview (resultQualBlock. _entityVal . _qualificationUserBlockFrom) <*> view (resultQualUser . _entityVal . _qualificationUserScheduleRenewal) <*> getStatusPlusTxt <*> getStatusPlusDay @@ -454,9 +489,9 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do Nothing -> maybeM (return Nothing) (const $ return $ Just "Open") $ preview (resultLmsUser . _entityVal . _lmsUserStarted) getStatusPlusDay = - (join . preview (resultLmsUser . _entityVal . _lmsUserStatus)) >>= \case - Just ls -> return $ Just $ lmsStatusDay ls - Nothing -> utctDay <<$>> preview (resultLmsUser . _entityVal . _lmsUserStarted) + (join . preview (resultLmsUser . _entityVal . _lmsUserStatusDay)) >>= \case + lsd@(Just _) -> return lsd + Nothing -> preview (resultLmsUser . _entityVal . _lmsUserStarted) dbtCsvDecode = Nothing dbtExtraReps = [] @@ -495,32 +530,54 @@ postQualificationR sid qsh = do now <- liftIO getCurrentTime let nowaday = utctDay now ((lmsRes, qualificationTable), Entity qid quali) <- runDB $ do - qent@Entity{entityVal=Qualification{ - qualificationAuditDuration=auditMonths - , qualificationValidDuration=validMonths + qent@Entity{ + entityKey=qid + , entityVal=Qualification{ + qualificationAuditDuration=auditMonths + , qualificationValidDuration=validMonths }} <- getBy404 $ SchoolQualificationShort sid qsh - let dayExpiry = flip addGregorianDurationClip nowaday . fromMonths <$> validMonths + -- Block copied to Handler/Qualifications TODO: refactor + let getBlockReasons unblk = Ex.select $ do + (quser :& qblock) <- Ex.from $ Ex.table @QualificationUser + `Ex.innerJoin` Ex.table @QualificationUserBlock + `Ex.on` (\(quser :& qblock) -> quser Ex.^. QualificationUserId Ex.==. qblock Ex.^. QualificationUserBlockQualificationUser) + Ex.where_ $ quser Ex.^. QualificationUserQualification Ex.==. Ex.val qid + Ex.&&. unblk (qblock Ex.^. QualificationUserBlockUnblock) + Ex.groupBy (qblock Ex.^. QualificationUserBlockReason) + let countRows' :: Ex.SqlExpr (Ex.Value Int64) = Ex.countRows + Ex.orderBy [Ex.desc countRows'] + Ex.limit 7 + pure (qblock Ex.^. QualificationUserBlockReason) + mkOption :: Ex.Value Text -> Option Text + mkOption (Ex.unValue -> t) = Option{ optionDisplay = t, optionInternalValue = t, optionExternalValue = toPathPiece t } + suggestionsBlock :: HandlerFor UniWorX (OptionList Text) + suggestionsBlock = mkOptionList . fmap mkOption <$> runDB (getBlockReasons Ex.not_) + suggestionsUnblock = mkOptionList . fmap mkOption <$> runDB (getBlockReasons id) + dayExpiry = flip addGregorianDurationClip nowaday . fromMonths <$> validMonths acts :: Map QualificationTableAction (AForm Handler QualificationTableActionData) acts = mconcat $ [ singletonMap QualificationActExpire $ pure QualificationActExpireData , singletonMap QualificationActUnexpire $ QualificationActUnexpireData <$ aformMessage msgUnexpire ] ++ bool - [ singletonMap QualificationActBlockSupervisor $ pure QualificationActBlockSupervisorData ] -- nonAdmin actions, ie. Supervisor - [ singletonMap QualificationActUnblock $ pure QualificationActUnblockData -- Admin-only actions + -- nonAdmin actions, ie. Supervisor + [ singletonMap QualificationActBlockSupervisor $ pure QualificationActBlockSupervisorData ] + -- Admin-only actions + [ singletonMap QualificationActUnblock $ QualificationActUnblockData + <$> apreq (textField & cfStrip & addDatalist suggestionsUnblock) (fslI MsgQualificationGrantReason) Nothing + <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockNotify) (Just False) , singletonMap QualificationActBlock $ QualificationActBlockData - <$> apreq textField (fslI MsgQualificationBlockReason) Nothing - <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockNotify) (Just False) - <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockRemoveSupervisor) (Just False) + <$> apreq (textField & cfStrip & addDatalist suggestionsBlock) (fslI MsgQualificationBlockReason) Nothing + <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockNotify) (Just False) + <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockRemoveSupervisor) (Just False) , singletonMap QualificationActRenew $ pure QualificationActRenewData , singletonMap QualificationActGrant $ QualificationActGrantData <$> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry <* aformMessage msgGrantWarning ] isAdmin - linkLmsUser = toMaybe isAdmin LmsUserR - linkUserName = bool ForProfileR ForProfileDataR isAdmin - blockedDueCell = bool qualificationBlockedCellNoReason qualificationBlockedCell isAdmin + linkLmsUser = toMaybe isAdmin (LmsUserR sid qsh) + linkUserName = bool ForProfileR ForProfileDataR isAdmin colChoices cmpMap = mconcat [ dbSelect (applying _2) id (return . view (hasEntity . _entityKey)) , colUserNameModalHdr MsgLmsUser linkUserName @@ -535,12 +592,13 @@ postQualificationR sid qsh = do (\(cmpName, cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> cs in wgtCell companies , guardMonoid isAdmin colUserMatriclenr - , sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser) + -- , sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser) + , sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d + , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) (dayCell . view ( resultQualUser . _entityVal . _qualificationUserValidUntil)) - , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d - , sortable (Just "blocked-due") (i18nCell MsgTableQualificationBlockedDue & cellTooltip MsgTableQualificationBlockedTooltipSimple - ) $ \( view $ resultQualUser . _entityVal . _qualificationUserBlockedDue -> b) -> blockedDueCell b - , sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip + , sortable (Just "blocked") (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltipSimple) $ \row -> + qualificationValidReasonCell' (Just $ LmsUserR sid qsh) isAdmin nowaday (row ^? resultQualBlock) row + , sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip ) $ \( view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification , sortable (Just "lms-status-plus")(i18nCell MsgTableLmsStatus & cellTooltipWgt Nothing (lmsStatusInfoCell isAdmin auditMonths)) $ \(preview $ resultLmsUser . _entityVal -> lu) -> foldMap (lmsStatusCell isAdmin linkLmsUser) lu @@ -552,7 +610,7 @@ postQualificationR sid qsh = do formResult lmsRes $ \case (QualificationActRenewData, selectedUsers) | isAdmin -> do - noks <- runDB $ renewValidQualificationUsers qid $ Set.toList selectedUsers + noks <- runDB $ renewValidQualificationUsers qid Nothing $ Set.toList selectedUsers addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks reloadKeepGetParams $ QualificationR sid qsh (QualificationActGrantData grantValidday, selectedUsers) | isAdmin -> do @@ -570,29 +628,24 @@ postQualificationR sid qsh = do reloadKeepGetParams $ QualificationR sid qsh (action, selectedUsers) | isBlockAct action && (isAdmin || action == QualificationActBlockSupervisorData) -> do let selUserIds = Set.toList selectedUsers - qubr = case action of - QualificationActUnblockData -> Nothing - QualificationActBlockSupervisorData -> Just $ mkQualificationBlocked QualificationBlockReturnedByCompany nowaday - QualificationActBlockData{..} -> Just $ QualificationBlocked - { qualificationBlockedDay = nowaday - , qualificationBlockedReason = qualTableActBlockReason - } - _ -> error "Handle.Qualification.isBlockAct returned non-block action" + (unblock, reason) = case action of + QualificationActBlockSupervisorData -> (False, Right QualificationBlockReturnedByCompany) + QualificationActBlockData{..} -> (False, Left qualTableActBlockReason) + QualificationActUnblockData{..} -> (True , Left qualTableActBlockReason) + _ -> error "Handle.Qualification.isBlockAct returned non-block action" -- cannot occur due to earlier checks notify = case action of QualificationActBlockData{qualTableActNotify} -> qualTableActNotify _ -> False oks <- runDB $ do when (blockActRemoveSupervisors action) $ deleteWhere [UserSupervisorUser <-. selUserIds] - qualificationUserBlocking qid selUserIds notify qubr + qualificationUserBlocking qid selUserIds unblock Nothing reason notify let nrq = length selectedUsers warnLevel = if | oks < 0 -> Error | oks == nrq -> Success | otherwise -> Warning - fbmsg = if - | isNothing qubr -> MsgQualificationStatusUnblock - | otherwise -> MsgQualificationStatusBlock + fbmsg = if unblock then MsgQualificationStatusUnblock else MsgQualificationStatusBlock addMessageI warnLevel $ fbmsg qsh oks nrq reloadKeepGetParams $ QualificationR sid qsh _ -> addMessageI Error MsgInvalidFormAction diff --git a/src/Handler/Tutorial/Form.hs b/src/Handler/Tutorial/Form.hs index 22ac01d81..6e4e608dd 100644 --- a/src/Handler/Tutorial/Form.hs +++ b/src/Handler/Tutorial/Form.hs @@ -90,7 +90,7 @@ tutorialForm cid template html = do <*> tutorForm where tutTypeDatalist :: HandlerFor UniWorX (OptionList (CI Text)) - tutTypeDatalist = fmap (mkOptionList . map (\t -> Option (CI.original t) t (CI.original t)) . Set.toAscList) . runDB $ + tutTypeDatalist = fmap (mkOptionList . map (\t -> Option (CI.original t) t (toPathPiece $ CI.original t)) . Set.toAscList) . runDB $ fmap (setOf $ folded . _Value) . E.select . E.from $ \tutorial -> do E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid return $ tutorial E.^. TutorialType diff --git a/src/Handler/Tutorial/Users.hs b/src/Handler/Tutorial/Users.hs index fc278f84c..f9be59482 100644 --- a/src/Handler/Tutorial/Users.hs +++ b/src/Handler/Tutorial/Users.hs @@ -58,21 +58,23 @@ data TutorialUserActionData getTUsersR, postTUsersR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler TypedContent getTUsersR = postTUsersR -postTUsersR tid ssh csh tutn = do +postTUsersR tid ssh csh tutn = do + isAdmin <- hasReadAccessTo AdminR (Entity tutid tut@Tutorial{..}, (participantRes, participantTable), qualifications) <- runDB $ do cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh tutEnt@(Entity tutid _) <- fetchTutorial tid ssh csh tutn qualifications <- getCourseQualifications cid now <- liftIO getCurrentTime - let minDur :: Maybe Int = minimumMaybe $ mapMaybe (view _qualificationValidDuration) qualifications -- no instance Ord CalendarDiffDays - dayExpiry = flip addGregorianDurationClip (utctDay now) . fromMonths <$> minDur + let nowaday = utctDay now + minDur :: Maybe Int = minimumMaybe $ mapMaybe (view _qualificationValidDuration) qualifications -- no instance Ord CalendarDiffDays + dayExpiry = flip addGregorianDurationClip nowaday . fromMonths <$> minDur colChoices = mconcat $ catMaybes [ pure $ dbSelect (applying _2) id (return . view (hasEntity . _entityKey)) , pure $ colUserNameModalHdr MsgTableCourseMembers ForProfileDataR , pure colUserEmail , pure colUserMatriclenr - , pure colUserQualifications - , pure colUserQualificationBlocked + , pure $ colUserQualifications nowaday + , pure $ colUserQualificationBlocked isAdmin nowaday ] psValidator = def & defaultSortingByName @@ -143,7 +145,7 @@ postTUsersR tid ssh csh tutn = do redirect $ CTutorialR tid ssh csh tutn TUsersR (TutorialUserRenewQualificationData{..}, selectedUsers) | tuQualification `Set.member` courseQids -> do - noks <- runDB $ renewValidQualificationUsers tuQualification $ Set.toList selectedUsers + noks <- runDB $ renewValidQualificationUsers tuQualification Nothing $ Set.toList selectedUsers addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks redirect $ CTutorialR tid ssh csh tutn TUsersR (TutorialUserSendMailData{}, selectedUsers) -> do diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 60e533856..ce86e627d 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -259,8 +259,7 @@ getDifferingLicences (AvsResponseGetLicences licences) = do --let (vorfeld, nonvorfeld) = Set.partition (`avsPersonLicenceIs` AvsLicenceVorfeld) licences -- rollfeld = Set.filter (`avsPersonLicenceIs` AvsLicenceRollfeld) nonvorfeld -- Note: FRADrive users with 'R' also own 'F' qualification, but AvsGetResponseGetLicences yields only either - let nowaday = utctDay now - vorORrollfeld' = Set.dropWhileAntitone (`avsPersonLicenceIsLEQ` AvsNoLicence) licences + let vorORrollfeld' = Set.dropWhileAntitone (`avsPersonLicenceIsLEQ` AvsNoLicence) licences rollfeld' = Set.dropWhileAntitone (`avsPersonLicenceIsLEQ` AvsLicenceVorfeld) vorORrollfeld' vorORrollfeld = Set.map avsLicencePersonID vorORrollfeld' rollfeld = Set.map avsLicencePersonID rollfeld' @@ -275,7 +274,7 @@ getDifferingLicences (AvsResponseGetLicences licences) = do (quali E.^. QualificationId E.==. qualUser E.^. QualificationUserQualification) -- NOTE: filters on the innerJoin must be part of ON-condition in order for anti-join to work! E.&&. (quali E.^. QualificationAvsLicence E.==. E.justVal lic) -- correct type of licence - E.&&. (nowaday `validQualification` qualUser) -- currently valid and not blocked + E.&&. (now `validQualification` qualUser) -- currently valid and not blocked ) `E.innerJoin` E.table @UserAvs `E.on` (\(_ :& qualUser :& usrAvs) -> qualUser E.^. QualificationUserUser E.==. usrAvs E.^. UserAvsUser) diff --git a/src/Handler/Utils/DateTime.hs b/src/Handler/Utils/DateTime.hs index cfe920688..754110bdb 100644 --- a/src/Handler/Utils/DateTime.hs +++ b/src/Handler/Utils/DateTime.hs @@ -62,7 +62,7 @@ localTimeToUTC = TZ.localTimeToUTCFull appTZ localTimeToUTCSimple :: LocalTime -> UTCTime localTimeToUTCSimple = TZ.localTimeToUTCTZ appTZ --- | Local midnight of given day +-- | Local midnight of given day; use Utils.DateTime.utctDayMidnight :: Day -> UTCTime instead to avoid Timezone conversion! toMidnight :: Day -> UTCTime toMidnight = toTimeOfDay 0 0 0 diff --git a/src/Handler/Utils/LMS.hs b/src/Handler/Utils/LMS.hs index 0376866cb..e47c58cc1 100644 --- a/src/Handler/Utils/LMS.hs +++ b/src/Handler/Utils/LMS.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Steffen Jost +-- SPDX-FileCopyrightText: 2022-23 Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -7,6 +7,7 @@ module Handler.Utils.LMS ( getLmsCsvDecoder , csvLmsIdent + , csvLmsDate , csvLmsTimestamp , csvLmsBlocked , csvLmsSuccess @@ -14,12 +15,18 @@ module Handler.Utils.LMS , csvLmsResetPin , csvLmsDelete , csvLmsStaff + , csvLmsResetTries + , csvLmsLock + , csvLmsResult , csvFilenameLmsUser , csvFilenameLmsUserlist , csvFilenameLmsResult + , csvFilenameLmsReport , lmsDeletionDate - , lmsUserToDelete, _lmsUserToDelete - , lmsUserToDeleteExpr + , lmsUserToDelete , _lmsUserToDelete , lmsUserToDeleteExpr + , lmsUserToResetTries , _lmsUserToResetTries , lmsUserToResetTriesExpr + , lmsUserToLock , _lmsUserToLock , lmsUserToLockExpr + , lmsUserStaff , _lmsUserStaff , lmsStatusInfoCell , lmsStatusIcon, lmsUserStatusWidget , randomLMSIdent, randomLMSIdentBut @@ -56,45 +63,63 @@ getLmsCsvDecoder = do -- generic Column names csvLmsIdent :: IsString a => a -csvLmsIdent = fromString "user" -- "Benutzerkennung" +csvLmsIdent = fromString "user" -- "Benutzerkennung" V1, V2 + +csvLmsDate :: IsString a => a +csvLmsDate = fromString "date" -- "Datum", V2 csvLmsTimestamp :: IsString a => a -csvLmsTimestamp = fromString "timestamp" -- "Zeitstempel" +csvLmsTimestamp = fromString "timestamp" -- "Zeitstempel" V1 -- for Users Table csvLmsPin :: IsString a => a -csvLmsPin = fromString "pin" -- "PIN" +csvLmsPin = fromString "pin" -- "PIN" V1, V2 csvLmsResetPin :: IsString a => a -csvLmsResetPin = fromString "reset_pin" -- "PIN zurücksetzen" +csvLmsResetPin = fromString "reset_pin" -- "PIN zurücksetzen" V1, V2 csvLmsDelete :: IsString a => a -csvLmsDelete = fromString "delete" -- "Account löschen" +csvLmsDelete = fromString "delete" -- "Account löschen" V1, V2 csvLmsStaff :: IsString a => a -csvLmsStaff = fromString "staff" -- "Mitarbeiter" +csvLmsStaff = fromString "staff" -- "Mitarbeiter" V1, V2 --- for Userlist Table +csvLmsResetTries :: IsString a => a +csvLmsResetTries = fromString "reset_tries" -- Anzahl Versuche zurücksetzen, V2 + +csvLmsLock :: IsString a => a +csvLmsLock = fromString "lock" -- Ist der Login derzeit gesperrt? V2 + +-- for Userlist Table V1 csvLmsBlocked :: IsString a => a -csvLmsBlocked = fromString "blocked" -- "Sperrung" +csvLmsBlocked = fromString "blocked" -- "Sperrung" V1 --- for Result Table +-- for Result Table V1 csvLmsSuccess :: IsString a => a -csvLmsSuccess = fromString "success" -- "Datum" +csvLmsSuccess = fromString "success" -- "Datum" V1 + +-- for Report Table V2 +csvLmsResult :: IsString a => a +csvLmsResult = fromString "result" -- LmsStatus: 0=Versuche aufgebraucht, 1=Offen, 2=Bestanden V2 --- | Filename for User transmission, contains current datestamp as agreed in LMS interface + +-- | Filename for User transmission, contains current datestamp as agreed in LMS interface V1 & V2 csvFilenameLmsUser :: MonadHandler m => QualificationShorthand -> m Text csvFilenameLmsUser = makeLmsFilename "user" --- | Filename for Userlist transmission, contains current datestamp as agreed in LMS interface +-- | Filename for Userlist transmission, contains current datestamp as agreed in LMS interface V2 csvFilenameLmsUserlist :: MonadHandler m => QualificationShorthand -> m Text csvFilenameLmsUserlist = makeLmsFilename "userliste" --- | Filename for Result transmission, contains current datestamp as agreed in LMS interface +-- | Filename for Result transmission, contains current datestamp as agreed in LMS interface V1 csvFilenameLmsResult :: MonadHandler m => QualificationShorthand -> m Text csvFilenameLmsResult = makeLmsFilename "ergebnisse" +-- | Filename for Report transmission, combining former Userlist and Result as agreed in new LMS interface V2 +csvFilenameLmsReport :: MonadHandler m => QualificationShorthand -> m Text +csvFilenameLmsReport = makeLmsFilename "report" + -- | Create filenames as specified by the LMS interface agreed with Know How AG makeLmsFilename :: MonadHandler m => Text -> QualificationShorthand -> m Text makeLmsFilename ftag (citext2lower -> qsh) = do @@ -106,25 +131,55 @@ getYMTH :: MonadHandler m => m Text getYMTH = formatTime' "%Y%m%d%H" =<< liftIO getCurrentTime -- -lmsDeletionDate :: Handler Day +lmsDeletionDate :: Handler UTCTime lmsDeletionDate = do LmsConf{lmsDeletionDays} <- getsYesod $ view _appLmsConf - addDays (fromIntegral $ negate lmsDeletionDays) . utctDay <$> liftIO getCurrentTime + addLocalDays (fromIntegral $ negate lmsDeletionDays) <$> liftIO getCurrentTime -- | Decide whether LMS platform should delete an identifier -lmsUserToDeleteExpr :: Day -> E.SqlExpr (Entity LmsUser) -> E.SqlExpr (E.Value Bool) +lmsUserToDeleteExpr :: UTCTime -> E.SqlExpr (Entity LmsUser) -> E.SqlExpr (E.Value Bool) lmsUserToDeleteExpr cutoff lmslist = E.isNothing (lmslist E.^. LmsUserEnded) - E.&&. E.not_ (E.isNothing $ lmslist E.^. LmsUserStatus) - E.&&. E.explicitUnsafeCoerceSqlExprValue "timestamp" ((lmslist E.^. LmsUserStatus) E.#>>. "{day}") E.<=. E.val cutoff - + E.&&. E.isJust (lmslist E.^. LmsUserStatus) + E.&&. E.isJust (lmslist E.^. LmsUserStatusDay) + E.&&. lmslist E.^. LmsUserStatusDay E.<=. E.justVal cutoff + -- | Is everything since cutoff day or before? -lmsUserToDelete :: Day -> LmsUser -> Bool -lmsUserToDelete cutoff LmsUser{lmsUserEnded=Nothing, lmsUserStatus= Just lstat} = lmsStatusDay lstat < cutoff +lmsUserToDelete :: UTCTime -> LmsUser -> Bool +lmsUserToDelete cutoff LmsUser{lmsUserEnded=Nothing, lmsUserStatusDay=Just lstat} = lstat < cutoff lmsUserToDelete _ _ = False -_lmsUserToDelete :: Day -> Getter LmsUser Bool +_lmsUserToDelete :: UTCTime -> Getter LmsUser Bool _lmsUserToDelete cutoff = to $ lmsUserToDelete cutoff +lmsUserToResetTriesExpr :: E.SqlExpr (Entity LmsUser) -> E.SqlExpr (E.Value Bool) +lmsUserToResetTriesExpr luser = (luser E.^. LmsUserResetTries) E.&&. (luser E.^. LmsUserLocked) E.&&. + ((luser E.^. LmsUserStatus) `E.in_` E.justValList [LmsBlocked, LmsExpired]) + +lmsUserToResetTries :: LmsUser -> Bool +lmsUserToResetTries LmsUser{..} = lmsUserResetTries && lmsUserLocked && + (lmsUserStatus == Just LmsBlocked || lmsUserStatus == Just LmsExpired) + -- only reset blocked learners + +_lmsUserToResetTries :: Getter LmsUser Bool +_lmsUserToResetTries = to lmsUserToResetTries + +-- | Answers "Should the LMS lock a user out?" +-- Note that LmsUserLocked only logs the current LMS state, not what it should be. +lmsUserToLockExpr :: E.SqlExpr (Entity LmsUser) -> E.SqlExpr (E.Value Bool) +lmsUserToLockExpr luser = E.isJust (luser E.^. LmsUserStatus) + +lmsUserToLock :: LmsUser -> Bool +lmsUserToLock LmsUser{..} = isJust lmsUserStatus -- only open LMS should be accessible + +_lmsUserToLock :: Getter LmsUser Bool +_lmsUserToLock = to lmsUserToLock + +lmsUserStaff :: LmsUser -> Bool +lmsUserStaff = const False -- legacy, currently ignored + +_lmsUserStaff :: Getter LmsUser Bool +_lmsUserStaff = to lmsUserStaff + -- random generation of LmsIdentifiers, maybe this should be in Model.Types.Lms since length specifications are type-y? lengthIdent :: Int @@ -184,6 +239,13 @@ lmsStatusInfoCell extendedInfo auditMonths =

          _{MsgLmsStatusExpired}
          ^{icon IconOK}
          _{MsgLmsStatusSuccess} + $if extendedInfo +
          ^{icon IconLocked} +
          _{MsgLmsStatusLocked} +
          ^{icon IconUnlocked} +
          _{MsgLmsStatusUnlocked} +
          ^{icon IconResetTries} +
          _{MsgLmsStatusResetTries}

          _{MsgLmsStatusDelay} |] @@ -194,20 +256,44 @@ lmsStatusIcon LmsExpired{} = IconExpired lmsStatusIcon _other = IconNotOK lmsUserStatusWidget :: Bool -> LmsUser -> Widget -lmsUserStatusWidget _ LmsUser{lmsUserStatus=Just lStat} = - [whamlet|$newline never - ^{formatTimeW SelFormatDate (lmsStatusDay lStat)} - \ ^{icon (lmsStatusIcon lStat)} - |] --- previously: IconWaitingForUser for lmsUserStatus==Nothing -lmsUserStatusWidget _ LmsUser{lmsUserNotified=Just d} = - [whamlet|$newline never - ^{formatTimeW SelFormatDate d} - \ ^{icon IconNotificationSent} - |] -lmsUserStatusWidget True LmsUser{lmsUserStarted} = -- E-Learning started, but not yet notified; only intended for Admins - [whamlet|$newline never - ^{formatTimeW SelFormatDate lmsUserStarted} - \ ^{icon IconPlanned} - |] -lmsUserStatusWidget _ _ = mempty +lmsUserStatusWidget adminInfo luser = case luser of + LmsUser{lmsUserStatus=Just lStat, lmsUserStatusDay=mbDay} -> + [whamlet|$newline never + $maybe aday <- mbDay + ^{formatTimeW SelFormatDateTime aday} + $nothing + --.--.---- + \ ^{iconFixed (lmsStatusIcon lStat)} + $if adminInfo + \ ^{lockIcon} + \ ^{resetIcon} + |] + + LmsUser{lmsUserNotified=Just d} -> + [whamlet|$newline never + ^{formatTimeW SelFormatDateTime d} + \ ^{iconFixed IconNotificationSent} + $if adminInfo + \ ^{lockIcon} + \ ^{resetIcon} + |] + + LmsUser{lmsUserStarted=dstart} | adminInfo -> -- E-Learning started, but not yet notified; only intended for Admins; + [whamlet|$newline never + ^{formatTimeW SelFormatDateTime dstart} + \ ^{iconFixed IconPlanned} + $if adminInfo + \ ^{resetIcon} + |] -- would always display Iconlocked + + _ -> mempty + + where + lockIcon + | lmsUserLocked luser == lmsUserToLock luser = mempty + | lmsUserLocked luser = iconFixed IconLocked + | otherwise = iconFixed IconUnlocked + + resetIcon + | lmsUserResetTries luser = iconFixed IconResetTries + | otherwise = mempty diff --git a/src/Handler/Utils/Qualification.hs b/src/Handler/Utils/Qualification.hs index 4f386659f..a0f4fb706 100644 --- a/src/Handler/Utils/Qualification.hs +++ b/src/Handler/Utils/Qualification.hs @@ -1,7 +1,8 @@ --- SPDX-FileCopyrightText: 2022 Steffen Jost +-- SPDX-FileCopyrightText: 2022-23 Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later +{-# LANGUAGE TypeApplications #-} module Handler.Utils.Qualification ( module Handler.Utils.Qualification @@ -9,71 +10,158 @@ module Handler.Utils.Qualification import Import +import qualified Data.Text as Text + -- import Data.Time.Calendar (CalendarDiffDays(..)) -import Database.Persist.Sql (updateWhereCount) +-- 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) +import Handler.Utils.Widgets (statusHtml) + +statusQualificationBlock :: Bool -> Html +statusQualificationBlock s = statusHtml (bool Error Success s) $ iconQualificationBlock s -isValidQualification :: HasQualificationUser a => Day -> a -> Bool -isValidQualification d q = d `inBetween` (q ^. hasQualificationUser . _qualificationUserFirstHeld - ,q ^. hasQualificationUser . _qualificationUserValidUntil) - && isNothing (q ^. hasQualificationUser . _qualificationUserBlockedDue) +-- needs refactoring, probbably no longer helpful +mkQualificationBlocked :: QualificationBlockStandardReason -> UTCTime -> QualificationUserId -> QualificationUserBlock +mkQualificationBlocked reason qualificationUserBlockFrom qualificationUserBlockQualificationUser = QualificationUserBlock{..} + where + qualificationUserBlockReason = qualificationBlockedReasonText reason + qualificationUserBlockUnblock = False + qualificationUserBlockBlocker = Nothing + +-- somewhat dangerous, if not used with latest effective block +isValidQualification :: (HasQualificationUser a, HasQualificationUserBlock b) => Day -> a -> Maybe b -> Bool +isValidQualification d qu qb= d `inBetween` (qu ^. hasQualificationUser . _qualificationUserFirstHeld + ,qu ^. hasQualificationUser . _qualificationUserValidUntil) + && all (^. hasQualificationUserBlock . _qualificationUserBlockUnblock) qb ------------------ -- SQL Snippets -- ------------------ --- TODO: consider replacing `nowaday` by `Database.Esqueleto.PostgreSQL.now_` or better `day(now_)` cast as date -validQualification :: Day -> E.SqlExpr (Entity QualificationUser) -> E.SqlExpr (E.Value Bool) -validQualification nowaday = \qualUser -> - (E.val nowaday `E.between` (qualUser E.^. QualificationUserFirstHeld - ,qualUser E.^. QualificationUserValidUntil)) -- currently valid - E.&&. E.isNothing (qualUser E.^. QualificationUserBlockedDue) -- not blocked +-- | Recently became invalid or blocked and not yet notified +quserToNotify :: E.SqlExpr (Entity QualificationUser) -> UTCTime -> E.SqlExpr (E.Value Bool) +quserToNotify quser cutoff = -- recently invalid or... + ( E.day (quser E.^. QualificationUserLastNotified) E.<. quser E.^. QualificationUserValidUntil + E.&&. E.notExists (do + qualUserBlock <- E.from $ E.table @QualificationUserBlock + E.where_ $ E.not_ (qualUserBlock E.^. QualificationUserBlockUnblock) + E.&&. qualUserBlock E.^. QualificationUserBlockFrom E.>. quser E.^. QualificationUserLastNotified + E.&&. qualUserBlock E.^. QualificationUserBlockFrom E.<=. E.val cutoff + E.&&. E.notExists (do -- block is the most recent block + qualUserLaterBlock <- E.from $ E.table @QualificationUserBlock + E.where_ $ -- ((E.>.) `on` (E.^. QualificationUserBlockFrom) qualUserLaterBlock qualUserBlock) + qualUserLaterBlock E.^. QualificationUserBlockFrom E.>. qualUserBlock E.^. QualificationUserBlockFrom + E.&&. qualUserLaterBlock E.^. QualificationUserBlockFrom E.<=. E.val cutoff + ) + ) + ) E.||. E.exists (do -- ...recently blocked + qualUserBlock <- E.from $ E.table @QualificationUserBlock + E.where_ $ E.not_ (qualUserBlock E.^. QualificationUserBlockUnblock) -- block is not an unblock + E.&&. E.day (qualUserBlock E.^. QualificationUserBlockFrom) E.<. quser E.^. QualificationUserValidUntil -- block was essential during validity + E.&&. qualUserBlock E.^. QualificationUserBlockFrom E.>. quser E.^. QualificationUserLastNotified -- block has not yet been communicated + E.&&. qualUserBlock E.^. QualificationUserBlockFrom E.<=. E.val cutoff -- block is already active + E.&&. E.notExists (do -- block is the most recent block + qualUserLaterBlock <- E.from $ E.table @QualificationUserBlock + E.where_ $ -- ((E.>.) `on` (E.^. QualificationUserBlockFrom) qualUserLaterBlock qualUserBlock)) + qualUserLaterBlock E.^. QualificationUserBlockFrom E.>. qualUserBlock E.^. QualificationUserBlockFrom + E.&&. qualUserLaterBlock E.^. QualificationUserBlockFrom E.<=. E.val cutoff + ) + ) -validQualification' :: Day -> E.SqlExpr (Maybe (Entity QualificationUser)) -> E.SqlExpr (E.Value Bool) -validQualification' nowaday qualUser = - (E.justVal nowaday `E.between` (qualUser E.?. QualificationUserFirstHeld - ,qualUser E.?. QualificationUserValidUntil)) -- currently valid - E.&&. E.isNothing (E.joinV $ qualUser E.?. QualificationUserBlockedDue) -- not blocked +-- condition to ensure that the lastes QualificationUserBlock was picked, better to be used in join-on clauses, since inside a where-clause it might not work as intended +isLatestBlockBefore :: E.SqlExpr (Maybe (Entity QualificationUserBlock)) -> E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value Bool) +isLatestBlockBefore qualBlock cutoff = (cutoff E.>~. qualBlock E.?. QualificationUserBlockFrom) E.&&. E.notExists (do + newerBlock <- E.from $ E.table @QualificationUserBlock + E.where_ $ newerBlock E.^. QualificationUserBlockFrom E.<=. cutoff + E.&&. E.just (newerBlock E.^. QualificationUserBlockFrom) E.>. qualBlock E.?. QualificationUserBlockFrom + E.&&. newerBlock E.^. QualificationUserBlockQualificationUser E.=?. qualBlock E.?. QualificationUserBlockQualificationUser + ) +-- cutoff can be `E.val now` or even `Database.Esqueleto.PostgreSQL.now_` +quserBlockAux :: Bool -> E.SqlExpr (E.Value UTCTime) -> (E.SqlExpr (E.Value QualificationUserId) -> E.SqlExpr (E.Value Bool)) -> Maybe (E.SqlExpr (Entity QualificationUserBlock) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (E.Value Bool) +quserBlockAux negCond cutoff checkQualUserId mbBlockCondition = bool E.notExists E.exists negCond $ do + qualUserBlock <- E.from $ E.table @QualificationUserBlock + E.where_ $ E.not_ (qualUserBlock E.^. QualificationUserBlockUnblock) + E.&&. (qualUserBlock E.^. QualificationUserBlockFrom E.<=. cutoff) + E.&&. checkQualUserId (qualUserBlock E.^. QualificationUserBlockQualificationUser) + E.&&. E.notExists (do + qualUserUnblock <- E.from $ E.table @QualificationUserBlock + E.where_ $ (qualUserUnblock E.^. QualificationUserBlockUnblock) + E.&&. checkQualUserId (qualUserUnblock E.^. QualificationUserBlockQualificationUser) + E.&&. qualUserUnblock E.^. QualificationUserBlockFrom E.<=. cutoff + E.&&. qualUserUnblock E.^. QualificationUserBlockFrom E.>=. qualUserBlock E.^. QualificationUserBlockFrom -- in case of identical timestamps, the unblock trumps the block + ) + whenIsJust mbBlockCondition (E.where_ . ($ qualUserBlock)) +-- | Test whether a QualificationUser was blocked/unblocked at a given day; negCond: True:isBlocked False:isUnblocked +quserBlock :: Bool -> UTCTime -> E.SqlExpr (Entity QualificationUser) -> E.SqlExpr (E.Value Bool) +quserBlock negCond cutoff qualUser = quserBlockAux negCond (E.val cutoff) (E.==. (qualUser E.^. QualificationUserId)) Nothing -selectValidQualifications :: QualificationId -> Maybe [UserId] -> Day -> DB [Entity QualificationUser] -selectValidQualifications qid mbUids nowaday = - -- nowaday <- utctDay <$> liftIO getCurrentTime +-- | Variant of `isBlocked` for outer joins +quserBlock' :: Bool -> UTCTime -> E.SqlExpr (Maybe (Entity QualificationUser)) -> E.SqlExpr (E.Value Bool) +quserBlock' negCond cutoff qualUser = quserBlockAux negCond (E.val cutoff) (E.=?. (qualUser E.?. QualificationUserId)) Nothing + +qualificationValid :: E.SqlExpr (Entity QualificationUser) -> UTCTime -> E.SqlExpr (E.Value Bool) +qualificationValid = flip validQualification + +validQualification :: UTCTime -> E.SqlExpr (Entity QualificationUser) -> E.SqlExpr (E.Value Bool) +validQualification cutoff qualUser = + (E.val (utctDay cutoff) `E.between` (qualUser E.^. QualificationUserFirstHeld + ,qualUser E.^. QualificationUserValidUntil)) -- currently valid + E.&&. quserBlock False cutoff qualUser + +-- | Variant of `validQualification` for outer joins +validQualification' :: UTCTime -> E.SqlExpr (Maybe (Entity QualificationUser)) -> E.SqlExpr (E.Value Bool) +validQualification' cutoff qualUser = + (E.justVal (utctDay cutoff) `E.between` (qualUser E.?. QualificationUserFirstHeld + ,qualUser E.?. QualificationUserValidUntil)) -- currently valid + E.&&. quserBlock' False cutoff qualUser + +-- selectValidQualifications :: QualificationId -> [UserId] -> UTCTime -> DB [Entity QualificationUser] +selectValidQualifications :: + ( MonadIO m + , BackendCompatible SqlBackend backend + , PersistQueryRead backend + , PersistUniqueRead backend + ) => QualificationId -> [UserId] -> UTCTime -> ReaderT backend m [Entity QualificationUser] +selectValidQualifications qid uids cutoff = + -- cutoff <- utctDay <$> liftIO getCurrentTime E.select $ do qUser <- E.from $ E.table @QualificationUser E.where_ $ (qUser E.^. QualificationUserQualification E.==. E.val qid) - E.&&. validQualification nowaday qUser - E.&&. maybe E.true (\uids -> qUser E.^. QualificationUserUser `E.in_` E.valList uids) mbUids + E.&&. qUser E.^. QualificationUserUser `E.in_` E.valList uids + E.&&. validQualification cutoff qUser + -- whenIsJust mbUids (\uids -> E.where_ $ qUser E.^. QualificationUserUser `E.in_` E.valList uids) pure qUser +selectRelevantBlock :: UTCTime -> QualificationUserId -> DB (Maybe (Entity QualificationUserBlock)) +selectRelevantBlock cutoff quid = + selectFirst [QualificationUserBlockQualificationUser ==. quid, QualificationUserBlockFrom <=. cutoff] [Desc QualificationUserBlockFrom] ------------------------ -- Complete Functions -- ------------------------ -upsertQualificationUser :: QualificationId -> Day -> Day -> Maybe Bool -> UserId -> DB () +upsertQualificationUser :: QualificationId -> Day -> Day -> Maybe Bool -> UserId -> DB () -- ignores blocking upsertQualificationUser qualificationUserQualification qualificationUserLastRefresh qualificationUserValidUntil mbScheduleRenewal qualificationUserUser = do Entity quid _ <- upsert QualificationUser - { qualificationUserFirstHeld = qualificationUserLastRefresh - , qualificationUserBlockedDue = Nothing + { qualificationUserFirstHeld = qualificationUserLastRefresh , qualificationUserScheduleRenewal = fromMaybe True mbScheduleRenewal - , qualificationUserLastNotified = toMidnight qualificationUserLastRefresh + , qualificationUserLastNotified = utctDayMidnight qualificationUserLastRefresh , .. } ( [ QualificationUserScheduleRenewal =. scheduleRenewal | Just scheduleRenewal <- [mbScheduleRenewal] ] ++ [ QualificationUserValidUntil =. qualificationUserValidUntil - , QualificationUserLastRefresh =. qualificationUserLastRefresh - , QualificationUserBlockedDue =. Nothing + , QualificationUserLastRefresh =. qualificationUserLastRefresh ] ) + audit TransactionQualificationUserEdit { transactionQualificationUser = quid , transactionQualification = qualificationUserQualification @@ -82,23 +170,38 @@ upsertQualificationUser qualificationUserQualification qualificationUserLastRef , transactionQualificationScheduleRenewal = mbScheduleRenewal } -renewValidQualificationUsers :: QualificationId -> [UserId] -> DB Int -renewValidQualificationUsers qid uids = - -- This code works in principle, but it does not allow audit log entries. +-- | Renew an existing valid qualification, ignoring all blocks otherwise +-- renewValidQualificationUsers :: QualificationId -> Maybe UTCTime -> [UserId] -> DB Int -- not general enough for use in YesodJobDB +renewValidQualificationUsers :: + ( AuthId (HandlerSite m) ~ Key User + , IsPersistBackend (YesodPersistBackend (HandlerSite m)) + , BaseBackend (YesodPersistBackend (HandlerSite m)) ~ SqlBackend + , BackendCompatible SqlBackend (YesodPersistBackend (HandlerSite m)) + , PersistQueryWrite (YesodPersistBackend (HandlerSite m)) + , PersistUniqueWrite (YesodPersistBackend (HandlerSite m)) + , HasInstanceID (HandlerSite m) InstanceId + , YesodAuthPersist (HandlerSite m) + , HasAppSettings (HandlerSite m) + , MonadHandler m + , MonadCatch m + ) => QualificationId -> Maybe UTCTime -> [UserId] -> ReaderT (YesodPersistBackend (HandlerSite m)) m Int +renewValidQualificationUsers qid renewalTime uids = + -- The following short code snippet suffices in principle, but would not allow audit log entries. Are these still needed? -- E.update $ \qu -> do -- E.set qu [ QualificationUserValidUntil E.+=. E.interval (CalendarDiffDays 2 0) ] -- TODO: for Testing only -- E.where_ $ (qu E.^. QualificationUserQualification E.==. E.val qid ) -- E.&&. (qu E.^. QualificationUserUser `E.in_` E.valList uids) get qid >>= \case Just Qualification{qualificationValidDuration=Just renewalMonths} -> do - nowaday <- utctDay <$> liftIO getCurrentTime - quEntsAll <- selectValidQualifications qid (Just uids) nowaday - let maxValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) nowaday - quEnts = filter (\q -> maxValidTo >= (q ^. _entityVal . _qualificationUserValidUntil)) quEntsAll + cutoff <- maybe (liftIO getCurrentTime) return renewalTime + quEntsAll <- selectValidQualifications qid uids cutoff + let cutoffday = utctDay cutoff + maxValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) cutoffday + quEnts = filter (\q -> maxValidTo >= (q ^. _entityVal . _qualificationUserValidUntil)) quEntsAll forM_ quEnts $ \(Entity quId QualificationUser{..}) -> do let newValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) qualificationUserValidUntil update quId [ QualificationUserValidUntil =. newValidTo - , QualificationUserLastRefresh =. nowaday + , QualificationUserLastRefresh =. cutoffday ] audit TransactionQualificationUserEdit { transactionQualificationUser = quId @@ -110,8 +213,7 @@ renewValidQualificationUsers qid uids = return $ length quEnts _ -> return (-1) -- qualificationId not found, isNothing qualificationValidDuration, etc. - --- qualificationUserBlocking :: QualificationId -> [UserId] -> Maybe QualificationBlocked -> DB Int64 +-- | Block or unblock some users for a given reason qualificationUserBlocking :: ( AuthId (HandlerSite m) ~ Key User , IsPersistBackend (YesodPersistBackend (HandlerSite m)) @@ -125,30 +227,44 @@ qualificationUserBlocking :: , MonadHandler m , MonadCatch m , Num n - ) => QualificationId -> [UserId] -> Bool -> Maybe QualificationBlocked -> ReaderT (YesodPersistBackend (HandlerSite m)) m n - -qualificationUserBlocking qid uids notify qb = do + ) => QualificationId -> [UserId] -> Bool -> Maybe UTCTime -> QualificationBlockReason -> Bool -> ReaderT (YesodPersistBackend (HandlerSite m)) m n +qualificationUserBlocking qid uids unblock mbBlockTime (qualificationBlockReasonText -> reason) notify = do + $logInfoS "BLOCK" $ Text.intercalate " - " [tshow qid, tshow uids, tshow unblock, tshow mbBlockTime, tshow reason, tshow notify] + authUsr <- liftHandler maybeAuthId now <- liftIO getCurrentTime - oks <- updateWhereCount -- prevents storage of transactionQualificatioUser - ( [ QualificationUserBlockedDue !=. Nothing | isNothing qb -- only unblock blocked qualification; allow overwrite for existing blocks - ] ++ - [ QualificationUserQualification ==. qid - , QualificationUserUser <-. uids - ] - ) - (guardMonoid (not notify) - [ QualificationUserLastNotified =. now - ] ++ - [ QualificationUserBlockedDue =. qb - ]) - forM_ uids $ \uid -> do - audit TransactionQualificationUserBlocking - { -- transactionQualificationUser = quid - transactionQualification = qid - , transactionUser = uid - , transactionQualificationBlock = qb - } - return $ fromIntegral oks + let blockTime = fromMaybe now mbBlockTime + -- -- Code would work, but problematic + -- oks <- E.insertSelectCount . E.from $ \qualificationUser -> do + -- E.where_ $ qualificationUser E.^. QualificationUserQualification E.==. E.val qid + -- E.&&. qualificationUser E.^. QualificationUserUser E.in_ E.valList uid + -- E.&&. quserBlock unblock blockTime qualificationUser -- only unblock blocked qualification and vice versa + -- return $ QualificationUserBlock + -- E.<# qualificationUser E.^. QualificationUserId + -- E.<&> E.val unblock + -- E.<&> E.val blockTime + -- E.<&> E.val reason + -- E.<&> E.val authUsr + toChange <- E.select $ do + qualUser <- E.from $ E.table @QualificationUser + E.where_ $ qualUser E.^. QualificationUserQualification E.==. E.val qid + E.&&. qualUser E.^. QualificationUserUser `E.in_` E.valList uids + E.&&. quserBlock unblock blockTime qualUser -- only unblock blocked qualification and vice versa + return (qualUser E.^. QualificationUserId, qualUser E.^. QualificationUserUser) + let newBlocks = map (\(E.Value quid, E.Value uid) -> (uid, QualificationUserBlock + { qualificationUserBlockQualificationUser = quid + , qualificationUserBlockUnblock = unblock + , qualificationUserBlockFrom = blockTime + , qualificationUserBlockReason = reason + , qualificationUserBlockBlocker = authUsr + })) toChange + E.insertMany_ (snd <$> newBlocks) + unless notify $ updateWhere [QualificationUserId <-. (qualificationUserBlockQualificationUser . snd <$> newBlocks)] [QualificationUserLastNotified =. now] + forM_ newBlocks $ \(uid, qub) -> audit TransactionQualificationUserBlocking + { transactionQualification = qid + , transactionUser = uid + , transactionQualificationBlock = qub + } + return $ fromIntegral $ length newBlocks qualificationUserUnblockByReason :: ( AuthId (HandlerSite m) ~ Key User @@ -163,20 +279,13 @@ qualificationUserUnblockByReason :: , MonadHandler m , MonadCatch m , Num n - ) => QualificationId -> [UserId] -> Text -> ReaderT (YesodPersistBackend (HandlerSite m)) m n -qualificationUserUnblockByReason qid uids reason = do - blockedUsers <- selectList [ QualificationUserQualification ==. qid - , QualificationUserBlockedDue !=. Nothing - , QualificationUserUser <-. uids - ] [Asc QualificationUserId] - let toUnblock = filter (\quent -> Just reason == quent ^? _entityVal . _qualificationUserBlockedDue . _Just . _qualificationBlockedReason) blockedUsers - oks <- updateWhereCount [ QualificationUserId <-. (view _entityKey <$> toUnblock) ] - [ QualificationUserBlockedDue =. Nothing ] - forM_ toUnblock $ \ubl -> do - audit TransactionQualificationUserBlocking - { -- transactionQualificationUser = quid - transactionQualification = qid - , transactionUser = ubl ^. _entityVal . _qualificationUserUser - , transactionQualificationBlock = Nothing - } - return $ fromIntegral oks \ No newline at end of file + ) => QualificationId -> [UserId] -> Maybe UTCTime -> QualificationBlockReason -> QualificationBlockReason -> Bool -> ReaderT (YesodPersistBackend (HandlerSite m)) m n +qualificationUserUnblockByReason qid uids mbUnblockTime (qualificationBlockReasonText -> reason) undo_reason notify = do + cutoff <- maybe (liftIO getCurrentTime) return mbUnblockTime + toUnblock <- E.select $ do + quser <- E.from $ E.table @QualificationUser + E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid + E.&&. quser E.^. QualificationUserUser `E.in_` E.valList uids + E.&&. quserBlockAux True (E.val cutoff) (E.==. (quser E.^. QualificationUserId)) (Just (\qblock -> (qblock E.^. QualificationUserBlockReason) E.==. E.val reason)) + return $ quser E.^. QualificationUserUser + qualificationUserBlocking qid (E.unValue <$> toUnblock) True mbUnblockTime undo_reason notify diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index e8e723bc8..1389b8305 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -14,7 +14,7 @@ import Handler.Utils.DateTime import Handler.Utils.Widgets import Handler.Utils.Occurrences import Handler.Utils.LMS (lmsUserStatusWidget) -import Handler.Utils.Qualification (isValidQualification) +import Handler.Utils.Qualification (isValidQualification) type CourseLink = (TermId, SchoolId, CourseShorthand) -- TODO: Refactor with WithHoles ! @@ -151,6 +151,12 @@ csvCell route = anchorCell route iconFileCSV modalCell :: (IsDBTable m a, ToWidget UniWorX w) => w -> DBCell m a modalCell content = cell $ modal (toWidget $ hasComment True) (Right $ toWidget content) +-- | Show Text if it is small, create modal otherwise +modalCellLarge :: (IsDBTable m a, ToWidget UniWorX t, MonoFoldable t, Element t ~ Char) => t -> DBCell m a +modalCellLarge content + | length content > 32 = modalCell content + | otherwise = textCell content + markupCellLargeModal :: IsDBTable m a => StoredMarkup -> DBCell m a markupCellLargeModal mup | markupIsSmallish mup = cell $ toWidget mup @@ -159,16 +165,16 @@ markupCellLargeModal mup ----------------- -- Datatype cells timeCell :: IsDBTable m a => UTCTime -> DBCell m a -timeCell t = cell $ formatTime SelFormatTime t >>= toWidget +timeCell t = cell $ formatTimeW SelFormatTime t dateTimeCell :: IsDBTable m a => UTCTime -> DBCell m a -dateTimeCell t = cell $ formatTime SelFormatDateTime t >>= toWidget +dateTimeCell t = cell $ formatTimeW SelFormatDateTime t dateCell :: IsDBTable m a => UTCTime -> DBCell m a -dateCell t = cell $ formatTime SelFormatDate t >>= toWidget +dateCell t = cell $ formatTimeW SelFormatDate t dayCell :: IsDBTable m a => Day -> DBCell m a -dayCell utctDay = cell $ formatTime SelFormatDate UTCTime{..} >>= toWidget +dayCell utctDay = cell $ formatTimeW SelFormatDate UTCTime{..} where utctDayTime = 0 -- | Show a date, and highlight date earlier than given watershed with an icon and cell class Warning @@ -320,14 +326,45 @@ qualificationDescrCell (view hasQualification -> q@Qualification{..}) = qualific Nothing -> mempty (Just descr) -> spacerCell <> markupCellLargeModal descr -qualificationValidUntilCell :: (IsDBTable m c, HasQualification a, HasQualificationUser a) => a -> DBCell m c -qualificationValidUntilCell q = textCell (qsh <> ": ") <> dayCell vtd - where - qsh = q ^. hasQualification . _qualificationShorthand . _CI - vtd = q ^. hasQualificationUser . _qualificationUserValidUntil +qualificationValidIconCell :: (IsDBTable m c, HasQualificationUser a, HasQualificationUserBlock b) => Day -> Maybe b -> a -> DBCell m c +qualificationValidIconCell d qb qu = do + blockIcon $ isValidQualification d qu qb + where + blockIcon = cell . toWidget . iconQualificationBlock -qualificationValidIconCell :: (IsDBTable m c, HasQualificationUser a) => Day -> a -> DBCell m c -qualificationValidIconCell = (iconBoolCell .) . isValidQualification +qualificationValidUntilCell :: (IsDBTable m c, HasQualificationUser a, HasQualificationUserBlock b) => Day -> Maybe b -> a -> DBCell m c +qualificationValidUntilCell = qualificationValidUntilCell' (Just LmsUserAllR) + +qualificationValidUntilCell' :: (IsDBTable m c, HasQualificationUser a, HasQualificationUserBlock b) => Maybe (CryptoUUIDUser -> Route UniWorX) -> Day -> Maybe b -> a -> DBCell m c +qualificationValidUntilCell' mbToLink d qb qu = cell $ case mbToLink of + Nothing -> headWgt <> dateWgt + Just toLink -> do + uuid <- liftHandler $ encrypt $ qu ^. hasQualificationUser . _qualificationUserUser + let modalWgt = modal dateWgt (Left $ SomeRoute $ toLink uuid) + headWgt <> modalWgt + where + dateWgt = formatTimeW SelFormatDate (qu ^. hasQualificationUser . _qualificationUserValidUntil) + iconWgt = toWidget $ iconQualificationBlock $ isValidQualification d qu qb + headWgt = iconWgt <> [whamlet| |] + +qualificationValidReasonCell :: (IsDBTable m c, HasQualificationUser a, HasQualificationUserBlock b) => Bool -> Day -> Maybe b -> a -> DBCell m c +qualificationValidReasonCell = qualificationValidReasonCell' (Just LmsUserAllR) + +qualificationValidReasonCell' :: (IsDBTable m c, HasQualificationUser a, HasQualificationUserBlock b) => Maybe (CryptoUUIDUser -> Route UniWorX) -> Bool -> Day -> Maybe b -> a -> DBCell m c +qualificationValidReasonCell' mbToLink showReason d qb qu = ic <> foldMap blc qb + where + ic = cell . toWidget . iconQualificationBlock $ isValidQualification d qu qb + blc (view hasQualificationUserBlock -> QualificationUserBlock{..}) + | showReason = spacerCell <> dc qualificationUserBlockFrom <> spacerCell <> modalCellLarge qualificationUserBlockReason + | qualificationUserBlockUnblock = mempty + | otherwise = spacerCell <> dateCell qualificationUserBlockFrom + dc tstamp + | Just toLink <- mbToLink = cell $ do + uuid <- liftHandler $ encrypt uid + modal (formatTimeW SelFormatDate tstamp) (Left $ SomeRoute $ toLink uuid) + -- anchorCellM (toLink <$> encrypt uid) + | otherwise = dateCell tstamp + uid = qu ^. hasQualificationUser . _qualificationUserUser lmsShortCell :: (IsDBTable m c, HasQualification a) => a -> DBCell m c lmsShortCell (view hasQualification -> Qualification{..}) = anchorCell link name @@ -376,18 +413,10 @@ lmsStatusCell extendedInfo (Just toLink) lu = cell $ do uuid <- liftHandler $ encrypt $ lu ^. _lmsUserUser modal (lmsUserStatusWidget extendedInfo lu) (Left $ SomeRoute $ toLink uuid) -qualificationBlockedCellNoReason :: IsDBTable m a => Maybe QualificationBlocked -> DBCell m a -qualificationBlockedCellNoReason Nothing = mempty -qualificationBlockedCellNoReason (Just QualificationBlocked{qualificationBlockedDay=d}) = - iconCell IconBlocked <> spacerCell <> dayCell d - -qualificationBlockedCell :: IsDBTable m a => Maybe QualificationBlocked -> DBCell m a -qualificationBlockedCell Nothing = mempty -qualificationBlockedCell (Just QualificationBlocked{..}) - | 32 >= length qualificationBlockedReason = mkCellWith textCell - | otherwise = mkCellWith modalCell - where - mkCellWith c = c qualificationBlockedReason <> spacerCell <> iconCell IconBlocked <> spacerCell <> dayCell qualificationBlockedDay +lmsStateCell :: IsDBTable m a => LmsState -> DBCell m a +lmsStateCell LmsFailed = iconBoolCell False +lmsStateCell LmsOpen = iconSpacerCell +lmsStateCell LmsPassed = iconBoolCell True avsPersonNoCell :: (IsDBTable m c, HasUserAvs a) => a -> DBCell m c avsPersonNoCell = numCell . view _userAvsNoPerson diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs index 07a122af2..280becf18 100644 --- a/src/Handler/Utils/Table/Columns.hs +++ b/src/Handler/Utils/Table/Columns.hs @@ -10,7 +10,7 @@ import Import hiding (link) import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E hiding ((->.)) -import Database.Esqueleto.Utils (mkExactFilter, mkExactFilterWith, mkContainsFilter, mkContainsFilterWith, anyFilter) +import Database.Esqueleto.Utils (mkExactFilter, mkExactFilterWith, mkContainsFilter, mkContainsFilterWith, mkContainsFilterWithComma, mkContainsFilterWithCommaPlus, anyFilter) --import Database.Esqueleto.Experimental ((:&)(..)) --import qualified Database.Esqueleto.Experimental as Ex @@ -399,9 +399,9 @@ fltrUserNameEmail :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool => (a -> E.SqlExpr (Entity User)) -> (d, FilterColumn t fs) fltrUserNameEmail queryUser = ( "user-name-email", FilterColumn $ anyFilter - [ mkContainsFilter $ queryUser >>> (E.^. UserDisplayName) - , mkContainsFilter $ queryUser >>> (E.^. UserSurname) - , mkContainsFilterWith CI.mk $ queryUser >>> (E.^. UserDisplayEmail) + [ mkContainsFilterWithCommaPlus id $ queryUser >>> (E.^. UserDisplayName) + , mkContainsFilterWithCommaPlus id $ queryUser >>> (E.^. UserSurname) + , mkContainsFilterWithCommaPlus CI.mk $ queryUser >>> (E.^. UserDisplayEmail) ] ) @@ -420,7 +420,7 @@ fltrUserNameEmailUI = fltrUserNameEmailHdrUI MsgTableCourseMembers fltrUserNameEmailHdrUI :: (RenderMessage UniWorX msg) => msg -> Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text]) fltrUserNameEmailHdrUI msg mPrev = - prismAForm (singletonFilter "user-name-email") mPrev $ aopt textField (fslI msg) + prismAForm (singletonFilter "user-name-email") mPrev $ aopt textField (fslI msg & setTooltip MsgTableFilterCommaPlus) ------------------- -- Matriculation -- @@ -436,7 +436,7 @@ sortUserMatriculation :: OpticSortColumn (Maybe UserMatriculation) sortUserMatriculation queryMatriculation = singletonMap "user-matriculation" . SortColumn $ view queryMatriculation fltrUserMatriculation :: OpticFilterColumn' t (Set Text) (E.SqlExpr (E.Value (Maybe UserMatriculation))) -fltrUserMatriculation queryMatriculation = singletonMap "user-matriculation" . FilterColumn . mkContainsFilterWith Just $ view queryMatriculation +fltrUserMatriculation queryMatriculation = singletonMap "user-matriculation" . FilterColumn . mkContainsFilterWithComma Just $ view queryMatriculation fltrUserMatriculationUI :: DBFilterUI fltrUserMatriculationUI mPrev = prismAForm (singletonFilter "user-matriculation") mPrev $ aopt textField (fslI MsgTableUserMatriculation) @@ -453,11 +453,11 @@ fltrUserMatriclenr :: ( IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bo ) => (a -> E.SqlExpr (Entity User)) -> (d, FilterColumn t fs) -fltrUserMatriclenr queryUser = ("user-matriclenumber", FilterColumn . mkContainsFilterWith Just $ queryUser >>> (E.^. UserMatrikelnummer)) +fltrUserMatriclenr queryUser = ("user-matriclenumber", FilterColumn . mkContainsFilterWithComma Just $ queryUser >>> (E.^. UserMatrikelnummer)) fltrUserMatriclenrUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text]) fltrUserMatriclenrUI mPrev = - prismAForm (singletonFilter "user-matriclenumber") mPrev $ aopt textField (fslI MsgTableMatrikelNr) + prismAForm (singletonFilter "user-matriclenumber") mPrev $ aopt textField (fslI MsgTableMatrikelNr & setTooltip MsgTableFilterComma) ---------------- diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 5b44a4b75..a2a5fc381 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -48,7 +48,7 @@ module Handler.Utils.Table.Pagination , linkEitherCell, linkEitherCellM, linkEitherCellM' , maybeAnchorCellM, maybeAnchorCellM', maybeLinkEitherCellM' , anchorCellC, anchorCellCM, anchorCellCM', linkEitherCellCM', maybeLinkEitherCellCM' - , cellTooltip, cellTooltipIcon, cellTooltipWgt + , cellTooltip, cellTooltips, cellTooltipIcon, cellTooltipWgt , listCell, listCell', listCellOf, listCellOf' , ilistCell, ilistCell', ilistCellOf, ilistCellOf' , formCell, DBFormResult(..), getDBFormResult @@ -1704,6 +1704,13 @@ i18nCell msg = cell $ do cellTooltip :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a -> DBCell m a cellTooltip = cellTooltipIcon Nothing +cellTooltips :: (RenderMessage UniWorX msg, IsDBTable m a) => [msg] -> DBCell m a -> DBCell m a +cellTooltips msgs = cellTooltipWgt Nothing [whamlet| + $forall msg <- msgs +

          + _{msg} +|] + cellTooltipIcon :: (RenderMessage UniWorX msg, IsDBTable m a) => Maybe Icon -> msg -> DBCell m a -> DBCell m a cellTooltipIcon icn = cellTooltipWgt icn . msg2widget diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index 087a543a7..fb19f07a7 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -815,30 +815,25 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do unless (Set.null qResolvable) $ deleteWhere [ LmsUserUser ==. oldUserId, LmsUserQualification <-. Set.toList qResolvable ] -- delete conflicting and finished LMS, which are still within auditDuration updateWhere [ LmsUserUser ==. oldUserId ] [ LmsUserUser =. newUserId ] updateWhere [ QualificationEditUser ==. oldUserId ] [ QualificationEditUser =. newUserId ] - E.insertSelectWithConflict - UniqueQualificationUser - (E.from $ \qualificationUser -> do - E.where_ $ qualificationUser E.^. QualificationUserUser E.==. E.val oldUserId - return $ QualificationUser - E.<# E.val newUserId - E.<&> (qualificationUser E.^. QualificationUserQualification) - E.<&> (qualificationUser E.^. QualificationUserValidUntil) - E.<&> (qualificationUser E.^. QualificationUserLastRefresh) - 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 - , QualificationUserLastRefresh E.=. combineWith current excluded E.greatest QualificationUserLastRefresh - , 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 ] + usrQualis <- E.select $ E.from $ \(oldQual `E.LeftOuterJoin` newQual) -> do + E.on ( newQual E.?. QualificationUserQualification E.?=. oldQual E.^. QualificationUserQualification + E.&&. newQual E.?. QualificationUserUser E.?=. E.val newUserId + ) + E.where_ $ oldQual E.^. QualificationUserUser E.==. E.val oldUserId + return (oldQual, newQual) + forM_ usrQualis $ \case + (Entity oldQKey _, Nothing) -> update oldQKey [ QualificationUserUser =. newUserId ] -- update must succeed if there is not RHS in the join + (Entity oldQKey oldQUsr, Just (Entity newQKey newQUsr)) -> do + updateWhere [ QualificationUserBlockQualificationUser ==. oldQKey ] [ QualificationUserBlockQualificationUser =. newQKey ] + update newQKey + [ QualificationUserValidUntil =. (max `on` view _qualificationUserValidUntil ) oldQUsr newQUsr + , QualificationUserLastRefresh =. (max `on` view _qualificationUserLastRefresh ) oldQUsr newQUsr + , QualificationUserFirstHeld =. (min `on` view _qualificationUserFirstHeld ) oldQUsr newQUsr + , QualificationUserScheduleRenewal =. (max `on` view _qualificationUserScheduleRenewal) oldQUsr newQUsr + , QualificationUserLastNotified =. (max `on` view _qualificationUserLastNotified ) oldQUsr newQUsr + ] + delete oldQKey + -- deleteWhere [ QualificationUserUser ==. oldUserId ] -- no longer needed -- Supervision is fully merged E.insertSelectWithConflict diff --git a/src/Handler/Utils/Widgets.hs b/src/Handler/Utils/Widgets.hs index 0d50aaa20..23a4b3a37 100644 --- a/src/Handler/Utils/Widgets.hs +++ b/src/Handler/Utils/Widgets.hs @@ -122,6 +122,12 @@ editedByW fmt tm usr = do ft <- handlerToWidget $ formatTime fmt tm [whamlet|_{MsgUtilEditedBy usr ft}|] + +---------- +-- HEAT -- +---------- + + boolHeat :: Bool -- ^ @isHot@ -> Milli boolHeat = bool 0 1 @@ -148,7 +154,6 @@ invCoHeat :: ( Real a, Real b) invCoHeat (realToFrac -> full) (realToFrac -> achieved) = fromRational $ cutOffPercent 0.3 (full^2) (achieved^2) - dualHeat :: ( Real a, Real b, Real c ) => a -> b -> c -> Milli -- ^ Distinguishes zero, zero is mapped to 0, @optimal@ is mapped to 1, @full@ is mapped to 2 @@ -180,6 +185,34 @@ invDualCoHeat :: ( Real a, Real b, Real c ) invDualCoHeat optimal full achieved = 2 - dualCoHeat optimal full achieved +----------- +-- COLOR -- +----------- + +-- TODO: someone with frontend capabilities should get rid of class tooltip__handle and check theme consistent colors + +statusHtml :: MessageStatus -> Html -> Html +statusHtml sts wgt = + [shamlet| + + ^{wgt} + |] + +statusWidget :: MessageStatus -> Widget -> Widget +statusWidget sts wgt = + [whamlet| + + ^{wgt} + |] + +heatedWidget :: Milli -> Widget -> Widget +heatedWidget ht wgt = + [whamlet| + + ^{wgt} + |] + + examOccurrenceMappingDescriptionWidget :: ExamOccurrenceRule -> Set ExamOccurrenceMappingDescription -> Widget examOccurrenceMappingDescriptionWidget rule descriptions = $(widgetFile "widgets/exam-occurrence-mapping-description") where diff --git a/src/Jobs.hs b/src/Jobs.hs index 0d5993ce7..f48922abb 100644 --- a/src/Jobs.hs +++ b/src/Jobs.hs @@ -81,6 +81,7 @@ import Jobs.Handler.PersonalisedSheetFiles import Jobs.Handler.PruneOldSentMails import Jobs.Handler.StudyFeatures import Jobs.Handler.LMS +import Jobs.Handler.Print import Jobs.HealthReport diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 04eb37018..c29f09ef2 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Steffen Jost ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-23 Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -9,6 +9,7 @@ module Jobs.Handler.LMS , dispatchJobLmsQualificationsDequeue , dispatchJobLmsEnqueue, dispatchJobLmsEnqueueUser , dispatchJobLmsDequeue + , dispatchJobLmsReports , dispatchJobLmsResults , dispatchJobLmsUserlist ) where @@ -17,6 +18,7 @@ import Import import Jobs.Queue -- import Jobs.Handler.Intervals.Utils +import Database.Persist.Sql -- (deleteWhereCount, updateWhereCount) import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Experimental as E --import qualified Database.Esqueleto.Legacy as E @@ -24,6 +26,7 @@ import qualified Database.Esqueleto.Experimental as E import qualified Database.Esqueleto.Utils as E import qualified Data.Set as Set +-- import qualified Data.Map as Map import qualified Data.Time.Zones as TZ import Handler.Utils.DateTime @@ -62,22 +65,21 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act $logInfoS "LMS" $ "Notifying about exipiring qualification " <> qshort now <- liftIO getCurrentTime case qualificationRefreshWithin quali of - Nothing -> return () -- TODO: no renewal period, no reminders currenty + Nothing -> return () -- TODO: no renewal period, no reminders currently (Just renewalPeriod) -> do - let now_day = utctDay now - renewalDate = addGregorianDurationClip renewalPeriod now_day - sendReminders remindPeriod = do - let remindDate = addGregorianDurationClip remindPeriod now_day - reminders <- E.select $ do -- TODO: refactor to remove some redundancies with later query + let nowaday = utctDay now + renewalDate = addGregorianDurationClip renewalPeriod nowaday + sendReminders remindPeriod = do + let remindDate = addGregorianDurationClip remindPeriod nowaday + reminders <- E.select $ do -- TODO: refactor to remove some redundancies with later query (luser :& quser) <- E.from $ E.table @LmsUser `E.innerJoin` E.table @QualificationUser `E.on` (\(luser :& quser) -> luser E.^. LmsUserQualification E.==. quser E.^. QualificationUserQualification E.&&. luser E.^. LmsUserUser E.==. quser E.^. QualificationUserUser ) E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid E.&&. quser E.^. QualificationUserScheduleRenewal - E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val now_day E.&&. quser E.^. QualificationUserValidUntil E.<=. E.val remindDate - E.&&. E.isNothing (quser E.^. QualificationUserBlockedDue) + E.&&. validQualification now quser E.&&. E.isNothing (luser E.^. LmsUserEnded) E.&&. E.isNothing (luser E.^. LmsUserStatus) E.&&. E.isJust (luser E.^. LmsUserNotified) @@ -98,9 +100,8 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act quser <- E.from $ E.table @QualificationUser E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid E.&&. quser E.^. QualificationUserScheduleRenewal - E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val now_day E.&&. quser E.^. QualificationUserValidUntil E.<=. E.val renewalDate - E.&&. E.isNothing (quser E.^. QualificationUserBlockedDue) + E.&&. (quser `qualificationValid` now) E.&&. E.notExists (do luser <- E.from $ E.table @LmsUser E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid @@ -126,11 +127,14 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act act = do identsInUseVs <- E.select $ do lui <- E.from $ - ( (E.^. LmsUserlistIdent) <$> E.from (E.table @LmsUserlist) ) -- no filter by Qid, since LmsIdents must be unique across all + + ( (E.^. LmsUserIdent) <$> E.from (E.table @LmsUser ) ) -- no filter by Qid, since LmsIdents must be unique across all `E.union_` - ( (E.^. LmsResultIdent) <$> E.from (E.table @LmsResult ) ) + ( (E.^. LmsReportIdent) <$> E.from (E.table @LmsReport ) ) -- V2 `E.union_` - ( (E.^. LmsUserIdent) <$> E.from (E.table @LmsUser ) ) + ( (E.^. LmsResultIdent) <$> E.from (E.table @LmsResult ) ) -- V1 DEPRECATED + `E.union_` + ( (E.^. LmsUserlistIdent) <$> E.from (E.table @LmsUserlist) ) -- V1 DEPRECATED E.orderBy [E.asc lui] pure lui now <- liftIO getCurrentTime @@ -143,21 +147,33 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act , lmsUserResetPin = False , lmsUserDatePin = now , lmsUserStatus = Nothing + , lmsUserStatusDay = Nothing , lmsUserStarted = now , lmsUserReceived = Nothing , lmsUserNotified = Nothing , lmsUserEnded = Nothing + , lmsUserResetTries = False + , lmsUserLocked = True -- initially display locked, since it is not yet available until the first feedback } -- startLmsUser :: YesodJobDB UniWorX (Maybe (Entity LmsUser)) startLmsUser = do - pw <- randomLMSpw - maybeM (pure Nothing) (E.insertUniqueEntity . mkLmsUser pw) (randomLMSIdentBut identsInUse) + lpw <- randomLMSpw + maybeM (pure Nothing) (E.insertUniqueEntity . mkLmsUser lpw) (randomLMSIdentBut identsInUse) + -- runMaybeT $ do + -- lid <- MaybeT $ randomLMSIdentBut identsInUse + -- MaybeT $ E.insertUniqueEntity $ mkLmsUser lpw lid inserted <- untilJustMaxM maxLmsUserIdentRetries startLmsUser case inserted of Nothing -> do uuid :: CryptoUUIDUser <- encrypt uid $logErrorS "LMS" $ "Generating and inserting fresh LmsIdent failed for uuid " <> tshow uuid <> " and qid " <> tshow qid <> "!" - (Just _) -> return () -- lmsUser started, but not yet notified + (Just Entity{entityKey=lkey, entityVal=LmsUser{lmsUserIdent=lid, lmsUserUser=luid, lmsUserQualification=lqid}}) -> -- lmsUser started, but not yet notified + audit $ TransactionLmsStart + { transactionQualification = lqid + , transactionLmsIdent = lid + , transactionLmsUser = luid + , transactionLmsUserKey = lkey + } -- purge LmsIdent after QualificationAuditDuration expired @@ -168,10 +184,9 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act 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 - let nowaday = utctDay now + now <- liftIO getCurrentTime -- end users that expired by doing nothing - expiredLearners <- E.select $ do + expiredLearners <- E.select $ do (quser :& luser) <- E.from $ E.table @QualificationUser `E.innerJoin` E.table @LmsUser @@ -182,27 +197,22 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act E.&&. luser E.^. LmsUserQualification E.==. E.val qid E.&&. E.isNothing (luser E.^. LmsUserStatus) E.&&. E.isNothing (luser E.^. LmsUserEnded) - E.&&. E.not_ (validQualification nowaday quser) - pure (luser E.^. LmsUserId) + E.&&. E.not_ (validQualification now quser) + pure (luser E.^. LmsUserId) nrExpired <- E.updateCount $ \luser -> do - E.set luser [LmsUserStatus E.=. E.justVal (LmsExpired nowaday)] + E.set luser [LmsUserStatus E.=. E.justVal LmsExpired, LmsUserStatusDay E.=. E.justVal now] E.where_ $ (luser E.^. LmsUserId) `E.in_` E.valList (E.unValue <$> expiredLearners) E.&&. luser E.^. LmsUserQualification E.==. E.val qid $logInfoS "LMS" $ "Expired lms users " <> tshow nrExpired <> " for qualification " <> qshort when (quali ^. _qualificationExpiryNotification) $ do - notifyInvalidDrivers <- E.select $ do - quser <- E.from $ E.table @QualificationUser - E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid - E.&&. 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.<. E.day' ((quser E.^. QualificationUserBlockedDue) E.->>. "day")) - )) - pure (quser E.^. QualificationUserUser) - + notifyInvalidDrivers <- E.select $ do + quser <- E.from $ E.table @QualificationUser + E.where_ $ E.not_ (quser `qualificationValid` now) -- currently invalid + E.&&. quser E.^. QualificationUserQualification E.==. E.val qid -- correct qualification + E.&&. quser `quserToNotify` now -- recently became invalid or blocked + pure (quser E.^. QualificationUserUser) + forM_ notifyInvalidDrivers $ \(E.Value uid) -> queueDBJob JobUserNotification { jRecipient = uid @@ -218,7 +228,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act delusersVals <- E.select $ do luser <- E.from $ E.table @LmsUser E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid - E.&&. luser E.^. LmsUserEnded E.<. E.just (E.val auditCutoff) + E.&&. luser E.^. LmsUserEnded E.<. E.justVal auditCutoff E.&&. E.isJust (luser E.^. LmsUserEnded) -- E.&&. E.notExists (do -- laudit <- E.from $ E.table @LmsAudit @@ -228,7 +238,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act -- ) pure (luser E.^. LmsUserIdent) let delusers = E.unValue <$> delusersVals - numdel = length delusers + 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] @@ -236,7 +246,129 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act deleteWhere [LmsResultQualification ==. qid, LmsResultIdent <-. delusers] -- deleteWhere [LmsAuditQualification ==. qid, LmsAuditIdent <-. delusers] --- processes received results and lengthen qualifications, if applicable + +dispatchJobLmsReports :: QualificationId -> JobHandler UniWorX +dispatchJobLmsReports qid = JobHandlerAtomic act + where + -- act :: YesodJobDB UniWorX () + act = whenM (exists [LmsReportQualification ==. qid]) $ do -- executing twice must be prohibited due to assertion that ALL learners are always sent (D fails otherwise) + now <- liftIO getCurrentTime + -- DEBUG 2rows; remove later + totalrows <- count [LmsReportQualification ==. qid] + $logInfoS "LMS" $ "Report processing " <> tshow totalrows <> " rows for qualification " <> tshow qid + let -- locDay = localDay $ TZ.utcToLocalTimeTZ appTZ now -- no longer necessary, since LMS reports dates only + -- DB query for LmsUserUser, provided a matching LmsReport exists + luserQry luFltr repFltr = E.select $ do + luser <- E.from $ E.table @LmsUser + E.where_ $ E.val qid E.==. luser E.^. LmsUserQualification + E.&&. E.isNothing (luser E.^. LmsUserEnded) -- ignore all closed learners + E.&&. luFltr luser + E.&&. E.exists (do + lreport <- E.from $ E.table @LmsReport + E.where_ $ lreport E.^. LmsReportIdent E.==. luser E.^. LmsUserIdent + E.&&. lreport E.^. LmsReportQualification E.==. E.val qid + E.&&. repFltr luser lreport + ) + return $ luser E.^. LmsUserUser + -- DB query for LmsUser innerJoin LmsReport + lrepQry lrFltr = E.select $ do + (luser :& lreport) <- E.from $ E.table @LmsUser`E.innerJoin` E.table @LmsReport + `E.on` (\(luser :& lreport) -> luser E.^. LmsUserIdent E.==. lreport E.^. LmsReportIdent + E.&&. luser E.^. LmsUserQualification E.==. lreport E.^. LmsReportQualification) + E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid + E.&&. lreport E.^. LmsReportQualification E.==. E.val qid + E.&&. E.isNothing (luser E.^. LmsUserEnded) -- ignore all closed learners + E.&&. lrFltr luser lreport + return (luser, lreport) + -- A) reset status for learners that had their tries just resetted as indicated by LmsOpen + E.update $ \luser -> do + E.set luser [ LmsUserStatus E.=. E.nothing + , LmsUserResetTries E.=. E.false ] + E.where_ $ E.val qid E.==. luser E.^. LmsUserQualification + E.&&. E.isNothing (luser E.^. LmsUserEnded ) -- must still exist at server + E.&&. E.isJust (luser E.^. LmsUserReceived) -- seen before, for otherwise it might not have been started yet + E.&&. luser E.^. LmsUserResetTries + E.&&. E.exists (do + lreport <- E.from $ E.table @LmsReport + E.where_ $ lreport E.^. LmsReportIdent E.==. luser E.^. LmsUserIdent + E.&&. lreport E.^. LmsReportQualification E.==. E.val qid + E.&&. lreport E.^. LmsReportResult E.==. E.val LmsOpen + E.&&. lreport E.^. LmsReportLock E.==. E.true + ) + -- B) notify all newly reported users that lms is available + let luserFltrNew luser = E.isNothing $ luser E.^. LmsUserReceived -- not seen before, just starting + notifyNewLearner (E.Value uid) = queueDBJob JobUserNotification { jRecipient = uid, jNotification = NotificationQualificationRenewal { nQualification = qid, nReminder = False } } + in luserQry luserFltrNew (const $ const E.true) >>= mapM_ notifyNewLearner + -- C) block qualifications for failed learners by calling qualificationUserBlocking [uids] (includes audit) + let lrFltrBlock luser lreport = E.isNothing (luser E.^. LmsUserStatus) E.&&. lreport E.^. LmsReportResult E.==. E.val LmsFailed + procBlock (Entity luid luser, Entity _ lreport) = do + let repDay = lmsReportDate lreport <|> Just now + ok_block <- qualificationUserBlocking qid [lmsUserUser luser] False (lmsReportDate lreport) (Right QualificationBlockFailedELearning) True -- only valid qualifications are blocked; transcribes to audit log + update luid [LmsUserStatus =. Just LmsBlocked, LmsUserStatusDay =. repDay] + return $ Sum ok_block + in lrepQry lrFltrBlock + >>= foldMapM procBlock + >>= \s -> $logInfoS "LMS" $ "Report processing: " <> tshow (getSum s) <> " status set to blocked for qualification " <> tshow qid -- debug, remove later + -- D) renew qualifications for all successfull learners + let lrFltrSuccess luser lreport = (E.isNothing (luser E.^. LmsUserStatus) E.||. luser E.^. LmsUserStatus E.!=. E.justVal LmsSuccess) E.&&. lreport E.^. LmsReportResult E.==. E.val LmsPassed -- LMS WORKAROUND 1: LmsPassed replaces any other status + procRenew (Entity luid luser, Entity _ lreport) = do + let repDay = lmsReportDate lreport <|> Just now + -- LMS WORKAROUND 2: [supposedly fixed now] sometimes we receive success and failure simultaneously; success is correct, hence we must unblock if the reason was e-learning + -- let reason_undo = Left $ "LMS Workaround undoing: " <> qualificationBlockedReasonText QualificationBlockFailedELearning + -- ok_unblock <- qualificationUserUnblockByReason qid [lmsUserUser luser] repTime (Right QualificationBlockFailedELearning) reason_undo False -- affects audit log + -- when (ok_unblock > 0) ($logWarnS "LMS" [st|LMS Result: workaround triggered, unblocking #{tshow ok_unblock} e-learners for #{tshow qid} having success reported after initially failed e-learning|]) + -- END LMS WORKAROUND 2 + ok_renew <- renewValidQualificationUsers qid repDay [lmsUserUser luser]-- only valid qualifications are truly renewed; transcribes to audit log + update luid [LmsUserStatus =. Just LmsSuccess, LmsUserStatusDay =. repDay] + return $ Sum ok_renew + in lrepQry lrFltrSuccess + >>= foldMapM procRenew + >>= \s -> $logInfoS "LMS" $ "Report processing: " <> tshow (getSum s) <> " renewed and status set to success for qualification " <> tshow qid -- debug, remove later + -- E) mark all previuosly reported, but now unreported users as ended (LMS deleted them as expected) + E.update $ \luser -> do + E.set luser [ LmsUserEnded E.=. E.justVal now ] + E.where_ $ E.val qid E.==. luser E.^. LmsUserQualification + E.&&. E.isNothing (luser E.^. LmsUserEnded ) + E.&&. E.isJust (luser E.^. LmsUserReceived) -- seen before, for otherwise it might not have been started yet + E.&&. E.notExists (do + lreport <- E.from $ E.table @LmsReport + E.where_ $ lreport E.^. LmsReportIdent E.==. luser E.^. LmsUserIdent + E.&&. lreport E.^. LmsReportQualification E.==. E.val qid + ) + + -- F) lock expired learners: happens during JobLmsDequeue only + -- G) update lock and received + let updateReceivedLocked lockstatus = E.updateCount $ \luser -> do -- due to the absence of UPDATE..FROM in esqueleto, we call update twice + E.set luser [ LmsUserReceived E.=. E.justVal now + , LmsUserLocked E.=. E.val lockstatus ] + E.where_ $ E.val qid E.==. luser E.^. LmsUserQualification + E.&&. E.isNothing (luser E.^. LmsUserEnded) + E.&&. E.exists (do + lreport <- E.from $ E.table @LmsReport + E.where_ $ lreport E.^. LmsReportIdent E.==. luser E.^. LmsUserIdent + E.&&. lreport E.^. LmsReportQualification E.==. E.val qid + E.&&. lreport E.^. LmsReportLock E.==. E.val lockstatus -- Maybe more efficient, but less readable: bool E.not_ id lockstatus (lreport E.^. LmsReport Lock) + ) + -- NOTE: this code leads to a runtime errror; apparently from-clauses are not allowed in updates yet + -- let updateReceivedLocked lockstatus = E.update $ \luser -> do -- attempt to use 'from'-clause in update as per PostgreSQL + -- E.set luser [ LmsUserReceived E.=. E.justVal now + -- , LmsUserLocked E.=. E.val lockstatus ] + -- lreport <- E.from $ E.table @LmsReport + -- E.where_ $ E.isNothing (luser E.^. LmsUserEnded) + -- E.&&. luser E.^. LmsUserQualification E.==. E.val qid + -- E.&&. lreport E.^. LmsReportQualification E.==. E.val qid + -- E.&&. lreport E.^. LmsReportIdent E.==. luser E.^. LmsUserIdent + -- E.&&. lreport E.^. LmsReportLock E.==. E.val lockstatus -- Maybe more efficient, but less readable: bool E.not_ id lockstatus (lreport E.^. LmsReport Lock) + updateReceivedLocked False + >>= \nr -> $logInfoS "LMS" $ "Report processing marked " <> tshow nr <> " rows as unlocked and received for qualification " <> tshow qid -- debug, remove later + updateReceivedLocked True + >>= \nr -> $logInfoS "LMS" $ "Report processing marked " <> tshow nr <> " rows as locked and received for qualification " <> tshow qid -- debug, remove later + -- G) Truncate LmsReport for qid and log + repProc <- deleteWhereCount [LmsReportQualification ==. qid] + $logInfoS "LMS" [st|Processed #{tshow repProc} e-learning status reports for qualification #{tshow qid}.|] + + +-- DEPRECATED processes received results and lengthen qualifications, if applicable dispatchJobLmsResults :: QualificationId -> JobHandler UniWorX dispatchJobLmsResults qid = JobHandlerAtomic act where @@ -260,38 +392,38 @@ dispatchJobLmsResults qid = JobHandlerAtomic act return (quser, luser, lresult) now <- liftIO getCurrentTime let locDay = localDay $ TZ.utcToLocalTimeTZ appTZ now - forM_ results $ \(Entity quid QualificationUser{..}, Entity luid LmsUser{..}, Entity lrid LmsResult{..}) -> do + 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 lmsUserStartedDay = localDay $ TZ.utcToLocalTimeTZ appTZ lmsUserStarted saneDate = lmsResultSuccess `inBetween` (lmsUserStartedDay, min qualificationUserValidUntil locDay) -- && qualificationUserLastRefresh <= utctDay lmsUserStarted NOTE: not always true due to manual intervention; also renewValidQualificationUsers prevents double renewals anyway - newStatus = Just $ LmsSuccess lmsResultSuccess -- newValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) qualificationUserValidUntil -- renew from old validUntil onwards - note <- if saneDate && replaceLmsStatus lmsUserStatus newStatus + note <- if saneDate && (lmsUserStatus /= Just LmsSuccess) then do -- WORKAROUND LMS-Bug [supposedly fixed now, but isnt]: sometimes we receive success and failure simultaneously; success is correct, hence we must unblock if the reason was e-learning - -- _ok <- qualificationUserUnblockByReason qid [qualificationUserUser] (qualificationBlockedReasonText QualificationBlockFailedELearning) -- affects audit log - when (Just (qualificationBlockedReasonText QualificationBlockFailedELearning) == qualificationUserBlockedDue ^? _Just . _qualificationBlockedReason) $ - update quid [ QualificationUserBlockedDue =. Nothing ] + let reason_undo = Left $ "LMS Workaround undoing: " <> qualificationBlockedReasonText QualificationBlockFailedELearning + ok_unblock <- qualificationUserUnblockByReason qid [qualificationUserUser] Nothing (Right QualificationBlockFailedELearning) reason_undo False -- affects audit log + when (ok_unblock > 0) ($logWarnS "LMS" [st|LMS Result: workaround triggered, unblocking #{tshow ok_unblock} e-learners for #{tshow qid}|]) - _ok <- renewValidQualificationUsers qid [qualificationUserUser] -- ignores possible blocks + _ok_renew <- renewValidQualificationUsers qid Nothing [qualificationUserUser] -- only unblocked are renewed -- when (ok==1) $ update luid -- we end lms regardless of whether or not a regular renewal was successful, since BPol users may simultaneoysly have on-premise renewal courses and E-Learnings - update luid - [ LmsUserStatus =. newStatus - , LmsUserReceived =. Just lmsResultTimestamp - ] + update luid + [ LmsUserStatus =. Just LmsSuccess + , LmsUserStatusDay =. Just (utctDayMidnight lmsResultSuccess) + , LmsUserReceived =. Just lmsResultTimestamp + ] return Nothing else do - let errmsg = [st|LMS Result: success with insane date #{tshow lmsResultSuccess} received for #{tshow lmsUserIdent}|] + let errmsg = [st|LMS Result: success with insane date #{tshow lmsResultSuccess} received for #{tshow lmsUserIdent} for #{tshow qid}|] $logErrorS "LMS" errmsg return $ Just errmsg audit TransactionLmsSuccess -- always log success, since this is only transmitted once { transactionQualification = qid , transactionLmsIdent = lmsUserIdent - , transactionLmsDay = lmsResultSuccess - , transactionLmsUser = Just lmsUserUser + , transactionLmsDay = utctDayMidnight lmsResultSuccess + , transactionLmsUser = lmsUserUser , transactionNote = note , transactionReceived = lmsResultTimestamp } @@ -299,13 +431,13 @@ dispatchJobLmsResults qid = JobHandlerAtomic act $logInfoS "LMS" [st|Processed #{tshow (length results)} LMS results|] --- processes received input and block qualifications, if applicable +-- DEPRECATED processes received input and block qualifications, if applicable dispatchJobLmsUserlist :: QualificationId -> JobHandler UniWorX dispatchJobLmsUserlist qid = JobHandlerAtomic act where act :: YesodJobDB UniWorX () act = whenM (exists [LmsUserlistQualification ==. qid]) $ do -- safeguard against multiple calls, which would close all learners due to first case below - now <- liftIO getCurrentTime + now <- liftIO getCurrentTime -- result :: [(Entity LmsUser, Entity LmsUserlist)] results <- E.select $ do (luser :& lulist) <- E.from $ @@ -322,37 +454,32 @@ dispatchJobLmsUserlist qid = JobHandlerAtomic act update luid [LmsUserEnded =. Just now] | otherwise -> return () -- users likely not yet started - (Entity luid luser, Just (Entity lulid lulist)) -> do - let lReceived = lmsUserlistTimestamp lulist - lmsMsgDay = utctDay lReceived - update luid [LmsUserReceived =. Just lReceived] -- LmsUserNotified is only updated upon sending notifications + (Entity luid luser, Just (Entity _lulid lulist)) -> do + let lReceived = lmsUserlistTimestamp lulist + update luid [LmsUserReceived =. Just lReceived] -- LmsUserNotified is only updated upon sending notifications when (isNothing $ lmsUserNotified luser) $ do -- notify users that lms is available queueDBJob JobUserNotification { jRecipient = lmsUserUser luser , jNotification = NotificationQualificationRenewal { nQualification = qid, nReminder = False } } - + let isBlocked = lmsUserlistFailed lulist oldStatus = lmsUserStatus luser - newStatus = bool Nothing (Just $ LmsBlocked lmsMsgDay) isBlocked - updateStatus = replaceLmsStatus oldStatus newStatus + updateStatus = isBlocked && oldStatus /= Just LmsSuccess when updateStatus $ do + update luid [LmsUserStatus =. Just LmsBlocked, LmsUserStatusDay =. Just lReceived] + ok <- qualificationUserBlocking qid [lmsUserUser luser] False Nothing (Right QualificationBlockFailedELearning) True + when (ok /= 1) $ do + uuid :: CryptoUUIDUser <- encrypt $ lmsUserUser luser + $logWarnS "LmsUserlist" [st|Blocking by failed E-learning failed for learner #{tshow uuid} and qualification #{tshow qid}] audit TransactionLmsBlocked { transactionQualification = qid , transactionLmsIdent = lmsUserIdent luser - , transactionLmsDay = lmsMsgDay - , transactionLmsUser = Just $ lmsUserUser luser + , transactionLmsDay = lReceived + , transactionLmsUser = lmsUserUser luser , transactionNote = Just $ "Old status was " <> tshow oldStatus , transactionReceived = lReceived } - update luid [LmsUserStatus =. newStatus] - void $ qualificationUserBlocking qid [lmsUserUser luser] True $ Just $ mkQualificationBlocked QualificationBlockFailedELearning lmsMsgDay - -- DEACTIVATED FOR NOW; UPON REACTIVATION: DELAY Sending to check for unblocking a few hours later! - -- queueDBJob JobUserNotification - -- { jRecipient = lmsUserUser luser - -- , jNotification = NotificationQualificationExpired { nQualification = qid } - -- } - delete lulid $logInfoS "LMS" [st|Processed LMS Userlist with #{tshow (length results)} entries|] diff --git a/src/Jobs/Handler/Print.hs b/src/Jobs/Handler/Print.hs new file mode 100644 index 000000000..cb16a2907 --- /dev/null +++ b/src/Jobs/Handler/Print.hs @@ -0,0 +1,60 @@ +-- SPDX-FileCopyrightText: 2023 Steffen Jost +-- +-- SPDX-License-Identifier: AGPL-3.0-or-later + +{-# LANGUAGE TypeApplications #-} + +module Jobs.Handler.Print + ( dispatchJobPrintAck + , dispatchJobPrintAckAgain + ) where + +import Import +import Jobs.Queue + +-- import Jobs.Handler.Intervals.Utils +import qualified Data.Text as Text +-- import UnliftIO.Concurrent (threadDelay) + +-- import Database.Persist.Sql (deleteWhereCount) +-- import Database.Esqueleto.Experimental ((:&)(..)) +-- import qualified Database.Esqueleto.Experimental as E +-- import qualified Database.Esqueleto.Legacy as E +-- import qualified Database.Esqueleto.PostgreSQL as E -- for insertSelect variant +-- import qualified Database.Esqueleto.Utils as E + + +jobPrintAckChunkSize :: Int +jobPrintAckChunkSize = 64 + +-- needed, since JobPrintAck cannot requeue itself due to JobNoQueueSame (and having no parameters) +dispatchJobPrintAckAgain :: JobHandler UniWorX +dispatchJobPrintAckAgain = JobHandlerException act + where + act = void $ queueJob JobPrintAck + -- liftIO $ threadDelay 3e6 -- wait 3s before continuing UPDATE: no wait needed + + +dispatchJobPrintAck :: JobHandler UniWorX +dispatchJobPrintAck = JobHandlerException act + where + act = do + moretodo <- runDB $ do + aliases <- selectList [] [Desc PrintAckIdAliasPriority] + let ftransAliases = id : fmap (\Entity{entityVal=PrintAckIdAlias{printAckIdAliasNeedle=n, printAckIdAliasReplacement=r}} -> Text.replace n r) aliases + ackOneId ackt apci = selectKeysList [PrintJobApcIdent ==. apci, PrintJobAcknowledged ==. Nothing] [Asc PrintJobCreated, LimitTo 1] >>= \case + [pjid] -> update pjid [PrintJobAcknowledged =. Just ackt] >> + return True + _ -> return False + procOneId oks Entity{entityKey=paid, entityVal=PrintAcknowledge{printAcknowledgeApcIdent=Text.strip -> apci, printAcknowledgeTimestamp=ackt}} = + andM [ackOneId ackt $ ftrans apci | ftrans <- ftransAliases] >>= \case + True -> delete paid >> return (succ oks) + False -> update paid [PrintAcknowledgeProcessed =. True] >> return oks + apcis <- selectList [PrintAcknowledgeProcessed ==. False] [Asc PrintAcknowledgeTimestamp, LimitTo jobPrintAckChunkSize] + oks <- foldM procOneId 0 apcis + let nr_apcis = length apcis + if nr_apcis == oks + then $logInfoS "APC" $ "Success: " <> tshow oks <> " print jobs were acknowledged as printed." + else $logErrorS "APC" $ "Error: Only " <> tshow oks <> " out of " <> tshow nr_apcis <> " print jobs could be acknowledged as printed." + return $ nr_apcis >= jobPrintAckChunkSize + when moretodo $ void $ queueJob JobPrintAckAgain diff --git a/src/Jobs/Handler/SendNotification/Qualification.hs b/src/Jobs/Handler/SendNotification/Qualification.hs index 2cbc59d2a..d5338acf6 100644 --- a/src/Jobs/Handler/SendNotification/Qualification.hs +++ b/src/Jobs/Handler/SendNotification/Qualification.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Steffen Jost +-- SPDX-FileCopyrightText: 2022-23 Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -43,18 +43,21 @@ dispatchNotificationQualificationExpiry nQualification dExpiry jRecipient = user dispatchNotificationQualificationExpired :: QualificationId -> UserId -> Handler () -dispatchNotificationQualificationExpired nQualification jRecipient = do +dispatchNotificationQualificationExpired nQualification jRecipient = do encRecipient :: CryptoUUIDUser <- encrypt jRecipient encRecShort <- encrypt jRecipient dbRes <- runDB $ (,,) <$> get jRecipient <*> get nQualification - <*> getBy (UniqueQualificationUser nQualification jRecipient) + <*> getBy (UniqueQualificationUser nQualification jRecipient) case dbRes of ( Just User{..}, Just Qualification{..}, Just (Entity quId QualificationUser{..})) -> do + now <- liftIO getCurrentTime + qub_entry <- entityVal <<$>> runDB (selectRelevantBlock now quId) + let block = filterMaybe (not . qualificationUserBlockUnblock) qub_entry urender <- getUrlRender - let expDay = maybe qualificationUserValidUntil (min qualificationUserValidUntil . qualificationBlockedDay) qualificationUserBlockedDue + let expDay = maybe qualificationUserValidUntil (min qualificationUserValidUntil . utctDay . qualificationUserBlockFrom) block qname = CI.original qualificationName qshort = CI.original qualificationShorthand letter = LetterExpireQualification @@ -73,8 +76,7 @@ dispatchNotificationQualificationExpired nQualification jRecipient = do then do notifyOk <- sendEmailOrLetter jRecipient letter if notifyOk - then do - now <- liftIO getCurrentTime + then do runDB $ update quId [QualificationUserLastNotified =. now] $logInfoS "LMS" $ "Notified " <> tshow encRecipient <> " about expired qualification " <> qname else diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index 60eee0b4c..a0717099a 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -128,8 +128,12 @@ data Job | JobLmsEnqueueUser { jQualification :: QualificationId, jUser :: UserId } | JobLmsQualificationsDequeue | JobLmsDequeue { jQualification :: QualificationId } - | JobLmsUserlist { jQualification :: QualificationId } - | JobLmsResults { jQualification :: QualificationId } + | JobLmsUserlist { jQualification :: QualificationId } -- Deprecated, remove together with routes + | JobLmsResults { jQualification :: QualificationId } -- Deprecated, remove together with routes + | JobLmsReports { jQualification :: QualificationId } + | JobPrintAck + | JobPrintAckAgain + deriving (Eq, Ord, Show, Read, Generic) data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId } @@ -359,7 +363,10 @@ jobNoQueueSame = \case JobLmsQualificationsDequeue -> Just JobNoQueueSame JobLmsDequeue {} -> Just JobNoQueueSame JobLmsUserlist {} -> Just JobNoQueueSame - JobLmsResults {} -> Just JobNoQueueSame + JobLmsResults {} -> Just JobNoQueueSame + JobLmsReports {} -> Just JobNoQueueSame + JobPrintAck {} -> Just JobNoQueueSame + JobPrintAckAgain {} -> Just JobNoQueueSame _ -> Nothing notifyNoQueueSame :: Notification -> Maybe JobNoQueueSame diff --git a/src/Model.hs b/src/Model.hs index 67b1ace01..cebdd4056 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -243,3 +243,9 @@ instance IsFileReference MaterialFile where fileReferenceTitleField = MaterialFileTitle fileReferenceContentField = MaterialFileContent fileReferenceModifiedField = MaterialFileModified + +deriveJSON defaultOptions + { tagSingleConstructors = False + , fieldLabelModifier = camelToPathPiece' 2 + , omitNothingFields = True + } ''QualificationUserBlock diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index 16ad3a474..dc0f83210 100644 --- a/src/Model/Migration.hs +++ b/src/Model/Migration.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Steffen Jost ,Sarah Vaupel +-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen ,Steffen Jost ,Sarah Vaupel ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -13,7 +13,7 @@ module Model.Migration import Import.NoModel hiding (Max(..), Last(..)) import Model import Foundation.Type -import Model.Migration.Definitions +import Model.Migration.Definitions -- SEE HERE: this module contains the actual migration code import qualified Model.Migration.Types as Legacy import qualified Data.Map as Map diff --git a/src/Model/Migration/Definitions.hs b/src/Model/Migration/Definitions.hs index 146785bea..4224ab7b7 100644 --- a/src/Model/Migration/Definitions.hs +++ b/src/Model/Migration/Definitions.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen ,Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -92,6 +92,8 @@ data ManualMigration | Migration20210208StudyFeaturesRelevanceCachedUUIDs | Migration20210318CrontabSubmissionRatedNotification | Migration20210608SeparateTermActive + | Migration20230524QualificationUserBlock + | Migration20230703LmsUserStatus deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic) deriving anyclass (Universe, Finite) @@ -111,7 +113,7 @@ derivePersistFieldPathPiece ''ManualMigration migrateManual :: Migration migrateManual = do - mapM_ (uncurry addIndex) + mapM_ (uncurry addIndex) -- NOTE: Indices are automatically created for primary keys and unique columns; manually create them frequent filter conditions that small results for speed up [ ("material_file_content", "CREATE INDEX material_file_content ON material_file (content)" ) , ("course_news_file_content", "CREATE INDEX course_news_file_content ON course_news_file (content)" ) , ("sheet_file_content", "CREATE INDEX sheet_file_content ON sheet_file (content)" ) @@ -130,7 +132,14 @@ migrateManual = do , ("study_features_relevance_cached", "CREATE INDEX study_features_relevance_cached ON \"study_features\" (relevance_cached)") , ("submission_rating_by", "CREATE INDEX submission_rating_by ON submission (rating_by) WHERE rating_by IS NOT NULL" ) , ("exam_corrector_user", "CREATE INDEX exam_corrector_user ON exam_corrector (\"user\")" ) - , ("submission_rating_time", "CREATE INDEX submission_rating_time ON submission (rating_time)" ) + , ("submission_rating_time", "CREATE INDEX submission_rating_time ON submission (rating_time)" ) + , ("idx_qualification_user_first_held" ,"CREATE INDEX idx_qualification_user_first_held ON \"qualification_user\" (\"first_held\")") + , ("idx_qualification_user_valid_until" ,"CREATE INDEX idx_qualification_user_valid_until ON \"qualification_user\" (\"valid_until\")") + , ("idx_qualification_user_block_quser" ,"CREATE INDEX idx_qualification_user_block_quser ON \"qualification_user_block\" (\"qualification_user\")") + , ("idx_qualification_user_block_unblock","CREATE INDEX idx_qualification_user_block_unblock ON \"qualification_user_block\" (\"unblock\")") + , ("idx_qualification_user_block_from" ,"CREATE INDEX idx_qualification_user_block_from ON \"qualification_user_block\" (\"from\")") + , ("idx_print_job_apc_ident" ,"CREATE INDEX idx_print_job_apc_ident ON \"print_job\" (\"apc_ident\")") + , ("idx_user_avs_card_person_id" ,"CREATE INDEX idx_user_avs_card_person_id ON \"user_avs_card\" (\"person_id\")") ] where addIndex :: Text -> Sql -> Migration @@ -854,6 +863,44 @@ customMigrations = mapF $ \case ALTER TABLE "term" DROP COLUMN "active"; |] + Migration20230524QualificationUserBlock -> + whenM (andM [ not <$> tableExists "qualification_user_block" + , tableExists "qualification_user" + , columnExists "qualification_user" "blocked_due" + ] ) $ do + [executeQQ| + CREATE TABLE "qualification_user_block" + ( "id" SERIAL8 PRIMARY KEY UNIQUE + , "qualification_user" bigint NOT NULL + , "unblock" boolean NOT NULL + , "from" timestamp with time zone NOT NULL + , "reason" character varying NOT NULL + , "blocker" bigint + , CONSTRAINT qualification_user_block_qualification_user_fkey FOREIGN KEY ("qualification_user") REFERENCES "qualification_user"(id) ON DELETE CASCADE ON UPDATE CASCADE + , CONSTRAINT qualification_user_block_blocker_fkey FOREIGN KEY ("blocker") REFERENCES "user"(id) + ); + |] + + let getBlocks = [queryQQ|SELECT "id", "blocked_due" FROM "qualification_user" WHERE "blocked_due" IS NOT NULL|] + migrateBlocks [ fromPersistValue -> Right (quid :: QualificationUserId), fromPersistValue -> Right (Just (Legacy.QualificationBlocked{..} :: Legacy.QualificationBlocked)) ] = + [executeQQ|INSERT INTO "qualification_user_block" ("qualification_user", "unblock", "from", "reason") VALUES (#{quid}, FALSE, #{qualificationBlockedDay}, #{qualificationBlockedReason})|] + migrateBlocks _ = return () + in runConduit $ getBlocks .| C.mapM_ migrateBlocks + + [executeQQ| + ALTER TABLE "qualification_user" DROP COLUMN "blocked_due"; + |] + + Migration20230703LmsUserStatus -> + whenM (columnNotExists "lms_user" "status_day") $ do + [executeQQ| + ALTER TABLE "lms_user" ADD COLUMN "status_day" date; + UPDATE "lms_user" + SET "status_day" = CAST("status"->>'day' AS date) + , "status" = "status"->'lms-status' + ; + |] + tableExists :: MonadIO m => Text -> ReaderT SqlBackend m Bool tableExists table = do @@ -882,9 +929,16 @@ tableDropEmpty table = whenM (tableExists table) $ do columnExists :: MonadIO m => Text -- ^ Table -> Text -- ^ Column - -> ReaderT SqlBackend m Bool + -> ReaderT SqlBackend m Bool -- BEWARE: use tablesExist beforehand!!! columnExists table column = do haveColumn <- [sqlQQ|SELECT column_name FROM information_schema.columns WHERE table_name=#{table} and column_name=#{column};|] case haveColumn :: [Single PersistValue] of [_] -> return True _other -> return False + +-- | equivalent to andM [ tableExists, not <$> columnExists] +columnNotExists :: MonadIO m + => Text -- ^ Table + -> Text -- ^ Column + -> ReaderT SqlBackend m Bool +columnNotExists table column = and2M (tableExists table) (not <$> columnExists table column) diff --git a/src/Model/Migration/Types.hs b/src/Model/Migration/Types.hs index 50df4a3ee..bd3da98fe 100644 --- a/src/Model/Migration/Types.hs +++ b/src/Model/Migration/Types.hs @@ -124,3 +124,18 @@ examModeDNF :: ExamModeDNF -> Current.ExamModeDNF examModeDNF (ExamModeDNF PredDNF{..}) = Current.ExamModeDNF . Current.PredDNF $ Set.map (impureNonNull . Set.map toCurrentPredLiteral . toNullable) dnfTerms where toCurrentPredLiteral PLVariable{..} = Current.PLVariable plVar toCurrentPredLiteral PLNegated{..} = Current.PLNegated plVar + + +data QualificationBlocked = QualificationBlocked { qualificationBlockedDay :: Day + , qualificationBlockedReason :: Text + } + deriving (Eq, Ord, Read, Show, Generic, NFData) + +-- makeLenses_ ''QualificationBlocked +-- +deriveJSON defaultOptions + { tagSingleConstructors = False + , fieldLabelModifier = camelToPathPiece' 2 + , omitNothingFields = True + } ''QualificationBlocked +Current.derivePersistFieldJSON ''QualificationBlocked \ No newline at end of file diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs index dc58f1087..997fa6588 100644 --- a/src/Model/Types/Avs.hs +++ b/src/Model/Types/Avs.hs @@ -44,7 +44,7 @@ o .:?~ key = o .: key <|> maybe empty parseJSON go -- Like (.:?) but maps Just null to Nothing, ie. Nothing instead of Just "" -(.:?!) :: (MonoFoldable a, FromJSON a) => Object -> Text -> Parser (Maybe a) +(.:?!) :: (Canonical (Maybe a), FromJSON a) => Object -> Text -> Parser (Maybe a) (.:?!) o k = canonical <$> (o .:? k) @@ -83,7 +83,7 @@ instance FromJSON SloppyBool where newtype AvsInternalPersonalNo = AvsInternalPersonalNo { avsInternalPersonalNo :: Text } -- ought to be all digits deriving (Eq, Ord, Show, Generic) - deriving newtype (NFData, PathPiece, PersistField, PersistFieldSql, Csv.ToField, Csv.FromField) + deriving newtype (NFData, PathPiece, PersistField, PersistFieldSql, Csv.ToField, Csv.FromField) instance E.SqlString AvsInternalPersonalNo -- AvsInternalPersonalNo is an untagged Text with respect to FromJSON/ToJSON, as needed by AVS API @@ -93,7 +93,7 @@ normalizeAvsInternalPersonalNo = Text.dropWhile (\c -> '0' == c || Char.isSpace mkAvsInternalPersonalNo :: Text -> AvsInternalPersonalNo mkAvsInternalPersonalNo = AvsInternalPersonalNo . normalizeAvsInternalPersonalNo -instance Canonical AvsInternalPersonalNo where +instance Canonical AvsInternalPersonalNo where canonical (AvsInternalPersonalNo ipn) = AvsInternalPersonalNo $ Text.dropWhile (\c -> '0' == c || Char.isSpace c) ipn instance FromJSON AvsInternalPersonalNo where parseJSON x = AvsInternalPersonalNo . normalizeAvsInternalPersonalNo <$> parseJSON x @@ -103,11 +103,11 @@ instance ToJSON AvsInternalPersonalNo where type instance Element AvsInternalPersonalNo = Char instance MonoFoldable AvsInternalPersonalNo where ofoldMap f = ofoldr (mappend . f) mempty . avsInternalPersonalNo - ofoldr x y = Text.foldr x y . avsInternalPersonalNo - ofoldl' x y = Text.foldl' x y . avsInternalPersonalNo + ofoldr x y = Text.foldr x y . avsInternalPersonalNo + ofoldl' x y = Text.foldl' x y . avsInternalPersonalNo otoList = Text.unpack . avsInternalPersonalNo - oall x = Text.all x . avsInternalPersonalNo - oany x = Text.any x . avsInternalPersonalNo + oall x = Text.all x . avsInternalPersonalNo + oany x = Text.any x . avsInternalPersonalNo onull = Text.null . avsInternalPersonalNo olength = Text.length . avsInternalPersonalNo ofoldr1Ex x = Text.foldr1 x . avsInternalPersonalNo @@ -128,19 +128,19 @@ instance MonoFoldable AvsInternalPersonalNo where {-# INLINE lastEx #-} {- -instance {-# OVERLAPS #-} Canonical (Maybe AvsInternalPersonalNo) where - canonical (Just aipn) | ipn@(AvsInternalPersonalNo pn) <- canonical aipn, not (null pn) = Just ipn +instance {-# OVERLAPS #-} Canonical (Maybe AvsInternalPersonalNo) where + canonical (Just aipn) | ipn@(AvsInternalPersonalNo pn) <- canonical aipn, not (null pn) = Just ipn canonical _ = Nothing -} --- CompleteCardNo = xxxxxxxx.y +-- CompleteCardNo = xxxxxxxx.y -- where x is an 8 digit AvsCardNo prefixed by zeros, see normalizeAvsCardNo -- and y is the 1 digit AvsVersionNo -type AvsVersionNo = Text -- always 1 digit +type AvsVersionNo = Text -- always 1 digit newtype AvsCardNo = AvsCardNo { avsCardNo :: Text } -- always 8 digits -- TODO: Create Smart Constructor deriving (Eq, Ord, Show, Generic) - deriving newtype (NFData, PathPiece, Csv.ToField, Csv.FromField) + deriving newtype (NFData, PathPiece, Csv.ToField, Csv.FromField) -- No longer needed: -- deriving newtype (PersistField, PersistFieldSql) -- instance E.SqlString AvsCardNo @@ -153,7 +153,7 @@ instance ToJSON AvsCardNo where normalizeAvsCardNo :: Text -> Text normalizeAvsCardNo = Text.justifyRight 8 '0' -instance Canonical AvsCardNo where +instance Canonical AvsCardNo where canonical AvsCardNo{..} = AvsCardNo $ normalizeAvsCardNo avsCardNo -- canonical = AvsCardNo . normalizeAvsCardNo . avsCardNo @@ -164,7 +164,7 @@ data AvsFullCardNo = AvsFullCardNo { avsFullCardNo :: AvsCardNo, avsFullCardVers tshowAvsFullCardNo :: AvsFullCardNo -> Text tshowAvsFullCardNo AvsFullCardNo{..} = avsCardNo (canonical avsFullCardNo) <> Text.cons '.' avsFullCardVersion -instance Show AvsFullCardNo where +instance Show AvsFullCardNo where show = Text.unpack . tshowAvsFullCardNo readAvsFullCardNo :: Text -> Maybe AvsFullCardNo @@ -175,9 +175,9 @@ readAvsFullCardNo _ = Nothing instance PersistField AvsFullCardNo where toPersistValue = PersistText . tshowAvsFullCardNo - fromPersistValue (PersistText t) - | Just afc <- readAvsFullCardNo t = Right afc - | otherwise = Left $ "Encoding of AvsFullCardNo is invalid: " <> t + fromPersistValue (PersistText t) + | Just afc <- readAvsFullCardNo t = Right afc + | otherwise = Left $ "Encoding of AvsFullCardNo is invalid: " <> t fromPersistValue other = Left $ "Encoding of AvsFullCardNo with invalid type: " <> tshow other instance PersistFieldSql AvsFullCardNo where @@ -185,7 +185,7 @@ instance PersistFieldSql AvsFullCardNo where discernAvsCardPersonalNo :: Text -> Maybe (Either AvsFullCardNo AvsInternalPersonalNo) -- Just implies it is a whole number or decimal with one digit after the point discernAvsCardPersonalNo (Text.span Char.isDigit -> (c, pv)) - | Text.null pv + | Text.null pv = Just $ Right $ mkAvsInternalPersonalNo c | not $ Text.null c , Just ('.', v) <- Text.uncons pv @@ -199,7 +199,7 @@ newtype AvsPersonId = AvsPersonId { avsPersonId :: Int } -- untagged Int deriving newtype (NFData, PathPiece, PersistField, PersistFieldSql, Csv.ToField, Csv.FromField, Hashable, Binary) -- TODO: consider using "makeWrapped ''AvsPersonId" instance E.SqlString AvsPersonId --- As opposed to AvsObjPersonId, AvsPersonId is an untagged Int with respect to FromJSON/ToJSON, as needed by AVS API; +-- As opposed to AvsObjPersonId, AvsPersonId is an untagged Int with respect to FromJSON/ToJSON, as needed by AVS API; instance FromJSON AvsPersonId where parseJSON x = AvsPersonId <$> parseJSON x instance ToJSON AvsPersonId where @@ -214,7 +214,7 @@ _AvsPersonId :: Iso AvsPersonId AvsPersonId Int Int _AvsPersonId = iso avsPersonId AvsPersonId -- | Non-existing default, also needed for query all ramp driving licences -avsPersonIdZero :: AvsPersonId +avsPersonIdZero :: AvsPersonId avsPersonIdZero = AvsPersonId 0 -- this mus be zero acording to VSM specification newtype AvsObjPersonId = AvsObjPersonId -- tagged object @@ -238,7 +238,7 @@ discernAvsIds someid = aux someid , let afcn = AvsFullCardNo (AvsCardNo $ Text.dropEnd 2 someid) (Text.singleton h2) = Just $ Left afcn | otherwise = Nothing - aux _ = Right . AvsPersonId <$> readMay someid -- must always succeed at that point + aux _ = Right . AvsPersonId <$> readMay someid -- must always succeed at that point data AvsLicence = AvsNoLicence | AvsLicenceVorfeld | AvsLicenceRollfeld @@ -265,10 +265,10 @@ instance FromJSON AvsLicence where -- we assume that the Ord-Instance is respected by the SQL Backend! instance PersistField AvsLicence where toPersistValue = PersistInt64 . fromIntegral . fromEnum - fromPersistValue (PersistInt64 v') + fromPersistValue (PersistInt64 v') | let v = fromIntegral v' , v >= fromEnum (minBound::AvsLicence) - , v <= fromEnum (maxBound::AvsLicence) + , v <= fromEnum (maxBound::AvsLicence) = Right $ toEnum v fromPersistValue other = Left $ "Encoding of AvsLicence " <> tshow other <> " is out of range" @@ -314,7 +314,7 @@ data AvsDataPersonCard = AvsDataPersonCard , avsDataPostalCode:: Maybe Text -- Nothing if returned with AvsResponseStatus , avsDataCity :: Maybe Text -- Nothing if returned with AvsResponseStatus , avsDataFirm :: Maybe Text -- Nothing if returned with AvsResponseStatus - , avsDataCardNo :: AvsCardNo -- always 8 digits number, prefixed with 0 + , avsDataCardNo :: AvsCardNo -- always 8 digits number, prefixed with 0 , avsDataVersionNo :: AvsVersionNo -- always 1 digit number } deriving (Eq, Ord, Show, Generic) @@ -478,17 +478,17 @@ deriveJSON defaultOptions { fieldLabelModifier = dropCamel 2 , omitNothingFields = True , tagSingleConstructors = False - , rejectUnknownFields = False + , rejectUnknownFields = False } ''AvsLicenceResponse -data AvsPersonInfo = AvsPersonInfo +data AvsPersonInfo = AvsPersonInfo { avsInfoPersonNo :: Text -- Int -- AVS Personennummer, zum Gebrauch in menschlicher Kommunikation , avsInfoFirstName :: Text -- WARNING: name stored as is, but AVS does contain weird whitespaces , avsInfoLastName :: Text -- WARNING: name stored as is, but AVS does contain weird whitespaces , avsInfoRampLicence :: Int -- AvsLicence -- unlike other queries, may return -1 for guest unable to hold a licence; currently not distinquished from no licence , avsInfoDateOfBirth :: Maybe Day , avsInfoPersonEMail :: Maybe Text - , avsInfoPersonMobilePhoneNo :: Maybe Text + , avsInfoPersonMobilePhoneNo :: Maybe Text , avsInfoInternalPersonalNo :: Maybe AvsInternalPersonalNo -- Fraport Personalnummer } deriving (Eq, Ord, Show, Generic) @@ -508,12 +508,12 @@ instance FromJSON AvsPersonInfo where instance ToJSON AvsPersonInfo where toJSON AvsPersonInfo{..} = object $ catMaybes - [ ("DateOfBirth" .=) <$> avsInfoDateOfBirth + [ ("DateOfBirth" .=) <$> avsInfoDateOfBirth , ("PersonEMail" .=) <$> avsInfoPersonEMail & canonical - , ("PersonMobilePhoneNo" .=) <$> avsInfoPersonMobilePhoneNo & canonical + , ("PersonMobilePhoneNo" .=) <$> avsInfoPersonMobilePhoneNo & canonical , ("InternalPersonalNo" .=) <$> avsInfoInternalPersonalNo & canonical ] <> - [ "PersonsNo" .= avsInfoPersonNo + [ "PersonsNo" .= avsInfoPersonNo , "FirstName" .= avsInfoFirstName , "LastName" .= avsInfoLastName , "RampLicence" .= avsInfoRampLicence @@ -521,7 +521,44 @@ instance ToJSON AvsPersonInfo where -- derivePersistFieldJSON ''AvsPersonInfo -data AvsFirmInfo = AvsFirmInfo +data AvsFirmCommunication = AvsFirmCommunication + { avsCommunicationZIPCode :: Maybe Text + , avsCommunicationCity :: Maybe Text + , avsCommunicationCountry :: Maybe Text + , avsCommunicationStreetANDHouseNo :: Maybe Text + , avsCommunicationEMail :: Maybe Text + } deriving (Eq, Ord, Show, Generic) + +instance {-# OVERLAPS #-} Canonical (Maybe AvsFirmCommunication) where + canonical (Just AvsFirmCommunication{..}) + | isNothing avsCommunicationZIPCode + , isNothing avsCommunicationCity + , isNothing avsCommunicationCountry + , isNothing avsCommunicationStreetANDHouseNo + , isNothing avsCommunicationEMail + = Nothing + canonical other = other + +makeLenses_ ''AvsFirmCommunication + +instance FromJSON AvsFirmCommunication where + parseJSON = withObject "AvsFirmCommunication" $ \o -> AvsFirmCommunication + <$> o .:?! "ZIPCode" + <*> o .:?! "City" + <*> o .:?! "Country" + <*> o .:?! "StreetANDHouseNo" + <*> o .:?! "EMail" + +instance ToJSON AvsFirmCommunication where + toJSON AvsFirmCommunication{..} = object $ catMaybes + [ ("ZIPCode" .=) <$> avsCommunicationZIPCode & canonical + , ("City" .=) <$> avsCommunicationCity & canonical + , ("Country" .=) <$> avsCommunicationCountry & canonical + , ("StreetANDHouseNo" .=) <$> avsCommunicationStreetANDHouseNo & canonical + , ("EMail" .=) <$> avsCommunicationEMail & canonical + ] + +data AvsFirmInfo = AvsFirmInfo { avsFirmFirm :: Text , avsFirmFirmNo :: Int , avsFirmAbbreviation :: Text -- enthält manchmal Leerzeichen! @@ -531,6 +568,7 @@ data AvsFirmInfo = AvsFirmInfo , avsFirmStreetANDHouseNo :: Maybe Text , avsFirmEMail :: Maybe Text , avsFirmEMailSuperior :: Maybe Text + , avsFirmCommunication :: Maybe AvsFirmCommunication } deriving (Eq, Ord, Show, Generic) makeLenses_ ''AvsFirmInfo @@ -546,15 +584,17 @@ instance FromJSON AvsFirmInfo where <*> o .:?! "StreetANDHouseNo" <*> o .:?! "EMail" <*> o .:?! "EMailSuperior" + <*> o .:?! "Communication" instance ToJSON AvsFirmInfo where toJSON AvsFirmInfo{..} = object $ catMaybes [ ("ZIPCode" .=) <$> avsFirmZIPCode & canonical - , ("City" .=) <$> avsFirmCity & canonical + , ("City" .=) <$> avsFirmCity & canonical , ("Country" .=) <$> avsFirmCountry & canonical , ("StreetANDHouseNo" .=) <$> avsFirmStreetANDHouseNo & canonical - , ("EMail" .=) <$> avsFirmEMail & canonical + , ("EMail" .=) <$> avsFirmEMail & canonical , ("EMailSuperior" .=) <$> avsFirmEMailSuperior & canonical + , ("Communication" .=) <$> avsFirmCommunication & canonical ] <> [ "Firm" .= avsFirmFirm , "FirmNo" .= avsFirmFirmNo @@ -566,7 +606,7 @@ instance ToJSON AvsFirmInfo where data AvsDataContact = AvsDataContact { avsContactPersonID :: AvsPersonId , avsContactPersonInfo :: AvsPersonInfo - , avsContactFirmInfo :: AvsFirmInfo + , avsContactFirmInfo :: AvsFirmInfo } deriving (Eq, Ord, Show, Generic) makeLenses_ ''AvsDataContact @@ -591,14 +631,14 @@ deriveJSON defaultOptions type AvsResponseStatus :: Type newtype AvsResponseStatus = AvsResponseStatus (Set AvsStatusPerson) deriving (Eq, Ord, Show, Generic) -makeWrapped ''AvsResponseStatus +makeWrapped ''AvsResponseStatus deriveJSON defaultOptions { fieldLabelModifier = dropCamel 2 , omitNothingFields = True , tagSingleConstructors = False , rejectUnknownFields = False } ''AvsResponseStatus -instance Semigroup AvsResponseStatus where +instance Semigroup AvsResponseStatus where (AvsResponseStatus a) <> (AvsResponseStatus b) = AvsResponseStatus (a <> b) newtype AvsResponsePerson = AvsResponsePerson (Set AvsDataPerson) @@ -668,11 +708,11 @@ deriveJSON defaultOptions } ''AvsQueryPerson newtype AvsQueryStatus = AvsQueryStatus (Set AvsPersonId) - deriving (Eq, Ord, Show, Generic) + deriving (Eq, Ord, Show, Generic) deriveJSON defaultOptions ''AvsQueryStatus makeWrapped ''AvsQueryStatus -newtype AvsQueryContact = AvsQueryContact (Set AvsObjPersonId) -- note the difference to AvsQueryStatus, which receives a list of id, whereas here we sent a list of single-field object +newtype AvsQueryContact = AvsQueryContact (Set AvsObjPersonId) -- note the difference to AvsQueryStatus, which receives a list of id, whereas here we sent a list of single-field object deriving (Eq, Ord, Show, Generic) deriveJSON defaultOptions ''AvsQueryContact makeWrapped ''AvsQueryContact diff --git a/src/Model/Types/Lms.hs b/src/Model/Types/Lms.hs index b965fecd8..48828607c 100644 --- a/src/Model/Types/Lms.hs +++ b/src/Model/Types/Lms.hs @@ -24,7 +24,7 @@ import Utils.Lens.TH newtype LmsIdent = LmsIdent { getLmsIdent :: Text } deriving (Eq, Ord, Read, Show, Generic) deriving newtype (NFData, PathPiece, PersistField, PersistFieldSql, Csv.ToField, Csv.FromField, Hashable) -instance E.SqlString LmsIdent +instance E.SqlString LmsIdent makeLenses_ ''LmsIdent deriveJSON defaultOptions @@ -35,79 +35,27 @@ deriveJSON defaultOptions -- TODO: Is this a good idea? An ordinary Enum and a separate Day column in the DB would be better, e.g. allowing use of insertSelect in Jobs.Handler.LMS? -- ...also see similar type QualificationBlocked -data LmsStatus = LmsBlocked { lmsStatusDay :: Day } - | LmsExpired { lmsStatusDay :: Day } - | LmsSuccess { lmsStatusDay :: Day } - deriving (Eq, Read, Show, Generic, NFData) +data LmsStatus = LmsExpired + | LmsBlocked + | LmsSuccess + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, NFData, Universe, Finite) -instance Ord LmsStatus where - compare a b - | daycmp <- compare (lmsStatusDay a) (lmsStatusDay b) - , daycmp /= EQ = daycmp - compare LmsSuccess{} LmsBlocked{} = GT - compare LmsSuccess{} LmsExpired{} = GT - compare LmsBlocked{} LmsSuccess{} = LT - compare LmsExpired{} LmsSuccess{} = LT - compare LmsBlocked{} LmsExpired{} = GT - compare LmsExpired{} LmsBlocked{} = LT - compare _ _ = EQ - -isLmsSuccess :: LmsStatus -> Bool -isLmsSuccess LmsSuccess{} = True -isLmsSuccess _other = False - -isLmsExpired :: LmsStatus -> Bool -isLmsExpired LmsExpired{} = True -isLmsExpired _other = False - --- | What to do if LMS sends multiple responses and whether an oldStatus should be overwritten -replaceLmsStatus :: Maybe LmsStatus -> Maybe LmsStatus -> Bool -replaceLmsStatus _ Nothing = False -replaceLmsStatus Nothing _ = True -replaceLmsStatus (Just LmsSuccess{}) _ = False -replaceLmsStatus (Just LmsExpired{}) (Just newStat) = not $ isLmsExpired newStat -replaceLmsStatus (Just LmsBlocked{}) (Just newStat) = isLmsSuccess newStat - -makeLenses_ ''LmsStatus - --- Entscheidung 16.09.22: Es gewinnt was zuerst gemeldet wurde. Das verhindert, dass eine Qualifikation doppelt verlängert wird! Siehe Model.TypesSpec -instance Semigroup LmsStatus where - a <> b = min a b -- earliest date, otherwise LmsBlocked before LmsSuccess +-- embedRenderMessage ''UniWorX ''LmsStatus (uncurry ((<>) . (<> "Status")) . Text.splitAt 3) -- moved to src/Foundation.hs deriveJSON defaultOptions - { constructorTagModifier = camelToPathPiece' 1 -- remove lms from constructor, since the object is tagged with lms already - , fieldLabelModifier = camelToPathPiece' 2 -- just day suffices for the day field - , omitNothingFields = True - , sumEncoding = TaggedObject "lms-status" "lms-result" + { constructorTagModifier = camelToPathPiece' 1 -- remove lms from constructor + , fieldLabelModifier = camelToPathPiece' 1 + , sumEncoding = UntaggedValue } ''LmsStatus derivePersistFieldJSON ''LmsStatus +nullaryPathPiece ''LmsStatus $ camelToPathPiece' 1 + instance Csv.ToField LmsStatus where - toField (LmsBlocked d) = "Failure: " <> Csv.toField d - toField (LmsExpired d) = "Expired: " <> Csv.toField d - toField (LmsSuccess d) = "Success: " <> Csv.toField d + toField = Csv.toField . toPathPiece -data QualificationBlocked = QualificationBlocked { qualificationBlockedDay :: Day - , qualificationBlockedReason :: Text - } - deriving (Eq, Ord, Read, Show, Generic, NFData) - -makeLenses_ ''QualificationBlocked - -deriveJSON defaultOptions - { tagSingleConstructors = False - , fieldLabelModifier = camelToPathPiece' 2 - , omitNothingFields = True - } ''QualificationBlocked -derivePersistFieldJSON ''QualificationBlocked - -instance Csv.ToField QualificationBlocked where - toField QualificationBlocked{..} = "Blocked " <> Csv.toField qualificationBlockedDay <> " due to " <> Csv.toField qualificationBlockedReason - --- | ToMessage instance ignores contained timestamp by design --- instance ToMessage QualificationBlocked where -- no longer used --- toMessage QualificationBlocked{..} = qualificationBlockedReason +-- | Default Block/Unblock reasons data QualificationBlockStandardReason = QualificationBlockFailedELearning | QualificationBlockReturnedByCompany @@ -122,10 +70,11 @@ qualificationBlockedReasonText = let dictionary :: Map.Map QualificationBlockStandardReason Text = Map.fromList [(r, tshow r) | r <- universeF] in (dictionary !) -- cannot fail due to universeF -mkQualificationBlocked :: QualificationBlockStandardReason -> Day -> QualificationBlocked -mkQualificationBlocked reason qualificationBlockedDay = QualificationBlocked{..} - where - qualificationBlockedReason = qualificationBlockedReasonText reason +type QualificationBlockReason = Either Text QualificationBlockStandardReason + +qualificationBlockReasonText :: QualificationBlockReason -> Text +qualificationBlockReasonText (Left reason) = reason +qualificationBlockReasonText (Right stdreason) = qualificationBlockedReasonText stdreason -- | LMS interface requires Bool to be encoded by 0 or 1 only newtype LmsBool = LmsBool { lms2bool :: Bool } @@ -139,10 +88,33 @@ instance Csv.ToField LmsBool where toField (LmsBool True ) = "1" instance Csv.FromField LmsBool where - parseField i - | i == "0" = pure $ LmsBool False - | i == "1" = pure $ LmsBool True - | otherwise = mempty + parseField "0" = pure $ LmsBool False + parseField "1" = pure $ LmsBool True + parseField _ = mempty + +-- | Only to be used in LMS interface communicating user status +data LmsState = LmsFailed | LmsOpen | LmsPassed + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, NFData, Universe, Finite) + +instance Csv.ToField LmsState where + toField LmsFailed = "0" + toField LmsOpen = "1" + toField LmsPassed = "2" + +instance Csv.FromField LmsState where + parseField "0" = pure LmsFailed + parseField "1" = pure LmsOpen + parseField "2" = pure LmsPassed + parseField _ = mempty + +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece' 1 -- remove lms from constructor + , fieldLabelModifier = camelToPathPiece' 1 + , sumEncoding = UntaggedValue + } ''LmsState +derivePersistFieldJSON ''LmsState +nullaryPathPiece ''LmsState $ camelToPathPiece' 1 + -- | LMS interface requires day format not compliant with iso8601; also LMS uses LOCAL TIMEZONE newtype LmsDay = LmsDay { lms2day :: Day } @@ -166,3 +138,27 @@ instance Csv.FromField LmsDay where d <- Time.parseTimeM True Time.defaultTimeLocale lmsDayFormat s <|> iso8601ParseM s -- Know-How AG considers supplying iso8601 dates in the future return $ LmsDay d + +-- | LMS interface requires day format not compliant with iso8601; also LMS uses LOCAL TIMEZONE +newtype LmsTimestamp = LmsTimestamp { lms2timestamp :: UTCTime } + deriving (Eq, Ord, Read, Show, Generic) + +_lmsTimestamp :: Iso' UTCTime LmsTimestamp +_lmsTimestamp = iso LmsTimestamp lms2timestamp + +-- | Format for day for LMS interface +lmsTimestampFormat :: String +lmsTimestampFormat = "%d-%m-%Y %T" -- fixed in LMS interface desctiption, due defaultTimeLocale, should not use named entities like weekdays or month names + +instance Csv.ToField LmsTimestamp where + toField (LmsTimestamp d) = Csv.toField $ Time.formatTime Time.defaultTimeLocale lmsTimestampFormat d -- TimeLocale should not matter since format string does not use names; getTimeLocale requires MonadHandler + +instance Csv.FromField LmsTimestamp where +-- parseField = fmap LmsDay . parseLmsDay <=< Csv.parseField +-- where parseLmsDay = Time.parseTimeM True Time.defaultTimeLocale lmsDayFormat + parseField i = do + s <- Csv.parseField i + d <- Time.parseTimeM True Time.defaultTimeLocale lmsTimestampFormat s + <|> (utctDayMidnight <$> Time.parseTimeM True Time.defaultTimeLocale lmsDayFormat s) + <|> iso8601ParseM s -- Know-How AG considers supplying iso8601 dates in the future + return $ LmsTimestamp d diff --git a/src/Model/Types/Security.hs b/src/Model/Types/Security.hs index dbea81892..cb73195b2 100644 --- a/src/Model/Types/Security.hs +++ b/src/Model/Types/Security.hs @@ -63,9 +63,9 @@ instance Hashable AuthenticationMode instance NFData AuthenticationMode deriveJSON defaultOptions - { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel - , fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel - , sumEncoding = UntaggedValue + { constructorTagModifier = camelToPathPiece' 1 + , fieldLabelModifier = camelToPathPiece' 1 + , sumEncoding = UntaggedValue } ''AuthenticationMode derivePersistFieldJSON ''AuthenticationMode diff --git a/src/Utils.hs b/src/Utils.hs index 92c0d7271..2cf4b1495 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -503,6 +503,10 @@ snakecase2camelcase t = Text.concat $ map textToCapital words words = Text.splitOn '_' t -} +-- also see Utils.Form.cfCommaSeparatedSet +commaSeparatedText :: Text -> Set Text +commaSeparatedText = Set.fromList . mapMaybe (assertM' (not . Text.null) . Text.strip) . Text.split (==',') + ----------- -- Fixed -- @@ -870,6 +874,12 @@ deepAlt altFst _ = altFst maybeEmpty :: Monoid m => Maybe a -> (a -> m) -> m maybeEmpty = flip foldMap + +-- The more general `find :: Foldable t => (a -> Bool) -> t a -> Maybe a` +filterMaybe :: (a -> Bool) -> Maybe a -> Maybe a +filterMaybe c r@(Just x) | c x = r +filterMaybe _ _ = Nothing + -- | also referred to as whenJust and forM_ whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m () whenIsJust (Just x) f = f x @@ -1204,11 +1214,12 @@ partitionM crit = ofoldlM dist mempty | okay -> acc `mappend` (opoint x, mempty) | otherwise -> acc `mappend` (mempty, opoint x) -mconcatMapM :: (Monoid b, Monad m, Foldable f) => (a -> m b) -> f a -> m b -mconcatMapM f = foldM (\x my -> mappend x <$> my) mempty . map f . Fold.toList +-- use `foldMapM` instead +-- mconcatMapM :: (Monoid b, Monad m, Foldable f) => (a -> m b) -> f a -> m b +-- mconcatMapM f = foldM (\x my -> mappend x <$> my) mempty . map f . Fold.toList -mconcatForM :: (Monoid b, Monad m, Foldable f) => f a -> (a -> m b) -> m b -mconcatForM = flip mconcatMapM +-- mconcatForM :: (Monoid b, Monad m, Foldable f) => f a -> (a -> m b) -> m b +-- mconcatForM = flip mconcatMapM findM :: (Monad m, Foldable f) => (a -> MaybeT m b) -> f a -> m (Maybe b) findM f = runMaybeT . Fold.foldr (\x as -> f x <|> as) mzero diff --git a/src/Utils/Avs.hs b/src/Utils/Avs.hs index 27932acda..c351243e8 100644 --- a/src/Utils/Avs.hs +++ b/src/Utils/Avs.hs @@ -72,7 +72,7 @@ mkAvsQuery :: BaseUrl -> BasicAuthData -> ClientEnv -> AvsQuery mkAvsQuery _ _ _ = AvsQuery { avsQueryPerson = \_ -> return . Right $ AvsResponsePerson mempty , avsQueryStatus = \_ -> return . Right $ AvsResponseStatus mempty - , avsQueryContact = \_ -> return . Right $ AvsResponseContact $ Set.singleton $ AvsDataContact (AvsPersonId 1234567) (AvsPersonInfo "123123123" "Heribert" "Sumpfmeier" (-1) Nothing Nothing Nothing Nothing) (AvsFirmInfo "Lange Firma" 7 "Kurz" Nothing Nothing Nothing Nothing Nothing Nothing) + , avsQueryContact = \_ -> return . Right $ AvsResponseContact $ Set.singleton $ AvsDataContact (AvsPersonId 1234567) (AvsPersonInfo "123123123" "Heribert" "Sumpfmeier" (-1) Nothing Nothing Nothing Nothing) (AvsFirmInfo "Lange Firma" 7 "Kurz" Nothing Nothing Nothing Nothing Nothing Nothing Nothing) , avsQuerySetLicences = \_ -> return . Right $ AvsResponseSetLicences mempty , avsQueryGetAllLicences = return . Right $ AvsResponseGetLicences mempty } diff --git a/src/Utils/DateTime.hs b/src/Utils/DateTime.hs index fb08fa474..27ba25ecb 100644 --- a/src/Utils/DateTime.hs +++ b/src/Utils/DateTime.hs @@ -19,6 +19,7 @@ module Utils.DateTime , diffMinute, diffHour, diffDay , module Zones , day + , utctDayMidnight ) where import ClassyPrelude.Yesod hiding (lift, Proxy(..)) @@ -181,3 +182,7 @@ day = QuasiQuoter{..} quoteType = error "day used as type" quoteDec = error "day used as declaration" quoteExp dStr = maybe (fail $ "Could not parse ISO8601 day: “" <> dStr <> "”") (lift :: Day -> Q Exp) $ Time.iso8601ParseM dStr + +-- | use Handler.Utils.DateTime.toMidnight instead, if the local timezone is to be accounted for +utctDayMidnight :: Day -> UTCTime +utctDayMidnight d = UTCTime { utctDayTime = 0, utctDay = d } diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs index eda59372c..2c8d9de6a 100644 --- a/src/Utils/Icon.hs +++ b/src/Utils/Icon.hs @@ -104,12 +104,16 @@ data Icon | IconRemoveUser | IconReset | IconBlocked + | IconCertificate | IconPrintCenter | IconLetter | IconAt | IconSupervisor -- | IconWaitingForUser | IconExpired + | IconLocked + | IconUnlocked + | IconResetTries -- also see IconReset deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic) deriving anyclass (Universe, Finite, NFData) @@ -191,12 +195,16 @@ iconText = \case IconSubmissionNoUsers -> "user-slash" IconReset -> "undo" -- From fontawesome v6 onwards: "arrow-rotate-left" IconBlocked -> "ban" + IconCertificate -> "badge-check" IconPrintCenter -> "mail-bulk" -- From fontawesome v6 onwards: "envelope-bulk" IconLetter -> "mail-bulk" -- Problem "envelope" already used for email as well IconAt -> "at" IconSupervisor -> "head-side" -- must be notably different to user -- IconWaitingForUser -> "user-cog" -- Waiting on a user to do something IconExpired -> "hourglass-end" + IconLocked -> "lock" + IconUnlocked -> "lock-open-alt" + IconResetTries -> "trash-undo" nullaryPathPiece ''Icon $ camelToPathPiece' 1 deriveLift ''Icon @@ -295,6 +303,10 @@ iconLetterOrEmail :: Bool -> Markup iconLetterOrEmail True = icon IconLetter iconLetterOrEmail False = icon IconAt +iconQualificationBlock :: Bool -> Markup +iconQualificationBlock True = icon IconCertificate +iconQualificationBlock False = icon IconBlocked + ---------------- -- For documentation on how to avoid these unneccessary functions -- we implement them here just once for the first icon: diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 2375e3f3c..861d98fd4 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -122,9 +122,12 @@ makeClassyFor_ ''StudySubTerms makeClassyFor_ ''Qualification makeClassyFor_ ''QualificationUser +makeClassyFor_ ''QualificationUserBlock makeClassyFor_ ''LmsUser +-- makeClassyFor_ ''LmsUserStatus makeClassyFor_ ''LmsUserlist makeClassyFor_ ''LmsResult +makeClassyFor_ ''LmsReport makeClassyFor_ ''UserAvs makeClassyFor_ ''UserAvsCard @@ -160,8 +163,11 @@ instance HasQualification a => HasQualification (a,b) where instance HasQualificationUser a => HasQualificationUser (Entity a) where hasQualificationUser = _entityVal . hasQualificationUser -instance HasQualificationUser a => HasQualificationUser (b,a) where - hasQualificationUser = _2 . hasQualificationUser +-- instance HasQualificationUser a => HasQualificationUser (b,a) where +-- hasQualificationUser = _2 . hasQualificationUser + +instance HasQualificationUserBlock a => HasQualificationUserBlock (Entity a) where + hasQualificationUserBlock = _entityVal . hasQualificationUserBlock instance HasLmsUser a => HasLmsUser (Entity a) where hasLmsUser = _entityVal . hasLmsUser diff --git a/src/Utils/Print/CourseCertificate.hs b/src/Utils/Print/CourseCertificate.hs index babcdfa54..5194a2b8f 100644 --- a/src/Utils/Print/CourseCertificate.hs +++ b/src/Utils/Print/CourseCertificate.hs @@ -50,6 +50,7 @@ instance MDLetter LetterCourseCertificate where letterMeta LetterCourseCertificate{..} DateTimeFormatter{ format } lang _rcvrEnt = mkMeta [ toMeta "participant" ccParticipant + , toMeta "subject-meta" ccParticipant , mbMeta "fra-number" ccFraNumber , mbMeta "fra-department" ccFraDepartment , mbMeta "company" ccCompany diff --git a/src/Utils/Print/ExpireQualification.hs b/src/Utils/Print/ExpireQualification.hs index ddbba609e..290e37bd7 100644 --- a/src/Utils/Print/ExpireQualification.hs +++ b/src/Utils/Print/ExpireQualification.hs @@ -53,6 +53,7 @@ instance MDLetter LetterExpireQualification where , toMeta "licencename" leqName , toMeta "licenceshort" leqShort , toMeta "licenceholder" leqHolderDN + , toMeta "subject-meta" leqHolderDN , mbMeta "expiry" (format SelFormatDate <$> leqExpiry) , mbMeta "licence-url" leqUrl , toMeta "de-opening" $ bool ("Guten Tag " <> leqHolderDN <> ",") "Sehr geehrte Damen und Herren," isSupervised diff --git a/src/Utils/Print/RenewQualification.hs b/src/Utils/Print/RenewQualification.hs index 55d24c5cc..db417b9b6 100644 --- a/src/Utils/Print/RenewQualification.hs +++ b/src/Utils/Print/RenewQualification.hs @@ -74,6 +74,7 @@ instance MDLetter LetterRenewQualificationF where , toMeta "login" lmsIdent , toMeta "pin" lmsPin , toMeta "examinee" qualHolderDN + , toMeta "subject-meta" qualHolderDN , toMeta "expiry" (format SelFormatDate qualExpiry) , mbMeta "validduration" (show <$> qualDuration) , toMeta "url-text" lmsUrl diff --git a/src/Utils/Set.hs b/src/Utils/Set.hs index 80b61cfeb..7ef167280 100644 --- a/src/Utils/Set.hs +++ b/src/Utils/Set.hs @@ -6,6 +6,7 @@ module Utils.Set ( setIntersectNotOne , setIntersections , setMapMaybe +, concatMapSet , setSymmDiff , setProduct , setPartitionEithers @@ -55,6 +56,10 @@ setIntersections (h:t) = foldl' Set.intersection h t setMapMaybe :: Ord b => (a -> Maybe b) -> Set a -> Set b setMapMaybe f = Set.fromList . mapMaybe f . Set.toList +concatMapSet :: Ord b => (a -> Set b) -> Set a -> Set b +concatMapSet f = Set.foldl ((. f) . (<>)) mempty +-- concatMapSet f = foldMap f --- requires Ord a as well, which we ought to have anyway + -- | Symmetric difference of two sets. setSymmDiff :: Ord a => Set a -> Set a -> Set a setSymmDiff x y = (x `Set.difference` y) `Set.union` (y `Set.difference` x) diff --git a/start.sh b/start.sh index f5c21989f..fb7492ae7 100755 --- a/start.sh +++ b/start.sh @@ -28,7 +28,7 @@ export ENCRYPT_ERRORS=${ENCRYPT_ERRORS:-false} export RIBBON=${RIBBON:-${__HOST:-localhost}} export APPROOT=${APPROOT:-http://localhost:$((${PORT_OFFSET:-0} + 3000))} export AVSPASS=${AVSPASS:-nopasswordset} -export PATH=${PATH:/home/jost/projects/fradrive} +export PATH=${PATH:/home/jost/projects/fradrive} export MAIL_REROUTE_TO_NAME='Steffen Jost' export MAIL_REROUTE_TO_EMAIL=jost@tcs.ifi.lmu.de unset HOST diff --git a/templates/admin-problems.hamlet b/templates/admin-problems.hamlet index 631b41e92..60ffd4d92 100644 --- a/templates/admin-problems.hamlet +++ b/templates/admin-problems.hamlet @@ -36,7 +36,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later

          - _{MsgProblemsHeadingUsers} + _{MsgProblemsHeadingNotifications}
          ^{flagError usersAreReachable} @@ -45,6 +45,16 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
          ^{flagError noStalePrintJobs}
          ^{simpleLinkI (MsgProblemsNoStalePrintJobs cutOffPrintDays) PrintCenterR} +
          ^{flagError noBadAPCids} +
          _{MsgProblemsNoBadAPCIds} + $maybe reroute <- rerouteMail
          ^{flagWarning False} -
          _{MsgMailRerouteTo reroute} \ No newline at end of file +
          _{MsgMailRerouteTo reroute} + +
          +

          + _{MsgProblemsHeadingMisc} +
          +
          ^{flagError noAvsSynchProblems} +
          ^{simpleLinkI MsgProblemsNoAvsSynchProblems ProblemAvsErrorR} diff --git a/templates/letter/din5008.latex b/templates/letter/din5008.latex index 0816d2ec5..17042126a 100644 --- a/templates/letter/din5008.latex +++ b/templates/letter/din5008.latex @@ -17,8 +17,8 @@ \IfFileExists{xurl.sty}{\usepackage{xurl}}{} % add URL line breaks if available \IfFileExists{bookmark.sty}{\usepackage{bookmark}}{\usepackage{hyperref}} \hypersetup{ -$if(title-meta)$ - pdftitle={$title-meta$}, +$if(subject-meta)$ + pdfsubject={$subject-meta$}, $endif$ $if(author-meta)$ pdfauthor={$author-meta$}, @@ -26,11 +26,17 @@ $endif$ $if(lang)$ pdflang={$lang$}, $endif$ -$if(subject)$ - pdfsubject={$subject$}, +$if(is-de)$ + $if(de-subject)$ + pdftitle={$de-subject$}, + $endif$ +$else$ + $if(en-subject)$ + pdftitle={$en-subject$}, + $endif$ $endif$ -$if(keywords)$ - pdfkeywords={$for(keywords)$$keywords$$sep$, $endfor$}, +$if(apc-ident)$ + pdfkeywords={$apc-ident$}, $endif$ } \usepackage{url} diff --git a/templates/letter/din5008with_pin.latex b/templates/letter/din5008with_pin.latex index 68047cc04..fe950b11c 100644 --- a/templates/letter/din5008with_pin.latex +++ b/templates/letter/din5008with_pin.latex @@ -17,8 +17,8 @@ \IfFileExists{xurl.sty}{\usepackage{xurl}}{} % add URL line breaks if available \IfFileExists{bookmark.sty}{\usepackage{bookmark}}{\usepackage{hyperref}} \hypersetup{ -$if(title-meta)$ - pdftitle={$title-meta$}, +$if(subject-meta)$ + pdfsubject={$subject-meta$}, $endif$ $if(author-meta)$ pdfauthor={$author-meta$}, @@ -26,11 +26,17 @@ $endif$ $if(lang)$ pdflang={$lang$}, $endif$ -$if(subject)$ - pdfsubject={$subject$}, +$if(is-de)$ + $if(de-subject)$ + pdftitle={$de-subject$}, + $endif$ +$else$ + $if(en-subject)$ + pdftitle={$en-subject$}, + $endif$ $endif$ -$if(keywords)$ - pdfkeywords={$for(keywords)$$keywords$$sep$, $endfor$}, +$if(apc-ident)$ + pdfkeywords={$apc-ident$}, $endif$ } \usepackage{url} diff --git a/templates/letter/plain_article.latex b/templates/letter/plain_article.latex index bdd9d7cd9..7c4038158 100644 --- a/templates/letter/plain_article.latex +++ b/templates/letter/plain_article.latex @@ -10,8 +10,14 @@ \IfFileExists{xurl.sty}{\usepackage{xurl}}{} % add URL line breaks if available \IfFileExists{bookmark.sty}{\usepackage{bookmark}}{\usepackage{hyperref}} \hypersetup{ -$if(title-meta)$ - pdftitle={$title-meta$}, +$if(is-de)$ + $if(de-subject)$ + pdftitle={$de-subject$}, + $endif$ +$else$ + $if(en-subject)$ + pdftitle={$en-subject$}, + $endif$ $endif$ $if(author-meta)$ pdfauthor={$author-meta$}, @@ -19,11 +25,11 @@ $endif$ $if(lang)$ pdflang={$lang$}, $endif$ -$if(subject)$ - pdfsubject={$subject$}, +$if(subject-meta)$ + pdfsubject={$subject-meta$}, $endif$ -$if(keywords)$ - pdfkeywords={$for(keywords)$$keywords$$sep$, $endfor$}, +$if(apc-ident)$ + pdfkeywords={$apc-ident$}, $endif$ } \usepackage{url} diff --git a/templates/lms-report.hamlet b/templates/lms-report.hamlet new file mode 100644 index 000000000..dc4a84f5c --- /dev/null +++ b/templates/lms-report.hamlet @@ -0,0 +1,11 @@ +$newline never + +$# SPDX-FileCopyrightText: 2022 Steffen Jost +$# +$# SPDX-License-Identifier: AGPL-3.0-or-later + +

          + ^{lmsTable} +

          + + _{MsgLmsDirectUpload} diff --git a/templates/lms-user.hamlet b/templates/lms-user.hamlet index 842013fc4..a084f582a 100644 --- a/templates/lms-user.hamlet +++ b/templates/lms-user.hamlet @@ -11,19 +11,28 @@ $else

          - #{qualificationShorthand quali} - #{qualificationName quali} (#{qualificationSchool quali})   #{boolSymbol (E.unValue validity)} + #{qualificationShorthand quali} # + #{statusQualificationBlock (E.unValue validity)} # + #{qualificationName quali} (#{qualificationSchool quali})
          - $maybe (Entity _ qualUsr) <- mbQualUsr + $maybe (Entity quid qualUsr) <- mbQualUsr
          _{MsgLmsQualificationValidUntil}
          ^{formatTimeW SelFormatDate (qualificationUserValidUntil qualUsr)} $if not (qualificationUserScheduleRenewal qualUsr) \ #{icon IconNoNotification} - $maybe (qblock) <- qualificationUserBlockedDue qualUsr + $maybe qblock <- Map.lookup quid qblocks
          _{MsgTableQualificationBlockedDue} -
          ^{formatTimeW SelFormatDate (qualificationBlockedDay qblock)} - \ #{icon IconBlocked} - \ #{qualificationBlockedReason qblock} +
          +
            + $forall (Entity _ block, blockerDN) <- qblock +
          • + #{iconQualificationBlock (view _qualificationUserBlockUnblock block)} + \ #{view _qualificationUserBlockReason block} # + $maybe bdn <- E.unValue blockerDN + ^{editedByW SelFormatDateTime (view _qualificationUserBlockFrom block) bdn} + $nothing + ^{formatTimeW SelFormatDateTime (view _qualificationUserBlockFrom block)}
            _{MsgTableQualificationLastRefresh}
            ^{formatTimeW SelFormatDate (qualificationUserLastRefresh qualUsr)}
            _{MsgTableQualificationFirstHeld} @@ -57,5 +66,6 @@ $else $maybe ts <- lmsUserEnded lmsUsr
            _{MsgTableLmsEnded}
            ^{formatTimeW SelFormatDateTime ts} - - + $nothing +
            _{MsgLmsInactive} +
            diff --git a/templates/lms.hamlet b/templates/lms.hamlet index 0f9f7b0a6..acfccaccf 100644 --- a/templates/lms.hamlet +++ b/templates/lms.hamlet @@ -15,7 +15,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
            _{MsgMonths (fromIntegral dvalid)} $maybe daudit <- qualificationAuditDuration quali -
            _{MsgQualificationAuditDuration} +
            _{MsgQualificationAuditDuration} ^{iconTooltip (msg2widget MsgQualificationAuditDurationTooltip) Nothing True}
            _{MsgMonths (fromIntegral daudit)} $maybe drefresh <- qualificationRefreshWithin quali @@ -29,6 +29,17 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later , # $if drd > 0 _{MsgDays (fromIntegral drd)} + $maybe drefresh <- qualificationRefreshReminder quali +
            _{MsgQualificationRefreshReminder} ^{iconTooltip (msg2widget MsgQualificationRefreshReminderTooltip) Nothing True} +
            + $with drm <- cdMonths drefresh + $with drd <- cdDays drefresh + $if drm > 0 + _{MsgMonths (fromIntegral drm)} + $if drd > 0 + , # + $if drd > 0 + _{MsgDays (fromIntegral drd)}
            _{MsgQualificationElearningStart}
            #{boolSymbol (qualificationElearningStart quali)} diff --git a/templates/profileData.hamlet b/templates/profileData.hamlet index b943c9591..91f194fed 100644 --- a/templates/profileData.hamlet +++ b/templates/profileData.hamlet @@ -22,11 +22,11 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later #{view _userAvsNoPerson avs} $maybe avsError <- view _userAvsLastSynchError avs
            - _{MsgProfileLastAvsSynchError} + _{MsgLastAvsSynchError}
            #{avsError}
            - _{MsgProfileLastAvsSynchronisation} + _{MsgLastAvsSynchronisation}
            ^{formatTimeW SelFormatDateTime (view _userAvsLastSynch avs)}
            diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 3f5567400..55beaff95 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -695,38 +695,50 @@ fillDb = do let f_descr = Just $ htmlToStoredMarkup [shamlet|

            Berechtigung zum Führen eines Fahrzeuges auf den Fahrstrassen des Vorfeldes.|] let r_descr = Just $ htmlToStoredMarkup [shamlet|

            Berechtigung zum Führen eines Fahrzeuges auf dem gesamten Rollfeld.|] let l_descr = Just $ htmlToStoredMarkup [shamlet|

            für unhabilitierte|] - qid_f <- insert' $ Qualification avn "F" "Vorfeldführerschein" f_descr (Just 24) (Just 6) (Just $ CalendarDiffDays 0 60) (Just $ CalendarDiffDays 0 14) True True (Just AvsLicenceVorfeld) $ Just "F4466" + + qid_f <- insert' $ Qualification avn "F" "Vorfeldführerschein" f_descr (Just 24) (Just 6) (Just $ CalendarDiffDays 0 60) (Just $ CalendarDiffDays 0 14) True True (Just AvsLicenceVorfeld) $ Just "F4466" qid_r <- insert' $ Qualification avn "R" "Rollfeldführerschein" r_descr (Just 12) (Just 6) (Just $ CalendarDiffDays 2 3) Nothing False False (Just AvsLicenceRollfeld) $ Just "R2801" - qid_l <- insert' $ Qualification ifi "L" "Lehrbefähigung" l_descr Nothing (Just 6) Nothing Nothing True False Nothing Nothing - 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) + qid_l <- insert' $ Qualification ifi "L" "Lehrbefähigung" l_descr Nothing (Just 6) Nothing Nothing False True Nothing Nothing + qfjost <- insert' $ QualificationUser jost qid_f (n_day 11) (n_day $ -1) (n_day $ -22) True (n_day' $ -9) -- TODO: better dates! + void . insert $ QualificationUserBlock qfjost False (n_day' $ -6) "First block" (Just svaupel) + void . insert $ QualificationUserBlock qfjost True (n_day' $ -5) "Second unblock" (Just gkleen) + void . insert $ QualificationUserBlock qfjost False (n_day' $ -4) "Third block" Nothing + void . insert $ QualificationUserBlock qfjost True (n_day' $ -3) "Fourth unblock" (Just sbarth) + void . insert $ QualificationUserBlock qfjost False (n_day' $ -1) "Fifth block" (Just svaupel) + void . insert' $ QualificationUser jost qid_r (n_day 99) (n_day $ -11) (n_day $ -222) True (n_day' $ -9) -- TODO: better dates! + void . insert' $ QualificationUser jost qid_l (n_day 999) (n_day $ -111) (n_day $ -2222) True (n_day' $ -9) -- TODO: better dates! + qfkleen <- insert' $ QualificationUser gkleen qid_f (n_day 33) (n_day $ -4) (n_day $ -20) True (n_day' $ -9) + void . insert $ QualificationUserBlock qfkleen False (n_day' 1) "Future block" (Just svaupel) + void . insert' $ QualificationUser maxMuster qid_f (n_day 0) (n_day $ -2) (n_day $ -8) False (n_day' $ -1) + qfvaupel <- insert' $ QualificationUser svaupel qid_f (n_day 2) (n_day $ -1) (n_day $ -2) True (n_day' $ -9) + void . insert $ QualificationUserBlock qfvaupel False (n_day' 0) "SameTimeBlock" (Just jost) + void . insert $ QualificationUserBlock qfvaupel True ( n_day' 0) "SameTimeUnblock" (Just jost) + void . insert' $ QualificationUser sbarth qid_f (n_day 400) (n_day $ -40) (n_day $ -1200) True (n_day' $ -2) + qftest <- insert' $ QualificationUser tinaTester qid_f (n_day 3) (n_day $ -60) (n_day $ -250) False (n_day' $ -9) + void . insert $ QualificationUserBlock qftest False (n_day' $ -7) "Some longer explanation for the block, which explains what has happened here, but is probably to long to be shown inline!" (Just jost) + void . insert' $ QualificationUser tinaTester qid_r (n_day 3) (n_day $ -60) (n_day $ -250) False (n_day' $ -3) + qrkleen <- insert' $ QualificationUser gkleen qid_r (n_day 44) (n_day $ -2) (n_day $ -9) True (n_day' $ -4) + void . insert $ QualificationUserBlock qrkleen True (n_day' $ -7) "Granted by lottery win" (Just jost) + void . insert' $ QualificationUser maxMuster qid_r (n_day 1) (n_day $ -1) (n_day $ -2) False (n_day' $ -6) + -- void . insert' $ QualificationUser fhamann qid_r (n_day $ -3) (n_day $ -1) (n_day $ -2) True (n_day' $ -9) + void . insert' $ QualificationUser svaupel qid_l (n_day 1) (n_day $ -1) (n_day $ -2) True (n_day' $ -7) + void . insert' $ QualificationUser gkleen qid_l (n_day 9) (n_day $ -1) (n_day $ -7) 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 (n_day' $ -11)| Entity uid _ <- take 200 matUsers, uid `Set.notMember` qidfUsers] + insertMany_ [QualificationUser uid qid_f (n_day (fromIntegral (length udn) - 12)) (n_day $ -42) (n_day $ -365) True (n_day' $ -11)| Entity uid User{userDisplayName=udn} <- 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 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 (Just $ n_day' (-7)) (Just $ n_day' (-5)) - void . insert' $ LmsUser qid_f svaupel (LmsIdent "abcdefg") "abc" False now (Just $ LmsSuccess $ n_day 1) (n_day' (-1)) (Just now) (Just $ n_day' 0) Nothing - void . insert' $ LmsUser qid_f gkleen (LmsIdent "hijklmn") "@#!" True now (Just $ LmsBlocked $ utctDay now) (n_day' (-2)) (Just now) (Just $ n_day' (-4)) Nothing - void . insert' $ LmsUser qid_f tinaTester (LmsIdent "qwvu") "45678" True now (Just $ LmsSuccess $ n_day (-22)) (n_day' (-3)) (Just $ n_day' (-1)) (Just $ n_day' (-1)) Nothing - void . insert' $ LmsUser qid_f maxMuster (LmsIdent "xyz") "a1b2c3" False now (Just $ LmsBlocked $ n_day (-11)) (n_day' (-4)) (Just $ n_day' (-2)) (Just $ n_day' (-2)) Nothing - void . insert' $ LmsUser qid_f fhamann (LmsIdent "123") "456" False now Nothing now Nothing Nothing Nothing + void . insert' $ LmsUser qid_f jost (LmsIdent "ijk" ) "123" False now Nothing Nothing now Nothing (Just $ n_day' (-7)) (Just $ n_day' (-5)) False False + void . insert' $ LmsUser qid_f svaupel (LmsIdent "abcdefg") "abc" False now (Just LmsSuccess) (Just $ n_day' 1) (n_day' (-1)) (Just now) (Just $ n_day' 0) Nothing True False + void . insert' $ LmsUser qid_f gkleen (LmsIdent "hijklmn") "@#!" True now (Just LmsBlocked) (Just $ now) (n_day' (-2)) (Just now) (Just $ n_day' (-4)) Nothing False True + void . insert' $ LmsUser qid_f tinaTester (LmsIdent "qwvu") "45678" True now (Just LmsSuccess) (Just $ n_day' (-22)) (n_day' (-3)) (Just $ n_day' (-1)) (Just $ n_day' (-1)) Nothing True True + void . insert' $ LmsUser qid_f maxMuster (LmsIdent "xyz") "a1b2c3" False now (Just LmsBlocked) (Just $ n_day' (-11)) (n_day' (-4)) (Just $ n_day' (-2)) (Just $ n_day' (-2)) Nothing True True + void . insert' $ LmsUser qid_f fhamann (LmsIdent "123") "456" False now Nothing Nothing now Nothing Nothing Nothing False False void . insert $ PrintJob "TestJob1" "AckTestJob1" "job1" "No Text herein." (n_day' (-1)) Nothing Nothing (Just svaupel) Nothing (Just qid_f) Nothing void . insert $ PrintJob "TestJob2" "AckTestJob2" "job2" "No Text herein." (n_day' (-3)) (Just $ n_day' (-1)) (Just jost) (Just svaupel) Nothing (Just qid_f) (Just $ LmsIdent "ijk") @@ -1090,7 +1102,7 @@ fillDb = do , exceptEnd = TimeOfDay 16 20 0 } , ExceptOccur - { exceptDay = succ $ succ $ secondDay + { exceptDay = succ $ succ secondDay , exceptStart = TimeOfDay 10 12 0 , exceptEnd = TimeOfDay 12 13 0 } @@ -1102,7 +1114,7 @@ fillDb = do , tutorialDeregisterUntil = jtt TermDayLectureStart (-5) (Just Monday) toMidnight , tutorialLastChanged = now , tutorialTutorControlled = True - , tutorialFirstDay = Just $ succ $ succ $ firstDay + , tutorialFirstDay = Just $ succ $ succ firstDay } when (odd tyear) $ void . insert' $ Exam diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs index d6fe5662d..fe9eb7325 100644 --- a/test/Model/TypesSpec.hs +++ b/test/Model/TypesSpec.hs @@ -403,9 +403,18 @@ instance Arbitrary SchoolAuthorshipStatementMode where instance Arbitrary SheetAuthorshipStatementMode where arbitrary = genericArbitrary +instance Arbitrary LmsBool where + arbitrary = LmsBool <$> arbitrary + instance Arbitrary LmsStatus where arbitrary = genericArbitrary +instance Arbitrary LmsState where + arbitrary = genericArbitrary + +instance Arbitrary LmsDay where + arbitrary = LmsDay <$> arbitrary + deriving newtype instance Arbitrary LmsIdent spec :: Spec @@ -521,8 +530,14 @@ spec = do [ eqLaws, ordLaws, showLaws, showReadLaws, boundedEnumLaws, finiteLaws, pathPieceLaws, jsonLaws, jsonKeyLaws, persistFieldLaws, binaryLaws, httpApiDataLaws ] lawsCheckHspec (Proxy @SheetAuthorshipStatementMode) [ eqLaws, ordLaws, showLaws, showReadLaws, boundedEnumLaws, finiteLaws, pathPieceLaws, jsonLaws, jsonKeyLaws, persistFieldLaws, binaryLaws, httpApiDataLaws ] + lawsCheckHspec (Proxy @LmsBool) + [ eqLaws, ordLaws, showLaws, showReadLaws, csvFieldLaws ] lawsCheckHspec (Proxy @LmsStatus) [ eqLaws, ordLaws, showLaws, showReadLaws, jsonLaws ] + lawsCheckHspec (Proxy @LmsState) + [ eqLaws, ordLaws, showLaws, showReadLaws, boundedEnumLaws, finiteLaws, csvFieldLaws ] + lawsCheckHspec (Proxy @LmsDay) + [ eqLaws, ordLaws, showLaws, showReadLaws, csvFieldLaws ] describe "TermIdentifier" $ do it "has compatible encoding/decoding to/from Text" . property $ @@ -627,10 +642,6 @@ spec = do showCompactCorrectorLoad Load{ byTutorial = Nothing, byProportion = 0, byDeficit = 0 } CorrectorNormal `shouldBe` "-D" showCompactCorrectorLoad Load{ byTutorial = Nothing, byProportion = 1, byDeficit = 0 } CorrectorMissing `shouldBe` "[1.0 - D]" showCompactCorrectorLoad Load{ byTutorial = Nothing, byProportion = 1, byDeficit = 0 } CorrectorExcused `shouldBe` "{1.0 - D}" - describe "Semigroup LmsStatus" $ do - it "lmsStatusDay merges to earliest" . property $ - \p1 p2 -> lmsStatusDay (p1 <> p2) == min (lmsStatusDay p1) (lmsStatusDay p2) - termExample :: (TermIdentifier, Text) -> Expectation termExample (term, encoded) = example $ do