Merge branch 'test'

CHANGELOG.md

@@ -2,6 +2,101 @@
 
 All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines.
 
+## [27.4.33](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/t27.4.32...t27.4.33) (2023-09-20)
+
+
+### Bug Fixes
+
+* **time:** midnight timezone conversion bug eliminated ([dfa07a9](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/dfa07a95eb29f1fceec258a466e1e7c779ff6e5c))
+
+## [27.4.32](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/t27.4.31...t27.4.32) (2023-09-19)
+
+
+### Bug Fixes
+
+* **lms:** ensure lms uniqueness across all qualifications ([b85c8bd](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/b85c8bd74f8db526fb1cbb43ff12a24b93c07eb3))
+* **lms:** simultaneous block/unblock lets unblock win in all situations ([ecd1a0f](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ecd1a0fc210d1340bff5c79d8bb676a47654b509))
+
+## [27.4.31](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/t27.4.30...t27.4.31) (2023-09-13)
+
+## [27.4.30](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/t27.4.29...t27.4.30) (2023-09-11)
+
+
+### Bug Fixes
+
+* **lms:** reset e-learning more lenient ([8b0737e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/8b0737e2aabc7153ae3a3df4f97f86ffc8592e7a))
+
+## [27.4.29](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/t27.4.28...t27.4.29) (2023-09-07)
+
+
+### Bug Fixes
+
+* **build:** v2 ([ac77aa1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ac77aa176a3c3977c4a802e5ed534fa2850528fe))
+
+## [27.4.28](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/t27.4.27...t27.4.28) (2023-09-07)
+
+## [27.4.27](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/t27.4.26...t27.4.27) (2023-09-07)
+
+## [27.4.26](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/t27.4.25...t27.4.26) (2023-09-04)
+
+
+### Bug Fixes
+
+* **lms:** accept success for no-status learners and print several more debug messages processing reports ([a7ed659](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/a7ed659866de1d4a178bbe4e8f9cd8fbc629c724))
+
+## [27.4.25](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/t27.4.24...t27.4.25) (2023-09-01)
+
+
+### Bug Fixes
+
+* **build:** add missing file ([1fd24f6](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/1fd24f608dc9202fa98f52f7908f4be908a18efc))
+
+## [27.4.24](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/t27.4.23...t27.4.24) (2023-08-30)
+
+
+### Bug Fixes
+
+* **lms:** filter by status ([a74c3d8](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/a74c3d80cada4f9d224365727dab9676cc905f54))
+* **lms:** negate learner locking condition ([a452b03](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/a452b032c43dbdfd086ffa4793c83ecc32c450f8))
+
+## [27.4.23](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/t27.4.22...t27.4.23) (2023-08-29)
+
+## [27.4.22](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/t27.4.21...t27.4.22) (2023-08-29)
+
+
+### Bug Fixes
+
+* **build:** refix test commits somehow ([34ada53](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/34ada53de0cc5804468791854e824b730fcc84de))
+
+## [27.4.21](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/t27.4.20...t27.4.21) (2023-07-26)
+
+
+### Bug Fixes
+
+* **apc:** apc cannot distinguish ij from ji, partial fix only. Needs new font ([b4ba0a3](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/b4ba0a30dc7c513bb9e3c567ca771d5d75de4343))
+* **block:** negate condition to test ([9cf7f39](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/9cf7f3965aa95f0b8f2a1574dbad90c0257edafd))
+* **qualification:** new block/unblock mechanism working now ([5397c7b](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/5397c7be353fc1b1e8310f66b49a9b93ee890253))
+* **users:** fix [#112](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/112) and also add some convenience ([35096ac](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/35096ace01a2bc2a2d666794bb1ff92f52b3edec))
+* **users:** fix [#112](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/112) working now ([88bf21c](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/88bf21c9c5de3755ea6591c97dc1f99a928914d5))
+
+## [27.4.20](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/t27.4.19...t27.4.20) (2023-07-18)
+
+
+### Bug Fixes
+
+* **build:** prevent migration on non-existing table ([5bb49cd](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/5bb49cd88941e510a50759efaad88690f841ca47))
+
+## [27.4.19](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/t27.4.18-2...t27.4.19) (2023-07-17)
+
+
+### Bug Fixes
+
+* **build:** major qualfication block quirks fixed ([ab48e40](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ab48e40ac7e5024b7847b3995e6ae16d1c401c60))
+* **build:** minor ([f9930f2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/f9930f2a00d1e0f0af9b7f2af7c387bcc09cef5a))
+* **db:** migration qualification block ([3d59527](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/3d595271d979f29ed8bbc546f495e5ad1deae5ca))
+* **job:** fix [#95](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/95) by implementing queued job deletion for admins ([5b9a554](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/5b9a5545457dbe506d20f7362fb6e0d6bae4f7f4))
+* **test:** LmsStatus is no longer a semigroup ([bf8cd4f](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/bf8cd4fa899bccd4a37906a4d899aca6ca25d726))
+
 ## [27.4.18](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.14...v27.4.18) (2023-07-17)
 
 ## [27.4.17](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.14...v27.4.17) (2023-07-17)

messages/uniworx/categories/admin/de-de-formal.msg

@@ -98,6 +98,8 @@ TestDownloadFromDatabase: Generierung während Download aus Datenbank
 
 ProblemsHeading: Problemübersicht
 ProblemsHeadingDrivers: Fahrberechtigungen
+ProblemsHeadingNotifications: Benachrichtigungen
+ProblemsHeadingMisc: Allgemein
 ProblemsAvsProblem: Synchronisation mit AVS/MoBaKo komplett fehlgeschlagen
 ProblemsDriverSynch n@Int: #{tshow n} Diskrepanzen zwischen AVS und FRADrive
 ProblemsDriverSynch0: Alle Sperrungen von Vorfeld-Fahrberechtigungen 'F' sind im AVS eingetragen
@@ -106,9 +108,10 @@ ProblemsDriverSynch1up: Alle gültigen Vorfeld-Fahrberechtigungen 'F' sind im AV
 ProblemsDriverSynch2: Alle gültigen Rollfeld-Fahrberechtigungen 'R' sind im AVS eingetragen
 ProblemsRDriversHaveFs: Alle Inhaber einer Rollfeld-Fahrberechtigung besitzen auch eine gültige Vorfeld-Fahrberechtigung
 ProblemsDriversHaveAvsIds: Alle Inhaber einer Fahrberechtigung konnten einer AVS Identifikationsnummer zugeordnet werden
-ProblemsHeadingUsers: Allgemein
 ProblemsUsersAreReachable: Für alle Benutzer ist eine E-Mail oder postalische Adresse bekannt 
 ProblemsNoStalePrintJobs n@Integer: Alle Briefversandaufträge der vergangenen #{show n} Tage wurden von der Druckerei bestätigt
+ProblemsNoBadAPCIds: Alle kürzlich empfangenen Druckauftragsbestätigungen waren gültig
+ProblemsNoAvsSynchProblems: Synchronisation mit Ausweisverwaltungssystem (AVS) meldete keine Probleme
 ProblemsUnreachableHeading: Unerreichbare Benutzer
 ProblemsUnreachableBody: Benutzer ohne E-Mail oder Postadresse, welche z.B. bei ablaufenden Berechtigungen nicht benachrichtigt werden können:
 ProblemsRWithoutFHeading: Fahrer mit R ohne F
@@ -116,3 +119,4 @@ ProblemsRWithoutFBody: Diese Fahrer sind wegen einer ungültigen Vorfeld-Fahrber
 ProblemsNoAvsIdHeading: Fahrer ohne AVS-Id
 ProblemsNoAvsIdBody: Fahrer mit gültiger Fahrberechtigung in FRADrive, welche trotzdem nicht fahren dürfen, da die Fahrberechtigung aufgrund einer unbekannten AVS Id nicht an die Ausweisstelle übermittelt werden konnte:
 ProblemsAvsSynchHeading: Synchronisation AVS Fahrberechtigungen
+ProblemsAvsErrorHeading: Fehlermeldungen

messages/uniworx/categories/admin/en-eu.msg

@@ -98,6 +98,8 @@ TestDownloadFromDatabase: Generate while streaming from database
 
 ProblemsHeading: Overview Problems
 ProblemsHeadingDrivers: Driving Licences
+ProblemsHeadingNotifications: User communication
+ProblemsHeadingMisc: Miscellaneous
 ProblemsAvsProblem: Synchronisation with AVS/MoBaKo failed entirely
 ProblemsDriverSynch n: #{tshow n} mismatches between AVS and FRADrive
 ProblemsDriverSynch0: All revocations of apron driving licences 'F' were successfully registered with AVS
@@ -106,9 +108,10 @@ ProblemsDriverSynch1up: All valid apron driving licences 'F' were successfully r
 ProblemsDriverSynch2: All valid maneuvering area driving licences 'R' were successfully registered with AVS
 ProblemsRDriversHaveFs: All driving licence 'R' holders also have a valid 'F' licence
 ProblemsDriversHaveAvsIds: All driving licence holder could be matched with their AVS id
-ProblemsHeadingUsers: Miscellaneous
 ProblemsUsersAreReachable: Either Email or postal address is known for all users
 ProblemsNoStalePrintJobs n: All requests for letter mailing within the last #{show n} days were acknowledged as printed by the airport printing center
+ProblemsNoBadAPCIds: All recently received print job ids from Airport Print Center were legit
+ProblemsNoAvsSynchProblems: AVS synchronisation had not problems
 ProblemsUnreachableHeading: Unreachable Users
 ProblemsUnreachableBody: Users without Email nor postal address, who thus cannot be notified about expiring qualifications:
 ProblemsRWithoutFHeading: Drivers having 'R' but not 'F'
@@ -116,3 +119,4 @@ ProblemsRWithoutFBody: Drivers without apron driving licence are prohibited from
 ProblemsNoAvsIdHeading: Drivers without AVS id
 ProblemsNoAvsIdBody: Drivers having a valid apron driving licence within FRADrive only, but who may not drive since a missing AVS id prevents communication of the driving licence to AVS:
 ProblemsAvsSynchHeading: Synchronisation AVS Driving Licences
+ProblemsAvsErrorHeading: Error Log

messages/uniworx/categories/avs/de-de-formal.msg

@@ -35,3 +35,5 @@ AvsCardColorGreen: Grün
 AvsCardColorBlue: Blau
 AvsCardColorRed: Rot
 AvsCardColorYellow: Gelb
+LastAvsSynchronisation: Letzte AVS-Synchronisation
+LastAvsSynchError: Letzte AVS-Fehlermeldung

messages/uniworx/categories/avs/en-eu.msg

@@ -35,3 +35,5 @@ AvsCardColorGreen: Green
 AvsCardColorBlue: Blue
 AvsCardColorRed: Red
 AvsCardColorYellow: Yellow
+LastAvsSynchronisation: Last AVS synchronisation
+LastAvsSynchError: Last AVS Error

messages/uniworx/categories/qualification/de-de-formal.msg

@@ -8,10 +8,11 @@ QualificationDescription: Beschreibung
 QualificationValidIndicator: Gültigkeit
 QualificationValidDuration: Gültigkeitsdauer
 QualificationAuditDuration: Aufbewahrung Audit Log
+QualificationAuditDurationTooltip: Optionaler Zeitraum zur Löschung von E‑Learning Daten. Hiweis: Der E‑Learning Server kann seine anonymisierten Daten schon früher löschen.
 QualificationRefreshWithin: Erneurerungszeitraum
-QualificationRefreshWithinTooltip: Optionaler Zeitraum vor Ablauf für automatischen Start des E‑Learnings und Versand einer Benachrichtigung per Brief oder Email
+QualificationRefreshWithinTooltip: Optionaler Zeitraum vor Ablauf für automatischen Start des E‑Learnings und Versand einer Benachrichtigung per Brief oder Email.
 QualificationRefreshReminder: 2. Erinnerung
-QualificationRefreshReminderTooltip: Optionaler Zeitraum vor Ablauf zur Versendung einer zweiten Erinnerung per Brief oder Email mit identischen Zugangsdaten, sofern in diesem Zeitraum vor Ablauf noch keine Ablaufbenachrichtigung versendet wurde
+QualificationRefreshReminderTooltip: Optionaler Zeitraum vor Ablauf zur Versendung einer zweiten Erinnerung per Brief oder Email mit identischen Zugangsdaten, sofern in diesem Zeitraum vor Ablauf noch keine Ablaufbenachrichtigung versendet wurde.
 QualificationElearningStart: Wird das E‑Learning automatisch gestartet?
 QualificationExpiryNotification: Ungültigkeitsbenachrichtigung?
 QualificationExpiryNotificationTooltip: Nutzer werden benachrichtigt, wenn die Qualifikation ungültig wird, sofern der jeweilige Nutzer in seinen Benutzereinstellungen diese Art Benachrichtigung aktiviert hat.
@@ -26,14 +27,17 @@ LmsQualificationValidUntil: Gültig bis
 TableQualificationLastRefresh: Zuletzt erneuert
 TableQualificationLastNotified: Letzte Benachrichtigung
 TableQualificationFirstHeld: Erstmalig
-TableQualificationBlockedDue: Entzogen
+TableQualificationBlockedDue: Entzug
 TableQualificationBlockedTooltip: Wann wurde die Qualifikation vorübergehend außer Kraft gesetzt und warum wurde dies veranlasst?
-TableQualificationBlockedTooltipSimple: Wann wurde die Qualifikation aus besonderem Grund wiederrufen?
+TableQualificationBlockedTooltipSimple: Falls die Qualifikation aus besonderem Grund vorzeitig widerrufen wurde, so wird das Datum des Widerrufs angezeigt
+InfoQualificationBlockStatus: Besteht aktuell ein Entzug? Falsch bedeutet, dass ein Entzug zuletzt aufgehoben wurde
+InfoQualificationBlockFrom: Datum der letzten Änderungen eines Entzugs oder der Aufhebung eines Entzugs
 TableQualificationNoRenewal: Auslaufend
 TableQualificationNoRenewalTooltip: Es wird keine Benachrichtigung mehr versendet, wenn diese Qualifikation ablaufen sollte. Die Qualifikation kann noch weiterhin gültig sein.
 QualificationScheduleRenewalTooltip: Wird eine Benachrichtigung versendet, falls diese Qualikation bald ablaufen sollte?
 QualificationUserNoRenewal: Läuft ohne Benachrichtigung aus
 QualificationUserNone: Für diese Person sind keine Qualifikationen registriert.
+QualificationGrantReason: Erteilungsbegründung
 QualificationBlockReason: Entzugsbegründung
 QualificationBlockNotify: Benachrichtigung verschicken
 QualificationBlockRemoveSupervisor: Alle Ansprechpartner löschen
@@ -46,6 +50,7 @@ TableLmsElearning: E‑Learning
 TableLmsPin: E‑Learning Passwort
 TableLmsResetPin: E-Learning Passwort zurücksetzen?
 TableLmsDatePin: E-Learning Passwort erstellt
+TableLmsDate: Datum
 TableLmsDelete: Löschen?
 TableLmsStaff: Interner Mitarbeiter?
 TableLmsStarted: Begonnen
@@ -57,11 +62,12 @@ TableLmsStatus: Status E‑Learning
 TableLmsStatusTooltip mbMonth@(Maybe Int): Zeigt #{maybeToMessage "bis zu " (fmap (flip pluralDEeN "Monat") mbMonth) " nach Abschluss"} den letzten Zustand eines E‑Learnings an:
 TableLmsStatusDay: Datum letzte Statusänderung E‑Learning
 TableLmsSuccess: Bestanden
-TableLmsFailed: Gesperrt
+TableLmsLock: Gesperrt
+TableLmsResetTries: E‑Learning Versuche zurücksetzen
 LmsStatusBlocked: Durchgefallen wegen zu vieler Fehlversuche
 LmsStatusExpired: Durchgefallen nach Fristablauf
 LmsStatusSuccess: E#{nonBreakableDash}Learning bestanden
-LmsStatusPlanned: E#{nonBreakableDash}Learning wird gerade eröffnet (nur für Admin sichtbar)
+LmsStatusPlanned: E#{nonBreakableDash}Learning wird gerade noch eröffnet (nur für Admin sichtbar)
 LmsStatusDelay: Hinweis: Statusänderung können in seltenen Fällen mehrere Stunden bis zur Anzeige benötigen.
 FilterLmsValid: Aktuell gültig
 FilterLmsRenewal: Erneuerung anstehend
@@ -69,17 +75,23 @@ FilterLmsNotified: Benachrichtigt
 FilterLmsNotificationDue: Benachrichtigung erforderlich
 CsvColumnLmsIdent: E‑Learning Identifikator, einzigartig pro Qualifikation und Teilnehmer
 CsvColumnLmsPin: Passwort E#{nonBreakableDash}Learning Zugang
-CsvColumnLmsResetPin: Wird das E-Learning Passwort bei der nächsten Synchronisation zurückgesetzt?
+CsvColumnLmsResetPin: Wird das E‑Learning Passwort bei der nächsten Synchronisation zurückgesetzt?
 CsvColumnLmsDelete: Wird der Identifikator in der E‑Learning Plattform bei der nächsten Synchronisation gelöscht?
 CsvColumnLmsStaff: Handelt es sich um einen internen Mitarbeiter? (Aus historischen Gründen, wird momentan ignoriert.)
-CsvColumnLmsSuccess: Zeitstempel der erfolgreichen Teilnahme (UTC)
+CsvColumnLmsSuccess: Zeitstempel der erfolgreichen Teilnahme
-CsvColumnLmsFailed: User was blocked by LMS, usually due to too many attempts
+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
+LmsResultUpdate: LMS Ergebnis Aktualisierung
-LmsResultCsvExceptionDuplicatedKey: CSV Import fand uneindeutigen Schlüssel
+LmsReportInsert: Neues LMS Ereignis
-LmsUserlistCsvExceptionDuplicatedKey: CSV Import fand uneindeutigen Schlüssel
+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
+LmsActReset: E‑Learning Fehlversuche zurücksetzen und entsperren
-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.
+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.
-LmsActRestartFeedback n@Int m@Int: #{n}/#{m} E-Learning wurden neu gestartet.
+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"}.

messages/uniworx/categories/qualification/en-eu.msg

@@ -8,10 +8,11 @@ QualificationDescription: Description
 QualificationValidIndicator: Validity
 QualificationValidDuration: Validity period
 QualificationAuditDuration: Audit log keept
+QualificationAuditDurationTooltip: Optional period for deletion of e‑learning data. Note that the e‑learning server may delete its anonymised data earlier.
 QualificationRefreshWithin: Refresh within
-QualificationRefreshWithinTooltip: Optional period before expiry to start e‑learning and send a notification by post or email
+QualificationRefreshWithinTooltip: Optional period before expiry to start e‑learning and send a notification by post or email.
 QualificationRefreshReminder: 2. Reminder
-QualificationRefreshReminderTooltip: Optional period before expiry to send a second notification by post or email once more, provided that no renewal notification was sent in this period before expiry
+QualificationRefreshReminderTooltip: Optional period before expiry to send a second notification by post or email once more, provided that no renewal notification was sent in this period before expiry.
 QualificationElearningStart: Is e‑learning automatically started?
 QualificationExpiryNotification: Invalidity notification?
 QualificationExpiryNotificationTooltip: Qualification holder are notfied upon invalidity, provided they have activated such notification in their user settings.
@@ -26,14 +27,17 @@ LmsQualificationValidUntil: Valid until
 TableQualificationLastRefresh: Last renewed
 TableQualificationLastNotified: Last notified
 TableQualificationFirstHeld: First held
-TableQualificationBlockedDue: Revoked
+TableQualificationBlockedDue: Revocations
 TableQualificationBlockedTooltip: Why and when was this qualification temporarily suspended?
-TableQualificationBlockedTooltipSimple: When was this qualification revoked due to extraordinary reasons?
+TableQualificationBlockedTooltipSimple: If a date is shown, this qualification has been revoked on that date due to extraordinary reasons
 TableQualificationNoRenewal: Discontinued
+InfoQualificationBlockStatus: Is the qualification currently revoked? False indicates, that a revocation had been lifted
+InfoQualificationBlockFrom: Date of last revocation or lifting of a revocation
 TableQualificationNoRenewalTooltip: No renewal notifications will be send for this qualification upon expiry. The qualification may still be valid.
 QualificationScheduleRenewalTooltip: Will there be a notification, if this qualification is about to expire soon?
 QualificationUserNoRenewal: Expires without further notification
 QualificationUserNone: No registered qualifications for this person.
+QualificationGrantReason: Reason for granting
 QualificationBlockReason: Reason for revoking
 QualificationBlockNotify: Send notification
 QualificationBlockRemoveSupervisor: Remove all supervisors
@@ -46,6 +50,7 @@ TableLmsPin: E‑learning password
 TableLmsElearning: E‑learning
 TableLmsResetPin: Reset E‑learning password?
 TableLmsDatePin: E‑learning password created
+TableLmsDate: Date
 TableLmsDelete: Delete?
 TableLmsStaff: Staff?
 TableLmsStarted: Started
@@ -57,11 +62,12 @@ TableLmsStatus: Status e‑learning
 TableLmsStatusTooltip mbMonth: Shows #{maybeToMessage "for up to " (fmap (flip pluralENsN "month") mbMonth) " after closure"} the last e#{nonBreakableDash}learning status change:
 TableLmsStatusDay: Date of last e‑learning status change
 TableLmsSuccess: Completed
-TableLmsFailed: Blocked
+TableLmsLock: Locked
+TableLmsResetTries: Reset e‑learning attempts
 LmsStatusBlocked: Failed after too many attempts
 LmsStatusExpired: Failed due to expiry
 LmsStatusSuccess: Passed
-LmsStatusPlanned: E#{nonBreakableDash}learning is about to be opened (visible to Admins only)
+LmsStatusPlanned: E#{nonBreakableDash}learning is about to be opened soon (visible to Admins only)
 LmsStatusDelay: Note that status changes may occassionaly require more than a hour to be displayed here.
 FilterLmsValid: Currently valid
 FilterLmsRenewal: Renewal due
@@ -70,16 +76,22 @@ FilterLmsNotificationDue: Notification due
 CsvColumnLmsIdent: E#{nonBreakableDash}learning identifier, unique for each qualification and user
 CsvColumnLmsPin: Password e#{nonBreakableDash}learning access
 CsvColumnLmsResetPin: Will the e#{nonBreakableDash}learning password be reset upon next synchronisation?
-CsvColumnLmsDelete: Will the identifier be deleted from the E‑learning platfrom upon next synchronisation?
+CsvColumnLmsDelete: Will the identifier be deleted from the e‑learning platfrom upon next synchronisation?
 CsvColumnLmsStaff: Is the user an internal staff member? (Legacy, currently ignored)
 CsvColumnLmsSuccess: Timestamp of successful completion (UTC)
-CsvColumnLmsFailed: Blockier durch LMS, üblicherweise wegen zu vieler Fehlversuche
+CsvColumnLmsResetTries: Reset number of used up e‑learning exam attempts
+CsvColumnLmsDate: Date of e‑learning event
+CsvColumnLmsResult: LMS Status
+CsvColumnLmsLock: E‑learning login is not permitted
 LmsUserlistInsert: New LMS user
 LmsUserlistUpdate: Update of LMS user
 LmsResultInsert: New LMS result
 LmsResultUpdate: Update of LMS result
-LmsResultCsvExceptionDuplicatedKey: CSV import with ambiguous key
+LmsReportInsert: New LMS event
-LmsUserlistCsvExceptionDuplicatedKey: CSV import with ambiguous key
+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
+LmsActReset: Reset and unlock 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.
+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"}.

messages/uniworx/categories/settings/de-de-formal.msg

@@ -94,8 +94,6 @@ TokensLastReset: Tokens zuletzt invalidiert
 ProfileNever: Nie
 ProfileLdapPrimaryKey: LDAP-Primärschlüssel
 ProfileLastLdapSynchronisation: Letzte LDAP-Synchronisation
-ProfileLastAvsSynchronisation: Letzte AVS-Synchronisation
-ProfileLastAvsSynchError: Letzte AVS-Fehlermeldung
 
 NotificationSettingsUpdate: Benachrichtigungs-Einstellungen erfolgreich gespeichert
 NotificationSettingsHeading displayName@Text: Benachrichtigungs-Einstellungen für #{displayName}

messages/uniworx/categories/settings/en-eu.msg

@@ -94,8 +94,6 @@ TokensLastReset: Tokens last reset
 ProfileNever: Never
 ProfileLdapPrimaryKey: LDAP primary key
 ProfileLastLdapSynchronisation: Last LDAP synchronisation
-ProfileLastAvsSynchronisation: Last AVS synchronisation
-ProfileLastAvsSynchError: Last AVS Error
 
 NotificationSettingsUpdate: Successfully updated notification settings
 NotificationSettingsHeading displayName: Notification settings for #{displayName}

messages/uniworx/utils/navigation/menu/de-de-formal.msg

@@ -120,18 +120,23 @@ MenuLanguage: Sprache
 MenuQualifications: Qualifikationen
 MenuLms !ident-ok: E‑Learning
 MenuLmsEdit: Bearbeiten E‑Learning
-MenuLmsUser: Benutzer Qualifikationen
+MenuLmsUser: Benutzerqualifikationen
-MenuLmsUsers: Export E‑Learning Benutzer
+MenuLmsUserSchool: Bereichs Benutzerqualifikationen
-MenuLmsUserlist: Melden E‑Learning Benutzer
+MenuLmsUserAll: Alle Benutzerqualifikationen
-MenuLmsResult: Melden Ergebnisse E‑Learning
+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

messages/uniworx/utils/navigation/menu/en-eu.msg

@@ -119,20 +119,25 @@ MenuCourseEventEdit: Edit course type occurrence
 MenuLanguage: Language
 
 MenuQualifications: Qualifications
-MenuLms: E‑Learning
+MenuLms: E‑learning
-MenuLmsEdit: Edit E‑Learning
+MenuLmsEdit: Edit e‑learning
 MenuLmsUser: User Qualifications
-MenuLmsUsers: Download E‑Learning Users
+MenuLmsUserSchool: Institute User Qualifications
-MenuLmsUserlist: Upload E‑Learning Users
+MenuLmsUserAll: All User Qualifications
-MenuLmsResult: Upload E‑Learning Results
+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

messages/uniworx/utils/table_column/de-de-formal.msg

@@ -86,3 +86,5 @@ TableJobLockInstance: Bearbeiter
 TableJobCreationInstance: Ersteller
 ActJobDelete: Job entfernen
 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.

messages/uniworx/utils/table_column/en-eu.msg

@@ -86,3 +86,5 @@ TableJobLockInstance: Worker
 TableJobCreationInstance: Creator
 ActJobDelete: Delete job
 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.

models/lms.model

@@ -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
+  -- Reasons and temporary revocations are implemented through QualificationUserBlock
-  -- Begründungsfeld vorsehen
+  -- 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
@@ -108,17 +123,27 @@ LmsUser
   pin               Text
   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

models/print.model

@@ -17,3 +17,15 @@ PrintJob
   -- 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

nix/docker/version.json

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

package-lock.json

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

package.json

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

package.yaml

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

routes

@@ -75,6 +75,7 @@
 /admin/problems/no-avs-id     ProblemWithoutAvsId  GET
 /admin/problems/r-without-f   ProblemFbutNoR       GET
 /admin/problems/avs  					ProblemAvsSynchR 		 GET POST
+/admin/problems/avs/errors		ProblemAvsErrorR 		 GET
 
 /print                                PrintCenterR    GET POST  !system-printer
 /print/acknowledge/#Day/#Int/#Int     PrintAckR       GET POST  !system-printer
@@ -261,29 +262,38 @@
 !/#UUID CryptoUUIDDispatchR GET                               !free -- just redirect
 -- !/*{CI FilePath} CryptoFileNameDispatchR GET                  !free -- Disabled until preliminary check for valid cID exists
 
-/qualification                                          QualificationAllR         GET       !free
+/qualification                                          QualificationAllR           GET       !free
-/qualification/#SchoolId                                QualificationSchoolR      GET       !free
+/qualification/#SchoolId                                QualificationSchoolR        GET       !free
-/qualification/#SchoolId/#QualificationShorthand        QualificationR            GET POST  !free
+/qualification/#SchoolId/#QualificationShorthand        QualificationR              GET POST  !free
-/qualifications/sap/direct                              QualificationSAPDirectR   GET  -- !token -- SAP EXPORT -- TODO reinstate token requirement
+-- /qualification/#SchoolId/#QualificationShorthand/#CryptoUUIDUser QualificationUserR GET -- see LmsUserR
--- /qualification/CryptoUUIDUser/ -- maybe distingquish via URL
+/qualifications/sap/direct                              QualificationSAPDirectR     GET  -- !token -- SAP EXPORT -- TODO reinstate token requirement
+
 
 -- LMS
-/lms                                                    LmsAllR               GET POST
+/lms                                                        LmsAllR                 GET POST
-/lms/#SchoolId                                          LmsSchoolR            GET
+/lms/#SchoolId                                              LmsSchoolR              GET
-/lms/#SchoolId/#QualificationShorthand                  LmsR  				        GET POST
+/lms/#SchoolId/#QualificationShorthand                      LmsR  				          GET POST
-/lms/#SchoolId/#QualificationShorthand/edit             LmsEditR			        GET POST
+/lms/#SchoolId/#QualificationShorthand/edit                 LmsEditR			          GET POST
-/lms/#SchoolId/#QualificationShorthand/users            LmsUsersR	            GET
+-- old V1 LMS Interface
-/lms/#SchoolId/#QualificationShorthand/users/direct     LmsUsersDirectR	      GET       !token -- LMS 
+/lms/#SchoolId/#QualificationShorthand/users                LmsUsersR	              GET
-/lms/#SchoolId/#QualificationShorthand/userlist         LmsUserlistR	        GET POST
+/lms/#SchoolId/#QualificationShorthand/users/direct         LmsUsersDirectR	        GET       !token -- LMS 
-/lms/#SchoolId/#QualificationShorthand/userlist/upload  LmsUserlistUploadR	  GET POST  !development
+/lms/#SchoolId/#QualificationShorthand/userlist             LmsUserlistR	          GET POST
-/lms/#SchoolId/#QualificationShorthand/userlist/direct  LmsUserlistDirectR	      POST  !token -- LMS
+/lms/#SchoolId/#QualificationShorthand/userlist/upload      LmsUserlistUploadR	    GET POST  !development
-/lms/#SchoolId/#QualificationShorthand/result           LmsResultR            GET POST
+/lms/#SchoolId/#QualificationShorthand/userlist/direct      LmsUserlistDirectR	        POST  !token -- LMS, also remove JobLmsUserlist constructor
-/lms/#SchoolId/#QualificationShorthand/result/upload    LmsResultUploadR      GET POST  !development
+/lms/#SchoolId/#QualificationShorthand/result               LmsResultR              GET POST
-/lms/#SchoolId/#QualificationShorthand/result/direct    LmsResultDirectR          POST  !token -- LMS
+/lms/#SchoolId/#QualificationShorthand/result/upload        LmsResultUploadR        GET POST  !development
-/lms/#SchoolId/#QualificationShorthand/ident/#LmsIdent  LmsIdentR             GET       -- redirect to LmsR with filter-parameter
+/lms/#SchoolId/#QualificationShorthand/result/direct        LmsResultDirectR            POST  !token -- LMS, also remove JobLmsResults constructor
-/lmsuser/#CryptoUUIDUser                                LmsUserR              GET
+-- 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

src/Audit/Types.hs

@@ -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
+    , transactionLmsDay        :: UTCTime
-    , transactionLmsUser       :: Maybe UserId
+    , transactionLmsUser       :: UserId
     , transactionNote          :: Maybe Text
     , transactionReceived      :: UTCTime -- when was the csv file received?
     }
   | TransactionLmsSuccess
     { transactionQualification :: QualificationId
     , transactionLmsIdent      :: LmsIdent
-    , transactionLmsDay        :: Day
+    , transactionLmsDay        :: UTCTime
-    , transactionLmsUser       :: Maybe UserId
+    , 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)
 

src/Database/Esqueleto/Utils.hs

@@ -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
@@ -283,6 +302,17 @@ mkExactFilterLastWith cast lenslike row criterias
   | 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)
 

src/Foundation/I18n.hs

@@ -248,9 +248,16 @@ mkMessageVariant ''UniWorX ''ButtonMessage "messages/button" "de"
 mkMessageVariant ''UniWorX ''FrontendMessage "messages/frontend" "de-de-formal"
 
 embedRenderMessage ''UniWorX ''AvsLicence id -- required by UniWorXAvsMessages
+
 mkMessageAddition ''UniWorX "Qualification" "messages/uniworx/categories/qualification" "de-de-formal"
 mkMessageAddition ''UniWorX "Avs" "messages/uniworx/categories/avs" "de-de-formal"
 
+embedRenderMessage ''UniWorX ''LmsStatus (uncurry ((<>) . (<> "Status")) . Text.splitAt 3)
+
+instance RenderMessage UniWorX (Maybe LmsStatus) where -- useful for Filter with optionsFinite
+  renderMessage f ls (Just s) = renderMessage f ls s
+  renderMessage f ls Nothing  = renderMessage f ls MsgLmsStateOpen
+
 instance RenderMessage UniWorX AvsDataCardColor where
   renderMessage _foundation _ls (AvsCardColorMisc t) = Text.cons '*' t
   renderMessage f ls AvsCardColorGrün = renderMessage f ls MsgAvsCardColorGreen

src/Foundation/Navigation.hs

@@ -121,6 +121,7 @@ breadcrumb ProblemUnreachableR  = i18nCrumb MsgProblemsUnreachableHeading $ Just
 breadcrumb ProblemWithoutAvsId  = i18nCrumb MsgProblemsNoAvsIdHeading     $ Just AdminProblemsR
 breadcrumb ProblemFbutNoR       = i18nCrumb MsgProblemsRWithoutFHeading   $ Just AdminProblemsR
 breadcrumb ProblemAvsSynchR     = i18nCrumb MsgProblemsAvsSynchHeading    $ Just AdminProblemsR
+breadcrumb ProblemAvsErrorR     = i18nCrumb MsgProblemsAvsErrorHeading    $ Just ProblemAvsSynchR
 
 breadcrumb PrintCenterR     = i18nCrumb MsgMenuApc              Nothing
 breadcrumb PrintSendR       = i18nCrumb MsgMenuPrintSend      $ Just PrintCenterR
@@ -186,8 +187,17 @@ breadcrumb (LmsUserlistDirectR  ssh  qsh) = i18nCrumb MsgMenuLmsUpload     $ Jus
 breadcrumb (LmsResultR          ssh  qsh) = i18nCrumb MsgMenuLmsResult     $ Just $ LmsR          ssh qsh
 breadcrumb (LmsResultUploadR    ssh  qsh) = i18nCrumb MsgMenuLmsUpload     $ Just $ LmsResultR    ssh qsh
 breadcrumb (LmsResultDirectR    ssh  qsh) = i18nCrumb MsgMenuLmsUpload     $ Just $ LmsResultR    ssh qsh -- never displayed
+-- v2
+breadcrumb (LmsLearnersR        ssh  qsh) = i18nCrumb MsgMenuLmsLearners   $ Just $ LmsR          ssh qsh
+breadcrumb (LmsLearnersDirectR  ssh  qsh) = i18nCrumb MsgMenuLmsLearners   $ Just $ LmsLearnersR  ssh qsh -- never displayed, TypedContent
+breadcrumb (LmsReportR          ssh  qsh) = i18nCrumb MsgMenuLmsReport     $ Just $ LmsR          ssh qsh
+breadcrumb (LmsReportUploadR    ssh  qsh) = i18nCrumb MsgMenuLmsUpload     $ Just $ LmsReportR    ssh qsh
+breadcrumb (LmsReportDirectR    ssh  qsh) = i18nCrumb MsgMenuLmsUpload     $ Just $ LmsReportR    ssh qsh -- never displayed
+-- 
 breadcrumb (LmsIdentR           ssh  qsh _ ) = breadcrumb $ LmsR ssh qsh -- just a redirect
-breadcrumb (LmsUserR _) = i18nCrumb MsgMenuLmsUser $ Just LmsAllR
+breadcrumb (LmsUserR            ssh _qsh u ) = i18nCrumb MsgMenuLmsUser       $ Just $ LmsUserSchoolR u ssh
+breadcrumb (LmsUserSchoolR    u _          ) = i18nCrumb MsgMenuLmsUserSchool $ Just $ LmsUserAllR u
+breadcrumb (LmsUserAllR                  _ ) = i18nCrumb MsgMenuLmsUserAll    $ Just   LmsAllR
 -- breadcrumb (LmsFakeR            ssh  qsh) = i18nCrumb MsgMenuLmsFake       $ Just $ LmsR          ssh qsh -- TODO: remove in production
 
 breadcrumb ProfileR               = i18nCrumb MsgBreadcrumbProfile   Nothing
@@ -2336,24 +2346,37 @@ pageActions ParticipantsListR = return
   ]
 pageActions (LmsR sid qsh) = return
   [ NavPageActionPrimary
+    { navLink = defNavLink MsgMenuLmsLearners $ LmsLearnersR sid qsh
+    , navChildren =
+        [ defNavLink MsgMenuLmsDirectDownload $ LmsLearnersDirectR sid qsh
+        ]
+    }
+  , NavPageActionPrimary
+    { navLink = defNavLink MsgMenuLmsReport $ LmsReportR sid qsh
+    , navChildren =
+        [ defNavLink MsgMenuLmsUpload       $ LmsReportUploadR sid qsh
+        , defNavLink MsgMenuLmsDirectUpload $ LmsReportDirectR sid qsh
+        ]
+    }
+  , NavPageActionSecondary
     { navLink = defNavLink MsgMenuLmsUsers $ LmsUsersR sid qsh
-    , navChildren =
+    -- , navChildren =
-        [ defNavLink MsgMenuLmsDirectDownload $ LmsUsersDirectR sid qsh
+    --     [ defNavLink MsgMenuLmsDirectDownload $ LmsUsersDirectR sid qsh
-        ]
+    --     ]
     }
-  , NavPageActionPrimary
+  , NavPageActionSecondary
     { navLink = defNavLink MsgMenuLmsUserlist $ LmsUserlistR sid qsh
-    , navChildren =
+    -- , navChildren =
-        [ defNavLink MsgMenuLmsUpload       $ LmsUserlistUploadR sid qsh
+    --     [ defNavLink MsgMenuLmsUpload       $ LmsUserlistUploadR sid qsh
-        , defNavLink MsgMenuLmsDirectUpload $ LmsUserlistDirectR sid qsh
+    --     , defNavLink MsgMenuLmsDirectUpload $ LmsUserlistDirectR sid qsh
-        ]
+    --     ]
     }
-  , NavPageActionPrimary
+  , NavPageActionSecondary
     { navLink = defNavLink MsgMenuLmsResult $ LmsResultR sid qsh
-    , navChildren =
+    -- , navChildren =
-        [ defNavLink MsgMenuLmsUpload       $ LmsResultUploadR sid qsh
+    --     [ defNavLink MsgMenuLmsUpload       $ LmsResultUploadR sid qsh
-        , defNavLink MsgMenuLmsDirectUpload $ LmsResultDirectR sid qsh
+    --     , defNavLink MsgMenuLmsDirectUpload $ LmsResultDirectR sid qsh
-        ]
+    --     ]
     }
   , NavPageActionSecondary {
       navLink = defNavLink MsgMenuLmsEdit $ LmsEditR sid qsh

src/Handler/Admin.hs

@@ -45,11 +45,13 @@ getAdminProblemsR = do
       cutOffPrintDays = 7
       cutOffPrintJob  = addLocalDays  (-cutOffPrintDays) now      
 
-  (usersAreReachable, driversHaveAvsIds, rDriversHaveFs, noStalePrintJobs) <- runDB $ (,,,) 
+  (usersAreReachable, driversHaveAvsIds, rDriversHaveFs, noStalePrintJobs, noBadAPCids, noAvsSynchProblems) <- runDB $ (,,,,,) 
       <$> areAllUsersReachable 
-      <*> allDriversHaveAvsId nowaday
+      <*> allDriversHaveAvsId now
-      <*> allRDriversHaveFs nowaday
+      <*> 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)
@@ -106,8 +108,7 @@ getProblemUnreachableR = do
 getProblemFbutNoR :: Handler Html
 getProblemFbutNoR = do 
   now <- liftIO getCurrentTime  
-  let nowaday = utctDay now
+  rnofs <- runDB $ E.select $ retrieveDriversRWithoutF now
-  rnofs <- runDB $ E.select $ retrieveDriversRWithoutF nowaday
   siteLayoutMsg MsgProblemsRWithoutFHeading $ do
     setTitleI   MsgProblemsRWithoutFHeading
     [whamlet|
@@ -122,8 +123,7 @@ getProblemFbutNoR = do
 getProblemWithoutAvsId :: Handler Html
 getProblemWithoutAvsId = do 
   now <- liftIO getCurrentTime  
-  let nowaday = utctDay now
+  rnofs <- runDB $ E.select $ retrieveDriversWithoutAvsId now
-  rnofs <- runDB $ E.select $ retrieveDriversWithoutAvsId nowaday
   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 :: UTCTime -> E.SqlQuery (E.SqlExpr (Entity User))
-retrieveDriversWithoutAvsId nowaday = do     
+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 :: UTCTime -> E.SqlQuery (E.SqlExpr (Entity User))
-retrieveDriversRWithoutF nowaday = do     
+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

src/Handler/Admin/Avs.hs

@@ -11,6 +11,7 @@ module Handler.Admin.Avs
   ( getAdminAvsR, postAdminAvsR
   , getAdminAvsUserR
   , getProblemAvsSynchR, postProblemAvsSynchR
+  , getProblemAvsErrorR
   ) where
 
 import Import
@@ -356,6 +357,7 @@ data LicenceTableActionData =  LicenceTableChangeAvsData
                               }
                             |  LicenceTableGrantFDriveData
                               { licenceTableChangeFDriveQId     :: QualificationId
+                              , licenceTableChangeFDriveReason  :: Text
                               , licenceTableChangeFDriveEnd     :: Day
                               , licenceTableChangeFDriveRenew   :: Maybe Bool
                               }
@@ -445,11 +447,7 @@ getProblemAvsSynchR = do
             then return (-1)
             else do
               uids <- view _userAvsUser <<$>> selectList [UserAvsPersonId <-. Set.toList apids] []
-              qualificationUserBlocking licenceTableChangeFDriveQId uids licenceTableChangeFDriveNotify $
+              qualificationUserBlocking licenceTableChangeFDriveQId uids False Nothing (Left licenceTableChangeFDriveReason) licenceTableChangeFDriveNotify
-                    Just $ QualificationBlocked 
-                    { qualificationBlockedDay     = nowaday
-                    , qualificationBlockedReason  = licenceTableChangeFDriveReason
-                    }                     
         if | oks < 0                      -> addMessageI Error   $ MsgRevokeFraDriveLicencesError alic
            | oks > 0, oks == length apids -> addMessageI Success $ MsgRevokeFraDriveLicences      alic oks
            | otherwise                    -> addMessageI Warning $ MsgRevokeFraDriveLicences      alic oks
@@ -459,6 +457,7 @@ getProblemAvsSynchR = do
         (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
@@ -477,21 +476,25 @@ 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)
+
+type LicenceTableData = DBRow (Entity UserAvs, Entity User, Maybe (Entity QualificationUser), Maybe (Entity Qualification), Maybe (Entity QualificationUserBlock))
 
 resultUserAvs :: Lens' LicenceTableData (Entity UserAvs)
 resultUserAvs = _dbrOutput . _1
@@ -505,30 +508,40 @@ resultQualUser = _dbrOutput . _3 . _Just
 resultQualification :: Traversal' LicenceTableData (Entity Qualification)
 resultQualification = _dbrOutput . _4 . _Just
 
+resultQualBlock :: Traversal' LicenceTableData (Entity QualificationUserBlock)
+resultQualBlock = _dbrOutput . _5 . _Just
+
 instance HasEntity LicenceTableData User where
   hasEntity = resultUser
 
 instance HasUser LicenceTableData where
-  hasUser   = resultUser . _entityVal
+  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
   currentRoute <- fromMaybe (error "mkLicenceTable called from 404-handler") <$> liftHandler getCurrentRoute
   avsQualifications <- selectList [QualificationAvsLicence !=. Nothing] []
   now <- liftIO getCurrentTime
+
   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
+      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)        
+        E.where_ $ fltrLic qual
-        return (usrAvs, user, qualUser, 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)
@@ -536,7 +549,7 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do
         [ 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
+        , 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
@@ -549,32 +562,33 @@ 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
+        , sortable (Just "last-refresh")  (i18nCell MsgTableQualificationLastRefresh)$ \(preview $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d)  -> cellMaybe dayCell d
-                                                                                   ) $ \(preview $ resultQualUser . _entityVal . _qualificationUserBlockedDue  -> b)  -> cellMaybe qualificationBlockedCell b
+        -- , 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 ("avspersonno"   , SortColumn          $ queryUserAvs        >>> (E.^. UserAvsNoPerson))
-        , single ("qualification" , SortColumn $ queryQualification >>> (E.?. QualificationShorthand))
+        , single ("qualification" , SortColumn          $ queryQualification  >>> (E.?. QualificationShorthand))
         , single $ sortUserCompany queryUser
-        , single ("valid-until"   , SortColumn $ queryQualUser      >>> (E.?. QualificationUserValidUntil))
+        , single ("valid-until"   , SortColumn          $ queryQualUser       >>> (E.?. QualificationUserValidUntil))
-        , single ("last-refresh"  , SortColumn $ queryQualUser      >>> (E.?. QualificationUserLastRefresh))
+        , single ("last-refresh"  , SortColumn          $ queryQualUser       >>> (E.?. QualificationUserLastRefresh))
-        , single ("first-held"    , SortColumn $ queryQualUser      >>> (E.?. QualificationUserFirstHeld))
+        , single ("first-held"    , SortColumn          $ queryQualUser       >>> (E.?. QualificationUserFirstHeld))
-        , single ("blocked-due"   , SortColumn $ queryQualUser      >>> (E.?. QualificationUserBlockedDue))
+        , single ("blocked"       , SortColumnNeverNull $ queryQualBlock      >>> (E.?. QualificationUserBlockFrom))
-        , single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.?. QualificationUserScheduleRenewal))
+        , single ("schedule-renew", SortColumnNullsInv  $ queryQualUser       >>> (E.?. QualificationUserScheduleRenewal))
-        , single ("validity"      , SortColumn $ queryQualUser      >>> validQualification' nowaday)
+        -- , 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 ("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`
@@ -600,17 +614,37 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do
           , 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
+                    <*> apreq (textField & cfStrip & addDatalist suggestionsBlock)    (fslI MsgQualificationBlockReason) Nothing
-                    <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockNotify) (Just False)
+                    <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant)       (fslI MsgQualificationBlockNotify) (Just False)
 
               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
           ]
@@ -689,3 +723,69 @@ getAdminAvsUserR uuid = 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}|]
+    

src/Handler/Admin/Test.hs

@@ -115,6 +115,8 @@ postAdminTestR = do
         , formAttrs = [("uw-async-form", "")]
         }
 
+  now <- liftIO getCurrentTime
+  $logInfoS "TEST" $ "Admin Test Page was retrieved at " <> tshow now <> "." -- to ensure that we can read the right log.
 
   let demoFormAction (_i,_b,_d) = addMessage Info "All ok."
   ((demoResult, formWidget),formEnctype) <- runFormPost $ makeDemoForm 7

src/Handler/Course/List.hs

@@ -105,7 +105,7 @@ colSchoolShort = sortable (Just "schoolshort") (i18nCell MsgFilterCourseSchoolSh
       in anchorCell (TermSchoolCourseListR courseTerm courseSchool) [whamlet|_{schoolShorthand}|]
 
 colRegistered :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
-colRegistered = sortable (Just "registered") (i18nCell MsgFilterRegistered) $ views resultIsRegistered tickmarkCell
+colRegistered = sortable (Just "registered") (i18nCell MsgFilterRegistered) $ views resultIsRegistered ((spacerCell <>) . tickmarkCell)
 
 
 makeCourseTable :: (ToSortable h, Functor h)

src/Handler/Course/Users.hs

@@ -18,7 +18,8 @@ import Import
 import Utils.Form
 import Handler.Utils
 import Handler.Utils.Course
-import qualified Database.Esqueleto.Utils as E
+import qualified Database.Esqueleto.Utils       as E
+import qualified Database.Esqueleto.PostgreSQL  as E
 import Database.Esqueleto.Utils.TH
 
 import Handler.Course.Register (deregisterParticipant)
@@ -87,7 +88,7 @@ userTableQuery cid ((user `E.InnerJoin` participant) `E.LeftOuterJoin` note `E.L
   E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid
   return (user, participant, note E.?. CourseUserNoteId, subGroup)
 
-type UserTableQualifications = [(Entity Qualification, Entity QualificationUser)]
+type UserTableQualifications = [(Entity Qualification, Entity QualificationUser, Maybe (Entity QualificationUserBlock))]
 
 type UserTableData = DBRow ( Entity User
                            , Entity CourseParticipant
@@ -131,7 +132,9 @@ _userSheets = _dbrOutput . _7
 -- last part: ([Entity Qualification] -> f [Entity Qualification]) -> UserTableQualfications -> f UserTableQualifications
 
 _userQualifications :: Getter UserTableData [Entity Qualification]
-_userQualifications = _dbrOutput . _8 . to (fmap fst)
+_userQualifications = _dbrOutput . _8 . to (fmap fst3)
+-- _userQualifications = _dbrOutput . _8 . each . _1 -- TODO: how to make this work 
+
 
 _userCourseQualifications :: Lens' UserTableData UserTableQualifications
 _userCourseQualifications = _dbrOutput . _8
@@ -182,18 +185,17 @@ colUserSheets shns = cap (Sortable Nothing caption) $ foldMap userSheetCol shns
       Just (preview _grading -> Just grading', Just points) -> i18nCell . bool MsgTableNotPassed MsgTablePassed $ Just True == gradingPassed grading' points
       _other -> mempty
 
-colUserQualifications :: forall m c. IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
+colUserQualifications :: forall m c. IsDBTable m c => Day -> Colonnade Sortable UserTableData (DBCell m c)
-colUserQualifications = sortable (Just "qualifications") (i18nCell MsgTableQualifications) $
+colUserQualifications cutoff = sortable (Just "qualifications") (i18nCell MsgTableQualifications) $
-  \(view _userCourseQualifications -> qualis) ->
+  let qualNamedValidCell (q,qu,qb) = textCell ((q ^. hasQualification . _qualificationShorthand . _CI) <> ": ") <> qualificationValidUntilCell cutoff qb qu
-      (cellAttrs <>~ [("class", "list--inline list--comma-separated list--iconless")]) . listCell qualis $ qualificationValidUntilCell
+  in  \(view _userCourseQualifications -> qualis) ->
-
+        (cellAttrs <>~ [("class", "list--inline list--comma-separated list--iconless")]) . listCell qualis $ qualNamedValidCell
-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
 
+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
+          qualis <- E.select . E.from $ \(qualification `E.InnerJoin` qualificationUser `E.LeftOuterJoin` qualificationBlock) -> do
-            E.on $ qualification E.^. QualificationId E.==. qualificationUser E.^. QualificationUserQualification
+            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.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
@@ -735,7 +740,6 @@ postCUsersR tid ssh csh = do
     (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
           let (exam, mOccurrence) = registerExam
           mExamReg <- lift $ insertUnique ExamRegistration
             { examRegistrationExam       = exam
@@ -760,7 +764,6 @@ postCUsersR tid ssh csh = do
 
       redirect $ CourseR tid ssh csh CUsersR
     (CourseUserReRegisterData, selectedUsers) -> do      
-      now <- liftIO getCurrentTime
       Sum nrSet <- runDB . flip foldMapM selectedUsers $ \uid -> maybeT (return mempty) $ do
         didUpdate <- lift $ updateWhereCount
           [ CourseParticipantUser ==. uid

src/Handler/LMS.hs

@@ -12,13 +12,21 @@ module Handler.LMS
   , getLmsR               , postLmsR
   , getLmsIdentR
   , getLmsEditR           , postLmsEditR
+  -- V1
   , getLmsUsersR          , getLmsUsersDirectR
   , getLmsUserlistR       , postLmsUserlistR
   , getLmsUserlistUploadR , postLmsUserlistUploadR, postLmsUserlistDirectR
   , getLmsResultR         , postLmsResultR
   , getLmsResultUploadR   , postLmsResultUploadR  , postLmsResultDirectR
+  -- V1
+  , getLmsLearnersR       , getLmsLearnersDirectR
+  , getLmsReportR         , postLmsReportR
+  , getLmsReportUploadR   , postLmsReportUploadR  , postLmsReportDirectR
+  --
   , getLmsFakeR           , postLmsFakeR
   , getLmsUserR
+  , getLmsUserSchoolR
+  , getLmsUserAllR     
   )
   where
 
@@ -42,11 +50,14 @@ import qualified Database.Esqueleto.Legacy as E
 import qualified Database.Esqueleto.PostgreSQL as E
 import qualified Database.Esqueleto.Utils as E
 import Database.Esqueleto.Utils.TH
-import Database.Persist.Sql (deleteWhereCount)
+import Database.Persist.Sql (deleteWhereCount, updateWhereCount)
-
+-- V1
 import Handler.LMS.Users    as Handler.LMS
 import Handler.LMS.Userlist as Handler.LMS
 import Handler.LMS.Result   as Handler.LMS
+-- V2
+import Handler.LMS.Learners as Handler.LMS
+import Handler.LMS.Report   as Handler.LMS
 import Handler.LMS.Fake     as Handler.LMS -- TODO: remove in production!
 
 
@@ -142,11 +153,15 @@ mkLmsAllTable isAdmin = do
               in anchorCell (LmsR (qualificationSchool quali) qsh) $ toWgt qnm
           , sortable Nothing (i18nCell MsgQualificationDescription) $ \(view resultAllQualification -> quali) ->
               maybeCell (qualificationDescription quali) markupCellLargeModal
-          , sortable Nothing (i18nCell MsgQualificationValidDuration & cellTooltip MsgTableDiffDaysTooltip) $
+          , sortable Nothing (i18nCell MsgQualificationValidDuration    & cellTooltip MsgTableDiffDaysTooltip) $
               foldMap (textCell . formatCalendarDiffDays . fromMonths) . view (resultAllQualification . _qualificationValidDuration)
-          , sortable Nothing (i18nCell MsgQualificationRefreshWithin & cellTooltip MsgTableDiffDaysTooltip) $
+          , sortable Nothing (i18nCell MsgQualificationRefreshWithin    & cellTooltips [SomeMessage MsgQualificationRefreshWithinTooltip  , SomeMessage MsgTableDiffDaysTooltip]) $
               foldMap (textCell . formatCalendarDiffDays             ) . view (resultAllQualification . _qualificationRefreshWithin)
           -- , sortable Nothing (i18nCell MsgQualificationRefreshWithin)   $ foldMap textCell . view (resultAllQualification . _qualificationRefreshWithin . to formatCalendarDiffDays) -- does not work, since there is a maybe in between
+          , sortable Nothing (i18nCell MsgQualificationRefreshReminder  & cellTooltips [SomeMessage MsgQualificationRefreshReminderTooltip, SomeMessage MsgTableDiffDaysTooltip]) $
+              foldMap (textCell . formatCalendarDiffDays             ) . view (resultAllQualification . _qualificationRefreshReminder)
+          , sortable Nothing (i18nCell MsgQualificationAuditDuration    & cellTooltips [SomeMessage MsgQualificationAuditDurationTooltip, SomeMessage MsgTableDiffDaysTooltip]) $
+              foldMap (textCell . formatCalendarDiffDays . fromMonths) . view (resultAllQualification . _qualificationAuditDuration)
           , sortable (Just "qelearning") (i18nCell MsgTableLmsElearning & cellTooltip MsgQualificationElearningStart)
                                                                         $ tickmarkCell . view (resultAllQualification . _qualificationElearningStart)
           , sortable Nothing (i18nCell MsgTableQualificationIsAvsLicence & cellTooltip MsgTableQualificationIsAvsLicenceTooltip) 
@@ -207,11 +222,13 @@ data LmsTableCsv = LmsTableCsv   -- L..T..C.. -> ltc..
   , ltcValidUntil     :: Day
   , ltcLastRefresh    :: Day
   , ltcFirstHeld      :: Day
-  , ltcBlockedDue     :: Maybe QualificationBlocked
+  , ltcBlockStatus    :: Maybe Bool
-  , ltcLmsIdent       :: Maybe LmsIdent
+  , ltcBlockFrom      :: Maybe UTCTime
+  , ltcLmsIdent       :: LmsIdent
   , ltcLmsStatus      :: Maybe LmsStatus
-  , ltcLmsStarted     :: Maybe UTCTime
+  , ltcLmsStatusDay   :: Maybe UTCTime
-  , ltcLmsDatePin     :: 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
+    , ltcFirstHeld      = pred $ pred compDay
-    , ltcBlockedDue     = Nothing
+    , ltcBlockStatus    = Nothing
-    , ltcLmsIdent       = Nothing
+    , ltcBlockFrom      = Nothing
-    , ltcLmsStatus      = Nothing
+    , ltcLmsIdent       = LmsIdent "abcdefgh"
-    , ltcLmsStarted     = Just compTime
+    , ltcLmsStatus      = Just LmsSuccess
-    , ltcLmsDatePin     = Nothing
+    , 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)
+type LmsTableExpr = (                   E.SqlExpr (Entity QualificationUser)
-                    `E.InnerJoin` E.SqlExpr (Entity User)
+                      `E.InnerJoin`     E.SqlExpr (Entity User)
-                    `E.InnerJoin` E.SqlExpr (Entity LmsUser)
+                      `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;
+    --   - 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 subsqueries to learn whether the request was indeed the latest
+    --  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!
     -- 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
@@ -387,27 +440,25 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
     cmps <- selectList [] [] -- [Asc CompanyShorthand]
     return $ Map.fromList $ fmap (\Entity{..} -> (entityKey, entityVal)) cmps
   let            
-    nowaday = utctDay now
-    -- mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday
     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 ("valid-until"   , SortColumnNullsInv $ queryQualUser  >>> (E.^. QualificationUserValidUntil))
-      , single ("validity"      , SortColumn         $ queryQualUser >>> validQualification nowaday)
+      -- , single ("validity"      , SortColumn         $ queryQualUser  >>> validQualification nowaday)
-      , single ("last-refresh"  , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserLastRefresh))
+      , single ("last-refresh"  , SortColumnNullsInv $ queryQualUser  >>> (E.^. QualificationUserLastRefresh))
-      , single ("first-held"    , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserFirstHeld))
+      , single ("first-held"    , SortColumnNullsInv $ queryQualUser  >>> (E.^. QualificationUserFirstHeld))
-      , single ("blocked-due"   , SortColumnNeverNull$ queryQualUser >>> (E.^. QualificationUserBlockedDue))
+      , single ("blocked"       , SortColumnNeverNull$ queryQualBlock >>> (E.?. QualificationUserBlockFrom))
-      , single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal))
+      , 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 ("ident"   , FilterColumn . E.mkContainsFilterWithCommaPlus 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 ("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 (resultQualBlock . _entityVal . _qualificationUserBlockUnblock . _not)
-          <*>  preview (resultLmsUser  . _entityVal . _lmsUserIdent)
+          <*>  preview (resultQualBlock . _entityVal . _qualificationUserBlockFrom)
-          <*> (join . preview (resultLmsUser  . _entityVal . _lmsUserStatus))
+          <*>  view    (resultLmsUser  . _entityVal . _lmsUserIdent)
-          <*>  preview (resultLmsUser  . _entityVal . _lmsUserStarted)
+          <*>  view    (resultLmsUser  . _entityVal . _lmsUserStatus)
-          <*>  preview (resultLmsUser  . _entityVal . _lmsUserDatePin)
+          <*>  view    (resultLmsUser  . _entityVal . _lmsUserStatusDay)
-          <*> (join . preview (resultLmsUser  . _entityVal . _lmsUserReceived))
+          <*>  view    (resultLmsUser  . _entityVal . _lmsUserStarted)
-          <*> (join . preview (resultLmsUser  . _entityVal . _lmsUserNotified)) -- TODO: only exports last email date / print job sending date, not print acknowledge
+          <*>  view    (resultLmsUser  . _entityVal . _lmsUserDatePin)
-          <*> (join . preview (resultLmsUser  . _entityVal . _lmsUserEnded))
+          <*>  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 "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 "first-held")    (i18nCell MsgTableQualificationFirstHeld)  $ \(   view $ resultQualUser . _entityVal . _qualificationUserFirstHeld   -> d)  -> dayCell d
-          , sortable (Just "blocked-due")   (i18nCell MsgTableQualificationBlockedDue & cellTooltip MsgTableQualificationBlockedTooltip
+          , sortable (Just "last-refresh")  (i18nCell MsgTableQualificationLastRefresh)$ \(   view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d)  -> dayCell d
-                                                                                    )  $ \(   view $ resultQualUser . _entityVal . _qualificationUserBlockedDue  -> b)  -> qualificationBlockedCell b
+          , 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 
+          numUsers  = Set.size   selectedUsers
-        when (lmsActRestartUnblock == Just True) $ do
+          isReset   = isResetAct action
-          unblockUsers <- view (_entityVal . _qualificationUserUser) <<$>> selectList 
+          actRestartExtend  = action & lmsActRestartExtend  
-            [ QualificationUserQualification ==. qid
+          actRestartUnblock = action & lmsActRestartUnblock 
-            , QualificationUserUser <-. usersList
+          actRestartNotify  = action & lmsActRestartNotify  
-            , QualificationUserBlockedDue !=. Nothing
-            ] []
-          void $ qualificationUserBlocking qid unblockUsers False Nothing
 
-        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
             , 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 ->
+      unless isReset $ 
-        queueJob' $ JobLmsEnqueueUser { jQualification = qid, jUser = uid }
+        forM_ selectedUsers $ \uid ->
-      let numUsers = length selectedUsers
+          queueJob' $ JobLmsEnqueueUser { jQualification = qid, jUser = uid }
-          mStatus  = bool Success Warning $ delUsers < numUsers
+
-      addMessageI mStatus $ MsgLmsActRestartFeedback delUsers numUsers      
+      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
+getLmsUserAllR :: CryptoUUIDUser -> Handler Html
-getLmsUserR uuid = do  
+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, qblocks) <- runDB $ do 
-  (user@User{userDisplayName}, quals) <- 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) 
+          Ex.where_ $ E.and $
-                E.||. E.isJust ( lmsUsr E.?. LmsUserUser)
+            (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)
+          pure (qual, qualUsr, lmsUsr, validQualification' now qualUsr)
-    return (usr,qs)
+    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

src/Handler/LMS/Fake.hs

@@ -129,7 +129,6 @@ fakeQualificationUsers (Entity qid Qualification{qualificationRefreshWithin}) (u
                   qualificationUserValidUntil       = addDays expOffset expiryNotifyDay
                   qualificationUserFirstHeld        = addGregorianMonthsClip (-24) qualificationUserValidUntil
                   qualificationUserLastRefresh      = qualificationUserFirstHeld                  
-                  qualificationUserBlockedDue       = Nothing
                   qualificationUserScheduleRenewal  = True
                   qualificationUserLastNotified     = now
               _ <- upsert QualificationUser{..} 

src/Handler/LMS/Learners.hs

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

src/Handler/LMS/Report.hs

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

src/Handler/LMS/Userlist.hs

@@ -54,7 +54,7 @@ instance FromNamedRecord LmsUserlistTableCsv where
 instance CsvColumnsExplained LmsUserlistTableCsv where
   csvColumnsExplanations _ = mconcat
     [ single csvLmsIdent   MsgCsvColumnLmsIdent
-    , single csvLmsBlocked MsgCsvColumnLmsFailed
+    , single csvLmsBlocked MsgCsvColumnLmsLock
     ]
     where
       single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget
@@ -97,7 +97,7 @@ mkUserlistTable sid qsh qid = do
         dbtProj   = dbtProjId
         dbtColonnade = dbColonnade $ mconcat
           [ sortable (Just csvLmsIdent)     (i18nCell MsgTableLmsIdent)    $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> textCell    $ lmsUserlistIdent & getLmsIdent
-          , sortable (Just csvLmsBlocked)   (i18nCell MsgTableLmsFailed)   $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> ifIconCell    lmsUserlistFailed IconBlocked
+          , sortable (Just csvLmsBlocked)   (i18nCell MsgTableLmsLock)     $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> ifIconCell    lmsUserlistFailed IconBlocked
           , sortable (Just csvLmsTimestamp) (i18nCell MsgTableLmsReceived) $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> dateTimeCell  lmsUserlistTimestamp
           ]
         dbtSorting = Map.fromList
@@ -111,7 +111,7 @@ mkUserlistTable sid qsh qid = do
           ]
         dbtFilterUI =  \mPrev -> mconcat
           [ prismAForm (singletonFilter csvLmsIdent   . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)     (fslI MsgTableLmsIdent)
-          , prismAForm (singletonFilter csvLmsBlocked . maybePrism _PathPiece) mPrev $ aopt (hoistField lift checkBoxField) (fslI MsgTableLmsFailed)
+          , prismAForm (singletonFilter csvLmsBlocked . maybePrism _PathPiece) mPrev $ aopt (hoistField lift checkBoxField) (fslI MsgTableLmsLock)
           ]
         dbtStyle =  def { dbsFilterLayout = defaultDBSFilterLayout }
         dbtParams = def

src/Handler/LMS/Users.hs

@@ -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
+-- | Mundane conversion needed for direct download without dbTable only
-lmsUser2csv :: Day -> LmsUser -> LmsUserTableCsv
+lmsUser2csv :: UTCTime -> LmsUser -> LmsUserTableCsv
 lmsUser2csv cutoff lu@LmsUser{..} = LmsUserTableCsv
   { csvLUTident     = lmsUserIdent
   , csvLUTpin       = lmsUserPin

src/Handler/PrintCenter.hs

@@ -27,12 +27,16 @@ import Database.Esqueleto.Utils.TH
 import Utils.Print
 
 -- import Data.Aeson (encode)
-import qualified Data.Text as Text
+-- import qualified Data.Text as Text
 -- import qualified Data.Set  as Set
 
 import Handler.Utils
 -- import Handler.Utils.Csv
 -- import qualified Data.Csv as Csv
+import qualified Data.CaseInsensitive as CI
+
+import Jobs.Queue
+
 
 -- avoids repetition of local definitions
 single :: (k,a) -> Map k a
@@ -219,32 +223,32 @@ mkPJTable = do
       , single ("lmsid"        , SortColumn $ queryPrintJob      >>> (E.^. PrintJobLmsUser))
       ]
     dbtFilter = mconcat
-      [ single ("name"         , FilterColumn . E.mkContainsFilter          $ views (to queryPrintJob)      (E.^. PrintJobName))
+      [ single ("name"         , FilterColumn . E.mkContainsFilterWithCommaPlus id                $ views (to queryPrintJob)      (E.^. PrintJobName))
-      , single ("apcid"        , FilterColumn . E.mkContainsFilter          $ views (to queryPrintJob)      (E.^. PrintJobApcIdent))
+      , single ("apcid"        , FilterColumn . E.mkContainsFilterWithComma     id                $ views (to queryPrintJob)      (E.^. PrintJobApcIdent))
-      , single ("filename"     , FilterColumn . E.mkContainsFilter          $ views (to queryPrintJob)      (E.^. PrintJobFilename))      
+      , single ("filename"     , FilterColumn . E.mkContainsFilter                            $ views (to queryPrintJob)      (E.^. PrintJobFilename))      
-      , single ("created"      , FilterColumn . E.mkDayFilter               $ views (to queryPrintJob)      (E.^. PrintJobCreated))
+      , single ("created"      , FilterColumn . E.mkDayFilter                                 $ views (to queryPrintJob)      (E.^. PrintJobCreated))
-      --, single ("created"      , FilterColumn . E.mkDayBetweenFilter               $ 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 ("recipient"    , FilterColumn . E.mkContainsFilterWithCommaPlus Just              $ views (to queryRecipient)     (E.?. UserDisplayName))
-      , single ("sender"       , FilterColumn . E.mkContainsFilterWith Just $ views (to querySender)        (E.?. UserDisplayName))
+      , single ("sender"       , FilterColumn . E.mkContainsFilterWithCommaPlus Just              $ views (to querySender)        (E.?. UserDisplayName))
-      , single ("course"       , FilterColumn . E.mkContainsFilterWith Just $ views (to queryCourse)        (E.?. CourseName))
+      , single ("course"       , FilterColumn . E.mkContainsFilterWith          (Just . CI.mk)    $ views (to queryCourse)        (E.?. CourseName))
-      , single ("qualification", FilterColumn . E.mkContainsFilterWith Just $ views (to queryQualification) (E.?. QualificationName))
+      , single ("qualification", FilterColumn . E.mkContainsFilterWith          (Just . CI.mk)    $ views (to queryQualification) (E.?. QualificationName))
-      , single ("lmsid"        , FilterColumn . E.mkContainsFilterWith Just $ views (to queryPrintJob)      (E.^. PrintJobLmsUser))
+      , 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 "recipient"    . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)                        (fslI MsgPrintRecipient & setTooltip MsgTableFilterCommaPlus)
-      , prismAForm (singletonFilter "sender"       . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)                        (fslI MsgPrintSender)
+      , 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 "lmsid"        . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)                        (fslI MsgPrintLmsUser & setTooltip MsgTableFilterCommaPlus)
-      , prismAForm (singletonFilter "apcid"        . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)                        (fslI MsgPrintJobApcAcknowledge)
+      , 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
+  now <- liftIO getCurrentTime
   (_params, files) <- runRequestBody
   (status, msg) <- case files of
-    [(fhead,file)] -> do      
+    [(_fhead,file)] -> do      
-      runDB $ 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?
+          Right nr -> do
-            let nrReq = length reqIds
+            let msg = "Success: received " <> tshow nr <> " APC identifiers to be processed later."
-            now <- liftIO getCurrentTime
+            $logInfoS "LMS" msg
-            nrApcIds <- updateWhereCount
+            when (nr > 0) $ queueDBJob JobPrintAck
-              [PrintJobAcknowledged ==. Nothing, PrintJobApcIdent <-. reqIds] 
+            return (ok200, msg)      
-              [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)
     []     -> do
       let msg = "Error: No file received. A file of lms identifiers must be supplied for print job acknowledging."
       $logWarnS "APC" msg

src/Handler/Profile.hs

@@ -570,6 +570,7 @@ getForProfileDataR cID = do
 
 makeProfileData :: Entity User -> DB Widget
 makeProfileData (Entity uid User{..}) = do
+  now <- liftIO getCurrentTime
   avsId <- entityVal <<$>> getBy (UniqueUserAvsUser uid)
   -- avsCards <- maybe (pure mempty) (\a -> selectList [UserAvsCardPersonId ==. userAvsPersonId a] []) avsId
   functions <- Map.fromListWith Set.union . map (\(Entity _ UserFunction{..}) -> (userFunctionFunction, Set.singleton userFunctionSchool)) <$> selectList [UserFunctionUser ==. uid] []
@@ -614,7 +615,7 @@ makeProfileData (Entity uid User{..}) = do
   submissionTable      <- mkSubmissionTable           uid -- Tabelle mit allen Abgaben und Abgabe-Gruppen
   submissionGroupTable <- mkSubmissionGroupTable      uid -- Tabelle mit allen Abgabegruppen
   correctionsTable     <- mkCorrectionsTable          uid -- Tabelle mit allen Korrektor-Aufgaben
-  qualificationsTable  <- mkQualificationsTable       uid -- Tabelle mit allen Qualifikationen
+  qualificationsTable  <- mkQualificationsTable  now  uid -- Tabelle mit allen Qualifikationen
   let examTable, ownTutorialTable, tutorialTable :: Widget
       examTable        = i18n MsgPersonalInfoExamAchievementsWip
       ownTutorialTable = i18n MsgPersonalInfoOwnTutorialsWip
@@ -949,39 +950,39 @@ mkCorrectionsTable =
 
 
 -- | Table listing all qualifications that the given user is enrolled in
-mkQualificationsTable :: UserId -> DB Widget
+mkQualificationsTable :: UTCTime -> UserId -> DB Widget
 mkQualificationsTable =
-  let withType :: ((E.SqlExpr (Entity Qualification) `E.InnerJoin` E.SqlExpr (Entity QualificationUser)) -> a)
+  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)) -> a)
+               -> ((E.SqlExpr (Entity Qualification) `E.InnerJoin` E.SqlExpr (Entity QualificationUser) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity QualificationUserBlock))) -> a)
       withType = id
-
+      validator = def & defaultSorting [SortAscBy "valid-until", SortAscBy "quali"]
-      validator = def -- TODO & defaultSorting [SortDescBy "valid-until"]
+  in \now uid -> dbTableWidget' validator
-
-  in \uid -> dbTableWidget' validator
     DBTable
       { dbtIdent     = "userQualifications" :: Text
-      , dbtSQLQuery  = \(quali `E.InnerJoin` quser) -> do
+      , dbtSQLQuery  = \(quali `E.InnerJoin` quser `E.LeftOuterJoin` qblock) -> do
-          E.on $ quali E.^. QualificationId E.==. quser E.^. QualificationUserQualification
+          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)
+          return (quali, quser, qblock)
-      , dbtRowKey = \(_quali `E.InnerJoin` quser) -> quser E.^. QualificationUserId
+      , 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)
+          [ sortSchool $ to (\(quali `E.InnerJoin` _ `E.LeftOuterJoin` _) -> quali E.^. QualificationSchool)
-          , singletonMap "quali"        $ SortColumn $ withType $ \(quali `E.InnerJoin` _) -> quali E.^. QualificationName  
+          , singletonMap "quali"        $ SortColumn $ withType $ \(quali `E.InnerJoin` _ `E.LeftOuterJoin`  _) -> quali  E.^. QualificationName  
-          , singletonMap "blocked-due"  $ SortColumn $ withType $ \(_ `E.InnerJoin` quser) -> quser E.^. QualificationUserBlockedDue
+          , singletonMap "blocked"      $ SortColumn $ withType $ \(_ `E.InnerJoin` _ `E.LeftOuterJoin` qblock) -> qblock E.?. QualificationUserBlockFrom
-          , singletonMap "valid-until"  $ SortColumn $ withType $ \(_ `E.InnerJoin` quser) -> quser E.^. QualificationUserValidUntil
+          , singletonMap "valid-until"  $ SortColumn $ withType $ \(_ `E.InnerJoin` quser `E.LeftOuterJoin`  _) -> quser  E.^. QualificationUserValidUntil
-          , singletonMap "last-refresh" $ SortColumn $ withType $ \(_ `E.InnerJoin` quser) -> quser E.^. QualificationUserLastRefresh
+          , singletonMap "last-refresh" $ SortColumn $ withType $ \(_ `E.InnerJoin` quser `E.LeftOuterJoin`  _) -> quser  E.^. QualificationUserLastRefresh
-          , singletonMap "first-held"   $ SortColumn $ withType $ \(_ `E.InnerJoin` quser) -> quser E.^. QualificationUserFirstHeld          
+          , singletonMap "first-held"   $ SortColumn $ withType $ \(_ `E.InnerJoin` quser `E.LeftOuterJoin`  _) -> quser  E.^. QualificationUserFirstHeld          
           ]
       , dbtFilter    = mempty
       , dbtFilterUI  = mempty

src/Handler/Qualification.hs

@@ -27,9 +27,10 @@ import qualified Data.Text as T
 import qualified Data.CaseInsensitive as CI
 import qualified Data.Conduit.List as C
 import Database.Persist.Sql (updateWhereCount)
+import           Database.Esqueleto.Experimental ((:&)(..))
 import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma
 import qualified Database.Esqueleto.Legacy as E
--- import qualified Database.Esqueleto.PostgreSQL as E
+import qualified Database.Esqueleto.PostgreSQL as E
 import qualified Database.Esqueleto.Utils as E
 import Database.Esqueleto.Utils.TH
 
@@ -79,7 +80,7 @@ mkQualificationAllTable isAdmin = do
                 Ex.where_ $ filterSvs quser 
               cactive = Ex.subSelectCount $ do 
                 quser <- Ex.from $ Ex.table @QualificationUser
-                Ex.where_ $ filterSvs quser Ex.&&. validQualification (utctDay now) quser
+                Ex.where_ $ filterSvs quser Ex.&&. validQualification now quser
           return (quali, cactive, cusers)                          
         dbtRowKey = (Ex.^. QualificationId)
         dbtProj = dbtProjId
@@ -96,9 +97,9 @@ 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) $
+          , 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)
@@ -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
@@ -205,6 +208,8 @@ instance CsvColumnsExplained QualificationTableCsv where
     , ('qtcCompanyNumbers , SomeMessage MsgTableCompanyNos)
     , ('qtcValidUntil     , SomeMessage MsgLmsQualificationValidUntil)
     , ('qtcLastRefresh    , SomeMessage MsgTableQualificationLastRefresh)
+    , ('qtcBlockStatus    , SomeMessage MsgInfoQualificationBlockStatus)
+    , ('qtcBlockFrom      , SomeMessage MsgInfoQualificationBlockFrom)
     , ('qtcScheduleRenewal, SomeMessage MsgQualificationScheduleRenewalTooltip)
     , ('qtcLmsStatusTxt   , SomeMessage MsgTableLmsStatus)
     , ('qtcLmsStatusDay   , SomeMessage MsgTableLmsStatusDay)    
@@ -214,18 +219,21 @@ 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 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)
+    E.where_ $    fltr qualUser 
-    return (qualUser, user, lmsUser)
+            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 ->
+          if  | Just True <- getLast criterion -> quser `quserToNotify` now          
-                (( 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"))
-                ))
               | 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 
+          (join . preview (resultLmsUser  . _entityVal . _lmsUserStatusDay)) >>= \case 
-            Just ls -> return $ Just $ lmsStatusDay ls
+            lsd@(Just _) -> return lsd
-            Nothing -> utctDay <<$>> preview (resultLmsUser  . _entityVal . _lmsUserStarted)
+            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{
+    qent@Entity{
-        qualificationAuditDuration=auditMonths
+        entityKey=qid
-      , qualificationValidDuration=validMonths
+      , 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
+          -- nonAdmin actions, ie. Supervisor
-          [ singletonMap QualificationActUnblock         $ pure QualificationActUnblockData           -- Admin-only actions
+          [ 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
+              <$> apreq (textField & cfStrip & addDatalist suggestionsBlock)    (fslI MsgQualificationBlockReason)             Nothing
-              <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockNotify)            (Just False)
+              <*> areq  (boolField . Just $ SomeMessage MsgBoolIrrelevant)      (fslI MsgQualificationBlockNotify)            (Just False)
-              <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockRemoveSupervisor)  (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
+        linkLmsUser     = toMaybe isAdmin (LmsUserR sid qsh)
-        linkUserName    = bool ForProfileR                      ForProfileDataR          isAdmin
+        linkUserName    = bool ForProfileR ForProfileDataR isAdmin        
-        blockedDueCell  = bool qualificationBlockedCellNoReason qualificationBlockedCell 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 "valid-until")   (i18nCell MsgLmsQualificationValidUntil)  (dayCell . view ( resultQualUser . _entityVal . _qualificationUserValidUntil))
+          , 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 "blocked-due")   (i18nCell MsgTableQualificationBlockedDue & cellTooltip MsgTableQualificationBlockedTooltipSimple
+          , sortable (Just "valid-until")   (i18nCell MsgLmsQualificationValidUntil)  (dayCell . view ( resultQualUser . _entityVal . _qualificationUserValidUntil))
-                                                                                    )     $ \(   view $ resultQualUser . _entityVal . _qualificationUserBlockedDue -> b)  -> blockedDueCell b
+          , sortable (Just "blocked")       (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltipSimple) $ \row -> 
-          , sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal  & cellTooltip MsgTableQualificationNoRenewalTooltip
+              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 
+          (unblock, reason) = case action of 
-              QualificationActUnblockData         -> Nothing
+              QualificationActBlockSupervisorData -> (False, Right QualificationBlockReturnedByCompany)              
-              QualificationActBlockSupervisorData -> Just $ mkQualificationBlocked QualificationBlockReturnedByCompany nowaday
+              QualificationActBlockData{..}       -> (False, Left qualTableActBlockReason)
-              QualificationActBlockData{..}       -> Just $ QualificationBlocked
+              QualificationActUnblockData{..}     -> (True , Left qualTableActBlockReason)
-                                                      { qualificationBlockedDay     = nowaday
+              _ -> error "Handle.Qualification.isBlockAct returned non-block action" -- cannot occur due to earlier checks
-                                                      , qualificationBlockedReason  = qualTableActBlockReason
-                                                      }
-              _ -> error "Handle.Qualification.isBlockAct returned non-block action"
           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
+          fbmsg = if unblock then MsgQualificationStatusUnblock else MsgQualificationStatusBlock
-            | isNothing qubr -> MsgQualificationStatusUnblock
-            | otherwise      -> MsgQualificationStatusBlock
       addMessageI warnLevel $ fbmsg qsh oks nrq
       reloadKeepGetParams $ QualificationR sid qsh
     _ -> addMessageI Error MsgInvalidFormAction

src/Handler/Tutorial/Form.hs

@@ -90,7 +90,7 @@ tutorialForm cid template html = do
     <*> tutorForm
   where
     tutTypeDatalist :: HandlerFor UniWorX (OptionList (CI Text))
-    tutTypeDatalist = fmap (mkOptionList . map (\t -> Option (CI.original t) t (CI.original t)) . Set.toAscList) . runDB $
+    tutTypeDatalist = fmap (mkOptionList . map (\t -> Option (CI.original t) t (toPathPiece $ CI.original t)) . Set.toAscList) . runDB $
       fmap (setOf $ folded . _Value) . E.select . E.from $ \tutorial -> do
         E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
         return $ tutorial E.^. TutorialType

src/Handler/Tutorial/Users.hs

@@ -59,20 +59,22 @@ data TutorialUserActionData
 getTUsersR, postTUsersR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler TypedContent
 getTUsersR = postTUsersR
 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
+    let nowaday = utctDay now
-        dayExpiry = flip addGregorianDurationClip (utctDay now) . fromMonths <$> minDur
+        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 $ colUserQualifications nowaday
-          , pure  colUserQualificationBlocked
+          , 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

src/Handler/Utils/Avs.hs

@@ -259,8 +259,7 @@ getDifferingLicences (AvsResponseGetLicences licences) = do
   --let (vorfeld, nonvorfeld) = Set.partition (`avsPersonLicenceIs` AvsLicenceVorfeld)  licences
   --     rollfeld             = Set.filter    (`avsPersonLicenceIs` AvsLicenceRollfeld) nonvorfeld
   -- Note: FRADrive users with 'R' also own 'F' qualification, but AvsGetResponseGetLicences yields only either
-  let nowaday = utctDay now      
+  let vorORrollfeld' = Set.dropWhileAntitone (`avsPersonLicenceIsLEQ` AvsNoLicence)      licences
-      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)

src/Handler/Utils/DateTime.hs

@@ -62,7 +62,7 @@ localTimeToUTC = TZ.localTimeToUTCFull appTZ
 localTimeToUTCSimple :: LocalTime -> UTCTime
 localTimeToUTCSimple = TZ.localTimeToUTCTZ appTZ
 
--- | Local midnight of given day
+-- | Local midnight of given day; use Utils.DateTime.utctDayMidnight :: Day -> UTCTime instead to avoid Timezone conversion!
 toMidnight :: Day -> UTCTime
 toMidnight = toTimeOfDay 0 0 0
 

src/Handler/Utils/LMS.hs

@@ -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
+  , lmsUserToDelete     , _lmsUserToDelete      , lmsUserToDeleteExpr
-  , 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.isJust (lmslist E.^. LmsUserStatus)
-  E.&&. E.explicitUnsafeCoerceSqlExprValue "timestamp" ((lmslist E.^. LmsUserStatus) E.#>>. "{day}") E.<=. E.val cutoff
+  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 :: UTCTime -> LmsUser -> Bool
-lmsUserToDelete cutoff LmsUser{lmsUserEnded=Nothing, lmsUserStatus= Just lstat} = lmsStatusDay lstat < cutoff
+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} =
+lmsUserStatusWidget adminInfo luser = case luser of
-  [whamlet|$newline never
+    LmsUser{lmsUserStatus=Just lStat, lmsUserStatusDay=mbDay} ->
-    ^{formatTimeW SelFormatDate (lmsStatusDay lStat)}
+      [whamlet|$newline never
-    \ ^{icon (lmsStatusIcon lStat)}
+        $maybe aday <- mbDay
-  |]
+          ^{formatTimeW SelFormatDateTime aday}
--- previously: IconWaitingForUser for lmsUserStatus==Nothing
+        $nothing
-lmsUserStatusWidget _ LmsUser{lmsUserNotified=Just d} =
+          --.--.----
-  [whamlet|$newline never
+        \ ^{iconFixed (lmsStatusIcon lStat)}
-    ^{formatTimeW SelFormatDate d}
+        $if adminInfo
-    \ ^{icon IconNotificationSent}
+          \ ^{lockIcon}
-  |]
+          \ ^{resetIcon}
-lmsUserStatusWidget True LmsUser{lmsUserStarted} =  -- E-Learning started, but not yet notified; only intended for Admins
+      |]
-  [whamlet|$newline never
+
-    ^{formatTimeW SelFormatDate lmsUserStarted}
+    LmsUser{lmsUserNotified=Just d} ->
-    \ ^{icon IconPlanned}
+      [whamlet|$newline never
-  |]
+        ^{formatTimeW SelFormatDateTime d}
-lmsUserStatusWidget _ _ = mempty
+        \ ^{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

src/Handler/Utils/Qualification.hs

@@ -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,61 +10,148 @@ 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
+-- needs refactoring, probbably no longer helpful
-isValidQualification d q = d `inBetween` (q ^. hasQualificationUser . _qualificationUserFirstHeld
+mkQualificationBlocked :: QualificationBlockStandardReason -> UTCTime -> QualificationUserId -> QualificationUserBlock
-                                         ,q ^. hasQualificationUser . _qualificationUserValidUntil)
+mkQualificationBlocked reason qualificationUserBlockFrom qualificationUserBlockQualificationUser = QualificationUserBlock{..}
-                            && isNothing (q ^. hasQualificationUser . _qualificationUserBlockedDue)  
+   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
+-- | Recently became invalid or blocked and not yet notified
-validQualification :: Day -> E.SqlExpr (Entity QualificationUser) -> E.SqlExpr (E.Value Bool)
+quserToNotify :: E.SqlExpr (Entity QualificationUser) -> UTCTime -> E.SqlExpr (E.Value Bool)
-validQualification nowaday = \qualUser ->
+quserToNotify quser cutoff =                                                                                        -- recently invalid or...
-  (E.val nowaday `E.between` (qualUser E.^. QualificationUserFirstHeld
+  (       E.day (quser E.^. QualificationUserLastNotified) E.<. quser E.^. QualificationUserValidUntil
-                             ,qualUser E.^. QualificationUserValidUntil))   -- currently valid
+    E.&&. E.notExists (do
-           E.&&. E.isNothing (qualUser E.^. QualificationUserBlockedDue)    -- not blocked            
+        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)
+-- 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
-validQualification' nowaday qualUser =
+isLatestBlockBefore :: E.SqlExpr (Maybe (Entity QualificationUserBlock)) -> E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value Bool)
-  (E.justVal nowaday `E.between` (qualUser E.?. QualificationUserFirstHeld
+isLatestBlockBefore qualBlock cutoff = (cutoff E.>~. qualBlock E.?. QualificationUserBlockFrom) E.&&. E.notExists (do
-                                 ,qualUser E.?. QualificationUserValidUntil))   -- currently valid
+    newerBlock <- E.from $ E.table @QualificationUserBlock
-     E.&&. E.isNothing (E.joinV $ qualUser E.?. QualificationUserBlockedDue)    -- not blocked            
+    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]
+-- | Variant of `isBlocked` for outer joins              
-selectValidQualifications qid mbUids nowaday = 
+quserBlock' :: Bool -> UTCTime -> E.SqlExpr (Maybe (Entity QualificationUser)) -> E.SqlExpr (E.Value Bool)
-  -- nowaday <- utctDay <$> liftIO getCurrentTime
+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.&&.  qUser E.^. QualificationUserUser `E.in_` E.valList uids
-          E.&&. maybe E.true (\uids -> qUser E.^. QualificationUserUser `E.in_` E.valList uids) mbUids
+          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
       , qualificationUserScheduleRenewal  = fromMaybe True mbScheduleRenewal
-      , qualificationUserLastNotified     = toMidnight qualificationUserLastRefresh
+      , qualificationUserLastNotified     = utctDayMidnight qualificationUserLastRefresh
       , ..
       }
     (
@@ -71,9 +159,9 @@ upsertQualificationUser  qualificationUserQualification qualificationUserLastRef
       ] ++
       [ QualificationUserValidUntil         =. qualificationUserValidUntil
       , QualificationUserLastRefresh        =. qualificationUserLastRefresh      
-      , QualificationUserBlockedDue         =. Nothing
       ]
     )
+  
   audit TransactionQualificationUserEdit
     { transactionQualificationUser            = quid
     , transactionQualification                = qualificationUserQualification
@@ -82,23 +170,38 @@ upsertQualificationUser  qualificationUserQualification qualificationUserLastRef
     , transactionQualificationScheduleRenewal = mbScheduleRenewal
     }
 
-renewValidQualificationUsers :: QualificationId -> [UserId] -> DB Int
+-- | Renew an existing valid qualification, ignoring all blocks otherwise
-renewValidQualificationUsers qid uids =
+-- renewValidQualificationUsers :: QualificationId -> Maybe UTCTime -> [UserId] -> DB Int -- not general enough for use in YesodJobDB
-  -- This code works in principle, but it does not allow audit log entries.
+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
+      cutoff <- maybe (liftIO getCurrentTime) return renewalTime
-      quEntsAll <- selectValidQualifications qid (Just uids) nowaday     
+      quEntsAll <- selectValidQualifications qid uids cutoff
-      let maxValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) nowaday
+      let cutoffday     = utctDay cutoff
-          quEnts = filter (\q -> maxValidTo >= (q ^. _entityVal . _qualificationUserValidUntil)) quEntsAll
+          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.
 
-
+-- | Block or unblock some users for a given reason 
--- qualificationUserBlocking :: QualificationId -> [UserId] -> Maybe QualificationBlocked -> DB Int64
 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
+  ) => QualificationId -> [UserId] -> Bool -> Maybe UTCTime -> QualificationBlockReason -> Bool -> ReaderT (YesodPersistBackend (HandlerSite m)) m n
-
+qualificationUserBlocking qid uids unblock mbBlockTime (qualificationBlockReasonText -> reason) notify = do
-qualificationUserBlocking qid uids notify qb = 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 
+  let blockTime = fromMaybe now mbBlockTime      
-    ( [ QualificationUserBlockedDue     !=. Nothing  |  isNothing qb  -- only unblock blocked qualification; allow overwrite for existing blocks
+  -- -- Code would work, but problematic 
-      ] ++  
+  -- oks <- E.insertSelectCount . E.from $ \qualificationUser -> do
-      [ QualificationUserQualification  ==. qid
+  --   E.where_ $ qualificationUser E.^. QualificationUserQualification E.==. E.val qid 
-      , QualificationUserUser           <-. uids    
+  --       E.&&.  qualificationUser E.^. QualificationUserUser E.in_ E.valList uid
-      ]
+  --       E.&&.  quserBlock unblock blockTime qualificationUser -- only unblock blocked qualification and vice versa
-    )
+  --   return $ QualificationUserBlock
-    (guardMonoid (not notify)
+  --     E.<#  qualificationUser E.^. QualificationUserId
-    [   QualificationUserLastNotified =. now
+  --     E.<&> E.val unblock
-    ] ++
+  --     E.<&> E.val blockTime
-    [   QualificationUserBlockedDue   =. qb 
+  --     E.<&> E.val reason
-    ])
+  --     E.<&> E.val authUsr
-  forM_ uids $ \uid -> do     
+  toChange <- E.select $ do
-    audit TransactionQualificationUserBlocking 
+    qualUser <- E.from $ E.table @QualificationUser
-      { -- transactionQualificationUser  = quid
+    E.where_ $ qualUser E.^. QualificationUserQualification E.==. E.val qid 
-        transactionQualification      = qid
+        E.&&.  qualUser E.^. QualificationUserUser `E.in_` E.valList uids
-      , transactionUser               = uid
+        E.&&.  quserBlock unblock blockTime qualUser -- only unblock blocked qualification and vice versa
-      , transactionQualificationBlock = qb
+    return (qualUser E.^. QualificationUserId, qualUser E.^. QualificationUserUser)
-      }
+  let newBlocks = map (\(E.Value quid, E.Value uid) -> (uid, QualificationUserBlock
-  return $ fromIntegral oks
+                      { 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
+  ) => QualificationId -> [UserId] -> Maybe UTCTime -> QualificationBlockReason -> QualificationBlockReason -> Bool -> ReaderT (YesodPersistBackend (HandlerSite m)) m n
-qualificationUserUnblockByReason qid uids reason = do
+qualificationUserUnblockByReason qid uids mbUnblockTime (qualificationBlockReasonText -> reason) undo_reason notify = do
-  blockedUsers <- selectList [ QualificationUserQualification ==. qid
+  cutoff <- maybe (liftIO getCurrentTime) return mbUnblockTime 
-                             , QualificationUserBlockedDue !=. Nothing
+  toUnblock <- E.select $ do
-                             , QualificationUserUser <-. uids
+    quser <- E.from $ E.table @QualificationUser
-                             ] [Asc QualificationUserId]
+    E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid
-  let toUnblock = filter (\quent -> Just reason == quent ^? _entityVal . _qualificationUserBlockedDue . _Just . _qualificationBlockedReason) blockedUsers
+        E.&&.  quser E.^. QualificationUserUser `E.in_` E.valList uids
-  oks <- updateWhereCount  [ QualificationUserId <-. (view _entityKey <$> toUnblock) ]
+        E.&&.  quserBlockAux True (E.val cutoff) (E.==. (quser E.^. QualificationUserId)) (Just (\qblock -> (qblock E.^. QualificationUserBlockReason) E.==. E.val reason))
-                           [ QualificationUserBlockedDue =. Nothing ]
+    return $ quser E.^. QualificationUserUser
-  forM_ toUnblock $ \ubl -> do     
+  qualificationUserBlocking qid (E.unValue <$> toUnblock) True mbUnblockTime undo_reason notify 
-    audit TransactionQualificationUserBlocking 
-      { -- transactionQualificationUser  = quid
-        transactionQualification      = qid
-      , transactionUser               = ubl ^. _entityVal . _qualificationUserUser
-      , transactionQualificationBlock = Nothing
-      }                           
-  return $ fromIntegral oks

src/Handler/Utils/Table/Cells.hs

@@ -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
+qualificationValidIconCell :: (IsDBTable m c, HasQualificationUser a, HasQualificationUserBlock b) => Day -> Maybe b -> a -> DBCell m c
-qualificationValidUntilCell q = textCell (qsh <> ": ") <> dayCell vtd 
+qualificationValidIconCell d qb qu = do
+  blockIcon $ isValidQualification d qu qb
   where 
-    qsh = q ^. hasQualification . _qualificationShorthand . _CI
+    blockIcon = cell . toWidget . iconQualificationBlock
-    vtd = q ^. hasQualificationUser . _qualificationUserValidUntil
 
-qualificationValidIconCell :: (IsDBTable m c, HasQualificationUser a) => Day -> a -> DBCell m c
+qualificationValidUntilCell :: (IsDBTable m c, HasQualificationUser a, HasQualificationUserBlock b) => Day -> Maybe b -> a -> DBCell m c
-qualificationValidIconCell = (iconBoolCell .) . isValidQualification
+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
+lmsStateCell :: IsDBTable m a => LmsState -> DBCell m a
-qualificationBlockedCellNoReason Nothing   = mempty 
+lmsStateCell LmsFailed  = iconBoolCell False
-qualificationBlockedCellNoReason (Just QualificationBlocked{qualificationBlockedDay=d}) =
+lmsStateCell LmsOpen    = iconSpacerCell 
-  iconCell IconBlocked <> spacerCell <> dayCell d
+lmsStateCell LmsPassed  = iconBoolCell True
-
-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
 
 avsPersonNoCell :: (IsDBTable m c, HasUserAvs a) => a -> DBCell m c
 avsPersonNoCell = numCell . view _userAvsNoPerson

src/Handler/Utils/Table/Columns.hs

@@ -10,7 +10,7 @@ import Import hiding (link)
 
 import qualified Database.Esqueleto.Legacy as E
 import qualified Database.Esqueleto.Utils as E hiding ((->.))
-import Database.Esqueleto.Utils (mkExactFilter, mkExactFilterWith, mkContainsFilter, mkContainsFilterWith, anyFilter)
+import Database.Esqueleto.Utils (mkExactFilter, mkExactFilterWith, mkContainsFilter, mkContainsFilterWith, mkContainsFilterWithComma, mkContainsFilterWithCommaPlus, anyFilter)
 --import           Database.Esqueleto.Experimental ((:&)(..))
 --import qualified Database.Esqueleto.Experimental as Ex
 
@@ -399,9 +399,9 @@ fltrUserNameEmail :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool
    => (a -> E.SqlExpr (Entity User))
    -> (d, FilterColumn t fs)
 fltrUserNameEmail queryUser = ( "user-name-email", FilterColumn $ anyFilter
-    [ mkContainsFilter $ queryUser >>> (E.^. UserDisplayName)
+    [ mkContainsFilterWithCommaPlus id    $ queryUser >>> (E.^. UserDisplayName)
-    , mkContainsFilter $ queryUser >>> (E.^. UserSurname)
+    , mkContainsFilterWithCommaPlus id    $ queryUser >>> (E.^. UserSurname)
-    , mkContainsFilterWith CI.mk $ queryUser >>> (E.^. UserDisplayEmail)
+    , 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)
 
 
 ----------------

src/Handler/Utils/Table/Pagination.hs

@@ -48,7 +48,7 @@ module Handler.Utils.Table.Pagination
   , linkEitherCell, linkEitherCellM, linkEitherCellM'
   , maybeAnchorCellM, maybeAnchorCellM', maybeLinkEitherCellM'
   , anchorCellC, anchorCellCM, anchorCellCM', linkEitherCellCM', maybeLinkEitherCellCM'
-  , cellTooltip, cellTooltipIcon, cellTooltipWgt
+  , cellTooltip, cellTooltips, cellTooltipIcon, cellTooltipWgt
   , listCell, listCell', listCellOf, listCellOf'
   , ilistCell, ilistCell', ilistCellOf, ilistCellOf'
   , formCell, DBFormResult(..), getDBFormResult
@@ -1704,6 +1704,13 @@ i18nCell msg = cell $ do
 cellTooltip :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a -> DBCell m a
 cellTooltip = cellTooltipIcon Nothing
 
+cellTooltips :: (RenderMessage UniWorX msg, IsDBTable m a) => [msg] -> DBCell m a -> DBCell m a
+cellTooltips msgs = cellTooltipWgt Nothing [whamlet|
+  $forall msg <- msgs
+    <p>
+      _{msg}
+|]
+
 cellTooltipIcon :: (RenderMessage UniWorX msg, IsDBTable m a) => Maybe Icon -> msg -> DBCell m a -> DBCell m a
 cellTooltipIcon icn = cellTooltipWgt icn . msg2widget
 

src/Handler/Utils/Users.hs

@@ -815,30 +815,25 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
   unless (Set.null qResolvable) $ deleteWhere [ LmsUserUser ==. oldUserId, LmsUserQualification <-. Set.toList qResolvable ] -- delete conflicting and finished LMS, which are still within auditDuration
   updateWhere [ LmsUserUser ==. oldUserId ] [ LmsUserUser =. newUserId ]
   updateWhere [ QualificationEditUser ==. oldUserId ] [ QualificationEditUser =. newUserId ]
-  E.insertSelectWithConflict
+  usrQualis <- E.select $ E.from $ \(oldQual `E.LeftOuterJoin` newQual) -> do
-    UniqueQualificationUser
+      E.on (      newQual E.?. QualificationUserQualification E.?=. oldQual E.^. QualificationUserQualification
-    (E.from $ \qualificationUser -> do
+            E.&&. newQual E.?. QualificationUserUser          E.?=. E.val newUserId
-        E.where_ $ qualificationUser E.^. QualificationUserUser E.==. E.val oldUserId
+            )
-        return $ QualificationUser
+      E.where_ $  oldQual E.^. QualificationUserUser          E.==. E.val oldUserId          
-          E.<#  E.val newUserId
+      return (oldQual, newQual)
-          E.<&> (qualificationUser E.^. QualificationUserQualification)
+  forM_ usrQualis $ \case 
-          E.<&> (qualificationUser E.^. QualificationUserValidUntil)
+    (Entity oldQKey _, Nothing) -> update oldQKey [ QualificationUserUser =. newUserId ] -- update must succeed if there is not RHS in the join
-          E.<&> (qualificationUser E.^. QualificationUserLastRefresh)
+    (Entity oldQKey oldQUsr, Just (Entity newQKey newQUsr)) -> do
-          E.<&> (qualificationUser E.^. QualificationUserFirstHeld)
+      updateWhere [ QualificationUserBlockQualificationUser ==. oldQKey ] [ QualificationUserBlockQualificationUser =. newQKey ]
-          E.<&> (qualificationUser E.^. QualificationUserBlockedDue)
+      update newQKey 
-          E.<&> (qualificationUser E.^. QualificationUserScheduleRenewal)
+        [ QualificationUserValidUntil       =. (max `on` view _qualificationUserValidUntil     ) oldQUsr newQUsr
-          E.<&> (qualificationUser E.^. QualificationUserLastNotified)
+        , QualificationUserLastRefresh      =. (max `on` view _qualificationUserLastRefresh    ) oldQUsr newQUsr
-    )
+        , QualificationUserFirstHeld        =. (min `on` view _qualificationUserFirstHeld      ) oldQUsr newQUsr
-    (\current excluded ->
+        , QualificationUserScheduleRenewal  =. (max `on` view _qualificationUserScheduleRenewal) oldQUsr newQUsr
-      [ QualificationUserValidUntil       E.=. combineWith current excluded E.greatest QualificationUserValidUntil
+        , QualificationUserLastNotified     =. (max `on` view _qualificationUserLastNotified   ) oldQUsr newQUsr
-      , QualificationUserLastRefresh      E.=. combineWith current excluded E.greatest QualificationUserLastRefresh
+        ]
-      , QualificationUserFirstHeld        E.=. combineWith current excluded E.least    QualificationUserFirstHeld
+      delete oldQKey
-      , QualificationUserBlockedDue       E.=. combineWith current excluded E.greatest QualificationUserBlockedDue  -- Tested: PostgreSQL GREATEST/LEAST ignores NULL values
+  -- deleteWhere [ QualificationUserUser ==. oldUserId ] -- no longer needed  
-      , QualificationUserScheduleRenewal  E.=. combineWith current excluded E.greatest QualificationUserScheduleRenewal
-      , QualificationUserLastNotified     E.=. combineWith current excluded E.greatest QualificationUserLastNotified
-      ]
-    )
-  deleteWhere [ QualificationUserUser ==. oldUserId ]
 
   -- Supervision is fully merged
   E.insertSelectWithConflict

src/Handler/Utils/Widgets.hs

@@ -122,6 +122,12 @@ editedByW fmt tm usr  = do
   ft <- handlerToWidget $ formatTime fmt tm
   [whamlet|_{MsgUtilEditedBy usr ft}|]
 
+
+----------
+-- HEAT --
+----------
+
+
 boolHeat :: Bool -- ^ @isHot@
          -> Milli
 boolHeat = bool 0 1
@@ -148,7 +154,6 @@ invCoHeat :: ( Real a, Real b)
 invCoHeat (realToFrac -> full) (realToFrac -> achieved)
   = fromRational $ cutOffPercent 0.3 (full^2) (achieved^2)
 
-
 dualHeat :: ( Real a, Real b, Real c )
          => a -> b -> c -> Milli
 -- ^ Distinguishes zero, zero is mapped to 0, @optimal@ is mapped to 1, @full@ is mapped to 2
@@ -180,6 +185,34 @@ invDualCoHeat :: ( Real a, Real b, Real c )
 invDualCoHeat optimal full achieved = 2 - dualCoHeat optimal full achieved
 
 
+-----------
+-- COLOR --
+-----------
+
+--  TODO: someone with frontend capabilities should get rid of class tooltip__handle and check theme consistent colors
+
+statusHtml :: MessageStatus -> Html -> Html
+statusHtml sts wgt =
+  [shamlet|
+    <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

src/Jobs.hs

@@ -81,6 +81,7 @@ import Jobs.Handler.PersonalisedSheetFiles
 import Jobs.Handler.PruneOldSentMails
 import Jobs.Handler.StudyFeatures
 import Jobs.Handler.LMS
+import Jobs.Handler.Print
 
 import Jobs.HealthReport
 

src/Jobs/Handler/LMS.hs

@@ -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,12 +65,12 @@ 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
+          let nowaday     = utctDay now
-              renewalDate = addGregorianDurationClip renewalPeriod now_day              
+              renewalDate = addGregorianDurationClip renewalPeriod nowaday
               sendReminders remindPeriod = do
-                let remindDate = addGregorianDurationClip remindPeriod now_day                
+                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
@@ -75,9 +78,8 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act
                             )
                   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
+            lpw <- randomLMSpw
-            maybeM (pure Nothing) (E.insertUniqueEntity . mkLmsUser pw) (randomLMSIdentBut identsInUse)
+            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
@@ -169,7 +185,6 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
       let qshort = CI.original $ qualificationShorthand quali
       $logInfoS "LMS" $ "Processing e-learning results for qualification " <> qshort
       now <- liftIO getCurrentTime      
-      let nowaday = utctDay now      
       -- end users that expired by doing nothing
       expiredLearners <- E.select $ do
           (quser :& luser) <- E.from $
@@ -182,10 +197,10 @@ 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)
+              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
@@ -193,14 +208,9 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
       when (quali ^. _qualificationExpiryNotification) $ do
         notifyInvalidDrivers <- E.select $ do
             quser <- E.from $ E.table @QualificationUser
-            E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid
+            E.where_ $ E.not_ (quser `qualificationValid` now)                 -- currently invalid
-              E.&&.  E.not_ (validQualification nowaday quser)              
+              E.&&. quser E.^. QualificationUserQualification E.==. E.val qid  -- correct qualification
-              E.&&. (( E.isNothing (quser E.^. QualificationUserBlockedDue)
+              E.&&. quser `quserToNotify` now                                  -- recently became invalid or blocked
-                      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)
 
         forM_ notifyInvalidDrivers $ \(E.Value 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
@@ -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
+              let reason_undo = Left $ "LMS Workaround undoing: " <> qualificationBlockedReasonText QualificationBlockFailedELearning
-              when (Just (qualificationBlockedReasonText QualificationBlockFailedELearning) == qualificationUserBlockedDue ^? _Just . _qualificationBlockedReason) $
+              ok_unblock <- qualificationUserUnblockByReason qid [qualificationUserUser] Nothing (Right QualificationBlockFailedELearning) reason_undo False -- affects audit log
-                update quid [ QualificationUserBlockedDue =. Nothing ]
+              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
+                [ LmsUserStatus     =. Just LmsSuccess
-                , LmsUserReceived =. Just lmsResultTimestamp
+                , 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
+            , transactionLmsDay        = utctDayMidnight lmsResultSuccess
-            , transactionLmsUser       = Just lmsUserUser
+            , transactionLmsUser       = lmsUserUser
             , transactionNote          = note
             , transactionReceived      = lmsResultTimestamp
             }
@@ -299,7 +431,7 @@ 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
@@ -322,9 +454,8 @@ dispatchJobLmsUserlist qid = JobHandlerAtomic act
               update luid [LmsUserEnded =. Just now]
           | otherwise -> return ()                     -- users likely not yet started
 
-        (Entity luid luser, Just (Entity lulid lulist)) -> do
+        (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
 
           when (isNothing $ lmsUserNotified luser) $ do -- notify users that lms is available
@@ -335,24 +466,20 @@ dispatchJobLmsUserlist qid = JobHandlerAtomic act
 
           let isBlocked = lmsUserlistFailed lulist
               oldStatus = lmsUserStatus luser
-              newStatus = bool Nothing (Just $ LmsBlocked lmsMsgDay) isBlocked
+              updateStatus = isBlocked && oldStatus /= Just LmsSuccess
-              updateStatus = replaceLmsStatus oldStatus newStatus 
           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
+              , transactionLmsDay        = lReceived
-              , transactionLmsUser       = Just $ lmsUserUser luser
+              , 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|]

src/Jobs/Handler/Print.hs

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

src/Jobs/Handler/SendNotification/Qualification.hs

@@ -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
 
@@ -53,8 +53,11 @@ dispatchNotificationQualificationExpired nQualification jRecipient = do
 
   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 
@@ -74,7 +77,6 @@ dispatchNotificationQualificationExpired nQualification jRecipient = do
           notifyOk <- sendEmailOrLetter jRecipient letter
           if notifyOk
             then do               
-              now <- liftIO getCurrentTime
               runDB $ update quId [QualificationUserLastNotified =. now]
               $logInfoS  "LMS" $ "Notified " <> tshow encRecipient <> " about expired qualification " <> qname
             else 

src/Jobs/Types.hs

@@ -128,8 +128,12 @@ data Job
   | JobLmsEnqueueUser { jQualification :: QualificationId, jUser :: UserId }
   | JobLmsQualificationsDequeue
   | JobLmsDequeue     { jQualification :: QualificationId }
-  | JobLmsUserlist    { jQualification :: QualificationId }
+  | JobLmsUserlist    { jQualification :: QualificationId } -- Deprecated, remove together with routes
-  | JobLmsResults     { jQualification :: QualificationId }
+  | JobLmsResults     { jQualification :: QualificationId } -- Deprecated, remove together with routes
+  | JobLmsReports     { jQualification :: QualificationId }
+  | JobPrintAck
+  | JobPrintAckAgain
+
   deriving (Eq, Ord, Show, Read, Generic)
 data Notification
   = NotificationSubmissionRated { nSubmission :: SubmissionId }
@@ -360,6 +364,9 @@ jobNoQueueSame = \case
   JobLmsDequeue     {}                -> Just JobNoQueueSame
   JobLmsUserlist    {}                -> Just JobNoQueueSame
   JobLmsResults     {}                -> Just JobNoQueueSame
+  JobLmsReports     {}                -> Just JobNoQueueSame
+  JobPrintAck       {}                -> Just JobNoQueueSame
+  JobPrintAckAgain  {}                -> Just JobNoQueueSame
   _                                   -> Nothing
 
 notifyNoQueueSame :: Notification -> Maybe JobNoQueueSame

src/Model.hs

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

src/Model/Migration.hs

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

src/Model/Migration/Definitions.hs

@@ -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)"                                  )
@@ -131,6 +133,13 @@ migrateManual = do
     , ("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)"                          )    
+    , ("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)

src/Model/Migration/Types.hs

@@ -124,3 +124,18 @@ examModeDNF :: ExamModeDNF -> Current.ExamModeDNF
 examModeDNF (ExamModeDNF PredDNF{..}) = Current.ExamModeDNF . Current.PredDNF $ Set.map (impureNonNull . Set.map toCurrentPredLiteral . toNullable) dnfTerms
   where toCurrentPredLiteral PLVariable{..} = Current.PLVariable plVar
         toCurrentPredLiteral PLNegated{..} = Current.PLNegated plVar
+
+
+data QualificationBlocked = QualificationBlocked { qualificationBlockedDay    :: Day
+                                                 , qualificationBlockedReason :: Text 
+                                                 } 
+  deriving (Eq, Ord, Read, Show, Generic, NFData)
+
+-- makeLenses_ ''QualificationBlocked
+-- 
+deriveJSON defaultOptions
+  { tagSingleConstructors = False
+  , fieldLabelModifier     = camelToPathPiece' 2
+  , omitNothingFields = True  
+  } ''QualificationBlocked 
+Current.derivePersistFieldJSON ''QualificationBlocked 

src/Model/Types/Avs.hs

@@ -44,7 +44,7 @@ o .:?~ key = o .: key <|> maybe empty parseJSON go
 
 
 -- Like (.:?) but maps Just null to Nothing, ie. Nothing instead of Just ""
-(.:?!) :: (MonoFoldable a, FromJSON a) => Object -> Text -> Parser (Maybe a)
+(.:?!) :: (Canonical (Maybe a), FromJSON a) => Object -> Text -> Parser (Maybe a)
 (.:?!) o k = canonical <$> (o .:? k)
 
 
@@ -521,6 +521,43 @@ instance ToJSON AvsPersonInfo where
 -- derivePersistFieldJSON ''AvsPersonInfo
 
 
+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
@@ -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,6 +584,7 @@ instance FromJSON AvsFirmInfo where
     <*> o .:?! "StreetANDHouseNo"
     <*> o .:?! "EMail"
     <*> o .:?! "EMailSuperior"
+    <*> o .:?! "Communication"
 
 instance ToJSON AvsFirmInfo where
   toJSON AvsFirmInfo{..} = object $ catMaybes
@@ -555,6 +594,7 @@ instance ToJSON AvsFirmInfo where
     , ("StreetANDHouseNo" .=) <$> avsFirmStreetANDHouseNo & canonical
     , ("EMail"            .=) <$> avsFirmEMail            & canonical
     , ("EMailSuperior"    .=) <$> avsFirmEMailSuperior    & canonical
+    , ("Communication"    .=) <$> avsFirmCommunication    & canonical
     ] <>
     [ "Firm"          .= avsFirmFirm
     , "FirmNo"        .= avsFirmFirmNo

src/Model/Types/Lms.hs

@@ -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 }
+data LmsStatus = LmsExpired
-               | LmsExpired { lmsStatusDay :: Day }
+               | LmsBlocked               
-               | LmsSuccess { lmsStatusDay :: Day }
+               | LmsSuccess
-  deriving (Eq, Read, Show, Generic, NFData)
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, NFData, Universe, Finite)  
 
-instance Ord LmsStatus where 
+-- embedRenderMessage ''UniWorX ''LmsStatus (uncurry ((<>) . (<> "Status")) . Text.splitAt 3) -- moved to src/Foundation.hs
-  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         
 
 deriveJSON  defaultOptions
-  { constructorTagModifier = camelToPathPiece' 1      -- remove lms from constructor, since the object is tagged with lms already
+  { constructorTagModifier = camelToPathPiece' 1      -- remove lms from constructor
-  , fieldLabelModifier     = camelToPathPiece' 2      -- just day suffices for the day field
+  , fieldLabelModifier     = camelToPathPiece' 1
-  , omitNothingFields = True
+  , sumEncoding = UntaggedValue
-  , sumEncoding = TaggedObject "lms-status" "lms-result"
   } ''LmsStatus
 derivePersistFieldJSON ''LmsStatus
 
+nullaryPathPiece ''LmsStatus $ camelToPathPiece' 1
+
 instance Csv.ToField LmsStatus where
-  toField (LmsBlocked d) = "Failure: " <> Csv.toField d
+  toField = Csv.toField . toPathPiece
-  toField (LmsExpired d) = "Expired: " <> Csv.toField d
-  toField (LmsSuccess d) = "Success: " <> Csv.toField d
 
-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
+type QualificationBlockReason = Either Text QualificationBlockStandardReason
-mkQualificationBlocked reason qualificationBlockedDay = QualificationBlocked{..}
+
-  where 
+qualificationBlockReasonText :: QualificationBlockReason -> Text
-    qualificationBlockedReason = qualificationBlockedReasonText reason
+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
+  parseField "0" = pure $ LmsBool False
-    | i == "0"  = pure $ LmsBool False
+  parseField "1" = pure $ LmsBool True 
-    | i == "1"  = pure $ LmsBool True 
+  parseField  _  = mempty
-    | otherwise = 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

src/Model/Types/Security.hs

@@ -63,9 +63,9 @@ instance Hashable AuthenticationMode
 instance NFData AuthenticationMode
 
 deriveJSON defaultOptions
-  { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel
+  { constructorTagModifier  = camelToPathPiece' 1
-  , fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
+  , fieldLabelModifier      = camelToPathPiece' 1
-  , sumEncoding = UntaggedValue
+  , sumEncoding             = UntaggedValue
   } ''AuthenticationMode
 
 derivePersistFieldJSON ''AuthenticationMode

src/Utils.hs

@@ -503,6 +503,10 @@ snakecase2camelcase t = Text.concat $ map textToCapital words
     words = Text.splitOn '_' t 
 -}
 
+-- also see Utils.Form.cfCommaSeparatedSet
+commaSeparatedText :: Text -> Set Text
+commaSeparatedText = Set.fromList . mapMaybe (assertM' (not . Text.null) . Text.strip) . Text.split (==',')
+
 
 -----------
 -- Fixed --
@@ -870,6 +874,12 @@ deepAlt altFst         _       = altFst
 maybeEmpty :: Monoid m => Maybe a -> (a -> m) -> m
 maybeEmpty = flip foldMap
 
+
+-- The more general `find :: Foldable t => (a -> Bool) -> t a -> Maybe a`
+filterMaybe :: (a -> Bool) -> Maybe a -> Maybe a
+filterMaybe c r@(Just x) | c x  = r
+filterMaybe _ _                 = Nothing
+
 -- | also referred to as whenJust and forM_
 whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m ()
 whenIsJust (Just x) f = f x
@@ -1204,11 +1214,12 @@ partitionM crit = ofoldlM dist mempty
         | okay ->      acc `mappend` (opoint x, mempty)
         | otherwise -> acc `mappend` (mempty, opoint x)
 
-mconcatMapM :: (Monoid b, Monad m, Foldable f) => (a -> m b) -> f a -> m b
+-- use `foldMapM` instead
-mconcatMapM f = foldM (\x my -> mappend x <$> my) mempty . map f . Fold.toList
+-- 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 :: (Monoid b, Monad m, Foldable f) => f a -> (a -> m b) -> m b
-mconcatForM = flip mconcatMapM
+-- 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

src/Utils/Avs.hs

@@ -72,7 +72,7 @@ mkAvsQuery :: BaseUrl -> BasicAuthData -> ClientEnv -> AvsQuery
 mkAvsQuery _ _ _ = AvsQuery
     { avsQueryPerson          = \_ -> return . Right $ AvsResponsePerson      mempty
     , avsQueryStatus          = \_ -> return . Right $ AvsResponseStatus      mempty
-    , avsQueryContact         = \_ -> return . Right $ AvsResponseContact     $ Set.singleton $ AvsDataContact (AvsPersonId 1234567) (AvsPersonInfo "123123123" "Heribert" "Sumpfmeier" (-1) Nothing Nothing Nothing Nothing) (AvsFirmInfo "Lange Firma" 7 "Kurz" Nothing Nothing Nothing Nothing Nothing Nothing)
+    , avsQueryContact         = \_ -> return . Right $ AvsResponseContact     $ Set.singleton $ AvsDataContact (AvsPersonId 1234567) (AvsPersonInfo "123123123" "Heribert" "Sumpfmeier" (-1) Nothing Nothing Nothing Nothing) (AvsFirmInfo "Lange Firma" 7 "Kurz" Nothing Nothing Nothing Nothing Nothing Nothing Nothing)
     , avsQuerySetLicences     = \_ -> return . Right $ AvsResponseSetLicences mempty
     , avsQueryGetAllLicences  =       return . Right $ AvsResponseGetLicences mempty
     }

src/Utils/DateTime.hs

@@ -19,6 +19,7 @@ module Utils.DateTime
   , diffMinute, diffHour, diffDay
   , module Zones  
   , day
+  , utctDayMidnight
   ) where
 
 import ClassyPrelude.Yesod hiding (lift, Proxy(..))
@@ -181,3 +182,7 @@ day = QuasiQuoter{..}
     quoteType = error "day used as type"
     quoteDec = error "day used as declaration"
     quoteExp dStr = maybe (fail $ "Could not parse ISO8601 day: “" <> dStr <> "”") (lift :: Day -> Q Exp) $ Time.iso8601ParseM dStr
+
+-- | use Handler.Utils.DateTime.toMidnight instead, if the local timezone is to be accounted for
+utctDayMidnight :: Day -> UTCTime
+utctDayMidnight d = UTCTime { utctDayTime = 0, utctDay = d }

src/Utils/Icon.hs

@@ -104,12 +104,16 @@ data Icon
   | IconRemoveUser
   | IconReset
   | IconBlocked
+  | IconCertificate
   | IconPrintCenter
   | IconLetter
   | IconAt
   | IconSupervisor
   -- | IconWaitingForUser
   | IconExpired
+  | IconLocked
+  | IconUnlocked
+  | IconResetTries -- also see IconReset
   deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic)
   deriving anyclass (Universe, Finite, NFData)
 
@@ -191,12 +195,16 @@ iconText = \case
     IconSubmissionNoUsers       -> "user-slash"
     IconReset                   -> "undo" -- From fontawesome v6 onwards: "arrow-rotate-left"
     IconBlocked                 -> "ban"
+    IconCertificate             -> "badge-check"
     IconPrintCenter             -> "mail-bulk" -- From fontawesome v6 onwards: "envelope-bulk"
     IconLetter                  -> "mail-bulk" -- Problem "envelope" already used for email as well
     IconAt                      -> "at"
     IconSupervisor              -> "head-side" -- must be notably different to user
     -- IconWaitingForUser          -> "user-cog"  -- Waiting on a user to do something
     IconExpired                 -> "hourglass-end"
+    IconLocked                  -> "lock"
+    IconUnlocked                -> "lock-open-alt"
+    IconResetTries              -> "trash-undo"
 
 nullaryPathPiece ''Icon $ camelToPathPiece' 1
 deriveLift ''Icon
@@ -295,6 +303,10 @@ iconLetterOrEmail :: Bool -> Markup
 iconLetterOrEmail True  = icon IconLetter
 iconLetterOrEmail False = icon IconAt
 
+iconQualificationBlock :: Bool -> Markup
+iconQualificationBlock True   = icon IconCertificate
+iconQualificationBlock False  = icon IconBlocked
+
 ----------------
 -- For documentation on how to avoid these unneccessary functions
 -- we implement them here just once for the first icon:

src/Utils/Lens.hs

@@ -122,9 +122,12 @@ makeClassyFor_ ''StudySubTerms
 
 makeClassyFor_ ''Qualification
 makeClassyFor_ ''QualificationUser
+makeClassyFor_ ''QualificationUserBlock
 makeClassyFor_ ''LmsUser
+-- makeClassyFor_ ''LmsUserStatus
 makeClassyFor_ ''LmsUserlist
 makeClassyFor_ ''LmsResult
+makeClassyFor_ ''LmsReport
 makeClassyFor_ ''UserAvs
 makeClassyFor_ ''UserAvsCard
 
@@ -160,8 +163,11 @@ instance HasQualification a => HasQualification (a,b) where
 instance HasQualificationUser a => HasQualificationUser (Entity a) where
   hasQualificationUser = _entityVal . hasQualificationUser
 
-instance HasQualificationUser a => HasQualificationUser (b,a) where
+-- instance HasQualificationUser a => HasQualificationUser (b,a) where
-  hasQualificationUser = _2 . hasQualificationUser
+--   hasQualificationUser = _2 . hasQualificationUser
+
+instance HasQualificationUserBlock a => HasQualificationUserBlock (Entity a) where
+  hasQualificationUserBlock = _entityVal . hasQualificationUserBlock
 
 instance HasLmsUser a => HasLmsUser (Entity a) where
   hasLmsUser = _entityVal . hasLmsUser

src/Utils/Print/CourseCertificate.hs

@@ -50,6 +50,7 @@ instance MDLetter LetterCourseCertificate where
   letterMeta LetterCourseCertificate{..} DateTimeFormatter{ format } lang _rcvrEnt = 
     mkMeta
       [ toMeta "participant"    ccParticipant
+      , toMeta "subject-meta"   ccParticipant
       , mbMeta "fra-number"     ccFraNumber
       , mbMeta "fra-department" ccFraDepartment      
       , mbMeta "company"        ccCompany

src/Utils/Print/ExpireQualification.hs

@@ -53,6 +53,7 @@ instance MDLetter LetterExpireQualification where
       , toMeta "licencename"    leqName
       , toMeta "licenceshort"   leqShort
       , toMeta "licenceholder"  leqHolderDN
+      , toMeta "subject-meta"   leqHolderDN
       , mbMeta "expiry"         (format SelFormatDate <$> leqExpiry)
       , mbMeta "licence-url"    leqUrl
       , toMeta "de-opening" $ bool ("Guten Tag " <> leqHolderDN <> ",") "Sehr geehrte Damen und Herren," isSupervised

src/Utils/Print/RenewQualification.hs

@@ -74,6 +74,7 @@ instance MDLetter LetterRenewQualificationF where
       , toMeta "login"          lmsIdent
       , toMeta "pin"            lmsPin
       , toMeta "examinee"       qualHolderDN
+      , toMeta "subject-meta"   qualHolderDN
       , toMeta "expiry"         (format SelFormatDate qualExpiry)
       , mbMeta "validduration"  (show <$> qualDuration)
       , toMeta "url-text"       lmsUrl

src/Utils/Set.hs

@@ -6,6 +6,7 @@ module Utils.Set
 ( setIntersectNotOne
 , setIntersections
 , setMapMaybe
+, concatMapSet
 , setSymmDiff
 , setProduct
 , setPartitionEithers
@@ -55,6 +56,10 @@ setIntersections (h:t) = foldl' Set.intersection h t
 setMapMaybe :: Ord b => (a -> Maybe b) -> Set a -> Set b
 setMapMaybe f = Set.fromList . mapMaybe f . Set.toList
 
+concatMapSet :: Ord b => (a -> Set b) -> Set a -> Set b
+concatMapSet f = Set.foldl ((. f) . (<>)) mempty
+-- concatMapSet f = foldMap f --- requires Ord a as well, which we ought to have anyway
+
 -- | Symmetric difference of two sets.
 setSymmDiff :: Ord a => Set a -> Set a -> Set a
 setSymmDiff x y = (x `Set.difference` y) `Set.union` (y `Set.difference` x)

templates/admin-problems.hamlet

@@ -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}
+
+<section>
+  <h2>
+    _{MsgProblemsHeadingMisc}
+  <dl .deflist>
+    <dt .deflist__dt>^{flagError noAvsSynchProblems}
+    <dd .deflist__dd>^{simpleLinkI MsgProblemsNoAvsSynchProblems ProblemAvsErrorR}

templates/letter/din5008.latex

@@ -17,8 +17,8 @@
 \IfFileExists{xurl.sty}{\usepackage{xurl}}{} % add URL line breaks if available
 \IfFileExists{bookmark.sty}{\usepackage{bookmark}}{\usepackage{hyperref}}
 \hypersetup{
-$if(title-meta)$
+$if(subject-meta)$
-  pdftitle={$title-meta$},
+  pdfsubject={$subject-meta$},
 $endif$
 $if(author-meta)$
   pdfauthor={$author-meta$},
@@ -26,11 +26,17 @@ $endif$
 $if(lang)$
   pdflang={$lang$},
 $endif$
-$if(subject)$
+$if(is-de)$
-  pdfsubject={$subject$},
+  $if(de-subject)$
+    pdftitle={$de-subject$},
+  $endif$
+$else$
+  $if(en-subject)$
+    pdftitle={$en-subject$},
+  $endif$
 $endif$
-$if(keywords)$
+$if(apc-ident)$
-  pdfkeywords={$for(keywords)$$keywords$$sep$, $endfor$},
+  pdfkeywords={$apc-ident$},
 $endif$
 }
 \usepackage{url}

templates/letter/din5008with_pin.latex

@@ -17,8 +17,8 @@
 \IfFileExists{xurl.sty}{\usepackage{xurl}}{} % add URL line breaks if available
 \IfFileExists{bookmark.sty}{\usepackage{bookmark}}{\usepackage{hyperref}}
 \hypersetup{
-$if(title-meta)$
+$if(subject-meta)$
-  pdftitle={$title-meta$},
+  pdfsubject={$subject-meta$},
 $endif$
 $if(author-meta)$
   pdfauthor={$author-meta$},
@@ -26,11 +26,17 @@ $endif$
 $if(lang)$
   pdflang={$lang$},
 $endif$
-$if(subject)$
+$if(is-de)$
-  pdfsubject={$subject$},
+  $if(de-subject)$
+    pdftitle={$de-subject$},
+  $endif$
+$else$
+  $if(en-subject)$
+    pdftitle={$en-subject$},
+  $endif$
 $endif$
-$if(keywords)$
+$if(apc-ident)$
-  pdfkeywords={$for(keywords)$$keywords$$sep$, $endfor$},
+  pdfkeywords={$apc-ident$},
 $endif$
 }
 \usepackage{url}

templates/letter/plain_article.latex

@@ -10,8 +10,14 @@
 \IfFileExists{xurl.sty}{\usepackage{xurl}}{} % add URL line breaks if available
 \IfFileExists{bookmark.sty}{\usepackage{bookmark}}{\usepackage{hyperref}}
 \hypersetup{
-$if(title-meta)$
+$if(is-de)$
-  pdftitle={$title-meta$},
+  $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)$
+$if(subject-meta)$
-  pdfsubject={$subject$},
+  pdfsubject={$subject-meta$},
 $endif$
-$if(keywords)$
+$if(apc-ident)$
-  pdfkeywords={$for(keywords)$$keywords$$sep$, $endfor$},
+  pdfkeywords={$apc-ident$},
 $endif$
 }
 \usepackage{url}

templates/lms-report.hamlet

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

templates/lms-user.hamlet

@@ -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)}
+                <dd .deflist__dd>
-                  \ #{icon IconBlocked} 
+                  <ul>
-                  \ #{qualificationBlockedReason qblock}
+                    $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> 

templates/lms.hamlet

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

templates/profileData.hamlet

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

test/Database/Fill.hs

@@ -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
+  qid_l  <- insert' $ Qualification ifi "L" "Lehrbefähigung"       l_descr Nothing   (Just 6) Nothing Nothing False True 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!
+  qfjost <- insert' $ QualificationUser jost       qid_f (n_day  11) (n_day $   -1) (n_day $   -22) 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  $ QualificationUserBlock qfjost False (n_day' $ -6) "First block"    (Just svaupel)
-  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  $ QualificationUserBlock qfjost True  (n_day' $ -5) "Second unblock" (Just gkleen)
-  void . insert' $ QualificationUser gkleen     qid_f (n_day $ -3) (n_day $ -4) (n_day $ -20) Nothing True (n_day' $ -9)
+  void . insert  $ QualificationUserBlock qfjost False (n_day' $ -4) "Third block"    Nothing
-  void . insert' $ QualificationUser maxMuster  qid_f (n_day    0) (n_day $ -2) (n_day $  -8) Nothing False (n_day' $ -1)
+  void . insert  $ QualificationUserBlock qfjost True  (n_day' $ -3) "Fourth unblock" (Just sbarth)
-  void . insert' $ QualificationUser svaupel    qid_f (n_day    1) (n_day $ -1) (n_day $  -2) Nothing True (n_day' $ -9)
+  void . insert  $ QualificationUserBlock qfjost False (n_day' $ -1) "Fifth block"    (Just svaupel)
-  void . insert' $ QualificationUser sbarth     qid_f (n_day  400) (n_day $ -40) (n_day $ -1200) Nothing True (n_day' $ -2)
+  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 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 jost       qid_l (n_day  999) (n_day $ -111) (n_day $ -2222) True (n_day' $ -9) -- TODO: better dates!
-  void . insert' $ QualificationUser tinaTester qid_r (n_day    3) (n_day $ -60) (n_day $ -250)  Nothing False (n_day' $ -3)
+  qfkleen <- insert' $ QualificationUser gkleen qid_f (n_day 33) (n_day $ -4) (n_day $ -20) True  (n_day' $ -9)
-  void . insert' $ QualificationUser gkleen     qid_r (n_day $ -7) (n_day $ -2) (n_day $  -9) Nothing True (n_day' $ -4)
+  void . insert  $ QualificationUserBlock qfkleen False (n_day' 1) "Future block"   (Just svaupel)
-  void . insert' $ QualificationUser maxMuster  qid_r (n_day    1) (n_day $ -1) (n_day $  -2) Nothing False (n_day' $ -6)
+  void . insert' $ QualificationUser maxMuster  qid_f (n_day    0) (n_day $ -2) (n_day $  -8) False (n_day' $ -1)
-  -- void . insert' $ QualificationUser fhamann    qid_r (n_day $ -3) (n_day $ -1) (n_day $  -2) Nothing True (n_day' $ -9)
+  qfvaupel <- insert' $ QualificationUser svaupel    qid_f (n_day    2) (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) Nothing True (n_day' $ -7)
+  void . insert  $ QualificationUserBlock qfvaupel False (n_day' 0) "SameTimeBlock"     (Just jost)
-  void . insert' $ QualificationUser gkleen     qid_l (n_day    9) (n_day $ -1) (n_day $  -7) Nothing True (n_day' $ -8)
+  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 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 $ n_day 1)     (n_day' (-1)) (Just now) (Just $ n_day' 0) Nothing
+  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 $ utctDay now) (n_day' (-2)) (Just now) (Just $ n_day' (-4)) Nothing
+  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 $ n_day (-22))  (n_day' (-3)) (Just $ n_day' (-1)) (Just $ n_day' (-1)) Nothing
+  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 $ n_day (-11))  (n_day' (-4)) (Just $ n_day' (-2)) (Just $ n_day' (-2)) Nothing
+  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 now Nothing Nothing Nothing
+  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

test/Model/TypesSpec.hs

@@ -403,9 +403,18 @@ instance Arbitrary SchoolAuthorshipStatementMode where
 instance Arbitrary SheetAuthorshipStatementMode where
   arbitrary = genericArbitrary
 
+instance Arbitrary LmsBool where
+  arbitrary = LmsBool <$> arbitrary
+
 instance Arbitrary LmsStatus where
   arbitrary = genericArbitrary
 
+instance Arbitrary LmsState where
+  arbitrary = genericArbitrary
+
+instance Arbitrary LmsDay where
+  arbitrary = LmsDay <$> arbitrary
+
 deriving newtype instance Arbitrary LmsIdent
 
 spec :: Spec
@@ -521,8 +530,14 @@ spec = do
       [ eqLaws, ordLaws, showLaws, showReadLaws, boundedEnumLaws, finiteLaws, pathPieceLaws, jsonLaws, jsonKeyLaws, persistFieldLaws, binaryLaws, httpApiDataLaws ]
     lawsCheckHspec (Proxy @SheetAuthorshipStatementMode)
       [ eqLaws, ordLaws, showLaws, showReadLaws, boundedEnumLaws, finiteLaws, pathPieceLaws, jsonLaws, jsonKeyLaws, persistFieldLaws, binaryLaws, httpApiDataLaws ]
+    lawsCheckHspec (Proxy @LmsBool)
+      [ eqLaws, ordLaws, showLaws, showReadLaws, csvFieldLaws ]
     lawsCheckHspec (Proxy @LmsStatus)
       [ eqLaws, ordLaws, showLaws, showReadLaws, jsonLaws ]
+    lawsCheckHspec (Proxy @LmsState)
+      [ eqLaws, ordLaws, showLaws, showReadLaws, boundedEnumLaws, finiteLaws, csvFieldLaws ]
+    lawsCheckHspec (Proxy @LmsDay)
+      [ eqLaws, ordLaws, showLaws, showReadLaws, csvFieldLaws ]
 
   describe "TermIdentifier" $ do
     it "has compatible encoding/decoding to/from Text" . property $
@@ -627,10 +642,6 @@ spec = do
       showCompactCorrectorLoad Load{ byTutorial = Nothing,    byProportion = 0, byDeficit = 0 } CorrectorNormal  `shouldBe` "-D"
       showCompactCorrectorLoad Load{ byTutorial = Nothing,    byProportion = 1, byDeficit = 0 } CorrectorMissing `shouldBe` "[1.0 - D]"
       showCompactCorrectorLoad Load{ byTutorial = Nothing,    byProportion = 1, byDeficit = 0 } CorrectorExcused `shouldBe` "{1.0 - D}"
-  describe "Semigroup LmsStatus" $ do 
-    it "lmsStatusDay merges to earliest" . property $
-      \p1 p2 -> lmsStatusDay (p1 <> p2) == min (lmsStatusDay p1) (lmsStatusDay p2) 
-
 
 termExample :: (TermIdentifier, Text) -> Expectation
 termExample (term, encoded) = example $ do