fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge branch 'test'

Browse Source
This commit is contained in:
Steffen Jost 2023-09-20 12:29:41 +00:00
commit 29e5ed25df
81 changed files with 2767 additions and 956 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

95
CHANGELOG.md
View File

@ -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)

6
messages/uniworx/categories/admin/de-de-formal.msg
View File

@ -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

6
messages/uniworx/categories/admin/en-eu.msg
View File

@ -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

4
messages/uniworx/categories/avs/de-de-formal.msg
View File

@ -34,4 +34,6 @@ TableAvsActiveCards: Gültige Ausweise
AvsCardColorGreen: Grün
AvsCardColorBlue: Blau
AvsCardColorRed: Rot
AvsCardColorYellow: Gelb
AvsCardColorYellow: Gelb
LastAvsSynchronisation: Letzte AVS-Synchronisation
LastAvsSynchError: Letzte AVS-Fehlermeldung

4
messages/uniworx/categories/avs/en-eu.msg
View File

@ -34,4 +34,6 @@ TableAvsActiveCards: Valid Cards
AvsCardColorGreen: Green
AvsCardColorBlue: Blue
AvsCardColorRed: Red
AvsCardColorYellow: Yellow
AvsCardColorYellow: Yellow
LastAvsSynchronisation: Last AVS synchronisation
LastAvsSynchError: Last AVS Error

52
messages/uniworx/categories/qualification/de-de-formal.msg
View File

@ -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"}.

46
messages/uniworx/categories/qualification/en-eu.msg
View File

@ -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"}.

2
messages/uniworx/categories/settings/de-de-formal.msg
View File

@ -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}

2
messages/uniworx/categories/settings/en-eu.msg
View File

@ -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}

13
messages/uniworx/utils/navigation/menu/de-de-formal.msg
View File

@ -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

17
messages/uniworx/utils/navigation/menu/en-eu.msg
View File

@ -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

4
messages/uniworx/utils/table_column/de-de-formal.msg
View File

@ -85,4 +85,6 @@ TableJobLockTime: Bearbeitung seit
TableJobLockInstance: Bearbeiter
TableJobCreationInstance: Ersteller
ActJobDelete: Job entfernen
TableJobActDeleteFeedback n@Int m@Int: #{n}/#{m} Jobs entfernt
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.

4
messages/uniworx/utils/table_column/en-eu.msg
View File

@ -85,4 +85,6 @@ TableJobLockTime: Lock time
TableJobLockInstance: Worker
TableJobCreationInstance: Creator
ActJobDelete: Delete job
TableJobActDeleteFeedback n@Int m@Int: #{n}/#{m} queued jobs deleted
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.

53
models/lms.model
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
-- SPDX-FileCopyrightText: 2022-23 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- 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

12
models/print.model
View File

@ -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

2
nix/docker/version.json
View File

@ -1,3 +1,3 @@
{
"version": "27.4.18"
"version": "27.4.33"
}

2
package-lock.json generated
View File

@ -1,6 +1,6 @@
{
"name": "uni2work",
"version": "27.4.18",
"version": "27.4.33",
"lockfileVersion": 1,
"requires": true,
"dependencies": {

2
package.json
View File

@ -1,6 +1,6 @@
{
"name": "uni2work",
"version": "27.4.18",
"version": "27.4.33",
"description": "",
"keywords": [],
"author": "",

2
package.yaml
View File

@ -1,5 +1,5 @@
name: uniworx
version: 27.4.18
version: 27.4.33
dependencies:
- base
- yesod

52
routes
View File

@ -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

29
src/Audit/Types.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>
-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,,Steffen Jost <s.jost@fraport.de>
--
-- 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)

74
src/Database/Esqueleto/Utils.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- 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)

7
src/Foundation/I18n.hs
View File

@ -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

51
src/Foundation/Navigation.hs
View File

@ -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

36
src/Handler/Admin.hs
View File

@ -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

316
src/Handler/Admin/Avs.hs
View File

@ -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|<h2>Error:</h2> #{msg}|]
Right (AvsResponsePerson pns) -> return $ Just [whamlet|
<ul>
$forall p <- pns
$forall p <- pns
<li>#{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|<h2>Error:</h2> #{msg}|]
Right (AvsResponseStatus pns) -> return $ Just [whamlet|
<ul>
$forall p <- pns
$forall p <- pns
<li>#{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|<h2>Error:</h2> #{msg}|]
Right (AvsResponseContact pns) -> return $ Just [whamlet|
<ul>
$forall AvsDataContact{..} <- pns
$forall AvsDataContact{..} <- pns
<li>
<ul>
<li>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|
<div .form-group >
<div .form-group__input>
<div .buttongroup>
^{modalBtn}
|]
|]
modalBtn = btnModal MsgBtnAvsRevokeUnknown (btnClasses BtnAvsRevokeUnknown) (Right youSureWgt)
youSureWgt = [whamlet|
<h1>
@ -411,133 +413,144 @@ getProblemAvsSynchR = do
<p>
^{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|
<p>
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.
<p>
<dl .deflist>
@ -664,28 +698,94 @@ getAdminAvsUserR uuid = do
<i>(bevorzugt)
<dd .deflist__dd>
$case mbContact
$of Left err
$of Left err
Fehler: #{tshow err}
$of Right contactInfo
#{decodeUtf8 (Pretty.encodePretty (toJSON contactInfo))}
#{decodeUtf8 (Pretty.encodePretty (toJSON contactInfo))}
<dt .deflist__dt>PersonStatus und mehrere PersonSearch <br>
<i>(benötigt mehrere AVS Abfragen)
<dd .deflist__dd>
$maybe dataPerson <- mbDataPerson
#{decodeUtf8 (Pretty.encodePretty (toJSON dataPerson))}
$nothing
Keine Daten erhalten.
$nothing
Keine Daten erhalten.
<h3>
Provisorische formatierte Ansicht
<p>
Generisch formatierte Ansicht, die zeigt, in welche Richtung die Endansicht gehen könnte.
<p>
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.
<p>
<p>
^{foldMap jsonWidget mbContact}
<p>
<p>
^{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}|]

2
src/Handler/Admin/Test.hs
View File

@ -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

2
src/Handler/Course/List.hs
View File

@ -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)

51
src/Handler/Course/Users.hs
View File

@ -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

283
src/Handler/LMS.hs
View File

@ -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

3
src/Handler/LMS/Fake.hs
View File

@ -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{..}

213
src/Handler/LMS/Learners.hs Normal file
View File

@ -0,0 +1,213 @@
-- SPDX-FileCopyrightText: 2023 Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- 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

334
src/Handler/LMS/Report.hs Normal file
View File

@ -0,0 +1,334 @@
-- SPDX-FileCopyrightText: 2023 Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- 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
<form method=post enctype=#{enctype}>
^{widget}
<p>
<input type=submit>
|]
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

6
src/Handler/LMS/Userlist.hs
View File

@ -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

6
src/Handler/LMS/Users.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
-- SPDX-FileCopyrightText: 2022-23 Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- 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

79
src/Handler/PrintCenter.hs
View File

@ -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

47
src/Handler/Profile.hs
View File

@ -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

195
src/Handler/Qualification.hs
View File

@ -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

2
src/Handler/Tutorial/Form.hs
View File

@ -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

14
src/Handler/Tutorial/Users.hs
View File

@ -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

5
src/Handler/Utils/Avs.hs
View File

@ -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)

2
src/Handler/Utils/DateTime.hs
View File

@ -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

170
src/Handler/Utils/LMS.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
-- SPDX-FileCopyrightText: 2022-23 Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- 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 =
<dd>_{MsgLmsStatusExpired}
<dt>^{icon IconOK}
<dd>_{MsgLmsStatusSuccess}
$if extendedInfo
<dt>^{icon IconLocked}
<dd>_{MsgLmsStatusLocked}
<dt>^{icon IconUnlocked}
<dd>_{MsgLmsStatusUnlocked}
<dt>^{icon IconResetTries}
<dd>_{MsgLmsStatusResetTries}
<p>
_{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

267
src/Handler/Utils/Qualification.hs
View File

@ -1,7 +1,8 @@
-- SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
-- SPDX-FileCopyrightText: 2022-23 Steffen Jost <s.jost@fraport.de>
--
-- 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
) => 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

77
src/Handler/Utils/Table/Cells.hs
View File

@ -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|&emsp;|]
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

16
src/Handler/Utils/Table/Columns.hs
View File

@ -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)
----------------

9
src/Handler/Utils/Table/Pagination.hs
View File

@ -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
<p>
_{msg}
|]
cellTooltipIcon :: (RenderMessage UniWorX msg, IsDBTable m a) => Maybe Icon -> msg -> DBCell m a -> DBCell m a
cellTooltipIcon icn = cellTooltipWgt icn . msg2widget

43
src/Handler/Utils/Users.hs
View File

@ -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

35
src/Handler/Utils/Widgets.hs
View File

@ -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|
<span .tooltip__handle .#{statusToUrgencyClass sts}>
^{wgt}
|]
statusWidget :: MessageStatus -> Widget -> Widget
statusWidget sts wgt =
[whamlet|
<span .tooltip__handle .#{statusToUrgencyClass sts}>
^{wgt}
|]
heatedWidget :: Milli -> Widget -> Widget
heatedWidget ht wgt =
[whamlet|
<span .heated style="--hotness: #{ht}">
^{wgt}
|]
examOccurrenceMappingDescriptionWidget :: ExamOccurrenceRule -> Set ExamOccurrenceMappingDescription -> Widget
examOccurrenceMappingDescriptionWidget rule descriptions = $(widgetFile "widgets/exam-occurrence-mapping-description")
where

1
src/Jobs.hs
View File

@ -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

269
src/Jobs/Handler/LMS.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
-- SPDX-FileCopyrightText: 2022-23 Steffen Jost <s.jost@fraport.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- 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|]

60
src/Jobs/Handler/Print.hs Normal file
View File

@ -0,0 +1,60 @@
-- SPDX-FileCopyrightText: 2023 Steffen Jost <s.jost@fraport.de>
--
-- 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

14
src/Jobs/Handler/SendNotification/Qualification.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
-- SPDX-FileCopyrightText: 2022-23 Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- 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

13
src/Jobs/Types.hs
View File

@ -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

6
src/Model.hs
View File

@ -243,3 +243,9 @@ instance IsFileReference MaterialFile where
fileReferenceTitleField = MaterialFileTitle
fileReferenceContentField = MaterialFileContent
fileReferenceModifiedField = MaterialFileModified
deriveJSON defaultOptions
{ tagSingleConstructors = False
, fieldLabelModifier = camelToPathPiece' 2
, omitNothingFields = True
} ''QualificationUserBlock

4
src/Model/Migration.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>
-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
--
-- 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

62
src/Model/Migration/Definitions.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
--
-- 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)

15
src/Model/Migration/Types.hs
View File

@ -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

116
src/Model/Types/Avs.hs
View File

@ -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

142
src/Model/Types/Lms.hs
View File

@ -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

6
src/Model/Types/Security.hs
View File

@ -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

19
src/Utils.hs
View File

@ -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

2
src/Utils/Avs.hs
View File

@ -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
}

5
src/Utils/DateTime.hs
View File

@ -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 }

12
src/Utils/Icon.hs
View File

@ -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:

10
src/Utils/Lens.hs
View File

@ -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

1
src/Utils/Print/CourseCertificate.hs
View File

@ -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

1
src/Utils/Print/ExpireQualification.hs
View File

@ -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

1
src/Utils/Print/RenewQualification.hs
View File

@ -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

5
src/Utils/Set.hs
View File

@ -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)

2
start.sh
View File

@ -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

14
templates/admin-problems.hamlet
View File

@ -36,7 +36,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
<section>
<h2>
_{MsgProblemsHeadingUsers}
_{MsgProblemsHeadingNotifications}
<dl .deflist>
<dt .deflist__dt>^{flagError usersAreReachable}
@ -45,6 +45,16 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
<dt .deflist__dt>^{flagError noStalePrintJobs}
<dd .deflist__dd>^{simpleLinkI (MsgProblemsNoStalePrintJobs cutOffPrintDays) PrintCenterR}
<dt .deflist__dt>^{flagError noBadAPCids}
<dd .deflist__dd>_{MsgProblemsNoBadAPCIds}
$maybe reroute <- rerouteMail
<dt .deflist__dt>^{flagWarning False}
<dd .deflist__dd>_{MsgMailRerouteTo reroute}
<dd .deflist__dd>_{MsgMailRerouteTo reroute}
<section>
<h2>
_{MsgProblemsHeadingMisc}
<dl .deflist>
<dt .deflist__dt>^{flagError noAvsSynchProblems}
<dd .deflist__dd>^{simpleLinkI MsgProblemsNoAvsSynchProblems ProblemAvsErrorR}

18
templates/letter/din5008.latex
View File

@ -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}

18
templates/letter/din5008with_pin.latex
View File

@ -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}

18
templates/letter/plain_article.latex
View File

@ -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}

11
templates/lms-report.hamlet Normal file
View File

@ -0,0 +1,11 @@
$newline never
$# SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
$#
$# SPDX-License-Identifier: AGPL-3.0-or-later
<p>
^{lmsTable}
<p>
<a href=@{directUploadLink}>
_{MsgLmsDirectUpload}

26
templates/lms-user.hamlet
View File

@ -11,19 +11,28 @@ $else
<section>
<div .container>
<h2>
#{qualificationShorthand quali} - #{qualificationName quali} (#{qualificationSchool quali}) &nbsp; #{boolSymbol (E.unValue validity)}
#{qualificationShorthand quali} #
#{statusQualificationBlock (E.unValue validity)} #
#{qualificationName quali} (#{qualificationSchool quali})
<div .container>
<dl .deflist>
$maybe (Entity _ qualUsr) <- mbQualUsr
$maybe (Entity quid qualUsr) <- mbQualUsr
<dt .deflist__dt>_{MsgLmsQualificationValidUntil}
<dd .deflist__dd>^{formatTimeW SelFormatDate (qualificationUserValidUntil qualUsr)}
$if not (qualificationUserScheduleRenewal qualUsr)
\ #{icon IconNoNotification}
$maybe (qblock) <- qualificationUserBlockedDue qualUsr
$maybe qblock <- Map.lookup quid qblocks
<dt .deflist__dt>_{MsgTableQualificationBlockedDue}
<dd .deflist__dd>^{formatTimeW SelFormatDate (qualificationBlockedDay qblock)}
\ #{icon IconBlocked}
\ #{qualificationBlockedReason qblock}
<dd .deflist__dd>
<ul>
$forall (Entity _ block, blockerDN) <- qblock
<li>
#{iconQualificationBlock (view _qualificationUserBlockUnblock block)}
\ #{view _qualificationUserBlockReason block} #
$maybe bdn <- E.unValue blockerDN
^{editedByW SelFormatDateTime (view _qualificationUserBlockFrom block) bdn}
$nothing
^{formatTimeW SelFormatDateTime (view _qualificationUserBlockFrom block)}
<dt .deflist__dt>_{MsgTableQualificationLastRefresh}
<dd .deflist__dd>^{formatTimeW SelFormatDate (qualificationUserLastRefresh qualUsr)}
<dt .deflist__dt>_{MsgTableQualificationFirstHeld}
@ -57,5 +66,6 @@ $else
$maybe ts <- lmsUserEnded lmsUsr
<dt .deflist__dt>_{MsgTableLmsEnded}
<dd .deflist__dd>^{formatTimeW SelFormatDateTime ts}
$nothing
<dt .deflist__dt>_{MsgLmsInactive}
<dd .deflist__dd>

13
templates/lms.hamlet
View File

@ -15,7 +15,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
<dd .deflist__dd>_{MsgMonths (fromIntegral dvalid)}
$maybe daudit <- qualificationAuditDuration quali
<dt .deflist__dt>_{MsgQualificationAuditDuration}
<dt .deflist__dt>_{MsgQualificationAuditDuration} ^{iconTooltip (msg2widget MsgQualificationAuditDurationTooltip) Nothing True}
<dd .deflist__dd>_{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
<dt .deflist__dt>_{MsgQualificationRefreshReminder} ^{iconTooltip (msg2widget MsgQualificationRefreshReminderTooltip) Nothing True}
<dd .deflist__dd>
$with drm <- cdMonths drefresh
$with drd <- cdDays drefresh
$if drm > 0
_{MsgMonths (fromIntegral drm)}
$if drd > 0
, #
$if drd > 0
_{MsgDays (fromIntegral drd)}
<dt .deflist__dt>_{MsgQualificationElearningStart}
<dd .deflist__dd>#{boolSymbol (qualificationElearningStart quali)}

4
templates/profileData.hamlet
View File

@ -22,11 +22,11 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
#{view _userAvsNoPerson avs}
$maybe avsError <- view _userAvsLastSynchError avs
<dt .deflist__dt>
_{MsgProfileLastAvsSynchError}
_{MsgLastAvsSynchError}
<dd .deflist__dd>
#{avsError}
<dt .deflist__dt>
_{MsgProfileLastAvsSynchronisation}
_{MsgLastAvsSynchronisation}
<dd .deflist__dd>
^{formatTimeW SelFormatDateTime (view _userAvsLastSynch avs)}
<dt .deflist__dt>

62
test/Database/Fill.hs
View File

@ -695,38 +695,50 @@ fillDb = do
let f_descr = Just $ htmlToStoredMarkup [shamlet|<p>Berechtigung zum Führen eines Fahrzeuges auf den Fahrstrassen des Vorfeldes.|]
let r_descr = Just $ htmlToStoredMarkup [shamlet|<p>Berechtigung zum Führen eines Fahrzeuges auf dem gesamten Rollfeld.|]
let l_descr = Just $ htmlToStoredMarkup [shamlet|<p>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

19
test/Model/TypesSpec.hs
View File

@ -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