Merge branch 'utils' into fraport-corporate-design-icons

CHANGELOG.md

@@ -2,6 +2,127 @@
 
 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.59](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.58...v27.4.59) (2024-02-13)
+
+
+### Bug Fixes
+
+* **sql:** remove potential bug in relation to missing parenthesis after not_ ([42695cf](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/42695cf5ef9f21691dc027f1ec97d57eec72f03e))
+
+## [27.4.58](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.57...v27.4.58) (2024-02-08)
+
+
+### Bug Fixes
+
+* **health:** negative interface routes working as intended now ([3303c4e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/3303c4eebf928e527d2f9c1eb6e2495c10b94b13))
+* **lms:** previouly failed notifications will be sent again ([263894b](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/263894b05899ce55635d790f5334729fbc655ecc))
+
+## [27.4.57](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.56...v27.4.57) (2024-02-06)
+
+
+### Bug Fixes
+
+* **course:** fix [#147](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/147) abort addd participant aborts now ([d332c0c](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/d332c0c11afd8b1dfe1343659f0b1626c968bbde))
+* **health:** fix [#151](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/151) by offering route /health/interface/* ([c71814d](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/c71814d1ef1efc16c278136dfd6ebd86bd1d20db))
+* **health:** fix [#153](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/153) and offer interface health route matching ([ce3852e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ce3852e3d365e62b32d181d58b7cbcc749e49373))
+
+## [27.4.56](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.55...v27.4.56) (2023-12-20)
+
+
+### Bug Fixes
+
+* **firm:** improve supervisor filter by caching ([88f24fe](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/88f24fe6f199290a83af2d204ba9aa2a838d11b8))
+* **firm:** improve supervisor filter yet once more ([c7b5a3c](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/c7b5a3c6cb70c314ecbfbe25969b4b6be1d43161))
+* **users:** fix [#121](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/121) by providing last login column, which was the last part missing ([decc5af](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/decc5af6829998e2d0db79382bbd9a7bad7b5b09))
+
+## [27.4.55](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.54...v27.4.55) (2023-12-14)
+
+
+### Bug Fixes
+
+* **build:** while the blank is necessary to prevent unnecessary migrations, it is not allowed either, see [#133](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/133) ([a4b2af7](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/a4b2af7f157444ead8c9df989741b266f7c2b4f2))
+* **firm:** supervisor filter performance ([db77850](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/db77850c4f4cd1d68bfd38e02e0ae24584e1e556))
+* **migration:** fix [#133](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/133) by removing old outdated migrations irrelevant to FRADrive ([d4f0d69](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/d4f0d69428a4f7fc887cb6854cb59e3dea83b9bc))
+* **migration:** ignore superfluous migration entries gracefully ([1d48b62](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/1d48b627f6b8cf1b03e2ef63850c36c429c9d3d6))
+* **school:** fix [#133](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/133) by adjusting default value ([2509358](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/25093588784381a19f34e5b091677b908420ddea))
+
+## [27.4.54](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.53...v27.4.54) (2023-12-11)
+
+
+### Bug Fixes
+
+* **db:** prevent superfluous migrations ([b73557a](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/b73557a1eee4315911c6369032447f8d1836d964))
+
+## [27.4.53](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.52...v27.4.53) (2023-12-09)
+
+
+### Bug Fixes
+
+* **admin:** minor fixes and translations for admin problem page ([30fae33](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/30fae33dedb1501e570e9edca288fea3c84ac84a))
+* **avs:** background synch was only triggerd by manual synchs ([48ef25a](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/48ef25aa8ffbbd96c1578ae85b76f090d9042595))
+* **firm:** group multi select field supervisor ([fc0ca7b](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/fc0ca7b854a686cf395dadf81b7423e530fd26b8))
+* **firm:** set supervisor field not all fields required ([9878956](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/9878956716b04c7ae88989cb9b059d3edcb923dc))
+* **firm:** supervisor filter ([3acb847](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/3acb847915010d10358ea02000c231dbba7cba26))
+* **form:** multiSelectField working with grouped options ([3aa8901](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/3aa89019a8b4393da0eca715871a3793c1e3abb2))
+* **print:** keep print jobs on user merge and lms id deletion ([a15862e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/a15862ea72bc374af870ef3a23f86ae32c2c67a9))
+
+## [27.4.52](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.51...v27.4.52) (2023-12-01)
+
+
+### Bug Fixes
+
+* **build:** redundant parenthesis ([50eda5f](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/50eda5f65f7394fe519546609fe748490cb4dd72))
+* **firm:** restrict firm access to company supervisors only ([0a06efd](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/0a06efd76c63180c996657c2c7d78efc5bddd83d))
+* **firm:** supervisor changes led to inconsistent DB ([1d3345c](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/1d3345cbba1cb65ee49c6f62e145750545439642))
+
+## [27.4.51](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.50...v27.4.51) (2023-11-24)
+
+
+### Bug Fixes
+
+* **build:** minor errors firm handler ([06bb44c](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/06bb44cf715375b5dd0141a46f8e10924ad6cd9c))
+* **cache:** remove risky caching for submissions ([4ae59fc](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/4ae59fc1fa658e1462139ddddd6dc80308d85872))
+* **firm:** show default supervisors with no employees too ([0f9a7a8](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/0f9a7a8c53d216ca7a6d0a25462b19ab1fa00bb4))
+
+## [27.4.50](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.49...v27.4.50) (2023-11-17)
+
+
+### Bug Fixes
+
+* **avs:** preserve unset pin passwords in update ([8c4f848](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/8c4f848675e1125547d1fdfa05560affe4794118))
+* **build:** fix whitespace in routes ([a24e44e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/a24e44efc9a20d3934d96640bb9e21b3b6d55b96))
+* **build:** minor ([954a239](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/954a23936a35ea6c32247d7e191312e63888c12d))
+* **firm:** add sql indices for frequent filters to greatly enhance performance ([63e6d94](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/63e6d94df2fd1ce879cb59d14bc854f3c2556586))
+* **firm:** firm messaging now works fine ([65cdc8d](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/65cdc8ddfef19eb3a5578c536575f91ba9717a13))
+* **firm:** foreign supervisor counts correct and sortable ([601ce7a](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/601ce7abdf2a392d30f1ff799a2338968be795f1))
+* **firm:** sending messages works, but not test messages ([42ff02d](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/42ff02d27e431a8855db7bf3046a1b74d297e6da))
+* **lms:** improve sorting for firm all ([3865bda](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/3865bda64d488c161b55e1f6eb48ca1b742dff98))
+* **lms:** LMS restart failing due to old LmsUser entry ([6761767](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/6761767c6ca8cab62a22aa6f755e6231e07ab411))
+
+## [27.4.49](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.48...v27.4.49) (2023-11-09)
+
+
+### Bug Fixes
+
+* **lms:** report log did not match qualification ([390ff31](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/390ff317ea3bb4ef8918c9cda858f5f228e4a882))
+
+## [27.4.48](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.47...v27.4.48) (2023-11-07)
+
+
+### Bug Fixes
+
+* **lms:** mark as ended only if not seen for at least one day ([8165892](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/8165892b2e4f945780bb8420cfc4eed50fdd294d))
+
+## [27.4.47](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.46...v27.4.47) (2023-11-03)
+
+## [27.4.46](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.45...v27.4.46) (2023-11-03)
+
+
+### Bug Fixes
+
+* **course:** grant qualifications now issues and unblocks ([5d8d8cf](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/5d8d8cf17e634ecb950a1c329c859fb93f94ef77))
+* **users:** allow prefer postal setting for users with fraport department ([a9d56c5](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/a9d56c51dcc727f8637b09a0e849372e75032f5e))
+
 ## [27.4.45](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.44...v27.4.45) (2023-10-18)
 
 

config/settings.yml

@@ -90,8 +90,9 @@ synchronise-avs-users-interval: "_env:SYNCHRONISE_AVS_INTERVAL:21600"   # alle 6
 study-features-recache-relevance-within: 172800
 study-features-recache-relevance-interval: 293
 
-# Enqueue at specified hour, dequeue 30min later
+# Enqueue at specified hour, a few minutes later
-# qualification-check-hour: 3
+# job-lms-qualifications-enqueue-hour: 15
+# job-lms-qualifications-dequeue-hour: 3
 
 log-settings:
   detailed:      "_env:DETAILED_LOGGING:false"

messages/faq/de-de-formal.msg

@@ -1,11 +1,9 @@
-# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
+# SPDX-FileCopyrightText: 2022-24 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
 
+FAQLoginExpired: Mein Passwort ist abgelaufen und muss erneuert werden
 FAQNoCampusAccount: Ich habe keine Fraport AG Kennung (Büko-Login); kann ich trotzdem Zugang zum System erhalten?
 FAQForgottenPassword: Ich habe mein Passwort vergessen
 FAQCampusCantLogin: Ich kann mich mit meiner Fraport AG Kennung (Büko-Login) nicht anmelden
-FAQCourseCorrectorsTutors: Wie kann ich Ausbilder oder Korrektoren für meine Kursart konfigurieren?
 FAQNotLecturerHowToCreateCourses: Wie kann ich eine neue Kursart anlegen?
-FAQExamPoints: Warum kann ich bei meiner Klausur keine Punkte eintragen?
-FAQInvalidCredentialsAdAccountDisabled: Ich kann mich nicht anmelden und bekomme die Meldung „Benutzereintrag gesperrt“

messages/faq/en-eu.msg

@@ -1,11 +1,9 @@
-# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
+# SPDX-FileCopyrightText: 2022-24 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
 
+FAQLoginExpired: My password expired
 FAQNoCampusAccount: I don't have Fraport AG credentials (Büko login); can I still get access?
 FAQForgottenPassword: I have forgotten my password
 FAQCampusCantLogin: I can't log in using my Fraport AG credentials (Büko login)
-FAQCourseCorrectorsTutors: How can I add instructors or correctors to my course?
 FAQNotLecturerHowToCreateCourses: How can I create new courses?
-FAQExamPoints: Why can't I enter achievements for my exam as points?
-FAQInvalidCredentialsAdAccountDisabled: I can't log in and am instead given the message “Account disabled”

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

@@ -111,7 +111,6 @@ ProblemsDriversHaveAvsIds: Alle Inhaber einer Fahrberechtigung konnten einer AVS
 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
@@ -120,3 +119,15 @@ 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
+ProblemsInterfaceSince: Berücksichtigt werden nur Erfolge und Fehler seit 
+
+InterfacesOk: Schnittstellen sind ok.
+InterfacesFail n@Int: #{pluralDEeN n "Schnittstellenproblem"}!
+InterfaceStatus !ident-ok: Status
+InterfaceName: Schnittstelle
+InterfaceLastSynch: Zuletzt
+InterfaceSubtype: Betreffend
+InterfaceWrite: Schreibend
+InterfaceSuccess: Rückmeldung
+InterfaceInfo: Nachricht
+InterfaceFreshness: Prüfungszeitraum (h)

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

@@ -111,7 +111,6 @@ ProblemsDriversHaveAvsIds: All driving licence holder could be matched with thei
 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'
@@ -120,3 +119,15 @@ 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
+ProblemsInterfaceSince: Only considering successes and errors since 
+
+InterfacesOk: Interfaces are ok.
+InterfacesFail n: #{pluralENsN n "interface problem"}!
+InterfaceStatus: Status
+InterfaceName: Interface
+InterfaceLastSynch: Last
+InterfaceSubtype: Affecting
+InterfaceWrite: Write
+InterfaceSuccess: Returned
+InterfaceInfo: Message
+InterfaceFreshness: Check hours

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

@@ -20,6 +20,8 @@ UnauthorizedTokenInvalidAuthorityValue: Ihr Authorisierungs-Token basiert auf Re
 UnauthorizedTokenInvalidImpersonation: Ihr Authorisierungs-Token enthält die Anweisung sich als ein Nutzer:in auszugeben, dies ist jedoch nicht allen Benutzer:innen, auf deren Rechten ihr Authorisierungs-Token basiert, erlaubt.
 UnauthorizedToken404: Authorisierungs-Tokens können nicht auf Fehlerseiten ausgewertet werden.
 UnauthorizedSupervisor: Sie sind kein Ansprechpartner:in für diesen Benutzer:in.
+UnauthorizedAnySupervisor: Sie sind kein Ansprechpartner:in.
+UnauthorizedCompanySupervisor fsh@CompanyShorthand: Sie sind kein Standard Ansprechpartner:in für Firma #{fsh}.
 UnauthorizedSiteAdmin: Sie sind nicht System-weiter Administrator:in.
 UnauthorizedSchoolAdmin: Sie sind nicht als Administrator:in für diesen Bereich eingetragen.
 UnauthorizedAdminEscalation: Sie sind nicht Administrator:in für alle Bereiche, für die dieser Nutzer/diese Nutzerin Administrator:in oder Veranstalter:in ist.

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

@@ -20,6 +20,8 @@ UnauthorizedTokenInvalidAuthorityValue: The specification of the rights in which
 UnauthorizedTokenInvalidImpersonation: Your authorisation-token contains an instruction to impersonate an user. Not all users on whose rights your token is based however are permitted to do so.
 UnauthorizedToken404: Authorisation-tokens cannot be processed on error pages.
 UnauthorizedSupervisor: You are not a supervisor for the requested user.
+UnauthorizedAnySupervisor: You are not a supervisor.
+UnauthorizedCompanySupervisor fsh: You are not a default supervisor for company #{fsh}.
 UnauthorizedSiteAdmin: You are no system-wide administrator.
 UnauthorizedSchoolAdmin: You are no administrator for this department.
 UnauthorizedAdminEscalation: You aren't an administrator for all departments for which this user is an administrator.

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

@@ -95,7 +95,7 @@ CourseParticipantsInvited n@Int: #{n} #{pluralDE n "Einladung" "Einladungen"} pe
 CourseParticipantsAlreadyRegistered n@Int: #{n} #{pluralDE n "Teinehmer:in" "Teilnehmer:innen"} #{pluralDE n "ist" "sind"} bereits zur Kursart angemeldet
 CourseParticipantsAlreadyTutorialMember n@Int: #{n} #{pluralDE n "Teinehmer:in" "Teilnehmer:innen"} #{pluralDE n "ist" "sind"} bereits in dieser Kurs angemeldet
 CourseParticipantsRegistered n@Int: #{n} #{pluralDE n "Teinehmer:in" "Teilnehmer:innen"} erfolgreich zur Kursart angemeldet
-CourseParticipantsRegisteredTutorial n@Int: #{n} #{pluralDE n "Teinehmer:in" "Teilnehmer:innen"} erfolgreich zur Kurs angemeldet
+CourseParticipantsRegisteredTutorial n@Int: #{n} #{pluralDE n "Teinehmer:in" "Teilnehmer:innen"} erfolgreich zum Kurs angemeldet
 CourseParticipantsRegisterConfirmationHeading: Teilnehmer:innen hinzufügen
 CourseParticipantsRegisterUnnecessary: Alle angeforderten Anmeldungen sind bereits vorhanden. Es wurden keine Änderungen vorgenommen.
 CourseParticipantsRegisterConfirmInvalid: Ungültiges Bestätigungsformular!

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

@@ -0,0 +1,60 @@
+# SPDX-FileCopyrightText: 2023 Steffen Jost <s.jost@fraport.de>
+#
+# SPDX-License-Identifier: AGPL-3.0-or-later
+
+FirmSuperDefault: Standardansprechpartner
+FirmSuperForeign: Firmenfremde Ansprechpartner
+FirmSuperIrregular: Irreguläre Ansprechpartner
+FirmAssociates: Firmenangehörige
+FirmContact: Firmenkontakt
+FirmNoContact: Keine allgemeinen Kontaktinformationen bekannt.
+FirmEmail: Allgemeine Email
+FirmAddress: Postanschrift
+FirmDefaultPreferenceInfo: Diese Voreinstellungen gelten nur für neue Firmenangehörige
+FirmAction: Firmenweite Aktion
+FirmActionInfo: Betrifft alle Firmenangehörigen unter Ihrer Aufsicht.
+FirmActNotify: Mitteilung versenden
+FirmActResetSupervision: Ansprechpartner für alle Firmenangehörigen zurücksetzen
+FirmActResetSuperKeep: Bisherige Ansprechpartner der Firmenangehörigen zusätzlich beibehalten?
+FirmActResetMutualSupervision: Ansprechpartner beaufsichtigen sich gegenseitig
+FirmActAddSupersvisors: Ansprechpartner hinzufügen
+FirmActAddSupersEmpty: Es konnten keine Ansprechpartner hinzugefügt werden
+FirmActAddSupersSet n@Int64 postal@(Maybe Bool): #{n} Standardansprechpartner geändert #{maybeBoolMessage postal "" "und auf Briefversand geschaltet" "und Benachrichtigungen per Email gesetzt"}, aber nicht nicht aktiviert.
+RemoveSupervisors ndef@Int64 nact@Int64: #{ndef} Standard Ansprechpartner entfernt#{bool ", aber noch nicht deaktiviert" (", " <> tshow nact <> " aktive Ansprechpartnerbeziehungen gelöscht") (nact > 0)}
+FirmActChangeContactUser: Kontaktinformationen von allen Firmenangehörigen ändern
+FirmActChangeContactFirm: Kontaktinformationen der Firma ändern
+FirmActChangeContactFirmInfo: Firmenkontaktinformationen werden nur für neue Firmenangehörige verwendet, für die sonst keine Kontaktinformationen vorliegen.
+FirmActChangeContactFirmResult: Firmenkontaktinformationen geändert. Betrifft nur neue Firmenangehörige ohne eigene Kontaktinformationen
+FirmUserActNotify: Mitteilung versenden
+FirmUserActResetSupervision: Ansprechpartner auf Firmenstandard zurücksetzen
+FirmUserActSetSupervisor: Ansprechpartner ändern
+FirmNewSupervisor: Neue individuelle Ansprechpartner hinzufügen
+FirmSetSupervisor: Existierende Ansprechpartner hinzufügen
+FirmSetSupersReport nusr@Int64 nspr@Int64 nrem@Int64: Für #{nusr} Firmenangehörige wurden #{nspr} individuelle Ansprechpartner eingetragen#{bool "." (" und " <> tshow nrem <> " individuelle Ansprechpartnerbeziehungen gelöscht.") (nrem >0)}
+FirmUserActMkSuper: Zum Firmenansprechpartner ernennen
+FirmUserActChangeContact: Kontaktinformationen für ausgewählte Firmenangehörige ändern
+FirmResetSupervision rem@Int64 set@Int64: #{tshow set} Ansprechpartner gesetzt#{bool mempty (", " <> tshow rem <> " zuvor gelöscht") (rem > 0)}
+FirmSuperActNotify: Mitteilung versenden
+FirmSuperActSwitchSuper: Standard Firmenansprechpartner abändern
+FirmSuperActSwitchSuperInfo: Betrifft keine firmenfremden Ansprechpartner und ändert keine aktiven individuellen Ansprechpartnerbeziehungen. Gegebenfalls im Anschluss die Funktion "Ansprechpartner auf Firmenstandard zurücksetzen" nutzen.
+FirmSuperActRMSuperDef: Firmenansprechpartner entfernen
+FirmSuperActRMSuperActive: Auch aktive Ansprechpartnerbeziehungen innerhalb dieser Firma beenden
+FirmsNotification: Firmen E-Mail versenden
+FirmNotification fsh@CompanyShorthand: E-Mail an #{fsh} senden
+FirmsNotificationTitle: Firmen benachrichtigen
+FirmNotificationTitle fsh@CompanyShorthand: #{fsh} benachrichtigen
+FilterSupervisor: Hat aktiven Ansprechpartner
+FilterSupervisorCompany fsh@CompanyShorthand: Hat aktiven Ansprechpartner, #{fsh} der angehört
+FilterSupervisorForeign fsh@CompanyShorthand: Hat aktiven Ansprechpartner, der selbst nicht #{fsh} angehört
+FilterForeignSupervisor: Hat firmenfremde Ansprechpartner
+FilterFirmExtern: Externe Firma
+FirmSupervisorOf fsh@CompanyShorthand: Ansprechpartner #{fsh} angehörig
+FirmSupervisorIndependent: Ansprechpartner ohne jegliche Firmenzugehörigkeit
+FirmEmployeeOf fsh@CompanyShorthand: Firmenangehörige #{fsh}
+NoCompanySelected: Bitte wählen Sie mindestens eine Firma aus.
+TableIsDefaultSupervisor: Standardansprechpartner
+TableIsDefaultReroute: Standardumleitung
+FormFieldPostal: Benachrichtigungseinstellung
+FormFieldPostalTip: Gilt für alle Benachrichtigungen an diese Person, nicht nur für Umleitungen an diesen Ansprechpartner
+FirmUserChanges n@Int64: Benachrichtigungseinstellung für #{n} Firmenangehörige wurden geändert
+FirmSupervisionKeyData: Kennzahlen Ansprechpartner

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

@@ -0,0 +1,60 @@
+# SPDX-FileCopyrightText: 2023 Steffen Jost <s.jost@fraport.de>
+#
+# SPDX-License-Identifier: AGPL-3.0-or-later
+
+FirmSuperDefault: Default supervisor
+FirmSuperForeign: External supervisor
+FirmSuperIrregular: Irregular supervisor
+FirmAssociates: Company associated users
+FirmContact: Company Contact
+FirmNoContact: No general contact information known.
+FirmEmail: General company email
+FirmAddress: Postal address
+FirmDefaultPreferenceInfo: Default setting for new company associates only
+FirmAction: Companywide action
+FirmActionInfo: Affects alle company associates under your supervision.
+FirmActNotify: Send message
+FirmActResetSupervision: Reset supervisors for all company associates
+FirmActResetSuperKeep: Additionally keep existing supervisors of company associates?
+FirmActResetMutualSupervision: Supervisors supervise each other
+FirmActAddSupersvisors: Add supervisors
+FirmActAddSupersEmpty: No supervisors added
+FirmActAddSupersSet n postal: #{n} default company supervisors changed #{maybeBoolMessage postal "" "and switched to postal notifications" "and switched to email notifications"}, but not yet activated.
+RemoveSupervisors ndef nact: #{ndef} default supervisors removed#{bool ", but not yet deactivated" (" and " <> tshow nact <> " active supervisions terminated") (nact > 0)}
+FirmActChangeContactUser: Change contact data for all company associates
+FirmActChangeContactFirm: Change company contact data
+FirmActChangeContactFirmInfo: The company contact data is only used for new company associates that would habe no contact information of their own otherwise.
+FirmActChangeContactFirmResult: Company contact data changed, affecting future company associates without contact information only
+FirmUserActNotify: Send message
+FirmUserActResetSupervision: Reset supervisors to company default
+FirmUserActSetSupervisor: Change supervision
+FirmNewSupervisor: Appoint new individual supervisors
+FirmSetSupervisor: Add existing supervisors
+FirmSetSupersReport nusr@Int64 nspr@Int64 nrem@Int64: #{nspr} individal supervisors set for #{nusr} company associates#{bool "." (" and " <> tshow nrem <> " other individual supervisions terminated.") (nrem >0)}
+FirmResetSupervision rem set: #{tshow set} supervisors set#{bool mempty (", " <> tshow rem <> " deleted before") (rem > 0)}
+FirmUserActChangeContact: Change contact data for selected company associates
+FirmUserActMkSuper: Mark as company supervisor
+FirmSuperActNotify: Send message
+FirmSuperActSwitchSuper: Change default company supervisor
+FirmSuperActSwitchSuperInfo: Does not affect company-external supervisors and does not change any active individal supervisions. Additionally use reset action, if desired.
+FirmSuperActRMSuperDef: Remove default supervisor
+FirmSuperActRMSuperActive: Also remove active supervisions within this company
+FirmsNotification: Send company notification e-mail
+FirmNotification fsh: Send e-mail to #{fsh}
+FirmsNotificationTitle: Company notification
+FirmNotificationTitle fsh@CompanyShorthand: #{fsh} notification
+FilterSupervisor: Has active supervisor
+FilterSupervisorCompany fsh: Has active company supervisor belonging to #{fsh}
+FilterSupervisorForeign fsh: Has active supervisor not belonging to #{fsh}
+FilterForeignSupervisor: Has company-external supervisors
+FilterFirmExtern: External company
+FirmSupervisorOf fsh@CompanyShorthand: Supervisors belonging to #{fsh}
+FirmSupervisorIndependent: Independent supervisors
+FirmEmployeeOf fsh@CompanyShorthand: #{fsh} associated users
+NoCompanySelected: Select at least one company, please.
+TableIsDefaultSupervisor: Default supervisor
+TableIsDefaultReroute: Default reroute
+FormFieldPostal: Notification type
+FormFieldPostalTip: Affects all notifications to this person, not just reroutes to this supervisor
+FirmUserChanges n: Notification settings changed for #{n} company associates
+FirmSupervisionKeyData: Supervision key data

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

@@ -15,7 +15,6 @@ ResetPassword: FRADrive-Passwort ändern bzw. setzen
 MailSubjectChangeUserDisplayEmail: E-Mail-Adresse in FRADrive verwenden
 MailIntroChangeUserDisplayEmail displayEmail@UserEmail: Der oben genannte Benutzer/Die oben genannte Benutzerin möchte „#{displayEmail}“ als E-Mail-Adresse in FRADrive verwenden. Wenn Sie diese Aktion nicht selbst ausgelöst haben, ignorieren Sie diese Mitteilung bitte!
 MailTitleChangeUserDisplayEmail displayName@Text: #{displayName} möchte diese E-Mail-Adresse in FRADrive verwenden
-CommCourseSubject: Kursartmitteilung
 InvitationAcceptDecline: Einladung annehmen/ablehnen
 InvitationFromTip displayName@Text: Sie erhalten diese Einladung, weil #{displayName} ihren Versand in FRADrive ausgelöst hat.
 InvitationFromTipAnonymous: Sie erhalten diese Einladung, weil ein nicht eingeloggter Benutzer/eine nichteingeloggte Benutzerin ihren Versand in FRADrive ausgelöst hat.

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

@@ -15,7 +15,6 @@ ResetPassword: Reselt FRADrive password
 MailSubjectChangeUserDisplayEmail: Set email address in FRADrive
 MailIntroChangeUserDisplayEmail displayEmail: The user mentioned above wants to set “#{displayEmail}” as their own email address. If you have not caused this email to be sent, please ignore it!
 MailTitleChangeUserDisplayEmail displayName: #{displayName} wants to set this email address as their own in FRADrive
-CommCourseSubject: Course type message
 InvitationAcceptDecline: Accept/Decline invitation
 InvitationFromTip displayName: You are receiving this invitation because #{displayName} has caused it to be sent from within FRADrive.
 InvitationFromTipAnonymous: You are receiving this invitiation because an user who didn't log in has caused it to be send from within FRADrive.

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

@@ -38,6 +38,7 @@ QualificationScheduleRenewalTooltip: Wird eine Benachrichtigung versendet, falls
 QualificationUserNoRenewal: Läuft ohne Benachrichtigung aus
 QualificationUserNone: Für diese Person sind keine Qualifikationen registriert.
 QualificationGrantReason: Erteilungsbegründung
+QualificationRenewReason: Verlängerungsbegründung
 QualificationBlockReason: Entzugsbegründung
 QualificationBlockNotify: Benachrichtigung verschicken
 QualificationBlockRemoveSupervisor: Alle Ansprechpartner löschen
@@ -83,14 +84,8 @@ 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
-LmsResultInsert: Neues LMS Ergebnis
-LmsResultUpdate: LMS Ergebnis Aktualisierung
 LmsReportInsert: Neues LMS Ereignis
 LmsReportUpdate: LMS Ereignis Aktualisierung
-LmsResultCsvExceptionDuplicatedKey: CSV-Import LmsResult fand uneindeutigen Schlüssel
-LmsUserlistCsvExceptionDuplicatedKey: CSV-Import LmsUserlist fand uneindeutigen Schlüssel
 LmsReportCsvExceptionDuplicatedKey: CSV-Import LmsReport fand uneindeutigen Schlüssel
 LmsDirectUpload: Direkter Upload für automatisierte Systeme
 LmsErrorNoRefreshElearning: Fehler: E‑Learning wird nicht automatisch gestartet, da die Zeitspanne für den Erneurerungszeitraum nicht festgelegt wurde.
@@ -137,7 +132,5 @@ LmsNotificationSend n@Int: E‑Learning Benachrichtigungen an #{n} #{pluralDE n
 LmsPinRenewal n@Int: E‑Learning Passwort ausgetauscht für #{n} #{pluralDE n "Prüfling" "Prüflinge"}.
 LmsActionFailed n@Int: Aktion nicht durchgeführt für #{n} #{pluralDE n "Person" "Personen"}, da diese derzeit nicht an einer Prüfung teilnehmen.
 LmsStarted: E‑Learning eröffnet
-LmsAutomaticQueuing n@Natural: Die folgenden Funktionen werden normalerweise einmal pro Tag um #{show n} Uhr ausgeführt.
-LmsManualQueuing: Die folgenden Funktionen sollten einmal pro Tag ausgeführt werden.
 BtnLmsEnqueue: Nutzer mit ablaufenden Qualifikationen zum E‑Learning anmelden und benachrichtigen
-BtnLmsDequeue: Nutzer mit beendetem E‑Learning ggf. benachrichtigen und aufräumen 
+BtnLmsDequeue: Nutzer mit beendetem E‑Learning aufräumen und ggf. benachrichtigen

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

@@ -7,7 +7,7 @@ QualificationName: Qualification
 QualificationDescription: Description
 QualificationValidIndicator: Validity
 QualificationValidDuration: Validity period
-QualificationAuditDuration: Audit log keept
+QualificationAuditDuration: Audit log retention period
 QualificationAuditDurationTooltip n@Int: Optional period for deletion of e‑learning data. Note that the e‑learning server may delete its anonymised data earlier, at most #{n} days after closing.
 QualificationRefreshWithin: Refresh within
 QualificationRefreshWithinTooltip: Optional period before expiry to start e‑learning and send a notification by post or email.
@@ -19,7 +19,7 @@ QualificationExpiryNotificationTooltip: Qualification holder are notfied upon in
 TableQualificationCountActive: Active
 TableQualificationCountActiveTooltip: Number of currently valid qualification holders
 TableQualificationCountTotal: Total
-TableQualificationIsAvsLicence: AVS Driving License
+TableQualificationIsAvsLicence: AVS driving license
 TableQualificationIsAvsLicenceTooltip: Under which name is this qualification synchronized with AVS, if any? Only applies to qualification holders having an AVS PersonID.
 TableQualificationSapExport: Sent to SAP
 TableQualificationSapExportTooltip: Is this qualification transmitted to SAP? Only applies to qualification holder having a Fraport AG personnel number.
@@ -38,6 +38,7 @@ QualificationScheduleRenewalTooltip: Will there be a notification, if this quali
 QualificationUserNoRenewal: Expires without further notification
 QualificationUserNone: No registered qualifications for this person.
 QualificationGrantReason: Reason for granting
+QualificationRenewReason: Reason for renewal
 QualificationBlockReason: Reason for revoking
 QualificationBlockNotify: Send notification
 QualificationBlockRemoveSupervisor: Remove all supervisors
@@ -83,14 +84,8 @@ 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
 LmsReportInsert: New LMS event
 LmsReportUpdate: Update of LMS event
-LmsResultCsvExceptionDuplicatedKey: CSV import LmsResult with ambiguous key
-LmsUserlistCsvExceptionDuplicatedKey: CSV import LmsUserlist with ambiguous key
 LmsReportCsvExceptionDuplicatedKey: CSV Import LmsReport with ambiguous key
 LmsDirectUpload: Direct upload for automated systems
 LmsErrorNoRefreshElearning: Error: E‑learning will not be started automatically due to refresh-within time period not being set.
@@ -137,7 +132,5 @@ LmsNotificationSend n: E‑learning notifications will be sent to #{n} #{pluralE
 LmsPinRenewal n: E‑learning password replaced randomly for #{n} #{pluralENs n "examinee"}.
 LmsActionFailed n: No action for #{n} #{pluralENs n "person"}, since there was no ongoing examination.
 LmsStarted: E‑learning open since
-LmsAutomaticQueuing n@Natural: The following functions are executed daily at #{show n} o'clock.
+BtnLmsEnqueue: Enqueue users with expiring qualifications for e‑learning and notify them
-LmsManualQueuing: The following functions should be executed daily.
+BtnLmsDequeue: Dequeue users with finished e‑learning and notify failed users
-BtnLmsEnqueue: Enqueue users with expiring qualifications for e‑learning and notify them.
-BtnLmsDequeue: Dequeue users with finished e‑learning and notify, if appropriate.

messages/uniworx/categories/send/send_notifications/de-de-formal.msg

@@ -103,4 +103,4 @@ MailSupervisorNoCopy: Warnung: Diese Nachricht wurde nicht an den eigentlichen E
 MailSupervisedNote: Hinweis
 MailSupervisedBody: Eine Kopie dieser Nachricht wurde auch an folgende in FRADrive eingetragene Ansprechpartner gesendet:
 MailSupervisorReroute: Benachrichtigungsumleitung
-MailSupervisorRerouteTooltip: Alle Benachrichtigungen werden stattdessen an alle Ansprechpartner mit Benachrichtigungsumleitung gesandt
+MailSupervisorRerouteTooltip: Alle Benachrichtigungen werden stattdessen an diese Ansprechpartner mit Benachrichtigungsumleitung gesandt

messages/uniworx/categories/send/send_notifications/en-eu.msg

@@ -103,4 +103,4 @@ MailSupervisorNoCopy: Warning: This message was not sent to the original recipie
 MailSupervisedNote: Please note
 MailSupervisedBody: A copy of this message has been sent to all supervisors registered for you in FRADrive, namely:
 MailSupervisorReroute: Reroute notifications
-MailSupervisorRerouteTooltip: All notification will be sent to all supervisors with notification rerouting instead
+MailSupervisorRerouteTooltip: All notification will be rerouted to these supervisors instead

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

@@ -37,7 +37,8 @@ PDFPassword: Passwort zur Verschlüsselung von PDF Anhängen an Email Benachrich
 PDFPasswordTip: Achtung, dieses Passwort ist für FRADrive Administratoren einsehbar und wird unverschlüsselt gespeichert!
 PDFPasswordInvalid c@Char: Bitte ein nicht-triviales Passwort für PDF Email Anhänge eintragen! Ungültiges Zeichen: #{char2Text c}
 PDFPasswordTooShort n@Int: Bitte ein PDF Passwort mit mindestens #{show n} Zeichen wählen oder Post-Versand aktivieren
-PrefersPostal: Sollen Benachrichtigung möglichst per Post versendet werden anstatt per Email?
+PrefersPostal: Bevorzugte Benachrichtigung
+PrefersPostalExp: Sollen Benachrichtigung möglichst per Post versendet werden anstatt per Email?
 PostalTip: Postversand kann in Rechnung gestellt werden und ist derzeit nur für Benachrichtigungen über Erneuerung und Ablauf von Qualifikation, wie z.B. Führerscheine, verfügbar.
 PostAddress: Postalische Adresse
 PostAddressTip: Mindestens eine Zeile mit Straße und Hausnummer und eine Zeile mit Postleitzahl und Ort. Kein Empfängername, denn dieser wird später automatisch hinzugefügt.

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

@@ -37,7 +37,8 @@ PDFPassword: Password to lock PDF email attachments
 PDFPasswordTip: Please note that this password is displayed to FRADrive admins and is saved unencrypted
 PDFPasswordInvalid c: Please supply a sensible password for encrypting PDF email attachments! Invalid character #{char2Text c}
 PDFPasswordTooShort n: Please provide a password with at least #{show n} characters or choose postal mail
-PrefersPostal: Should notifications preferably send by post instead of email?
+PrefersPostal: Notification preference
+PrefersPostalExp: Should notifications preferably send by post instead of email?
 PostalTip: Mailing may incur a fee and is currently only avaulable for qualification expiry notifications, such as driving lincence renewal.
 PostAddress: Postal address
 PostAddressTip: Should contain at least one line with street and house number and another line featuring zip code and town. Omit a recipient name, since it will be added later.

messages/uniworx/misc/de-de-formal.msg

@@ -10,6 +10,7 @@ BoolIrrelevant !ident-ok: —
 FieldPrimary: Hauptfach
 FieldSecondary: Nebenfach
 MultiEmailFieldTip: Es sind mehrere, Komma-separierte, E-Mail-Adressen möglich
+MultiSelectTip: Mehrfachauswahl und Abwählen mit Strg-Klick
 WeekDay: Wochentag
 LdapIdentificationOrEmail: Fraport AG-Kennung / E-Mail-Adresse
 Months num@Int64: #{num} #{pluralDE num "Monat" "Monate"}

messages/uniworx/misc/en-eu.msg

@@ -10,6 +10,7 @@ BoolIrrelevant: —
 FieldPrimary: Major
 FieldSecondary: Minor
 MultiEmailFieldTip: Multiple emails addresses may be specified (comma-separated)
+MultiSelectTip: Multiple selection and desection via Ctrl-Click
 WeekDay: Day of the week
 LdapIdentificationOrEmail: Fraport AG-Kennung / email address
 Months num: #{num} #{pluralEN num "Month" "Months"}

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

@@ -23,6 +23,7 @@ MenuPayments: Zahlungsbedingungen
 
 MenuInstance: Instanz-Identifikation
 MenuHealth: Instanz-Zustand
+MenuHealthInterface: Schnittstellen Zustand
 MenuHelp: Hilfe
 MenuProfile: Anpassen
 MenuLogin !ident-ok: Login
@@ -124,8 +125,6 @@ MenuLmsUser: Benutzerqualifikationen
 MenuLmsUserSchool: Bereichs Benutzerqualifikationen
 MenuLmsUserAll: Alle Benutzerqualifikationen
 MenuLmsUsers: Veralteter Export E‑Learning Benutzer
-MenuLmsUserlist: Veraltetes Melden E‑Learning Benutzer
-MenuLmsResult: Veralteter Melden Ergebnisse E‑Learning
 MenuLmsUpload: Hochladen
 MenuLmsDirectUpload: Direkter Upload
 MenuLmsDirectDownload: Direkter Download
@@ -133,6 +132,12 @@ MenuLmsFake: Testnutzer generieren
 MenuLmsLearners: Export Benutzer E‑Learning
 MenuLmsReport: Ergebnisse E‑Learning
 
+MenuFirms: Firmen
+MenuFirmUsers: Angehörige
+MenuFirmSupervisors: Ansprechpartner
+MenuFirmsComm: Mitteilung
+
+MenuInterfaces: Schnittstellen
 MenuSap: SAP Schnittstelle
 
 MenuAvs: AVS Schnittstelle
@@ -141,6 +146,8 @@ MenuLdap: LDAP Schnittstelle
 MenuApc: Druckerei
 MenuPrintSend: Manueller Briefversand
 MenuPrintDownload: Brief herunterladen
+MenuPrintLog: LPR Schnittstelle
+MenuPrintAck: Druckbestätigung
 
 MenuApiDocs: API-Dokumentation (Englisch)
 MenuSwagger !ident-ok: OpenAPI 2.0 (Swagger)

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

@@ -23,6 +23,7 @@ MenuPayments: Payment Terms
 
 MenuInstance: Instance identification
 MenuHealth: Instance health
+MenuHealthInterface: Interface health
 MenuHelp: Support
 MenuProfile: Settings
 MenuLogin: Login
@@ -70,7 +71,6 @@ MenuCourseDelete: Delete course
 MenuSubmissionNew: Create submission
 MenuSubmissionOwn: Submission
 MenuCorrectors: Correctors
-
 MenuSheetEdit: Edit exercise sheet
 MenuSheetDelete: Delete exercise sheet
 MenuSheetClone: Clone exercise sheet
@@ -125,8 +125,6 @@ MenuLmsUser: User Qualifications
 MenuLmsUserSchool: Institute User Qualifications
 MenuLmsUserAll: All User Qualifications
 MenuLmsUsers: Legacy download e‑learning users
-MenuLmsUserlist: Legacy upload e‑learning users
-MenuLmsResult: Legacy upload r‑learning results
 MenuLmsUpload: Upload
 MenuLmsDirectUpload: Direct Upload
 MenuLmsDirectDownload: Direct Download
@@ -134,6 +132,12 @@ MenuLmsFake: Generate Test Users
 MenuLmsLearners: E‑learning Users
 MenuLmsReport: E‑learning Results
 
+MenuFirms: Companies
+MenuFirmUsers: Associates
+MenuFirmSupervisors: Supervisors
+MenuFirmsComm: Messaging
+
+MenuInterfaces: Interfaces
 MenuSap: SAP Interface 
 
 MenuAvs: AVS Interface
@@ -142,6 +146,8 @@ MenuLdap: LDAP Interface
 MenuApc: Printing
 MenuPrintSend: Send Letter
 MenuPrintDownload: Download Letter
+MenuPrintLog: LPR Interface
+MenuPrintAck: Acknowledge Printing
 
 MenuApiDocs: API documentation
 MenuSwagger: OpenAPI 2.0 (Swagger)

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

@@ -75,8 +75,23 @@ TableExamOfficeLabelStatus: Label-Farbe
 TableExamOfficeLabelPriority: Label-Priorität
 TableQualifications: Qualifikationen
 TableCompany: Firma
+TableCompanyFilter: Firma oder Nummer
+TableCompanyShort: Firmenkürzel
 TableCompanies: Firmen
+TableCompanyNo: Firmennummer
 TableCompanyNos: Firmennummern
+TableCompanyUser: Firmenangehöriger
+TableCompanyNrUsers: Firmenangehörige
+TableCompanyNrSupers: Ansprechpartner
+TableCompanyNrEmpSupervised: Firmenangehörige mit Ansprechpartner
+TableCompanyNrEmpRerouted: Firmenangehörige mit Umleitung
+TableCompanyNrEmpRerPost: Firmenangehörige mit postalischer Umleitung
+TableCompanyNrSupersActive: Mitarbeiter mit Ansprechpartner
+TableCompanyNrSupersDefault: Standard Ansprechpartner
+TableCompanyNrForeignSupers: Firmenfremde Ansprechpartner
+TableCompanyNrRerouteDefault: Standard Umleitungen
+TableCompanyNrRerouteActive: Aktive Umleitungen
+TableCompanyPostalPreference: Benachrichtigungspräferenz neue Firmenangehörige
 TableSupervisor: Ansprechpartner
 TableCreationTime: Erstellungszeit
 TableJob !ident-ok: Job
@@ -88,3 +103,7 @@ 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.
+TableFilterCommaName: Mehrere Namen mit Komma trennen.
+TableFilterCommaNameNr: Mehrere Namen oder Nummern mit Komma trennen. Nummern werden nur exakt gesucht.
+TableUserEdit: Benutzer bearbeiten
+TableRows: Zeilen

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

@@ -75,8 +75,23 @@ TableExamOfficeLabelStatus: Label colour
 TableExamOfficeLabelPriority: Label priority
 TableQualifications: Qualifications
 TableCompany: Company
+TableCompanyFilter: Company/Nr
+TableCompanyShort: Company shorthand
 TableCompanies: Companies
+TableCompanyNo: Company number
 TableCompanyNos: Company numbers
+TableCompanyUser: Associate
+TableCompanyNrUsers: Associates
+TableCompanyNrSupers: Supervisors
+TableCompanyNrEmpSupervised: Supervised employees 
+TableCompanyNrEmpRerouted: Employees having reroute
+TableCompanyNrEmpRerPost: Employees having postal reroute
+TableCompanyNrSupersActive: Associates having supervisors
+TableCompanyNrSupersDefault: Default supervisors
+TableCompanyNrForeignSupers: External Supervisors
+TableCompanyNrRerouteDefault: Default reroutes
+TableCompanyNrRerouteActive: Active reroutes
+TableCompanyPostalPreference: Default notification preference
 TableSupervisor: Supervisor
 TableCreationTime: Creation
 TableJob !ident-ok: Job
@@ -88,3 +103,7 @@ 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.
+TableFilterCommaName: Separate names by comma.
+TableFilterCommaNameNr: Separate names and numbers by comma. Numbers have to match exact.
+TableUserEdit: Edit user
+TableRows: Rows

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

@@ -13,10 +13,13 @@ RGCourseUnacceptedApplicants: Nicht akzeptierte Bewerber:innen
 RecipientToggleAll: Alle/Keine
 CommCourseTestSubject customSubject@Text !ident-ok: [TEST] #{customSubject}
 UtilCommCourseSubject: Kursartmitteilung
+UtilCommFirmSubject: Firmenmitteilung
 CommRecipients: Empfänger:innen
 CommRecipientsTip: Sie selbst erhalten immer eine Kopie der Nachricht
 CommRecipientsList: Die an Sie selbst verschickte Kopie der Nachricht wird, zu Archivierungszwecken, eine vollständige Liste aller Empfänger:innen enthalten. Die Empfängerliste wird im CSV-Format an die E-Mail angehängt. Andere Empfänger:innen erhalten die Liste nicht. Bitte entfernen Sie dementsprechend den Anhang bevor Sie die E-Mail weiterleiten oder anderweitig mit Dritten teilen.
 UtilEMail: E-Mail
+UtilPostal: Brief
+UtilUnchanged: Nicht verändern
 UtilMultiEmailFieldTip: Es sind mehrere, Komma-separierte, E-Mail-Adressen möglich
 RGTutorialParticipants tutn@TutorialName: Kursteilnehmer:innen (#{tutn})
 RGExamRegistered examn@ExamName: Angemeldet zur Prüfung „#{examn}“
@@ -93,6 +96,9 @@ RoomReferenceLinkLink !ident-ok: Link
 RoomReferenceLinkLinkPlaceholder !ident-ok: URL
 RoomReferenceLinkInstructions: Anweisungen
 RoomReferenceLinkInstructionsPlaceholder: Anweisungen
+UtilEmptyChoice: Auswahl war leer
+UtilEmptyNoChangeTip: Eine leere Eingabe belässt den vorherigen Wert unverändert.
+MultiNoSelection: Keine Auswahl
 
 #invitation.hs
 InvitationAction: Aktion

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

@@ -13,10 +13,13 @@ RGCourseUnacceptedApplicants: Applicants not accepted
 RecipientToggleAll: All/None
 CommCourseTestSubject customSubject: [TEST] #{customSubject}
 UtilCommCourseSubject: Course type message
+UtilCommFirmSubject: Company message 
 CommRecipients: Recipients
 CommRecipientsTip: You always receive a copy of the message
 CommRecipientsList: For archival purposes the copy of the message sent to you will contain a complete list of all recipients. The list of recipients will be attached to the email in CSV-format. Other recipients do not receive the list. Thus, please remove the attachment before you forward the email or otherwise share it with third parties.
 UtilEMail: Email
+UtilPostal: Postal
+UtilUnchanged: No change
 UtilMultiEmailFieldTip: Multiple emails addresses may be specified (comma-separated)
 RGTutorialParticipants tutn: Course participants (#{tutn})
 RGExamRegistered examn: Registered for exam “#{examn}”
@@ -93,6 +96,9 @@ RoomReferenceLinkLink: Link
 RoomReferenceLinkLinkPlaceholder: URL
 RoomReferenceLinkInstructions: Instructions
 RoomReferenceLinkInstructionsPlaceholder: Instructions
+UtilEmptyChoice: Empty selection
+UtilEmptyNoChangeTip: Existing values remain unchanged if this field is left empty.
+MultiNoSelection: No selection
 
 #invitation.hs
 InvitationAction: Action

models/audit.model

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
+-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -10,3 +10,22 @@ TransactionLog
   remote IP Maybe -- Remote party that triggered this action via HTTP
   info Value -- JSON-encoded `Transaction`
   deriving Eq Read Show Generic
+
+InterfaceLog  
+  interface Text
+  subtype   Text
+  write     Bool                  -- requestMethod /= GET, i.e. True implies a write to FRADrive
+  time      UTCTime
+  rows      Int Maybe             -- number of datasets transmitted  
+  info      Text                  -- addtional status information
+  success   Bool default=true     -- false logs a failure; but it will be overwritten by next transaction, but logged in TransactionLog
+  UniqueInterfaceSubtypeWrite interface subtype write
+  deriving Eq Read Show Generic
+
+InterfaceHealth
+  interface Text
+  subtype   Text Maybe
+  write     Bool Maybe
+  hours     Int  
+  UniqueInterfaceHealth interface subtype write !force -- Note that nullable fields must be either empty or unique
+  deriving Eq Read Show Generic

models/company.model

@@ -10,6 +10,7 @@ Company
   avsId           Int     default=0       -- primary key from avs
   prefersPostal   Bool    default=false   -- new company users prefers letters by post instead of email
   postAddress     StoredMarkup Maybe      -- default company postal address 
+  email           UserEmail Maybe         -- Case-insensitive generic company eMail address
   UniqueCompanyName name 
   UniqueCompanyShorthand shorthand
   -- UniqueCompanyAvsId avsId             -- should be the case, unclear if enforcing works here, since we cannot query avs by company id

models/lms.model

@@ -20,7 +20,7 @@ Qualification
   SchoolQualificationShort school shorthand            -- must be unique per school and shorthand
   SchoolQualificationName  school name                 -- must be unique per school and name
   -- across all schools, only one qualification may be a driving licence:
-  UniqueQualificationAvsLicence avsLicence      !force
+  UniqueQualificationAvsLicence avsLicence      !force -- either empty or unique
     -- NOTE: two NULL values are not equal for the purpose of Uniqueness constraints!
   deriving Eq Generic
 
@@ -95,25 +95,20 @@ QualificationUserBlock
   --     - delete-flag: isJust LmsUserStatus
   --   Note: REST means that LmsUserResetPin and LmsUserDelete remain unchanged by this GET request!
   --
-  -- 3. REST POST Userlist.csv: just save as is to LmsUserlist
+  -- 3. REST POST Report.csv: just save as is to LmsReport for later processing
   --
-  -- 4. REST POST Ergebnisse.csv: just save as is to LmsResult
+  -- 4. When received: Job LmsReport:               -- Note: containment needs at-once processing
-  --
-  -- 5. When received: Job LmsUserlist:               -- Note: containment needs at-once processing
   --     - For all LmsUser:
   --         + if contained:
   --              set LmsUserReceived to Just now()
-  --              if LmsUserlistFailed: set LmsUserStatus to Just LmsBlocked now
+  --              if Failed:  set LmsUserStatus to Just LmsBlocked now
+  --              if Success: set LmsUserStatus to Just LmsSuccess now
+  --                          and renew QualificationValidTo
   --         + not contained, by LmsUserReceived is set: set LmsUserEnded to Just now()
   --     - move row to LmsAudit
   --
-  -- 6. When received: Daily Job LmsResult:
+  -- 5. Daily Job: dequeue LMS Users
-  --     - set LmsUserReceived to Just now()             -- always
+  --     - fail and mark expired LmsUser
-  --     - set LmsUserStatus   to Just LmsSuccess now    -- conditional
-  --     -   and renew QualificationValidTo
-  --     - move row to LmsAudit
-  --
-  -- 7. Daily Job: dequeue LMS Users
   --     - remove from LmsUser after audit Period has passed
 
 LmsUser
@@ -144,24 +139,7 @@ LmsUser
 --   UniqueLmsUserStatus lmsUser -- enforcing uniqueness prohibits history
 --   deriving Generic
 
--- LmsUserlist stores LMS upload for later processing only
+-- V2 Stores LMS upload for processing in Background Job
-LmsUserlist
-  qualification     QualificationId OnDeleteCascade OnUpdateCascade
-  ident             LmsIdent        
-  failed            Bool
-  timestamp         UTCTime         default=now()
-  UniqueLmsUserlist qualification ident
-  deriving Generic Show
-
--- LmsResult stores LMS upload for later processing only
-LmsResult
-  qualification     QualificationId OnDeleteCascade OnUpdateCascade
-  ident             LmsIdent        
-  success           Day             -- BEWARE: timezone is local as submitted by LMS
-  timestamp         UTCTime         default=now()
-  UniqueLmsResult qualification ident -- required by DBTable
-  deriving Generic
-
 LmsReport
   qualification     QualificationId OnDeleteCascade OnUpdateCascade
   ident             LmsIdent
@@ -171,3 +149,15 @@ LmsReport
   timestamp         UTCTime         default=now()
   UniqueLmsReport qualification ident -- required by DBTable
   deriving Generic
+
+-- LmsAudit removed by commit 71cde92a
+-- due to frequent transmit errors, a separate lms tranmission log is necessary again
+LmsReportLog
+  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()  
+  missing           Bool            default=false
+  deriving Generic

models/print.model

@@ -9,11 +9,11 @@ PrintJob
   file            ByteString      -- stores plain pdf; otherwise use FileContentReference Maybe
   created         UTCTime
   acknowledged    UTCTime Maybe
-  recipient       UserId Maybe          OnDeleteCascade OnUpdateCascade   -- optional as some letters may contain just an address
+  recipient       UserId Maybe          OnDeleteSetNull OnUpdateCascade   -- optional as some letters may contain just an address
   sender          UserId Maybe          OnDeleteSetNull OnUpdateCascade   -- senders and associations are optional
   course          CourseId Maybe        OnDeleteCascade OnUpdateCascade
   qualification   QualificationId Maybe OnDeleteCascade OnUpdateCascade
-  lmsUser         LmsIdent        Maybe OnDeleteCascade OnUpdateCascade   -- allows tracking if recipient has been notified; must be unique  
+  lmsUser         LmsIdent        Maybe OnDeleteSetNull OnUpdateCascade   -- allows tracking if recipient has been notified; must be unique  
   -- UniquePrintJobLmsUser lmsUser -- Note that in fact multiple print jobs per LMS user are possible!
   -- UniquePrintJobApcIdent apcIdent -- TODO: not yet enforced, since LmsIdent is currently used
   deriving Generic

models/schools.model

@@ -10,7 +10,7 @@ School json
     examMinimumRegisterBeforeStart NominalDiffTime Maybe
     examMinimumRegisterDuration    NominalDiffTime Maybe
     examRequireModeForRegistration Bool default=false
-    examDiscouragedModes ExamModeDNF default='{"dnf-terms":[]}'  -- This comment fixes syntax highlighting error only " 
+    examDiscouragedModes ExamModeDNF
     examCloseMode ExamCloseMode default='separate' 
     sheetAuthorshipStatementMode SchoolAuthorshipStatementMode default='optional'
     sheetAuthorshipStatementDefinition AuthorshipStatementDefinitionId Maybe

models/users.model

@@ -2,7 +2,7 @@
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
--- The files in /models determine the database scheme.
+-- The files in /models determine t he database scheme.
 -- The organisational split into several files has no operational effects.
 -- White-space and case matters: Each SQL table is named in 1st column of this file
 -- Indendent lower-case lines describe the SQL-columns of the table with name, type and options
@@ -34,7 +34,7 @@ User json    -- Each Uni2work user has a corresponding row in this table; create
     timeFormat     DateTimeFormat "default='%R'"             -- preferred Time-only display format for user; user-defined
     downloadFiles  Bool default=false           -- Should files be opened in browser or downloaded? (users often oblivious that their browser has a setting for this)
     languages      Languages Maybe          -- Preferred language; user-defined
-    notificationSettings NotificationSettings  "default='{}'::jsonb"   -- Bit-array for which events email notifications are requested by user; user-defined
+    notificationSettings NotificationSettings  "default='{}'::jsonb"   -- Bit-array for which events email notifications are requested by user; user-defined; missing fields in json object will be parsed to default trigger
     warningDays    NominalDiffTime default=1209600 -- timedistance to pending deadlines for homepage infos
     csvOptions     CsvOptions "default='{}'::jsonb"
     sex            Sex Maybe  -- currently ignored

nix/docker/version.json

@@ -1,3 +1,3 @@
 {
-  "version": "27.4.45"
+  "version": "27.4.59"
 }

package-lock.json

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

package.json

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

package.yaml

@@ -3,7 +3,7 @@
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
 name: uniworx
-version: 27.4.45
+version: 27.4.59
 dependencies:
   - base
   - yesod
@@ -263,6 +263,7 @@ ghc-options:
   - -j
   - -freduction-depth=0
   - -fprof-auto-calls
+  - -g
 when:
   - condition: flag(pedantic)
     ghc-options:

routes

@@ -79,24 +79,26 @@
 
 /print                                PrintCenterR    GET POST  !system-printer
 /print/acknowledge/#Day/#Int/#Int     PrintAckR       GET POST  !system-printer
-/print/acknowledge/direct             PrintAckDirectR     POST  !system-printer
+/print/acknowledge/direct             PrintAckDirectR GET POST  !system-printer
 /print/send                           PrintSendR      GET POST
 /print/download/#CryptoUUIDPrintJob   PrintDownloadR  GET       !system-printer
+/print/log                            PrintLogR       GET       !system-printer
 
-/health                       HealthR          GET              !free
+/health                       HealthR           GET             !free
-/instance                     InstanceR        GET              !free
+/health/interface/+Texts      HealthInterfaceR  GET             !free
-/info                         InfoR            GET              !free
+/instance                     InstanceR         GET             !free
-/info/lecturer                InfoLecturerR    GET              !free
+/info                         InfoR             GET             !free
-/info/supervisor              InfoSupervisorR  GET              !free
+/info/lecturer                InfoLecturerR     GET             !free
-/info/legal                   LegalR           GET              !free
+/info/supervisor              InfoSupervisorR   GET             !free
-/info/glossary                GlossaryR        GET              !free
+/info/legal                   LegalR            GET             !free
-/info/faq                     FaqR             GET              !free
+/info/glossary                GlossaryR         GET             !free
-/info/terms-of-use            TermsOfUseR      GET              !free
+/info/faq                     FaqR              GET             !free
-/info/payments                PaymentsR        GET              !free
+/info/terms-of-use            TermsOfUseR       GET             !free
-/imprint                      ImprintR         GET              !free
+/info/payments                PaymentsR         GET             !free
-/data-protection              DataProtectionR  GET              !free
+/imprint                      ImprintR          GET             !free
-/version                      VersionR         GET              !free
+/data-protection              DataProtectionR   GET             !free
-/status                       StatusR          GET              !free
+/version                      VersionR          GET             !free
+/status                       StatusR           GET             !free
 
 /help                         HelpR            GET POST         !free
 
@@ -113,6 +115,11 @@
 /for/#CryptoUUIDUser/user         ForProfileR       GET POST    !supervisor !self
 /for/#CryptoUUIDUser/user/profile ForProfileDataR   GET         !supervisor !self
 
+/firms                          FirmAllR            GET POST		-- not yet !supervisor
+/firms/comm/+Companies          FirmsCommR          GET POST
+/firm/#CompanyShorthand/comm    FirmCommR						GET POST
+/firm/#CompanyShorthand         FirmUsersR          GET POST    -- not yet !supervisor
+/firm/#CompanyShorthand/supers  FirmSupersR         GET POST    -- not yet !supervisor
 
 /exam-office               ExamOfficeR                         !exam-office:
   /                        EOExamsR            GET POST        !system-exam-office
@@ -274,20 +281,11 @@
 /lms/#SchoolId                                              LmsSchoolR              GET
 /lms/#SchoolId/#QualificationShorthand                      LmsR  				          GET POST
 /lms/#SchoolId/#QualificationShorthand/edit                 LmsEditR			          GET POST
--- old V1 LMS Interface
-/lms/#SchoolId/#QualificationShorthand/users                LmsUsersR	              GET
-/lms/#SchoolId/#QualificationShorthand/users/direct         LmsUsersDirectR	        GET       !token -- LMS 
-/lms/#SchoolId/#QualificationShorthand/userlist             LmsUserlistR	          GET POST
-/lms/#SchoolId/#QualificationShorthand/userlist/upload      LmsUserlistUploadR	    GET POST  !development
-/lms/#SchoolId/#QualificationShorthand/userlist/direct      LmsUserlistDirectR	        POST  !token -- LMS, also remove JobLmsUserlist constructor
-/lms/#SchoolId/#QualificationShorthand/result               LmsResultR              GET POST
-/lms/#SchoolId/#QualificationShorthand/result/upload        LmsResultUploadR        GET POST  !development
-/lms/#SchoolId/#QualificationShorthand/result/direct        LmsResultDirectR            POST  !token -- LMS, also remove JobLmsResults constructor
 -- new V2 LMS Interface
 /lms/#SchoolId/#QualificationShorthand/learners             LmsLearnersR	          GET
 /lms/#SchoolId/#QualificationShorthand/learners/direct      LmsLearnersDirectR	    GET       !token -- LMS
 /lms/#SchoolId/#QualificationShorthand/report               LmsReportR              GET POST
-/lms/#SchoolId/#QualificationShorthand/report/upload        LmsReportUploadR        GET POST  !development
+/lms/#SchoolId/#QualificationShorthand/report/upload        LmsReportUploadR        GET POST
 /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

shell.nix

@@ -223,7 +223,7 @@ let
     fi
   '';
 
-  killallUni2work = pkgs.writeScriptBin "killall-uni2work" ''
+  killallUni2work = pkgs.writeScriptBin "killuni2work" ''
     #!${pkgs.zsh}/bin/zsh
 
     set -o pipefail

src/Application.hs

@@ -145,6 +145,7 @@ import Handler.Material
 import Handler.CryptoIDDispatch
 import Handler.SystemMessage
 import Handler.Health
+import Handler.Health.Interface
 import Handler.Exam
 import Handler.ExamOffice
 import Handler.Metrics
@@ -159,6 +160,7 @@ import Handler.SAP
 import Handler.PrintCenter
 import Handler.ApiDocs
 import Handler.Swagger
+import Handler.Firm
 
 import ServantApi () -- YesodSubDispatch instances
 import Servant.API

src/Audit.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
+-- SPDX-FileCopyrightText: 2023 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -8,6 +8,7 @@ module Audit
   , audit
   , AuditRemoteException(..)
   , getRemote
+  , logInterface, logInterface'
   ) where
 
 
@@ -103,12 +104,68 @@ audit :: ( AuthId (HandlerSite m) ~ Key User
 --   - `transactionLogInitiator` is currently logged in user (or none)
 --   - `transactionLogRemote` is determined from current HTTP-Request
 audit transaction@(toJSON -> transactionLogInfo) = do
-
   transactionLogTime <- liftIO getCurrentTime
   transactionLogInstance <- getsYesod $ view instanceID
   transactionLogInitiator <- liftHandler maybeAuthId
   transactionLogRemote <- handle (throwM . AuditRemoteException) $ Just <$> getRemote
-
   insert_ TransactionLog{..}
-
   $logInfoS "Audit" $ Text.filter (/= '\n') $ tshow (transaction, transactionLogInitiator, transactionLogRemote) <> " - " <> pack (prettyCallStack callStack)
+
+logInterface :: ( AuthId (HandlerSite m) ~ Key User
+         , IsSqlBackend (YesodPersistBackend (HandlerSite m))
+         , SqlBackendCanWrite (YesodPersistBackend (HandlerSite m))
+         , HasInstanceID (HandlerSite m) InstanceId
+         , YesodAuthPersist (HandlerSite m)
+         , MonadHandler m
+         , MonadCatch m
+         , HasAppSettings (HandlerSite m)
+         , HasCallStack
+         )
+      => Text       -- ^ Interface that is used
+      -> Text       -- ^ Subtype of the interface, if any
+      -> Bool       -- ^ Success=True, Failure=False
+      -> Maybe Int  -- ^ Number of transmitted datasets
+      -> Text       -- ^ Any additional information
+      -> ReaderT (YesodPersistBackend (HandlerSite m)) m ()
+-- ^ Log a transaction using information available from `HandlerT`, also calls `audit`
+logInterface interfaceLogInterface interfaceLogSubtype interfaceLogSuccess interfaceLogRows interfaceLogInfo = do 
+  interfaceLogWrite <- (methodGet /=) . Wai.requestMethod . reqWaiRequest <$> getRequest
+  logInterface' interfaceLogInterface interfaceLogSubtype interfaceLogWrite interfaceLogSuccess interfaceLogRows interfaceLogInfo
+
+logInterface' :: ( AuthId (HandlerSite m) ~ Key User
+         , IsSqlBackend (YesodPersistBackend (HandlerSite m))
+         , SqlBackendCanWrite (YesodPersistBackend (HandlerSite m))
+         , HasInstanceID (HandlerSite m) InstanceId
+         , YesodAuthPersist (HandlerSite m)
+         , MonadHandler m
+         , MonadCatch m
+         , HasAppSettings (HandlerSite m)
+         , HasCallStack
+         )
+      => Text       -- ^ Interface that is used
+      -> Text       -- ^ Subtype of the interface, if any
+      -> Bool       -- ^ True indicates Write Access to FRADrive
+      -> Bool       -- ^ Success=True, Failure=False
+      -> Maybe Int  -- ^ Number of transmitted datasets
+      -> Text       -- ^ Any additional information
+      -> ReaderT (YesodPersistBackend (HandlerSite m)) m ()
+-- ^ Log a transaction using information available from `HandlerT`, also calls `audit`
+logInterface' (Text.strip -> interfaceLogInterface) (Text.strip -> interfaceLogSubtype) interfaceLogWrite interfaceLogSuccess interfaceLogRows (Text.strip -> interfaceLogInfo) = do
+  interfaceLogTime  <- liftIO getCurrentTime
+  -- deleteBy $ UniqueInterfaceSubtypeWrite interfaceLogInterface interfaceLogSubtype interfaceLogWrite -- always replace: deleteBy & insert seems to be safest and fastest
+  -- insert_ InterfaceLog{..}
+  void $ upsertBy (UniqueInterfaceSubtypeWrite interfaceLogInterface interfaceLogSubtype interfaceLogWrite)
+    ( InterfaceLog{..} )
+    [ InterfaceLogTime    =. interfaceLogTime
+    , InterfaceLogRows    =. interfaceLogRows
+    , InterfaceLogInfo    =. interfaceLogInfo
+    , InterfaceLogSuccess =. interfaceLogSuccess
+    ]
+  audit TransactionInterface
+    { transactionInterfaceName    = interfaceLogInterface
+    , transactionInterfaceSubtype = interfaceLogSubtype
+    , transactionInterfaceWrite   = interfaceLogWrite
+    , transactionInterfaceRows    = interfaceLogRows
+    , transactionInterfaceInfo    = interfaceLogInfo
+    , transactionInterfaceSuccess = Just interfaceLogSuccess
+    }

src/Audit/Types.hs

@@ -1,4 +1,4 @@
--- 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-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
 
@@ -216,6 +216,7 @@ data Transaction
     , transactionQualification                :: QualificationId    
     , transactionQualificationValidUntil      :: Day
     , transactionQualificationScheduleRenewal :: Maybe Bool -- Maybe, because some update may leave it unchanged (also avoids DB Migration)
+    , transactionNote                         :: Maybe Text
     }
   | TransactionQualificationUserDelete
     { transactionUser               :: UserId
@@ -233,6 +234,14 @@ data Transaction
     , transactionQualification                :: QualificationId
     , transactionQualificationScheduleRenewal :: Maybe Bool           -- TRUE=will be notified upon expiry, FALSE=won't be notified; always JUST, for compatibility with TransactionQualificationUserEdit
     }
+  | TransactionInterface
+    { transactionInterfaceName                :: Text
+    , transactionInterfaceSubtype             :: Text
+    , transactionInterfaceWrite               :: Bool                 -- True implies a write to FRADrive
+    , transactionInterfaceRows                :: Maybe Int
+    , transactionInterfaceInfo                :: Text
+    , transactionInterfaceSuccess             :: Maybe Bool            -- Just False implies a failure; Maybe used to achieve backwards compatibility
+    }
   deriving (Eq, Ord, Read, Show, Generic)
 
 deriveJSON defaultOptions

src/Database/Esqueleto/Utils.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022-23 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
+-- SPDX-FileCopyrightText: 2022-24 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
 
@@ -17,8 +17,9 @@ module Database.Esqueleto.Utils
   , (>~.), (<~.)
   , or, and
   , any, all
+  , not__, parens
   , subSelectAnd, subSelectOr
-  , mkExactFilter, mkExactFilterWith
+  , mkExactFilter, mkExactFilterWith, mkExactFilterWithComma
   , mkExactFilterLast, mkExactFilterLastWith
   , mkExactFilterMaybeLast, mkExactFilterMaybeLast'
   , mkContainsFilter, mkContainsFilterWith
@@ -43,8 +44,10 @@ module Database.Esqueleto.Utils
   , (->.), (->>.), (#>>.)
   , fromSqlKey
   , unKey
+  , subSelectCountDistinct
   , selectCountRows, selectCountDistinct
   , selectMaybe
+  , num2text
   , day, day', dayMaybe, interval, diffDays, diffTimes
   , exprLift
   , explicitUnsafeCoerceSqlExprValue
@@ -225,8 +228,13 @@ explicitUnsafeCoerceSqlExprValue typ (E.ERaw _m1 f1) = E.ERaw E.noMeta $ \_nPare
       )
 
 and, or :: Foldable f => f (E.SqlExpr (E.Value Bool)) -> E.SqlExpr (E.Value Bool)
-and = F.foldr (E.&&.) true
+-- and = F.foldl' (E.&&.) true -- we can use foldl' since PostgreSQL reorders conditions anyway
-or = F.foldr (E.||.) false
+-- or = F.foldl' (E.||.) false
+-- Maybe this help the PostgreSQL query optimizer, though I doubt it?
+and f | F.null f    = true
+      | otherwise = F.foldl1 (E.&&.) f
+or f  | F.null f    = false
+      | otherwise = F.foldl1 (E.||.) f
 
 -- | Given a test and a set of values, check whether anyone succeeds the test
 --   WARNING: SQL leaves it explicitely unspecified whether `||` is short curcuited (i.e. lazily evaluated)
@@ -245,6 +253,9 @@ subSelectOr  q = parens . E.subSelectUnsafe $ flip (E.unsafeSqlAggregateFunction
 parens :: E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value a)
 parens = E.unsafeSqlFunction ""
 
+-- | Workaround for Esqueleto-Bug not placing parenthesis after NOT, see #155
+not__ :: E.SqlExpr (E.Value Bool) -> E.SqlExpr (E.Value Bool)
+not__ = E.not_ . parens
 
 -- Allow usage of Tuples as DbtRowKey, i.e. SqlIn instances for tuples
 $(sqlInTuples [2..16])
@@ -283,6 +294,17 @@ mkExactFilterWith cast lenslike row criterias
   | Set.null criterias = true
   | otherwise = lenslike row `E.in_` E.valList (cast <$> Set.toList criterias)
 
+-- | like `mkExactFilterWith` but splits comma separared Texts into multiple criteria
+mkExactFilterWithComma :: (PersistField b)
+  => (Text -> Maybe b)                   -- ^ type conversion
+  -> (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)
+mkExactFilterWithComma cast lenslike row (foldMap commaSeparatedText -> criterias)
+  | Set.null criterias = true
+  | otherwise = lenslike row `E.in_` E.valList (mapMaybe cast $ Set.toList criterias)
+
 -- | generic filter creation for dbTable
 --   Given a lens-like function, make filter for exact matches against last element of a collection
 mkExactFilterLast :: (PersistField a)
@@ -638,6 +660,12 @@ unKey :: ( Coercible (Key entity) a
       => E.SqlExpr (E.Value (Key entity)) -> E.SqlExpr (E.Value a)
 unKey = E.veryUnsafeCoerceSqlExprValue
 
+-- | distinct version of `Database.Esqueleto.subSelectCount`
+subSelectCountDistinct :: (Num a, PersistField a) => Ex.SqlQuery (Ex.SqlExpr (Ex.Value typ)) -> Ex.SqlExpr (Ex.Value a)
+subSelectCountDistinct query = Ex.subSelectUnsafe (Ex.countDistinct <$> query)
+  
+-- PersistField a => SqlQuery (SqlExpr (Value a)) -> SqlExpr (Value a)
+-- countDistinct :: Num a => SqlExpr (Value typ) -> SqlExpr (Value a)
 
 selectCountRows :: (Num a, PersistField a, MonadIO m) => E.SqlQuery ignored -> E.SqlReadT m a
 selectCountRows q = do
@@ -660,10 +688,14 @@ selectCountDistinct q = do
 selectMaybe :: (E.SqlSelect a r, MonadIO m) => E.SqlQuery a -> E.SqlReadT m (Maybe r)
 selectMaybe = fmap listToMaybe . E.select . (<* E.limit 1)
 
+-- | cast numeric type to text, which is safe and allows for an inefficient but safe comparison of numbers stored as text and numbers
+num2text :: Num n => E.SqlExpr (E.Value n) -> E.SqlExpr (E.Value Text)
+num2text = E.unsafeSqlCastAs "text"
 
 day :: E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value Day)
 day = E.unsafeSqlCastAs "date"
 
+-- | cast text to day, truly unsafe
 day' :: E.SqlExpr (E.Value Text) -> E.SqlExpr (E.Value Day)
 day' = E.unsafeSqlCastAs "date"
 
@@ -677,7 +709,6 @@ interval = E.unsafeSqlCastAs "interval". E.unsafeSqlValue . wrapSqlString . Text
     singleQuote     = Text.Builder.singleton '\''
     wrapSqlString b = singleQuote <> b <> singleQuote
 
-
 infixl 6 `diffDays`, `diffTimes`
 
 diffDays :: E.SqlExpr (E.Value Day) -> E.SqlExpr (E.Value Day) -> E.SqlExpr (E.Value Int)

src/Foundation/Authorization.hs

@@ -539,8 +539,11 @@ tagAccessPredicate AuthAdmin = cacheAPSchoolFunction SchoolAdmin (Just $ Right d
         return Authorized
 
 tagAccessPredicate AuthSupervisor = APDB $ \_ _ mAuthId route _ -> case route of 
-    ForProfileR     cID -> checkSupervisor (mAuthId, cID)
+    ForProfileR     cID -> checkSupervisor        (mAuthId, cID)
-    ForProfileDataR cID -> checkSupervisor (mAuthId, cID)
+    ForProfileDataR cID -> checkSupervisor        (mAuthId, cID)
+    FirmAllR            -> checkAnySupervisor      mAuthId
+    FirmUsersR      fsh -> checkCompanySupervisor (mAuthId, fsh)
+    FirmSupersR     fsh -> checkCompanySupervisor (mAuthId, fsh)
     r -> $unsupportedAuthPredicate AuthSupervisor r    
   where 
     checkSupervisor sup@(mAuthId, cID) = $cachedHereBinary sup . exceptT return return $ do
@@ -549,6 +552,17 @@ tagAccessPredicate AuthSupervisor = APDB $ \_ _ mAuthId route _ -> case route of
       isSupervisor <- lift . existsBy $ UniqueUserSupervisor authId uid
       guardMExceptT isSupervisor (unauthorizedI MsgUnauthorizedSupervisor)
       return Authorized
+    checkCompanySupervisor sup@(mAuthId, fsh) = $cachedHereBinary sup . exceptT return return $ do
+      authId <- maybeExceptT AuthenticationRequired $ return mAuthId      
+      -- isSupervisor <- lift . existsBy $ UniqueUserCompany authId $ CompanyKey fsh
+      isSupervisor <- lift $ exists [UserCompanyUser ==. authId, UserCompanyCompany ==. CompanyKey fsh, UserCompanySupervisor ==. True]
+      guardMExceptT isSupervisor (unauthorizedI $ MsgUnauthorizedCompanySupervisor fsh)
+      return Authorized
+    checkAnySupervisor mAuthId = $cachedHereBinary mAuthId . exceptT return return $ do
+      authId <- maybeExceptT AuthenticationRequired $ return mAuthId      
+      isSupervisor <- lift $ exists [UserSupervisorSupervisor ==. authId]
+      guardMExceptT isSupervisor (unauthorizedI MsgUnauthorizedAnySupervisor)
+      return Authorized
 
 tagAccessPredicate AuthSystemExamOffice = cacheAPSystemFunction SystemExamOffice (Just $ Right diffHour) $ \mAuthId' _ _ examOfficeList -> if
   | maybe True (`Set.notMember` examOfficeList) mAuthId' -> Right $ if

src/Foundation/I18n.hs

@@ -1,7 +1,12 @@
--- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
+-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
+-- To add new language files:
+--   1. include new statement, e.g. mkMessageAddition ''UniWorX "Print" "messages/uniworx/categories/print" "de-de-formal"
+--   2. create appropriate translation files in the specified folder
+--   3. add constructor to list of module exports
+
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
@@ -20,6 +25,7 @@ module Foundation.I18n
   , UniWorXI18nMessage(..),UniWorXJobsHandlerMessage(..), UniWorXModelTypesMessage(..), UniWorXYesodMiddlewareMessage(..)
   , UniWorXQualificationMessage(..)
   , UniWorXPrintMessage(..)
+  , UniWorXFirmMessage(..)
   , UniWorXAvsMessage(..)
   , UniWorXAuthorshipStatementMessage(..)
   , ShortTermIdentifier(..)
@@ -37,6 +43,8 @@ module Foundation.I18n
   , UniWorXMessages(..)
   , uniworxMessages
   , unRenderMessage, unRenderMessage', unRenderMessageLenient
+  , SomeMessages(..)
+  , someMessages
   , module Foundation.I18n.TH
   ) where
 
@@ -197,6 +205,11 @@ maybeToMessage :: ToMessage m => Text -> Maybe m -> Text -> Text
 maybeToMessage _      Nothing  _     = mempty
 maybeToMessage before (Just x) after = before <> toMessage x <> after
 
+maybeBoolMessage :: Maybe Bool -> Text -> Text -> Text -> Text
+maybeBoolMessage Nothing      n _ _ = n
+maybeBoolMessage (Just True)  _ t _ = t
+maybeBoolMessage (Just False) _ _ f = f
+
 
 newtype ShortTermIdentifier = ShortTermIdentifier TermIdentifier
   deriving stock (Eq, Ord, Read, Show)
@@ -233,6 +246,7 @@ mkMessageAddition ''UniWorX "Send" "messages/uniworx/categories/send" "de-de-for
 mkMessageAddition ''UniWorX "YesodMiddleware" "messages/uniworx/categories/yesod_middleware" "de-de-formal"
 mkMessageAddition ''UniWorX "User" "messages/uniworx/categories/user" "de-de-formal"
 mkMessageAddition ''UniWorX "Print" "messages/uniworx/categories/print" "de-de-formal"
+mkMessageAddition ''UniWorX "Firm" "messages/uniworx/categories/firm" "de-de-formal"
 mkMessageAddition ''UniWorX "Button" "messages/uniworx/utils/buttons" "de-de-formal"
 mkMessageAddition ''UniWorX "Form" "messages/uniworx/utils/handler_form" "de-de-formal"
 mkMessageAddition ''UniWorX "TableColumn" "messages/uniworx/utils/table_column" "de-de-formal"
@@ -254,6 +268,18 @@ mkMessageAddition ''UniWorX "Avs" "messages/uniworx/categories/avs" "de-de-forma
 
 embedRenderMessage ''UniWorX ''LmsStatus (uncurry ((<>) . (<> "Status")) . Text.splitAt 3)
 
+
+newtype SomeMessages master = SomeMessages [SomeMessage master]  
+  deriving newtype (Semigroup, Monoid)
+
+instance master ~ master' => RenderMessage master (SomeMessages master') where
+  renderMessage a b (SomeMessages msgs) = Text.intercalate "\n " $ renderMessage a b <$> msgs
+
+-- | convenienience function if all messages happen to belong to the exact same type
+someMessages :: RenderMessage master msg => [msg] -> SomeMessages master
+someMessages msgs = SomeMessages $ SomeMessage <$> msgs
+
+
 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

src/Foundation/Navigation.hs

@@ -121,13 +121,20 @@ 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 ProblemAvsErrorR     = i18nCrumb MsgProblemsAvsErrorHeading    $ Just AdminProblemsR
+
+breadcrumb FirmAllR         = i18nCrumb MsgMenuFirms              Nothing
+breadcrumb FirmsCommR{}     = i18nCrumb MsgMenuFirmsComm        $ Just   FirmAllR
+breadcrumb FirmUsersR{}     = i18nCrumb MsgMenuFirmUsers        $ Just   FirmAllR
+breadcrumb (FirmSupersR fsh)= i18nCrumb MsgMenuFirmSupervisors  $ Just $ FirmUsersR fsh
+breadcrumb (FirmCommR   fsh)= i18nCrumb MsgMenuFirmsComm        $ Just $ FirmUsersR fsh
 
 breadcrumb PrintCenterR     = i18nCrumb MsgMenuApc              Nothing
 breadcrumb PrintSendR       = i18nCrumb MsgMenuPrintSend      $ Just PrintCenterR
 breadcrumb PrintDownloadR{} = i18nCrumb MsgMenuPrintDownload  $ Just PrintCenterR
 breadcrumb PrintAckR{}      = i18nCrumb MsgMenuPrintSend      $ Just PrintCenterR -- never displayed
-breadcrumb PrintAckDirectR{}= i18nCrumb MsgMenuPrintSend      $ Just PrintCenterR -- never displayed
+breadcrumb PrintAckDirectR{}= i18nCrumb MsgMenuPrintAck       $ Just PrintCenterR
+breadcrumb PrintLogR        = i18nCrumb MsgMenuPrintLog       $ Just PrintCenterR
 
 breadcrumb SchoolListR      = i18nCrumb MsgMenuSchoolList       $ Just AdminR
 breadcrumb (SchoolR ssh sRoute) = case sRoute of
@@ -158,9 +165,10 @@ breadcrumb FaqR             = i18nCrumb MsgBreadcrumbFaq            $ Just InfoR
 breadcrumb HelpR            = i18nCrumb MsgMenuHelp            Nothing
 
 
-breadcrumb HealthR          = i18nCrumb MsgMenuHealth          Nothing
+breadcrumb HealthR              = i18nCrumb MsgMenuHealth          Nothing
-breadcrumb InstanceR        = i18nCrumb MsgMenuInstance        Nothing
+breadcrumb (HealthInterfaceR _) = i18nCrumb MsgMenuHealthInterface (Just HealthR)
-breadcrumb StatusR          = i18nCrumb MsgMenuHealth          Nothing  -- never displayed
+breadcrumb InstanceR            = i18nCrumb MsgMenuInstance        Nothing
+breadcrumb StatusR              = i18nCrumb MsgMenuHealth          Nothing  -- never displayed
 
 breadcrumb  QualificationAllR                       = i18nCrumb MsgMenuQualifications Nothing
 breadcrumb (QualificationSchoolR          ssh     ) = useRunDB . maybeT (i18nCrumb MsgBreadcrumbSchool . Just $ SchoolListR) $ do -- redirect only, used in other breadcrumbs
@@ -179,14 +187,6 @@ breadcrumb (LmsR                ssh  qsh) = useRunDB . maybeT (i18nCrumb MsgBrea
   guardM . lift . existsBy $ SchoolQualificationShort ssh qsh
   return (CI.original qsh, Just $ LmsSchoolR ssh)
 breadcrumb (LmsEditR            ssh  qsh) = i18nCrumb MsgMenuLmsEdit       $ Just $ LmsR          ssh qsh
-breadcrumb (LmsUsersR           ssh  qsh) = i18nCrumb MsgMenuLmsUsers      $ Just $ LmsR          ssh qsh
-breadcrumb (LmsUsersDirectR     ssh  qsh) = i18nCrumb MsgMenuLmsUsers      $ Just $ LmsUsersR     ssh qsh -- never displayed, TypedContent
-breadcrumb (LmsUserlistR        ssh  qsh) = i18nCrumb MsgMenuLmsUserlist   $ Just $ LmsR          ssh qsh
-breadcrumb (LmsUserlistUploadR  ssh  qsh) = i18nCrumb MsgMenuLmsUpload     $ Just $ LmsUserlistR  ssh qsh
-breadcrumb (LmsUserlistDirectR  ssh  qsh) = i18nCrumb MsgMenuLmsUpload     $ Just $ LmsUserlistR  ssh qsh -- never displayed
-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
@@ -754,6 +754,18 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the
         , navForceActive = False
         }
       }
+  , return NavHeader
+      { navHeaderRole = NavHeaderPrimary
+      , navIcon       = IconCompany
+      , navLink       = NavLink
+        { navLabel       = MsgMenuFirms
+        , navRoute       = FirmAllR
+        , navAccess'     = NavAccessTrue
+        , navType        = NavTypeLink { navModal = False }
+        , navQuick'      = mempty
+        , navForceActive = False
+        }
+      }
   , return NavHeader
       { navHeaderRole = NavHeaderPrimary
       , navIcon       = IconPrintCenter
@@ -1323,6 +1335,17 @@ pageActions HealthR = return
       }
     , navChildren = []
     }
+  , NavPageActionPrimary
+    { navLink = NavLink
+      { navLabel       = MsgMenuHealthInterface
+      , navRoute       = HealthInterfaceR []
+      , navAccess'     = NavAccessTrue
+      , navType        = NavTypeLink { navModal = False }
+      , navQuick'      = mempty
+      , navForceActive = False
+      }
+    , navChildren = []
+    }
   ]
 pageActions InstanceR = return
   [ NavPageActionPrimary
@@ -2358,26 +2381,6 @@ pageActions (LmsR sid qsh) = return
         , defNavLink MsgMenuLmsDirectUpload $ LmsReportDirectR sid qsh
         ]
     }
-  , NavPageActionSecondary
-    { navLink = defNavLink MsgMenuLmsUsers $ LmsUsersR sid qsh
-    -- , navChildren =
-    --     [ defNavLink MsgMenuLmsDirectDownload $ LmsUsersDirectR sid qsh
-    --     ]
-    }
-  , NavPageActionSecondary
-    { navLink = defNavLink MsgMenuLmsUserlist $ LmsUserlistR sid qsh
-    -- , navChildren =
-    --     [ defNavLink MsgMenuLmsUpload       $ LmsUserlistUploadR sid qsh
-    --     , defNavLink MsgMenuLmsDirectUpload $ LmsUserlistDirectR sid qsh
-    --     ]
-    }
-  , NavPageActionSecondary
-    { navLink = defNavLink MsgMenuLmsResult $ LmsResultR sid qsh
-    -- , navChildren =
-    --     [ defNavLink MsgMenuLmsUpload       $ LmsResultUploadR sid qsh
-    --     , defNavLink MsgMenuLmsDirectUpload $ LmsResultDirectR sid qsh
-    --     ]
-    }
   , NavPageActionSecondary {
       navLink = defNavLink MsgMenuLmsEdit $ LmsEditR sid qsh
     }
@@ -2398,6 +2401,18 @@ pageActions ApiDocsR = return
     , navChildren = []
     }
   ]
+pageActions (FirmUsersR fsh) = return
+  [ NavPageActionPrimary
+    { navLink = defNavLink MsgTableCompanyNrSupers $ FirmSupersR fsh
+    , navChildren = []
+    }
+  ]
+pageActions (FirmSupersR fsh) = return
+  [ NavPageActionPrimary
+    { navLink = defNavLink MsgTableCompanyNrUsers  $ FirmUsersR fsh
+    , navChildren = []
+    }
+  ]
 pageActions PrintCenterR = do
   openDays <- useRunDB $ Ex.select $ do
     pj <- Ex.from $ Ex.table @PrintJob
@@ -2433,8 +2448,28 @@ pageActions PrintCenterR = do
                       , navForceActive = False
                       }
                     }
+      printLog = NavPageActionSecondary
+                    { navLink = NavLink
+                      { navLabel       = MsgMenuPrintLog
+                      , navRoute       = PrintLogR
+                      , navAccess'     = NavAccessTrue
+                      , navType        = NavTypeLink { navModal = False }
+                      , navQuick'      = mempty
+                      , navForceActive = False
+                      }
+                    }
+      printAck = NavPageActionSecondary
+                    { navLink = NavLink
+                      { navLabel       = MsgMenuPrintAck
+                      , navRoute       = PrintAckDirectR
+                      , navAccess'     = NavAccessTrue
+                      , navType        = NavTypeLink { navModal = False }
+                      , navQuick'      = mempty
+                      , navForceActive = False
+                      }
+                    }
   dayLinks <- mapM toDayAck $ Map.toAscList dayMap
-  return $ manualSend : take 9 dayLinks
+  return $ manualSend : printLog : printAck : take 9 dayLinks
 
 pageActions AdminCrontabR = return
   [ NavPageActionPrimary

src/Foundation/Yesod/ErrorHandler.hs

@@ -9,9 +9,9 @@ module Foundation.Yesod.ErrorHandler
 import Import.NoFoundation hiding (errorHandler)
 
 import Foundation.Type
--- import Foundation.I18n
+import Foundation.I18n
 import Foundation.Authorization
--- import Foundation.SiteLayout
+import Foundation.SiteLayout
 import Foundation.Routes
 import Foundation.DB
 
@@ -20,15 +20,15 @@ import qualified Data.Text as Text
 
 import qualified Network.Wai as W
   
--- import System.Exit -- DEBUG: just for testing
+import System.Exit -- DEBUG: just for testing
--- import System.Posix.Process -- DEBUG: just for testing
+import System.Posix.Process -- DEBUG: just for testing
 
 errorHandler :: ( MonadSecretBox (HandlerFor UniWorX)
-                -- , MonadSecretBox (WidgetFor UniWorX)
+                , MonadSecretBox (WidgetFor UniWorX)
                 , MonadSecretBox (ExceptT EncodedSecretBoxException (HandlerFor UniWorX))
                 , MonadAuth (HandlerFor UniWorX)
                 , BearerAuthSite UniWorX
-                -- , YesodPersistBackend UniWorX ~ SqlBackend
+                , YesodPersistBackend UniWorX ~ SqlBackend
                 )
              => ErrorResponse -> HandlerFor UniWorX TypedContent
 errorHandler err = do
@@ -72,39 +72,39 @@ errorHandler err = do
   setSessionJson SessionError sessErr
 
   selectRep $ do
-    -- provideRep $ do
+    provideRep $ do
-    --   mr <- getMessageRender
+      mr <- getMessageRender
-    --   let
+      let
-    --     encrypted :: Text -> WidgetFor UniWorX () -> WidgetFor UniWorX ()
+        encrypted :: Text -> WidgetFor UniWorX () -> WidgetFor UniWorX ()
-    --     encrypted plaintextJson plaintext = do
+        encrypted plaintextJson plaintext = do
-    --       let displayEncrypted ciphertext = 
+          let displayEncrypted ciphertext = 
-    --             [whamlet|
+                [whamlet|
-    --               $newline never
+                  $newline never
-    --               <p>_{MsgErrorResponseEncrypted}
+                  <p>_{MsgErrorResponseEncrypted}
-    --               <pre .literal-error>
+                  <pre .literal-error>
-    --                 #{ciphertext}
+                    #{ciphertext}
-    --             |]
+                |]
-    --       if
+          if
-    --         | isEncrypted && shouldEncrypt -> displayEncrypted plaintextJson
+            | isEncrypted && shouldEncrypt -> displayEncrypted plaintextJson
-    --         | shouldEncrypt -> displayEncrypted =<< encodedSecretBox SecretBoxPretty plaintextJson
+            | shouldEncrypt -> displayEncrypted =<< encodedSecretBox SecretBoxPretty plaintextJson
-    --         | otherwise -> plaintext
+            | otherwise -> plaintext
 
-    --     errPage = case err of
+        errPage = case err of
-    --       NotFound -> [whamlet|<p>_{MsgErrorResponseNotFound}|]
+          NotFound -> [whamlet|<p>_{MsgErrorResponseNotFound}|]
-    --       InternalError err'
+          InternalError err'
-    --         | "Crash Button" `isPrefixOf` err'   -> liftIO $ exitImmediately ExitSuccess -- DEBUG: just for Testing
+            | "Crash Button" `isPrefixOf` err'   -> liftIO $ exitImmediately ExitSuccess -- DEBUG: just for Testing
-    --         | otherwise -> encrypted err' [whamlet|<p .literal-error>#{fromMaybe err' decrypted}|]
+            | otherwise -> encrypted err' [whamlet|<p .literal-error>#{fromMaybe err' decrypted}|]
-    --       InvalidArgs errs -> [whamlet|
+          InvalidArgs errs -> [whamlet|
-    --           <ul>
+              <ul>
-    --             $forall err' <- errs
+                $forall err' <- errs
-    --               <li .literal-error>
+                  <li .literal-error>
-    --                 #{err'}
+                    #{err'}
-    --          |]
+             |]
-    --       NotAuthenticated -> [whamlet|<p>_{MsgErrorResponseNotAuthenticated}|]
+          NotAuthenticated -> [whamlet|<p>_{MsgErrorResponseNotAuthenticated}|]
-    --       PermissionDenied err' -> [whamlet|<p .errMsg>#{err'}|]
+          PermissionDenied err' -> [whamlet|<p .errMsg>#{err'}|]
-    --       BadMethod method -> [whamlet|<p>_{MsgErrorResponseBadMethod (decodeUtf8 method)}|]
+          BadMethod method -> [whamlet|<p>_{MsgErrorResponseBadMethod (decodeUtf8 method)}|]
-    --   siteLayout (toWgt . mr $ ErrorResponseTitle err) $ do
+      siteLayout (toWgt . mr $ ErrorResponseTitle err) $ do
-    --     errPage
+        errPage
     provideRep $ case err of
       PermissionDenied err' -> return err'
       InternalError err'

src/Handler/Admin.hs

@@ -21,11 +21,10 @@ import           Database.Esqueleto.Experimental ((:&)(..))
 import qualified Database.Esqueleto.Experimental as E
 import qualified Database.Esqueleto.Utils as E
 
-import Handler.Utils.DateTime
+import Handler.Utils
 import Handler.Utils.Avs
-import Handler.Utils.Widgets
 import Handler.Utils.Users
-import Handler.Utils.Qualification
+import Handler.Health.Interface
 
 import Handler.Admin.Test as Handler.Admin
 import Handler.Admin.ErrorMessage as Handler.Admin
@@ -42,16 +41,29 @@ getAdminProblemsR :: Handler Html
 getAdminProblemsR = do 
   now <- liftIO getCurrentTime
   let nowaday = utctDay now
-      cutOffPrintDays = 7
+      cutOffOldDays = 1
-      cutOffPrintJob  = addLocalDays  (-cutOffPrintDays) now      
+      cutOffOldTime  = toMidnight $ addDays (-cutOffOldDays) nowaday
 
-  (usersAreReachable, driversHaveAvsIds, rDriversHaveFs, noStalePrintJobs, noBadAPCids, noAvsSynchProblems) <- runDB $ (,,,,,) 
+  -- we abuse messageTooltip for colored icons here
+  msgSuccessTooltip <- messageI Success MsgMessageSuccess
+  msgWarningTooltip <- messageI Warning MsgMessageWarning
+  msgErrorTooltip   <- messageI Error   MsgMessageError
+
+  let flagError   = messageTooltip . bool msgErrorTooltip   msgSuccessTooltip
+      flagWarning = messageTooltip . bool msgWarningTooltip msgSuccessTooltip      
+      flagNonZero :: Int -> Widget
+      flagNonZero n | n <= 0    = flagError True
+                    | otherwise = messageTooltip =<< handlerToWidget (messageI Error (MsgProblemsDriverSynch n))                                    
+
+  (usersAreReachable, driversHaveAvsIds, rDriversHaveFs, noStalePrintJobs, noBadAPCids, (interfaceOks, interfaceTable)) <- runDB $ (,,,,,) 
       <$> areAllUsersReachable 
       <*> allDriversHaveAvsId now
       <*> allRDriversHaveFs now
-      <*> (not <$> exists [PrintJobAcknowledged ==. Nothing, PrintJobCreated  <=. cutOffPrintJob])
+      <*> (not <$> exists [PrintJobAcknowledged ==. Nothing, PrintJobCreated  <. cutOffOldTime])
       <*> (not <$> exists [PrintAcknowledgeProcessed ==. False])      
-      <*> (not <$> exists [UserAvsLastSynchError !=. Nothing])    
+      <*>  mkInterfaceLogTable flagError mempty
+  let interfacesBadNr = length $ filter (not . snd) interfaceOks
+      -- interfacesOk = all snd interfaceOks      
   diffLics <- try retrieveDifferingLicences >>= \case
     -- (Left (UnsupportedContentType "text/html" resp)) -> Left $ text2widget "Html received"
     (Left e) -> return $ Left $ text2widget $ tshow (e :: SomeException)
@@ -73,17 +85,6 @@ getAdminProblemsR = do
   --   , Catch.Handler (\(ex::SomeException) -> return $ Left $ text2widget $ tshow ex)
   --   ]
 
-  -- we abuse messageTooltip for colored icons here
-  msgSuccessTooltip <- messageI Success MsgMessageSuccess
-  msgWarningTooltip <- messageI Warning MsgMessageWarning
-  msgErrorTooltip   <- messageI Error   MsgMessageError
-
-  let flagError   = messageTooltip . bool msgErrorTooltip   msgSuccessTooltip
-      flagWarning = messageTooltip . bool msgWarningTooltip msgSuccessTooltip
-      flagNonZero :: Int -> Widget
-      flagNonZero n | n <= 0    = flagError True
-                    | otherwise = messageTooltip =<< handlerToWidget (messageI Error (MsgProblemsDriverSynch n))                                    
-  
   rerouteMail <- getsYesod $ view _appMailRerouteTo
 
   siteLayoutMsg MsgProblemsHeading $ do
@@ -237,4 +238,3 @@ retrieveDriversRWithoutF now = do
   E.where_ $ E.exists (hasValidQual AvsLicenceRollfeld)
     E.&&. E.notExists (hasValidQual AvsLicenceVorfeld)
   return usr
-  

src/Handler/Admin/Avs.hs

@@ -548,18 +548,19 @@ 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) -> avsPersonNoLinkedCellAdmin a
         -- , colUserCompany
         , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \(view (resultUser . _entityKey) -> uid) -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX"
             companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
               E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
               E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid
               E.orderBy [E.asc (comp E.^. CompanyName)]
-              return (comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor)
+              return (comp E.^. CompanyShorthand, comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor)
-            let companies = intersperse (text2markup ", ") $
+            let icnSuper  = toWidget $ text2markup " " <> icon IconSupervisor
-                  (\(E.Value cmpName, E.Value cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> companies'
+                companies = 
-                icnSuper = text2markup " " <> icon IconSupervisor
+                  (\(E.Value cmpSh, E.Value cmpName, E.Value cmpSpr) -> simpleLink (citext2widget cmpName) (FirmUsersR cmpSh) <> bool mempty icnSuper cmpSpr) <$> companies'
-            pure $ toWgt $ mconcat companies
+                
+            pure $ intercalate (text2widget "; ") companies
         , sortable (Just "qualification") (i18nCell MsgTableQualifications)          $ \(preview   resultQualification -> q) -> cellMaybe lmsShortCell q
         , sortable (Just "first-held")    (i18nCell MsgTableQualificationFirstHeld)  $ \(preview $ resultQualUser . _entityVal . _qualificationUserFirstHeld   -> d)  -> cellMaybe dayCell d
         , sortable (Just "last-refresh")  (i18nCell MsgTableQualificationLastRefresh)$ \(preview $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d)  -> cellMaybe dayCell d
@@ -751,7 +752,7 @@ getProblemAvsErrorR = do
         dbtRowKey = qerryUsrAvs >>> (E.^. UserAvsId)
         dbtProj = dbtProjId
         dbtColonnade = dbColonnade $ mconcat
-          [ colUserNameModalHdr MsgLmsUser AdminUserR
+          [ colUserNameModalHdrAdmin MsgLmsUser AdminUserR
           , sortable (Just "avs-nr")          (i18nCell MsgAvsPersonNo)
               $ avsPersonNoLinkedCell . view reserrUsrAvs
           , sortable Nothing                  (i18nCell MsgAvsPersonId)

src/Handler/Course/Communication.hs

@@ -64,8 +64,10 @@ postCCommR tid ssh csh = do
 
     return (cid, tuts, exams, sheets)
 
+  let heading = SomeMessage . prependCourseTitle tid ssh csh $ SomeMessage MsgCommCourseHeading
   commR CommunicationRoute
-    { crHeading    = SomeMessage . prependCourseTitle tid ssh csh $ SomeMessage MsgCommCourseHeading
+    { crHeading    = heading
+    , crTitle      = heading
     , crUltDest    = SomeRoute $ CourseR tid ssh csh CCommR
     , crJobs       = crJobsCourseCommunication cid
     , crTestJobs   = crTestJobsCourseCommunication cid

src/Handler/Course/Edit.hs

@@ -279,8 +279,8 @@ getCourseNewR = do
                     , E.desc $ courseCreated course]                                     -- most recent created course
           E.limit 1
           return course
-      template <- case listToMaybe oldCourses of
+      template <- case oldCourses of
-        (Just oldTemplate) ->
+        (oldTemplate:_) ->
             let newTemplate = courseToForm oldTemplate mempty mempty in
             return $ Just $ newTemplate
                 { cfCourseId   = Nothing
@@ -289,7 +289,7 @@ getCourseNewR = do
                 , cfRegTo      = Nothing
                 , cfDeRegUntil = Nothing
                 }
-        Nothing -> do
+        [] -> do
             (tidOk,sshOk,cshOk) <- runDB $ (,,)
                 <$> ifMaybeM mbTid True existsKey
                 <*> ifMaybeM mbSsh True existsKey

src/Handler/Course/List.hs

@@ -226,7 +226,16 @@ getCourseListR = do
         ]
       validator = def
         & defaultSorting [SortDescBy "term",SortAscBy "course"]
-  coursesTable <- runDB $ makeCourseTable colonnade validator
+  now <- liftIO getCurrentTime
+  coursesTable <- runDB $ do
+    activeTs <- selectList [TermActiveFrom <=. now
+                , FilterOr [TermActiveTo >. Just now, TermActiveTo ==. Nothing]
+                , FilterOr [TermActiveFor ==. muid, TermActiveFor ==. Nothing]   -- TermActiveFor <-. [Nothing, muid] did not work as intended
+                ] [Desc TermActiveTerm]
+    let addTermFilter = if null activeTs 
+          then id
+          else defaultFilter $ singletonMap "term" [toPathPiece termActiveTerm | Entity _ TermActive{termActiveTerm} <- activeTs]
+    makeCourseTable colonnade (validator & addTermFilter)
   defaultLayout $ do
     setTitleI MsgCourseListTitle
     $(widgetFile "courses")

src/Handler/Course/ParticipantInvite.hs

@@ -192,26 +192,37 @@ handleAddUserR tid ssh csh tdesc ttyp = do
 
   currentRoute <- fromMaybe (error "postCAddUserR called from 404-handler") <$> getCurrentRoute
 
-  confirmedActs :: Set CourseRegisterActionData <- fmap Set.fromList . throwExceptT . mapMM encodedSecretBoxOpen . lookupPostParams $ toPathPiece PostCourseUserAddConfirmAction
+  (_ , registerConfirmResult) <- runButtonForm FIDCourseRegisterConfirm    
-  --   $logDebugS "CAddUserR confirmedActs" . tshow $ Set.map Aeson.encode confirmedActs
+  --   $logDebugS "***AbortProblem***" $ tshow registerConfirmResult
-  unless (Set.null confirmedActs) $ do -- TODO: check that all acts are member of availableActs
+  prefillUsers <- case registerConfirmResult of 
-    let
+    Nothing -> return mempty
-      users = Map.fromList . fmap (\act -> (crActIdent act, Just . view _1 $ crActUser act)) $ Set.toList confirmedActs
+    (Just BtnCourseRegisterAbort)   -> do 
-      tutActs = Set.filter (is _CourseRegisterActionAddTutorialMemberData) confirmedActs
+      addMessageI Warning MsgAborted
-      actTutorial = crActTutorial <$> Set.lookupMin tutActs -- tutorial ident must be the same for every added member!      
+      -- prefill confirmed users for convenience. Note that Browser-Back may also return to the filled form, but history.back() does not in Chrome
-    registeredUsers <- registerUsers cid users
+      confirmedActs :: [CourseRegisterActionData] <- exceptT (const $ return mempty) return . mapMM encodedSecretBoxOpen . lookupPostParams $ toPathPiece PostCourseUserAddConfirmAction  -- ignore any exception, since it is only used to prefill a form field for convenience
-    whenIsJust actTutorial $ \(tutName,tutType,tutDay) -> do
+      return $ Just $ Set.fromList $ fmap crActIdent confirmedActs
-      whenIsJust (tutName <|> fmap (tutorialDefaultName tutType) tutDay) $ \tName -> do
+    (Just BtnCourseRegisterConfirm) -> do
-        tutId <- upsertNewTutorial cid tName tutType tutDay
+      confirmedActs :: Set CourseRegisterActionData <- fmap Set.fromList . throwExceptT . mapMM encodedSecretBoxOpen . lookupPostParams $ toPathPiece PostCourseUserAddConfirmAction  
-        registerTutorialMembers tutId registeredUsers
+      --   $logDebugS "CAddUserR confirmedActs" . tshow $ Set.map Aeson.encode confirmedActs
-        -- when (Set.size tutActs == Set.size confirmedActs) $ -- not sure how this condition might be false at this point
+      unless (Set.null confirmedActs) $ do -- TODO: check that all acts are member of availableActs
-        redirect $ CTutorialR tid ssh csh tName TUsersR
+        let
-    redirect $ CourseR tid ssh csh CUsersR
+          users = Map.fromList . fmap (\act -> (crActIdent act, Just . view _1 $ crActUser act)) $ Set.toList confirmedActs
+          tutActs = Set.filter (is _CourseRegisterActionAddTutorialMemberData) confirmedActs
+          actTutorial = crActTutorial <$> Set.lookupMin tutActs -- tutorial ident must be the same for every added member!      
+        registeredUsers <- registerUsers cid users
+        whenIsJust actTutorial $ \(tutName,tutType,tutDay) -> do
+          whenIsJust (tutName <|> fmap (tutorialDefaultName tutType) tutDay) $ \tName -> do
+            tutId <- upsertNewTutorial cid tName tutType tutDay
+            registerTutorialMembers tutId registeredUsers
+            -- when (Set.size tutActs == Set.size confirmedActs) $ -- not sure how this condition might be false at this point
+            redirect $ CTutorialR tid ssh csh tName TUsersR
+        redirect $ CourseR tid ssh csh CUsersR
+      return mempty
   
-  ((usersToAdd :: FormResult AddUserRequest, formWgt), formEncoding) <- runFormPost . renderWForm FormStandard $ do
+  ((usersToAdd :: FormResult AddUserRequest, formWgt), formEncoding) <- runFormPost . identifyForm FIDCourseRegister . renderWForm FormStandard $ do
     let tutTypesMsg   = [(SomeMessage tt,tt) | tt <- tutTypes]
         tutDefType    = ttyp >>= (\ty -> if ty `elem` tutTypes then Just ty else Nothing)        
-    auReqUsers <- wreq (textField & cfAnySeparatedSet) (fslI MsgCourseParticipantsRegisterUsersField & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) mempty
+    auReqUsers <- wreq (textField & cfAnySeparatedSet) (fslI MsgCourseParticipantsRegisterUsersField & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) prefillUsers
     auReqTutorial <- optionalActionW
       ( (,,) 
         <$> aopt  (textField & cfStrip & cfCI & addDatalist tutNameSuggestions)

src/Handler/Course/Users.hs

@@ -660,7 +660,7 @@ postCUsersR tid ssh csh = do
           , pure . cap' $ colUserNameLink (CourseR tid ssh csh . CUserR)
           , guardOn showSex . cap' $ colUserSex'
           , pure . cap' $ colUserEmail
-          , pure . cap' $ colUserMatriclenr
+          , pure . cap' $ colUserMatriclenr False
           , pure . cap' $ colUserQualifications nowaday
           , guardOn hasSubmissionGroups $ cap' colUserSubmissionGroup
           , guardOn hasTutorials . cap' $ colUserTutorials tid ssh csh

src/Handler/Exam/Users.hs

@@ -484,7 +484,7 @@ postEUsersR tid ssh csh examn = do
           dbtColonnade = mconcat $ catMaybes
             [ pure $ dbSelect (_2 . applying _2) _1 $ return . view (resultExamRegistration . _entityKey)
             , pure $ colUserNameLink (CourseR tid ssh csh . CUserR)
-            , pure   colUserMatriclenr
+            , pure $ colUserMatriclenr False
             , pure $ colStudyFeatures resultStudyFeatures
             , pure $ sortable (Just "occurrence") (i18nCell MsgTableExamOccurrence) $ maybe mempty (anchorCell' (\n -> CExamR tid ssh csh examn EShowR :#: [st|exam-occurrence__#{n}|]) id . examOccurrenceName . entityVal) . view _userTableOccurrence
             , guardOn showPasses $ sortable Nothing (i18nCell MsgAchievedPasses) $ \(view $ resultUser . _entityKey -> uid) ->

src/Handler/Health/Interface.hs

@@ -0,0 +1,251 @@
+-- SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
+--
+-- SPDX-License-Identifier: AGPL-3.0-or-later
+
+
+module Handler.Health.Interface
+  (
+    getHealthInterfaceR
+  , mkInterfaceLogTable
+  , runInterfaceChecks
+  )
+ where
+
+import Import
+
+-- import qualified Data.Set as Set
+import qualified Data.Text as Text
+import Handler.Utils
+import Handler.Utils.Concurrent
+
+-- import           Database.Esqueleto.Experimental ((:&)(..))
+import qualified Database.Esqueleto.Experimental as E
+import qualified Database.Esqueleto.Utils as E
+import qualified Database.Esqueleto.Legacy as EL (on)
+import qualified Database.Persist.Sql as E (deleteWhereCount)
+
+
+-- | identify a wildcard argument
+wc2null :: Text -> Maybe Text
+-- wc2null "." = Nothing -- does not work, since dots are eliminated in URLs
+-- wc2null "-" = Nothing -- used as wildcard subtype in lpr interface
+wc2null "_" = Nothing
+wc2null "*" = Nothing
+wc2null  o  = Just o
+
+-- | sloppily parse a boolean, also see Model.Types.Avs.SloppyBool
+pbool :: Text -> Maybe Bool
+pbool (Text.toLower . Text.strip -> w)
+  | w `elem` ["1", "t", "true" ,"wahr", "w"] = Just True
+  | w `elem` ["0", "f", "false","falsch"]    = Just False
+  | otherwise                                = Nothing
+
+-- | parse UniqueInterfaceHealth with subtype and write arguments being optional for the last interface. Wildcards '_' or '.' are also allowed in all places.
+identifyInterfaces :: [Text] -> [Unique InterfaceHealth]
+identifyInterfaces []        = []
+identifyInterfaces [i]       = [UniqueInterfaceHealth i Nothing     Nothing]
+identifyInterfaces [i,s]     = [UniqueInterfaceHealth i (wc2null s) Nothing]
+identifyInterfaces (i:s:w:r) =  UniqueInterfaceHealth i (wc2null s) (pbool w) : identifyInterfaces r
+
+type ReqBanInterfaceHealth = ([Unique InterfaceHealth],[Unique InterfaceHealth])
+
+-- | Interface names prefixed with '-' are to be excluded from the query
+splitInterfaces :: [Unique InterfaceHealth] -> ReqBanInterfaceHealth
+splitInterfaces = foldl' aux mempty
+  where
+    aux (reqs,bans) uih@(UniqueInterfaceHealth i s w)
+      | Just ('-', b) <- Text.uncons i = (reqs, UniqueInterfaceHealth b s w : bans)
+      | otherwise = (uih : reqs, bans)
+
+-- | check whether the first argument is equal or more specialzed (i.e. more Just) than the second
+matchesUniqueInterfaceHealth :: Unique InterfaceHealth -> Unique InterfaceHealth -> Bool
+matchesUniqueInterfaceHealth (UniqueInterfaceHealth ai as aw) (UniqueInterfaceHealth bi bs bw) = ai == bi && eqOrNothing as bs && eqOrNothing aw bw
+  where
+    eqOrNothing _ Nothing = True
+    eqOrNothing a b       = a == b
+
+
+getHealthInterfaceR :: [Text] -> Handler TypedContent
+getHealthInterfaceR (dropWhile (=="force") -> ris) = do               -- for backwards compatibility we ignore leading "force"
+  let interfs = splitInterfaces $ identifyInterfaces ris
+  (missing, allok, res, iltable) <- runInterfaceLogTable interfs
+  when missing notFound                                               -- send 404 if any requested interface was not found
+  let ihstatus = if allok then status200
+                          else internalServerError500
+      plainMsg = if allok then "Interfaces are healthy."
+                          else "Unhealthy interfaces: " <> Text.intercalate ", " [iface | (iface, False) <- res]
+  sendResponseStatus ihstatus <=< selectRep $ do                      -- most browsers send accept:text/html, thus text/plain can be default here
+    provideRep . return . RepPlain $ toContent plainMsg               -- /?_accept=text/plain
+    provideRep . siteLayoutMsg MsgMenuHealthInterface $ do            -- /?_accept=text/html
+      setTitleI MsgMenuHealthInterface
+      [whamlet|
+        <div>
+          #{plainMsg}
+        <div>
+          ^{iltable}
+      |]
+
+
+runInterfaceLogTable :: ReqBanInterfaceHealth -> Handler (Bool, Bool, [(Text,Bool)], Widget)
+runInterfaceLogTable interfs@(reqIfs,_) = do
+  -- we abuse messageTooltip for colored icons here
+  msgSuccessTooltip <- messageI Success MsgMessageSuccess
+  -- msgWarningTooltip <- messageI Warning MsgMessageWarning
+  msgErrorTooltip   <- messageI Error   MsgMessageError
+  let flagError = messageTooltip . bool msgErrorTooltip msgSuccessTooltip
+  (res, twgt) <- runDB $ mkInterfaceLogTable flagError interfs
+  let missing = notNull [ifce | (UniqueInterfaceHealth ifce _subt _writ) <- reqIfs, ifce `notElem` (fst <$> res) ]
+      allok   = all snd res
+  return (missing, allok, res, twgt)
+
+-- ihDebugShow :: Unique InterfaceHealth -> Text
+-- ihDebugShow (UniqueInterfaceHealth i s w) = "(" <> tshow i <> "," <> tshow s <> "," <> tshow w <> ")"
+
+mkInterfaceLogTable :: (Bool -> Widget) -> ReqBanInterfaceHealth -> DB ([(Text,Bool)], Widget)
+mkInterfaceLogTable flagError interfs@(reqIfs, banIfs) = do
+    --   $logWarnS "DEBUG" $ tshow ([ihDebugShow x | x<- reqIfs], [ihDebugShow x | x<- banIfs])
+    void $ liftHandler $ timeoutHandler 42000001 $ runDB $ runInterfaceChecks interfs
+    now <- liftIO getCurrentTime
+    dbTableDB ilvalidator DBTable{dbtColonnade=colonnade now, ..}
+  where
+    sanitize      = text2AlphaNumPlus ['+','-','_','Ä','Ö','Ü','ß','ä','ö','ü']
+    dbtIdent      = "interface-log" :: Text
+    dbtProj       = dbtProjId
+    dbtSQLQuery (ilog `E.LeftOuterJoin` ihealth) = do
+      EL.on (       ilog E.^. InterfaceLogInterface E.=?.          ihealth E.?. InterfaceHealthInterface
+              E.&&. ilog E.^. InterfaceLogSubtype   E.=~. E.joinV (ihealth E.?. InterfaceHealthSubtype)
+              E.&&. ilog E.^. InterfaceLogWrite     E.=~. E.joinV (ihealth E.?. InterfaceHealthWrite  )
+            )
+      let matchUIH crits = E.or
+           [ E.and $ catMaybes
+             [  ilog E.^. InterfaceLogInterface E.==.    E.val  (sanitize     ifce) & Just
+             , (ilog E.^. InterfaceLogSubtype   E.==.) . E.val . sanitize <$> subt
+             , (ilog E.^. InterfaceLogWrite     E.==.) . E.val            <$> writ
+             ]
+           | (UniqueInterfaceHealth ifce subt writ) <- crits
+           ]
+          matchUIHnot crits = E.and
+           [ E.or $ catMaybes
+             [  ilog E.^. InterfaceLogInterface E.!=.    E.val  (sanitize     ifce) & Just
+             , (ilog E.^. InterfaceLogSubtype   E.!=.) . E.val . sanitize <$> subt
+             , (ilog E.^. InterfaceLogWrite     E.!=.) . E.val            <$> writ
+             ]
+           | (UniqueInterfaceHealth ifce subt writ) <- crits
+           ]
+      unless (null reqIfs) $ E.where_ $ matchUIH    reqIfs
+      unless (null banIfs) $ E.where_ $ matchUIHnot banIfs
+      -- unless (null banIfs) $ E.where_ $ E.not_ $ matchUIH banIfs -- !!! DOES NOT WORK !!! Yields strange results, see #155
+      -- unless (null banIfs) $ E.where_ $ E.not_ $ E.parens $ matchUIH banIfs -- WORKS OKAY
+      -- E.where_ $ E.not_ (ilog E.^. InterfaceLogInterface E.==. E.val "LMS" E.&&.  ilog E.^. InterfaceLogSubtype E.==. E.val (sanitize "F")) -- BAD  All missing, except for "Printer" "F"
+      -- E.where_ $ E.not_ $ E.parens (ilog E.^. InterfaceLogInterface E.==. E.val "LMS" E.&&.  ilog E.^. InterfaceLogSubtype E.==. E.val (sanitize "F")) -- WORKS OKAY
+      -- E.where_ $         ilog E.^. InterfaceLogInterface E.!=. E.val "LMS" E.||.  ilog E.^. InterfaceLogSubtype E.!=. E.val (sanitize "F")  -- WORKS OKAY
+      let ihour = E.coalesceDefault [ihealth E.?. InterfaceHealthHours] (E.val $ 3 * 24)  -- if no default time is set, use 3 days instead
+      return (ilog, ihour)
+
+    queryILog     :: (E.SqlExpr (Entity InterfaceLog) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity InterfaceHealth))) -> E.SqlExpr (Entity InterfaceLog)
+    queryILog     = $(E.sqlLOJproj 2 1)
+    resultILog    :: Lens' (DBRow (Entity InterfaceLog, E.Value Int)) InterfaceLog
+    resultILog    = _dbrOutput . _1 . _entityVal
+    resultHours   :: Lens' (DBRow (Entity InterfaceLog, E.Value Int)) Int
+    resultHours   = _dbrOutput . _2 . E._unValue
+
+    dbtRowKey     = queryILog >>> (E.^.InterfaceLogId)
+    colonnade now = mconcat
+        [ sortable Nothing (i18nCell MsgInterfaceStatus) $ \row -> -- do
+            let hours   = row ^. resultHours
+                -- defmsg  = row ^? resultErrMsg
+                logtime = row ^. resultILog . _interfaceLogTime
+                success = row ^. resultILog . _interfaceLogSuccess
+                iface   = row ^. resultILog . _interfaceLogInterface
+                status  = success && now <= addHours hours logtime
+            in tellCell [(iface,status)] $
+                wgtCell $ flagError status
+        , sortable (Just "interface") (i18nCell MsgInterfaceName      ) $ \(view (resultILog . _interfaceLogInterface) -> n) -> textCell n
+        , sortable (Just "subtype")   (i18nCell MsgInterfaceSubtype   ) $ textCell . view (resultILog . _interfaceLogSubtype)
+        , sortable (Just "write")     (i18nCell MsgInterfaceWrite     ) $ (`ifIconCell` IconEdit) . view (resultILog . _interfaceLogWrite)
+        , sortable (Just "time")      (i18nCell MsgInterfaceLastSynch ) $ dateTimeCell . view (resultILog . _interfaceLogTime)
+        , sortable Nothing            (i18nCell MsgInterfaceFreshness ) $ numCell . view resultHours
+        , sortable (Just "rows")      (i18nCell MsgTableRows          ) $ cellMaybe numCell . view (resultILog . _interfaceLogRows)
+        , sortable (Just "success")   (i18nCell MsgInterfaceSuccess   ) $ \(view (resultILog . _interfaceLogSuccess) -> s) -> iconBoolCell s
+        , sortable Nothing            (i18nCell MsgInterfaceInfo      ) $ \(view resultILog -> ilt) -> case ilt of
+            InterfaceLog "AVS" "Synch" True _ _ i _ -> anchorCell ProblemAvsErrorR  $ toWgt $ bool i "AVS-Log" $ null i
+            InterfaceLog "LPR" _       _    _ _ i _ -> anchorCell PrintLogR         $ toWgt $ bool i "LPR-Log" $ null i
+            InterfaceLog _     _       _    _ _ i _ -> textCell i
+        ]
+
+    dbtSorting    = mconcat
+        [ singletonMap "interface" $ SortColumn $ queryILog >>> (E.^. InterfaceLogInterface)
+        , singletonMap "subtype"   $ SortColumn $ queryILog >>> (E.^. InterfaceLogSubtype)
+        , singletonMap "write"     $ SortColumn $ queryILog >>> (E.^. InterfaceLogWrite)
+        , singletonMap "time"      $ SortColumn $ queryILog >>> (E.^. InterfaceLogTime)
+        , singletonMap "rows"      $ SortColumn $ queryILog >>> (E.^. InterfaceLogRows)
+        , singletonMap "success"   $ SortColumn $ queryILog >>> (E.^. InterfaceLogSuccess)
+        ]
+    ilvalidator   = def & defaultSorting [SortAscBy "interface", SortAscBy "subtype", SortAscBy "write"]
+    dbtFilter     = mempty
+    dbtFilterUI   = mempty
+    dbtStyle      = def
+    dbtParams     = def
+    dbtCsvEncode  = noCsvEncode
+    dbtCsvDecode  = Nothing
+    dbtExtraReps  = []
+
+
+-- | runs additional checks and logs results within InterfaceLogTable; assumed to executable within a handler call
+runInterfaceChecks :: ReqBanInterfaceHealth -> DB ()
+runInterfaceChecks interfs = do
+  avsInterfaceCheck interfs
+  lprAckCheck interfs
+
+maybeRunCheck :: ReqBanInterfaceHealth -> Unique InterfaceHealth -> (UTCTime -> DB ()) -> DB ()
+maybeRunCheck (reqIfs,banIfs) uih act
+  | null reqIfs ||      any (matchesUniqueInterfaceHealth uih) reqIfs
+  , null banIfs || not (any (matchesUniqueInterfaceHealth uih) banIfs) = do
+      mih <- getBy uih
+      whenIsJust mih $ \eih -> do
+        now <- liftIO getCurrentTime
+        act $ addHours (negate $ interfaceHealthHours $ entityVal eih) now
+  | otherwise = return ()
+
+
+lprAckCheck :: ReqBanInterfaceHealth -> DB ()
+lprAckCheck interfs = maybeRunCheck interfs (UniqueInterfaceHealth "Printer" (Just "Acknowledge") (Just True)) $ \cutOffOldTime -> do
+    unproc <- selectList [PrintAcknowledgeTimestamp <. cutOffOldTime, PrintAcknowledgeProcessed ==. False] []
+    if notNull unproc
+      then mkLog False (Just $ length unproc) "Long unprocessed APC-Idents exist"
+      else do
+        oks <- E.deleteWhereCount [PrintAcknowledgeTimestamp <. cutOffOldTime, PrintAcknowledgeProcessed ==. True]
+        if oks > 0
+          then mkLog True (Just $ fromIntegral oks) "Long processed APC-Idents removed"
+          else mkLog True Nothing mempty
+  where
+    mkLog = logInterface' "Printer" "Acknowledge" True
+
+
+avsInterfaceCheck :: ReqBanInterfaceHealth -> DB ()
+avsInterfaceCheck interfs = maybeRunCheck interfs (UniqueInterfaceHealth "AVS" (Just "Synch") (Just True)) $ \cutOffOldTime -> do
+  avsSynchStats <- E.select $ do
+    uavs <- E.from $ E.table @UserAvs
+    E.where_ $ uavs E.^. UserAvsLastSynch E.>. E.val cutOffOldTime
+    let isOk = E.isNothing (uavs E.^. UserAvsLastSynchError)
+    E.groupBy isOk
+    E.orderBy [E.descNullsLast isOk]
+    return (isOk, E.countRows, E.max_ $ uavs E.^. UserAvsLastSynch)
+  let
+    mkBadInfo badRows (fromMaybe cutOffOldTime -> badTime) | badRows > 0 = do
+      fmtCut <- formatTime SelFormatDate cutOffOldTime
+      fmtBad <- formatTime SelFormatDateTime badTime
+      return $ tshow badRows <> " Fehler seit " <> fmtCut <> ", zuletzt um " <> fmtBad
+    mkBadInfo _ _ = return mempty
+    writeAvsSynchStats okRows badInfo =
+      logInterface' "AVS" "Synch" True (null badInfo) okRows badInfo
+  --case $(unValueN 3) <$> avsSynchStats of
+  case avsSynchStats of
+    ((E.Value True , E.Value okRows, E.Value _okTime):(E.Value False, E.Value badRows, E.Value badTime):_) ->
+      writeAvsSynchStats (Just okRows) =<< mkBadInfo badRows badTime
+    ((E.Value True , E.Value okRows, E.Value _okTime):_)    ->
+      writeAvsSynchStats (Just okRows) mempty
+    ((E.Value False, E.Value badRows, E.Value badTime):_) ->
+      -- lastOk <- userAvsLastSynch . entityVal <<$>> selectFirst [UserAvsLastSynchError ==. Nothing] [Desc UserAvsLastSynch]
+      writeAvsSynchStats Nothing =<< mkBadInfo badRows badTime
+    _ -> return ()

src/Handler/Info.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022-2023 Felix Hamann <felix.hamann@campus.lmu.de>, Gregor Kleen <gregor@kleen.consulting>, Sarah Vaupel <sarah.vaupel@ifi.lmu.de>, Steffen Jost <jost@tcs.ifi.lmu.de>, Winnie Ros <winnie.ros@campus.lmu.de>
+-- SPDX-FileCopyrightText: 2022-2024 Felix Hamann <felix.hamann@campus.lmu.de>, Gregor Kleen <gregor@kleen.consulting>, Sarah Vaupel <sarah.vaupel@ifi.lmu.de>, Steffen Jost <jost@tcs.ifi.lmu.de>, Winnie Ros <winnie.ros@campus.lmu.de>, Steffen Jost <s.jost@fraport.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -13,12 +13,12 @@ import Data.Map ((!))
 import qualified Data.CaseInsensitive as CI
 import qualified Data.Set as Set
 
-import qualified Database.Esqueleto.Legacy as E
+-- import qualified Database.Esqueleto.Legacy as E
-import qualified Database.Esqueleto.Utils as E
+-- import qualified Database.Esqueleto.Utils as E
 
 import Development.GitRev
 
-import Auth.LDAP (ADError(..), ADInvalidCredentials(..), CampusMessage(..))
+-- import Auth.LDAP (ADError(..), ADInvalidCredentials(..), CampusMessage(..))
 
 import Yesod.Auth.Message(AuthMessage(..)) 
 
@@ -175,6 +175,7 @@ showFAQ :: ( MonadAP m
            , MonadThrow m
            )
         => Route UniWorX -> FAQItem -> m Bool
+showFAQ _ FAQLoginExpired = return True
 showFAQ _ FAQNoCampusAccount = is _Nothing <$> maybeAuthId
 showFAQ (AuthR _) FAQCampusCantLogin = return True
 showFAQ _ FAQCampusCantLogin = is _Nothing <$> maybeAuthId
@@ -183,38 +184,20 @@ showFAQ _ FAQForgottenPassword = is _Nothing <$> maybeAuthId
 showFAQ _ FAQNotLecturerHowToCreateCourses
   = and2M (is _Just <$> maybeAuthId)
           (not <$> hasWriteAccessTo CourseNewR)
-showFAQ (CourseR tid ssh csh _) FAQCourseCorrectorsTutors
+-- showFAQ (CourseR tid ssh csh _) FAQCourseCorrectorsTutors
-  = and2M (is _Just <$> maybeAuthId)
+--   = and2M (is _Just <$> maybeAuthId)
-          (or2M (hasWriteAccessTo $ CourseR tid ssh csh SheetNewR)
+--           (or2M (hasWriteAccessTo $ CourseR tid ssh csh SheetNewR)
-                (hasWriteAccessTo $ CourseR tid ssh csh CTutorialNewR)
+--                 (hasWriteAccessTo $ CourseR tid ssh csh CTutorialNewR)
-          )
+--           )
-showFAQ (CExamR tid ssh csh examn _) FAQExamPoints
+-- showFAQ _ _ = return False
-  = and2M (hasWriteAccessTo $ CExamR tid ssh csh examn EEditR)
-          noExamParts
-  where
-    noExamParts = liftHandler . runDB . E.selectNotExists . E.from $ \(examPart `E.InnerJoin` exam `E.InnerJoin` course) -> do
-      E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
-      E.on $ exam E.^. ExamId E.==. examPart E.^. ExamPartExam
-      E.where_ $ course E.^. CourseTerm E.==. E.val tid
-           E.&&. course E.^. CourseSchool E.==. E.val ssh
-           E.&&. course E.^. CourseShorthand E.==. E.val csh
-           E.&&. exam E.^. ExamName E.==. E.val examn
-showFAQ _ FAQInvalidCredentialsAdAccountDisabled = maybeT (return False) $ do
-  guardM $ is _Nothing <$> maybeAuthId
-  sessionError <- MaybeT $ lookupSessionJson SessionError
-  guard $ sessionError == PermissionDenied (toPathPiece $ ADInvalidCredentials ADAccountDisabled)
-  return True
-showFAQ _ _ = return False
 
 prioFAQ :: Monad m
         => Route UniWorX -> FAQItem -> m Rational
+prioFAQ _ FAQLoginExpired = return 2
 prioFAQ _ FAQNoCampusAccount = return 1
 prioFAQ _ FAQCampusCantLogin = return 1
 prioFAQ _ FAQForgottenPassword = return 1
 prioFAQ _ FAQNotLecturerHowToCreateCourses = return 1
-prioFAQ _ FAQCourseCorrectorsTutors = return 1
-prioFAQ _ FAQExamPoints = return 2
-prioFAQ _ FAQInvalidCredentialsAdAccountDisabled = return 3  
 
 
 getInfoLecturerR :: Handler Html

src/Handler/LMS.hs

@@ -3,7 +3,6 @@
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
 {-# OPTIONS_GHC -fno-warn-orphans #-}      -- needed for HasEntity instances
-{-# OPTIONS -Wno-unused-top-binds #-}      -- TODO: remove me, for debugging only
 {-# LANGUAGE TypeApplications #-}
 
 module Handler.LMS
@@ -12,13 +11,7 @@ module Handler.LMS
   , getLmsR               , postLmsR
   , getLmsIdentR
   , getLmsEditR           , postLmsEditR
-  -- V1
+  -- V2
-  , getLmsUsersR          , getLmsUsersDirectR
-  , getLmsUserlistR       , postLmsUserlistR
-  , getLmsUserlistUploadR , postLmsUserlistUploadR, postLmsUserlistDirectR
-  , getLmsResultR         , postLmsResultR
-  , getLmsResultUploadR   , postLmsResultUploadR  , postLmsResultDirectR
-  -- V1
   , getLmsLearnersR       , getLmsLearnersDirectR
   , getLmsReportR         , postLmsReportR
   , getLmsReportUploadR   , postLmsReportUploadR  , postLmsReportDirectR
@@ -42,7 +35,7 @@ import qualified Data.Set as Set
 import qualified Data.Map as Map
 import qualified Data.Csv as Csv
 import qualified Data.Text as T
-import qualified Data.CaseInsensitive as CI
+-- import qualified Data.CaseInsensitive as CI
 import qualified Data.Conduit.List as C
 import           Database.Esqueleto.Experimental ((:&)(..))
 import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma
@@ -51,10 +44,6 @@ import qualified Database.Esqueleto.PostgreSQL as E
 import qualified Database.Esqueleto.Utils as E
 import Database.Esqueleto.Utils.TH
 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
@@ -76,7 +65,7 @@ embedRenderMessage ''UniWorX ''ButtonManualLms id
 
 instance Button UniWorX ButtonManualLms where
   btnClasses BtnLmsEnqueue = [BCIsButton, BCPrimary]
-  btnClasses BtnLmsDequeue = [BCIsButton, BCDefault]
+  btnClasses BtnLmsDequeue = [BCIsButton, BCPrimary]
 
 
 getLmsSchoolR :: SchoolId -> Handler Html
@@ -86,7 +75,8 @@ getLmsAllR, postLmsAllR :: Handler Html
 getLmsAllR = postLmsAllR
 postLmsAllR = do
   isAdmin <- hasReadAccessTo AdminR
-  mbQcheck <- getsYesod $ view _appQualificationCheckHour
+  mbJLQenqueue <- getsYesod $ view _appJobLmsQualificationsEnqueueHour
+  mbJLQdequeue <- getsYesod $ view _appJobLmsQualificationsDequeueHour
   -- TODO: Move this functionality elsewhere without the need for `isAdmin`
   mbBtnForm <- if not isAdmin then return Nothing else do
     ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm ("buttons" :: Text) (buttonForm :: Form ButtonManualLms)
@@ -110,7 +100,7 @@ postLmsAllR = do
     view _2 <$> mkLmsAllTable isAdmin lmsDeletionDays
   siteLayoutMsg MsgMenuLms $ do
     setTitleI   MsgMenuLms
-    $(widgetFile "lms-all")
+    $(i18nWidgetFile "lms-all")
 
 type AllQualificationTableData = DBRow (Entity Qualification, Ex.Value Word64, Ex.Value Word64)
 resultAllQualification :: Lens' AllQualificationTableData Qualification
@@ -360,9 +350,8 @@ data LmsTableAction = LmsActNotify
                     | LmsActReset
                     | LmsActRestart
   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
+  deriving anyclass (Universe, Finite)
   
-instance Universe LmsTableAction
-instance Finite LmsTableAction
 nullaryPathPiece ''LmsTableAction $ camelToPathPiece' 2
 embedRenderMessage ''UniWorX ''LmsTableAction id
 
@@ -445,7 +434,7 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
     cmps <- selectList [] [] -- [Asc CompanyShorthand]
     return $ Map.fromList $ fmap (\Entity{..} -> (entityKey, entityVal)) cmps
   let            
-    csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName)
+    csvName = T.replace " " "-" $ ciOriginal (quali ^. _qualificationName)
     dbtIdent :: Text
     dbtIdent = "lms"
     dbtSQLQuery = lmsTableQuery now qid
@@ -506,7 +495,7 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
                 let testname = (E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf`
                                 (E.explicitUnsafeCoerceSqlExprValue "citext" (comp E.^. CompanyName) :: E.SqlExpr (E.Value (CI Text)))
                     testnumber nr = E.val nr E.==. comp E.^. CompanyAvsId
-                    testcrit = maybe testname testnumber $ readMay $ CI.original criterion
+                    testcrit = maybe testname testnumber $ readMay $ ciOriginal criterion
                 E.on $     usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
                 E.where_ $ usrComp E.^. UserCompanyUser    E.==. queryUser row E.^. UserId E.&&. testcrit
         )        
@@ -633,19 +622,16 @@ postLmsR sid qsh = do
               <*  aformMessage msgRestartWarning              
           ]        
         colChoices cmpMap = mconcat
-          [ if not isAdmin then mempty else dbSelect (applying _2) id (return . view (resultUser . _entityKey))
+          [ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultUser . _entityKey))
-          , colUserNameModalHdr MsgLmsUser AdminUserR
+          , colUserNameModalHdrAdmin MsgLmsUser AdminUserR
           , colUserEmail
           , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultCompanyUser -> cmps) ->
-              let icnSuper = text2markup " " <> icon IconSupervisor
+              let cs =  [ companyCell (unCompanyKey cmpId) cmpName cmpSpr
-                  cs =  [ (cmpName, cmpSpr) 
                         | Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps
                         , let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap                        
                         ]
-                  companies = intercalate (text2markup ", ") $
+              in intercalate spacerCell cs
-                    (\(cmpName, cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> cs
+          , colUserMatriclenr isAdmin
-              in wgtCell companies            
-          , colUserMatriclenr
           -- , sortable (Just "validity")      (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser)          
           , sortable (Just "first-held")    (i18nCell MsgTableQualificationFirstHeld)  $ \(   view $ resultQualUser . _entityVal . _qualificationUserFirstHeld   -> d)  -> dayCell d
           , sortable (Just "last-refresh")  (i18nCell MsgTableQualificationLastRefresh)$ \(   view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d)  -> dayCell d

src/Handler/LMS/Learners.hs

@@ -213,6 +213,6 @@ getLmsLearnersDirectR sid qsh = do
   $logInfoS "LMS" msg
   addHeader "Content-Disposition" $ "attachment; filename=\"" <> csvSheetName <> "\""
   csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered
-
+    <* runDB (logInterface "LMS" (ciOriginal qsh) True (Just nr) "")
 -- direct Download see:
 -- https://ersocon.net/blog/2017/2/22/creating-csv-files-in-yesod

src/Handler/LMS/Report.hs

@@ -200,7 +200,6 @@ mkReportTable sid qsh qid = do
                   , LmsReportLock             =. lmsReportCsvLock   actionData
                   , LmsReportTimestamp        =. eanow
                   ]                
-                -- audit $ Transaction.. (add to Audit.Types)
             lift . queueDBJob $ JobLmsReports qid
             return $ LmsReportR sid qsh
           , dbtCsvRenderKey           = const $ \case
@@ -296,7 +295,6 @@ postLmsReportUploadR sid qsh = do
         [whamlet|$newline never
           <form method=post enctype=#{enctype}>
             ^{widget}            
-            <p>
             <input type=submit>
         |]
 
@@ -316,11 +314,13 @@ postLmsReportDirectR sid qsh = do
         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
+            logInterface "LMS" (ciOriginal qsh) False Nothing ""
             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
+            logInterface "LMS" (ciOriginal qsh) True (Just nr) ""
             return (ok200, msg)
     []     -> do
       let msg = "Report upload file missing."

src/Handler/LMS/Result.hs

@@ -1,293 +0,0 @@
--- SPDX-FileCopyrightText: 2022 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.Result
-  ( getLmsResultR, postLmsResultR
-  , getLmsResultUploadR, postLmsResultUploadR
-  , postLmsResultDirectR
-  )
-  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 LmsResultTableCsv = LmsResultTableCsv
-  { csvLRTident   :: LmsIdent
-  , csvLRTsuccess :: LmsDay
-  }
-  deriving Generic
-makeLenses_ ''LmsResultTableCsv
-
--- csv without headers
-instance Csv.ToRecord   LmsResultTableCsv -- default suffices
-instance Csv.FromRecord LmsResultTableCsv -- default suffices
-
--- csv with headers
-lmsResultTableCsvHeader :: Csv.Header
-lmsResultTableCsvHeader = Csv.header [ csvLmsIdent, csvLmsSuccess ]
-
-instance ToNamedRecord LmsResultTableCsv where
-  toNamedRecord LmsResultTableCsv{..} = Csv.namedRecord
-    [ csvLmsIdent   Csv..= csvLRTident
-    , csvLmsSuccess Csv..= csvLRTsuccess
-    ]
-
-instance FromNamedRecord LmsResultTableCsv where
-  parseNamedRecord (lsfHeaderTranslate -> csv)
-    = LmsResultTableCsv
-        <$> csv Csv..: csvLmsIdent
-        <*> csv Csv..: csvLmsSuccess
-
-instance CsvColumnsExplained LmsResultTableCsv where
-  csvColumnsExplanations _ = mconcat
-    [ single csvLmsIdent   MsgCsvColumnLmsIdent
-    , single csvLmsSuccess MsgCsvColumnLmsSuccess
-    ]
-    where
-      single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget
-      single k v = singletonMap k [whamlet|_{v}|]
-
-data LmsResultCsvActionClass = LmsResultInsert | LmsResultUpdate
-  deriving (Eq, Ord, Read, Show, Generic, Enum, Bounded)
-embedRenderMessage ''UniWorX ''LmsResultCsvActionClass id
-
--- By coincidence the action type is identical to LmsResultTableCsv
-data LmsResultCsvAction = LmsResultInsertData { lmsResultInsertIdent :: LmsIdent, lmsResultInsertSuccess :: Day }
-                        | LmsResultUpdateData { lmsResultInsertIdent :: LmsIdent, lmsResultInsertSuccess :: Day }
-  deriving (Eq, Ord, Read, Show, Generic)
-
-deriveJSON defaultOptions
-  { constructorTagModifier = camelToPathPiece'' 2 1   -- LmsResultInsertData -> insert
-  , fieldLabelModifier     = camelToPathPiece'  2     -- lmsResultInsertIdent -> insert-ident | lmsResultInsertSuccess -> insert-success
-  , sumEncoding = TaggedObject "action" "data"
-  } ''LmsResultCsvAction
-
-data LmsResultCsvException
-  = LmsResultCsvExceptionDuplicatedKey -- TODO: this is not used anywhere?!
-  deriving (Show, Generic)
-
-instance Exception LmsResultCsvException
-embedRenderMessage ''UniWorX ''LmsResultCsvException id
-
-mkResultTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget)
-mkResultTable sid qsh qid = do
-  now_day <- utctDay <$> liftIO getCurrentTime
-  dbtCsvName <- csvFilenameLmsResult qsh
-  let dbtCsvSheetName = dbtCsvName
-  let
-    resultDBTable = DBTable{..}
-      where
-        dbtSQLQuery lmsresult = do
-          E.where_ $ lmsresult E.^. LmsResultQualification E.==. E.val qid
-          return lmsresult
-        dbtRowKey = (E.^. LmsResultId)
-        dbtProj = dbtProjId
-        dbtColonnade = dbColonnade $ mconcat
-          [ sortable (Just csvLmsIdent)     (i18nCell MsgTableLmsIdent)    $ \(view $ _dbrOutput . _entityVal . _lmsResultIdent . _getLmsIdent -> ident) -> textCell ident
-          , sortable (Just csvLmsSuccess)   (i18nCell MsgTableLmsSuccess)  $ \(view $ _dbrOutput . _entityVal . _lmsResultSuccess            -> success) -> dayCell success
-          , sortable (Just csvLmsTimestamp) (i18nCell MsgTableLmsReceived) $ \(view $ _dbrOutput . _entityVal . _lmsResultTimestamp        -> timestamp) -> dateTimeCell timestamp
-          ]
-        dbtSorting = Map.fromList
-          [ (csvLmsIdent    , SortColumn (E.^. LmsResultIdent))
-          , (csvLmsSuccess  , SortColumn (E.^. LmsResultSuccess))
-          , (csvLmsTimestamp, SortColumn (E.^. LmsResultTimestamp))
-          ]
-        dbtFilter = Map.fromList
-          [ (csvLmsIdent  , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsResultIdent))
-          , (csvLmsSuccess, FilterColumn $ E.mkExactFilter                 (E.^. LmsResultSuccess))
-          ]
-        dbtFilterUI = \mPrev -> mconcat
-          [ prismAForm (singletonFilter csvLmsIdent   . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent)
-          , prismAForm (singletonFilter csvLmsSuccess . maybePrism _PathPiece) mPrev $ aopt (hoistField lift dayField)  (fslI MsgTableLmsSuccess)
-          ]
-        dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
-        dbtParams = def
-        dbtIdent :: Text
-        dbtIdent = "lms-result"
-        dbtCsvEncode = Just DBTCsvEncode
-          { dbtCsvExportForm   = pure ()
-          , dbtCsvDoEncode     = \() -> C.map (doEncode' . view _2)
-          , dbtCsvName
-          , dbtCsvSheetName
-          , dbtCsvNoExportData = Just id
-          , dbtCsvHeader       = const $ return lmsResultTableCsvHeader
-          , dbtCsvExampleData  = Just
-            [ LmsResultTableCsv{csvLRTident = LmsIdent lid, csvLRTsuccess = LmsDay $ addDays (-dos) now_day }
-            | (lid,dos) <- zip ["abcdefgh", "12345678", "ident8ch"] [1..]
-            ]
-          }
-          where
-            doEncode' = LmsResultTableCsv
-              <$> view (_dbrOutput . _entityVal . _lmsResultIdent)
-              <*> view (_dbrOutput . _entityVal . _lmsResultSuccess . _lmsDay)
-        dbtCsvDecode = Just DBTCsvDecode -- Just save to DB; Job will process data later
-          { dbtCsvRowKey = \LmsResultTableCsv{..} ->
-              fmap E.Value . MaybeT . getKeyBy $ UniqueLmsResult qid csvLRTident
-          , dbtCsvComputeActions = \case -- purpose is to show a diff to the user first
-              DBCsvDiffNew{dbCsvNewKey = Nothing, dbCsvNew} -> do
-                yield $ LmsResultInsertData
-                        { lmsResultInsertIdent   = csvLRTident   dbCsvNew
-                        , lmsResultInsertSuccess = csvLRTsuccess dbCsvNew & lms2day
-                        }
-              DBCsvDiffNew{dbCsvNewKey = Just _, dbCsvNew = _} -> error "UniqueLmsResult was found, but the key no longer exists." -- TODO: how can this ever happen? Check Pagination-Code
-              DBCsvDiffExisting{dbCsvNew = LmsResultTableCsv{..}, dbCsvOld} -> do
-                let successDay = lms2day csvLRTsuccess
-                when (successDay /= dbCsvOld ^. _dbrOutput . _entityVal . _lmsResultSuccess) $
-                  yield $ LmsResultUpdateData
-                          { lmsResultInsertIdent   = csvLRTident
-                          , lmsResultInsertSuccess = successDay
-                          }
-              DBCsvDiffMissing{}  -> return () -- no deletion
-          , dbtCsvClassifyAction      = \case
-              LmsResultInsertData{} -> LmsResultInsert
-              LmsResultUpdateData{} -> LmsResultUpdate
-          , dbtCsvCoarsenActionClass  = \case
-              LmsResultInsert -> DBCsvActionNew
-              LmsResultUpdate -> DBCsvActionExisting
-          , dbtCsvValidateActions     = return ()  -- no validation, since this is an automatic upload, i.e. no user to review error
-          , dbtCsvExecuteActions      = do
-            C.mapM_ $ \actionData -> do
-                now <- liftIO getCurrentTime
-                void $ upsert
-                  LmsResult
-                    { lmsResultQualification  =  qid
-                    , lmsResultIdent          =  lmsResultInsertIdent   actionData
-                    , lmsResultSuccess        =  lmsResultInsertSuccess actionData
-                    , lmsResultTimestamp      =  now -- lmsResultInsertTimestamp -- does it matter which one to choose?
-                    }
-                  [ LmsResultSuccess          =. lmsResultInsertSuccess actionData
-                  , LmsResultTimestamp        =. now
-                  ]
-                -- audit $ Transaction.. (add to Audit.Types)
-            lift . queueDBJob $ JobLmsResults qid
-            return $ LmsResultR sid qsh
-          , dbtCsvRenderKey           = const $ \case
-              LmsResultInsertData{..} -> do -- TODO: i18n
-                [whamlet|
-                  $newline never
-                  Insert: Ident #{getLmsIdent lmsResultInsertIdent} #
-                  had success on ^{formatTimeW SelFormatDate lmsResultInsertSuccess}
-                |]
-              LmsResultUpdateData{..} -> do -- TODO: i18n
-                [whamlet|
-                  $newline never
-                  Update: Ident #{getLmsIdent lmsResultInsertIdent} #
-                  had success on ^{formatTimeW SelFormatDate lmsResultInsertSuccess}
-                |]
-          , dbtCsvRenderActionClass   = toWidget <=< ap getMessageRender . pure
-          , dbtCsvRenderException     = ap getMessageRender . pure :: LmsResultCsvException -> DB Text
-          }
-        dbtExtraReps = []
-
-    resultDBTableValidator = def
-      & defaultSorting [SortAscBy csvLmsIdent]
-  dbTable resultDBTableValidator resultDBTable
-
-getLmsResultR,  postLmsResultR :: SchoolId -> QualificationShorthand -> Handler Html
-getLmsResultR = postLmsResultR
-postLmsResultR sid qsh = do
-  let directUploadLink = LmsResultUploadR sid qsh
-  lmsTable <- runDB $ do
-    qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
-    view _2 <$> mkResultTable sid qsh qid
-  siteLayoutMsg MsgMenuLmsResult $ do
-    setTitleI MsgMenuLmsResult
-    $(widgetFile "lms-result")
-
-
--- Direct File Upload/Download
-
-saveResultCsv :: QualificationId -> Int -> LmsResultTableCsv -> DB Int
-saveResultCsv qid i LmsResultTableCsv{..} = do
-    now <- liftIO getCurrentTime
-    void $ upsert
-      LmsResult
-        { lmsResultQualification  =  qid
-        , lmsResultIdent          =  csvLRTident
-        , lmsResultSuccess        =  csvLRTsuccess & lms2day
-        , lmsResultTimestamp      =  now
-        }
-      [ LmsResultSuccess          =. (csvLRTsuccess & lms2day)
-      , LmsResultTimestamp        =. now
-      ]
-    return $ succ i
-
-makeResultUploadForm :: Form FileInfo
-makeResultUploadForm = renderAForm FormStandard $ fileAFormReq "Result CSV"
-
-getLmsResultUploadR, postLmsResultUploadR :: SchoolId -> QualificationShorthand -> Handler Html
-getLmsResultUploadR = postLmsResultUploadR
-postLmsResultUploadR sid qsh = do
-  ((result,widget), enctype) <- runFormPost makeResultUploadForm
-  case result of
-    FormSuccess file -> do
-      -- content <- fileSourceByteString file
-      -- return $ Just (fileName file, content)
-      nr <- runDB $ do
-        qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
-        nr <- runConduit $ fileSource file
-                .| decodeCsv
-                .| foldMC (saveResultCsv qid) 0
-        queueJob' $ JobLmsResults qid
-        return nr
-      addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file <> pack (" mit " <> show nr <> " Zeilen")
-      redirect $ LmsResultR sid qsh
-    FormFailure errs -> do
-      forM_ errs $ addMessage Error . toHtml
-      redirect $ LmsResultUploadR sid qsh
-    FormMissing ->
-      siteLayoutMsg MsgMenuLmsResult $ do
-        setTitleI MsgMenuLmsUpload
-        [whamlet|$newline never
-          <form method=post enctype=#{enctype}>
-            ^{widget}
-            <p>
-            <input type=submit>
-        |]
-
-
-postLmsResultDirectR :: SchoolId -> QualificationShorthand -> Handler Html
-postLmsResultDirectR sid qsh = do
-  (_params, files) <- runRequestBody
-  (status, msg) <- case files of
-    [(fhead,file)] -> do
-      lmsDecoder <- getLmsCsvDecoder
-      runDB $ do
-        qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
-        enr <- try $ runConduit $ fileSource file
-                .| lmsDecoder
-                .| foldMC (saveResultCsv qid) 0
-        case enr of
-          Left (e :: SomeException) -> do -- catch all to avoid ok220 in case of any error
-            $logWarnS "LMS" $ "Result upload failed parsing: " <> tshow e
-            return (badRequest400, "Exception: " <> tshow e)
-          Right nr -> do
-            let msg = "Success. LMS Result upload file " <> fileName file <> " containing " <> tshow nr <> " rows for " <> fhead <> ".  "
-            $logInfoS "LMS" msg
-            when (nr > 0) $ queueJob' $ JobLmsResults qid
-            return (ok200, msg)
-    []     -> do
-      let msg = "Result upload file missing."
-      $logWarnS "LMS" msg
-      return (badRequest400, msg)
-    _other -> do
-      let msg = "Result upload received multiple files; all ignored."
-      $logWarnS "LMS" msg
-      return (badRequest400, msg)
-  sendResponseStatus status msg
-

src/Handler/LMS/Userlist.hs

@@ -1,288 +0,0 @@
--- SPDX-FileCopyrightText: 2022 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.Userlist
-  ( getLmsUserlistR, postLmsUserlistR
-  , getLmsUserlistUploadR, postLmsUserlistUploadR
-  , postLmsUserlistDirectR
-  )
-  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 LmsUserlistTableCsv = LmsUserlistTableCsv
-  { csvLULident  :: LmsIdent
-  , csvLULfailed :: LmsBool
-  }
-  deriving Generic
-makeLenses_ ''LmsUserlistTableCsv
-
--- csv without headers
-instance Csv.ToRecord   LmsUserlistTableCsv
-instance Csv.FromRecord LmsUserlistTableCsv
-
--- csv with headers
-instance DefaultOrdered LmsUserlistTableCsv where
-   headerOrder = const $ Csv.header [ csvLmsIdent, csvLmsBlocked ]
-
-instance ToNamedRecord LmsUserlistTableCsv where
-  toNamedRecord LmsUserlistTableCsv{..} = Csv.namedRecord
-    [ csvLmsIdent   Csv..= csvLULident
-    , csvLmsBlocked Csv..= csvLULfailed
-    ]
-instance FromNamedRecord LmsUserlistTableCsv where
-  parseNamedRecord (lsfHeaderTranslate -> csv)
-    = LmsUserlistTableCsv
-        <$> csv Csv..: csvLmsIdent
-        <*> csv Csv..: csvLmsBlocked
-
-instance CsvColumnsExplained LmsUserlistTableCsv where
-  csvColumnsExplanations _ = mconcat
-    [ single csvLmsIdent   MsgCsvColumnLmsIdent
-    , single csvLmsBlocked MsgCsvColumnLmsLock
-    ]
-    where
-      single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget
-      single k v = singletonMap k [whamlet|_{v}|]
-
-
-data LmsUserlistCsvActionClass = LmsUserlistInsert | LmsUserlistUpdate
-  deriving (Eq, Ord, Read, Show, Generic, Enum, Bounded)
-embedRenderMessage ''UniWorX ''LmsUserlistCsvActionClass id
-
-data LmsUserlistCsvAction = LmsUserlistInsertData { lmsUserlistInsertIdent :: LmsIdent, lmsUserlistInsertFailed :: Bool }
-                          | LmsUserlistUpdateData { lmsUserlistInsertIdent :: LmsIdent, lmsUserlistInsertFailed :: Bool }
-  deriving (Eq, Ord, Read, Show, Generic)
-
-deriveJSON defaultOptions
-  { constructorTagModifier = camelToPathPiece'' 2 1   -- LmsUserlistInsertData -> insert
-  , fieldLabelModifier = camelToPathPiece' 2          -- lmsUserlistInsertIdent -> insert-ident | lmsUserlistInsertFailed -> insert-failed
-  , sumEncoding = TaggedObject "action" "data"
-  } ''LmsUserlistCsvAction
-
-
-data LmsUserlistCsvException
-  = LmsUserlistCsvExceptionDuplicatedKey -- TODO: this is not used anywhere?!
-  deriving (Show, Generic)
-
-instance Exception LmsUserlistCsvException
-embedRenderMessage ''UniWorX ''LmsUserlistCsvException id
-
-mkUserlistTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget)
-mkUserlistTable sid qsh qid = do
-  dbtCsvName <- csvFilenameLmsUserlist qsh
-  let dbtCsvSheetName = dbtCsvName
-  let
-    userlistTable = DBTable{..}
-      where
-        dbtSQLQuery lmslist = do
-          E.where_ $ lmslist E.^. LmsUserlistQualification E.==. E.val qid
-          return lmslist
-        dbtRowKey = (E.^. LmsUserlistId)
-        dbtProj   = dbtProjId
-        dbtColonnade = dbColonnade $ mconcat
-          [ sortable (Just csvLmsIdent)     (i18nCell MsgTableLmsIdent)    $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> textCell    $ lmsUserlistIdent & getLmsIdent
-          , 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
-          [ (csvLmsIdent    , SortColumn $ \lmslist -> lmslist E.^. LmsUserlistIdent)
-          , (csvLmsBlocked  , SortColumn $ \lmslist -> lmslist E.^. LmsUserlistFailed)
-          , (csvLmsTimestamp, SortColumn $ \lmslist -> lmslist E.^. LmsUserlistTimestamp)
-          ]
-        dbtFilter = Map.fromList
-          [ (csvLmsIdent  , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsUserlistIdent ))
-          , (csvLmsBlocked, FilterColumn $ E.mkExactFilter                 (E.^. LmsUserlistFailed))
-          ]
-        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 MsgTableLmsLock)
-          ]
-        dbtStyle =  def { dbsFilterLayout = defaultDBSFilterLayout }
-        dbtParams = def
-        dbtIdent :: Text
-        dbtIdent = "lms-userlist"
-        dbtCsvEncode = simpleCsvEncode dbtCsvName dbtCsvSheetName doEncode' <&> addExample
-          where
-            addExample dce = dce{ dbtCsvExampleData = csvExample }
-            csvExample = Just
-              [ LmsUserlistTableCsv{csvLULident = LmsIdent lid, csvLULfailed = LmsBool ufl}
-              | (lid,ufl) <- zip ["abcdefgh", "12345678", "ident8ch"] [False,True,False]
-              ]
-            doEncode' = LmsUserlistTableCsv
-              <$> view (_dbrOutput . _entityVal . _lmsUserlistIdent)
-              <*> view (_dbrOutput . _entityVal . _lmsUserlistFailed . _lmsBool)
-        dbtCsvDecode = Just DBTCsvDecode {..}
-          where
-            dbtCsvRowKey = \LmsUserlistTableCsv{csvLULident} ->
-              fmap E.Value . MaybeT . getKeyBy $ UniqueLmsUserlist qid csvLULident
-            dbtCsvComputeActions = \case -- shows a diff first
-              DBCsvDiffNew{dbCsvNew} -> do
-                yield $ LmsUserlistInsertData
-                          { lmsUserlistInsertIdent  =            csvLULident   dbCsvNew
-                          , lmsUserlistInsertFailed = lms2bool $ csvLULfailed  dbCsvNew
-                          }
-              DBCsvDiffExisting{dbCsvNew = LmsUserlistTableCsv{..}, dbCsvOld} -> do
-                let failedBool = lms2bool csvLULfailed
-                when (failedBool /= dbCsvOld ^. _dbrOutput . _entityVal . _lmsUserlistFailed) $
-                  yield $ LmsUserlistUpdateData
-                            { lmsUserlistInsertIdent  = csvLULident
-                            , lmsUserlistInsertFailed = csvLULfailed & lms2bool
-                            }
-              DBCsvDiffMissing{} -> return () -- no deletion
-            dbtCsvClassifyAction = \case
-               LmsUserlistInsertData{} -> LmsUserlistInsert
-               LmsUserlistUpdateData{} -> LmsUserlistUpdate
-            dbtCsvCoarsenActionClass = \case
-               LmsUserlistInsert -> DBCsvActionNew
-               LmsUserlistUpdate -> DBCsvActionExisting
-            dbtCsvValidateActions = return ()  -- no validation, since this is an automatic upload, i.e. no user to review error
-            dbtCsvExecuteActions = do
-              C.mapM_ $ \actionData -> do
-                now <- liftIO getCurrentTime
-                void $ upsert LmsUserlist
-                  {
-                    lmsUserlistQualification  =  qid
-                  , lmsUserlistIdent          =  lmsUserlistInsertIdent   actionData
-                  , lmsUserlistFailed         =  lmsUserlistInsertFailed  actionData
-                  , lmsUserlistTimestamp      =  now
-                  }
-                  [
-                    LmsUserlistFailed         =. lmsUserlistInsertFailed  actionData -- TODO: should we allow a reset from failed: True to False?
-                  , LmsUserlistTimestamp      =. now
-                  ]
-                -- audit
-              lift . queueDBJob $ JobLmsUserlist qid
-              return $ LmsUserlistR sid qsh
-            dbtCsvRenderKey = const $ \case
-              LmsUserlistInsertData{..} -> do -- TODO: i18n
-                [whamlet|
-                  $newline never
-                  Insert: Course for Ident #{getLmsIdent lmsUserlistInsertIdent} #
-                  $if lmsUserlistInsertFailed
-                    is closed due to failure.
-                  $else
-                    is open.
-                |]
-              LmsUserlistUpdateData{..} -> do -- TODO: i18n
-                [whamlet|
-                  $newline never
-                  Update: Course for Ident #{getLmsIdent lmsUserlistInsertIdent} #
-                  $if lmsUserlistInsertFailed
-                    is now closed due to failure.
-                  $else
-                    is still open.
-                |]
-            dbtCsvRenderActionClass = toWidget <=< ap getMessageRender . pure
-            dbtCsvRenderException = ap getMessageRender . pure :: LmsUserlistCsvException -> DB Text
-        dbtExtraReps = []
-
-    userlistDBTableValidator = def
-      & defaultSorting [SortAscBy csvLmsIdent]
-
-  dbTable userlistDBTableValidator userlistTable
-
-
-getLmsUserlistR, postLmsUserlistR :: SchoolId -> QualificationShorthand -> Handler Html
-getLmsUserlistR = postLmsUserlistR
-postLmsUserlistR sid qsh = do
-  lmsTable <- runDB $ do
-    qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
-    view _2 <$> mkUserlistTable sid qsh qid
-  siteLayoutMsg MsgMenuLmsUserlist $ do
-    setTitleI MsgMenuLmsUserlist
-    lmsTable
-
-
--- Direct File Upload/Download
---  saveUserlistCsv :: (PersistUniqueWrite backend, MonadIO m, BaseBackend backend ~ SqlBackend, Enum b) =>
---                      Key Qualification -> b -> LmsUserlistTableCsv -> ReaderT backend m b
-saveUserlistCsv :: QualificationId -> Int -> LmsUserlistTableCsv -> DB Int
-saveUserlistCsv qid i LmsUserlistTableCsv{..} = do
-    now <- liftIO getCurrentTime
-    void $ upsert
-      LmsUserlist
-        { lmsUserlistQualification  =  qid
-        , lmsUserlistIdent          =  csvLULident
-        , lmsUserlistFailed         =  csvLULfailed & lms2bool
-        , lmsUserlistTimestamp      =  now
-        }
-      [ LmsUserlistFailed           =. (csvLULfailed & lms2bool)
-      , LmsUserlistTimestamp        =. now
-      ]
-    return $ succ i
-
-makeUserlistUploadForm :: Form FileInfo
-makeUserlistUploadForm = renderAForm FormStandard $ fileAFormReq "Userlist CSV"
-
-getLmsUserlistUploadR, postLmsUserlistUploadR :: SchoolId -> QualificationShorthand -> Handler Html
-getLmsUserlistUploadR = postLmsUserlistUploadR
-postLmsUserlistUploadR sid qsh = do
-  ((result,widget), enctype) <- runFormPost makeUserlistUploadForm
-  case result of
-    FormSuccess file -> do
-      nr <- runDB $ do
-        qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
-        nr <- runConduit $ fileSource file .| decodeCsv .| foldMC (saveUserlistCsv qid) 0
-        queueJob' $ JobLmsUserlist qid
-        return nr
-      addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file <> pack (" mit " <> show nr <> " Zeilen")
-      redirect $ LmsUserlistR sid qsh
-    FormFailure errs -> do
-      forM_ errs $ addMessage Error . toHtml
-      redirect $ LmsUserlistUploadR sid qsh
-    FormMissing ->
-      siteLayoutMsg MsgMenuLmsUserlist $ do
-        setTitleI MsgMenuLmsUpload
-        [whamlet|$newline never
-          <form method=post enctype=#{enctype}>
-            ^{widget}
-            <p>
-            <input type=submit>
-        |]
-
-
-postLmsUserlistDirectR :: SchoolId -> QualificationShorthand -> Handler Html
-postLmsUserlistDirectR sid qsh = do
-  (_params, files) <- runRequestBody
-  (status, msg) <- case files of
-    [(fhead,file)] -> do
-      lmsDecoder <- getLmsCsvDecoder
-      runDB $ do
-        qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
-        enr <- try $ runConduit $ fileSource file
-                .| lmsDecoder
-                .| foldMC (saveUserlistCsv qid) 0
-        case enr of
-          Left (e :: SomeException) -> do
-            $logWarnS "LMS" $ "Userlist upload failed parsing: " <> tshow e
-            return (badRequest400, "Exception: " <> tshow e)
-          Right nr -> do
-            let msg = "Success. LMS Userlist upload file " <> fileName file <> " containing " <> tshow nr <> " rows for " <> fhead <> ".  "
-            $logInfoS "LMS" msg 
-            when (nr > 0) $ queueJob' $ JobLmsUserlist qid
-            return (ok200, msg)
-    []     -> do
-      let msg = "Userlist upload file missing."
-      $logWarnS "LMS" msg
-      return (badRequest400, msg)
-    _other -> do
-      let msg = "Userlist upload received multiple files; all ignored."
-      $logWarnS "LMS" msg
-      return (badRequest400, msg)
-  sendResponseStatus status msg

src/Handler/PrintCenter.hs

@@ -10,7 +10,8 @@ module Handler.PrintCenter
   , getPrintCenterR, postPrintCenterR
   , getPrintSendR  , postPrintSendR
   , getPrintAckR   , postPrintAckR
-  , postPrintAckDirectR  
+  , getPrintAckDirectR, postPrintAckDirectR
+  , getPrintLogR
   ) where
 
 import Import
@@ -26,7 +27,7 @@ import Database.Esqueleto.Utils.TH
 
 import Utils.Print
 
--- import Data.Aeson (encode)
+import qualified Data.Aeson  as Aeson
 -- import qualified Data.Text as Text
 -- import qualified Data.Set  as Set
 
@@ -441,6 +442,21 @@ postPrintAckR ackDay numAck chksm = do
 saveApcident :: UTCTime -> Natural -> Text -> JobDB Natural
 saveApcident t i apci = insert_ (PrintAcknowledge apci t False) >> return (succ i)
 
+
+makeAckUploadForm :: Form FileInfo
+makeAckUploadForm = renderAForm FormStandard $ fileAFormReq "Acknowledge APC-Ident CSV"
+
+getPrintAckDirectR :: Handler Html
+getPrintAckDirectR = do
+  (widget, enctype) <- generateFormPost makeAckUploadForm
+  siteLayoutMsg MsgMenuPrintAck $ do
+    setTitleI MsgMenuPrintAck
+    [whamlet|$newline never
+      <form method=post enctype=#{enctype}>
+        ^{widget}
+        <input type=submit>
+    |]
+
 postPrintAckDirectR :: Handler Html
 postPrintAckDirectR = do
   now <- liftIO getCurrentTime
@@ -471,3 +487,55 @@ postPrintAckDirectR = do
       $logErrorS "APC" msg
       return (badRequest400, msg)
   sendResponseStatus status msg -- must be outside of runDB; otherwise transaction is rolled back
+
+
+getPrintLogR :: Handler Html
+getPrintLogR = do
+  let
+    logDBTable = DBTable{..}
+      where
+        resultLog :: Lens' (DBRow (TransactionLog, Aeson.Result Transaction)) TransactionLog
+        resultLog = _dbrOutput . _1
+
+        resultTrans :: Lens' (DBRow (TransactionLog, Aeson.Result Transaction)) (Aeson.Result Transaction)
+        resultTrans = _dbrOutput . _2
+
+        tCell' err c dbr = case view resultTrans dbr of
+          (Aeson.Error msg) -> err msg -- should not happen, due to query filter
+          (Aeson.Success t) -> c t
+        tCellErr = tCell' stringCell
+        tCell    = tCell' $ const mempty
+
+        dbtIdent = "lpr-log" :: Text
+        dbtSQLQuery l = do
+          E.where_ $ E.val "LPR" E.==. l E.^. TransactionLogInfo E.->>. "interface-name"
+            -- E.&&. E.val "interface" E.==. l E.^. TransactionLogInfo E.->>. "transaction" -- not necessary
+          return l
+        dbtRowKey = (E.^. TransactionLogId)
+        dbtProj = dbtProjSimple $ \(Entity _ l) -> do
+          return (l, Aeson.fromJSON $ transactionLogInfo l)
+        dbtColonnade = dbColonnade $ mconcat
+          [ sortable (Just "time")    (i18nCell MsgSystemMessageTimestamp) $ \(view $ resultLog . to transactionLogTime -> t) -> dateTimeCell t
+          , sortable (Just "status")  (textCell "Status")                $ tCell    (cellMaybe iconBoolCell . transactionInterfaceSuccess)
+          , sortable (Just "subtype") (i18nCell MsgInterfaceSubtype)     $ tCell    (              textCell . transactionInterfaceSubtype)
+          , sortable (Just "info")    (i18nCell MsgSystemMessageContent) $ tCellErr (              textCell . transactionInterfaceInfo)
+          ]
+        dbtSorting = mconcat
+          [ singletonMap "time"     $ SortColumn (E.^. TransactionLogTime)
+          , singletonMap "status"   $ SortColumn (\r -> r E.^. TransactionLogTime E.->>. "interface-success")
+          , singletonMap "subtype"  $ SortColumn (\r -> r E.^. TransactionLogTime E.->>. "interface-subtype")
+          , singletonMap "info"     $ SortColumn (\r -> r E.^. TransactionLogTime E.->>. "interface-info"   )
+          ]
+        dbtFilter   = mempty
+        dbtFilterUI = mempty
+
+        dbtStyle  = def
+        dbtParams = def
+        dbtCsvEncode = noCsvEncode
+        dbtCsvDecode = Nothing
+        dbtExtraReps = []
+    validator = def & defaultSorting [ SortDescBy "time" ]
+  tbl <- runDB $ dbTableDB' validator logDBTable
+  siteLayoutMsg MsgMenuPrintLog $ do
+    setTitleI MsgMenuPrintLog
+    [whamlet|^{tbl}|]

src/Handler/Profile.hs

@@ -70,6 +70,9 @@ data SettingsForm = SettingsForm
       , stgPrefersPostal        :: Bool
       , stgPostAddress          :: Maybe StoredMarkup
       
+      , stgTelephone            :: Maybe Text
+      , stgMobile               :: Maybe Text
+
       , stgExamOfficeSettings   :: ExamOfficeSettings
       , stgSchools              :: Set SchoolId
       , stgNotificationSettings :: NotificationSettings
@@ -129,9 +132,12 @@ makeSettingForm template html = do
         <*> apopt checkBoxField (fslI MsgShowSex & setTooltip MsgShowSexTip) (stgShowSex <$> template)
 
         <*  aformSection MsgFormNotifications
-        <*> aopt  (textField & cfStrip) (fslI MsgPDFPassword   & setTooltip MsgPDFPasswordTip) (stgPinPassword   <$> template)
+        <*> aopt  (textField & cfStrip) (fslI MsgPDFPassword      & setTooltip MsgPDFPasswordTip) (stgPinPassword   <$> template)
-        <*> apopt checkBoxField         (fslI MsgPrefersPostal & setTooltip MsgPostalTip)      (stgPrefersPostal <$> template)
+        <*> apopt checkBoxField         (fslI MsgPrefersPostalExp & setTooltip MsgPostalTip)      (stgPrefersPostal <$> template)
-        <*> aopt  htmlField             (fslI MsgPostAddress   & setTooltip MsgPostAddressTip) (stgPostAddress   <$> template)
+        <*> aopt  htmlField             (fslI MsgPostAddress      & setTooltip MsgPostAddressTip) (stgPostAddress   <$> template)
+
+        <*> aopt  (textField & cfStrip) (fslI MsgUserTelephone) (stgTelephone <$> template)
+        <*> aopt  (textField & cfStrip) (fslI MsgUserMobile   ) (stgMobile    <$> template)      
 
         <*> examOfficeForm (stgExamOfficeSettings <$> template)        
         <*> schoolsForm (stgSchools <$> template)
@@ -362,14 +368,14 @@ validateSettings User{..} = do
     validEmail' userDisplayEmail'
 
   userPostAddress'  <- use _stgPostAddress
-  let postalNotSet  = isNothing userPostAddress'
+  let postalNotSet  = isNothing userPostAddress' -- TODO $ canonical userPostAddress'
       postalIsValid = validPostAddress userPostAddress'
   guardValidation MsgUserPostalInvalid $
     postalNotSet || postalIsValid
 
   userPrefersPostal' <- use _stgPrefersPostal
   guardValidation MsgUserPrefersPostalInvalid $
-    not $ userPrefersPostal' && (postalNotSet || isJust userCompanyDepartment)
+    not $ userPrefersPostal' && postalNotSet && isNothing userCompanyDepartment
 
   userPinPassword'  <- use _stgPinPassword
   let pinBad     = validCmdArgument =<< userPinPassword'
@@ -439,6 +445,8 @@ serveProfileR (uid, user@User{..}) = do
         , stgPinPassword          = userPinPassword
         , stgPostAddress          = userPostAddress
         , stgPrefersPostal        = userPrefersPostal  
+        , stgTelephone            = userTelephone
+        , stgMobile               = userMobile
         , stgExamOfficeSettings   = ExamOfficeSettings
                                     { eosettingsGetSynced = userExamOfficeGetSynced
                                     , eosettingsGetLabels = userExamOfficeGetLabels
@@ -467,9 +475,11 @@ serveProfileR (uid, user@User{..}) = do
         , UserWarningDays          =. stgWarningDays
         , UserNotificationSettings =. stgNotificationSettings
         , UserShowSex              =. stgShowSex
-        , UserPinPassword          =. stgPinPassword
+        , UserPinPassword          =. (stgPinPassword & canonical)
-        , UserPostAddress          =. stgPostAddress
+        , UserPostAddress          =. (stgPostAddress & canonical)
         , UserPrefersPostal        =. stgPrefersPostal
+        , UserTelephone            =. (stgTelephone   & canonical)
+        , UserMobile               =. (stgMobile      & canonical)
         , UserExamOfficeGetSynced  =. (stgExamOfficeSettings & eosettingsGetSynced)
         , UserExamOfficeGetLabels  =. (stgExamOfficeSettings & eosettingsGetLabels)
         ]

src/Handler/Qualification.hs

@@ -296,7 +296,7 @@ data QualificationTableActionData
   | QualificationActBlockSupervisorData
   | QualificationActBlockData           { qualTableActBlockReason :: Text, qualTableActNotify :: Bool, qualTableActRemoveSupervisors :: Bool }
   | QualificationActUnblockData         { qualTableActBlockReason :: Text, qualTableActNotify :: Bool}
-  | QualificationActRenewData
+  | QualificationActRenewData           { qualTableActChangeReason :: Text}
   | QualificationActGrantData           { qualTableActGrantUntil  :: Day }   
   deriving (Eq, Ord, Show, Generic)  
 
@@ -504,8 +504,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
       , dbParamsFormAttrs  = []
       , dbParamsFormSubmit = FormSubmit
       , dbParamsFormAdditional
-          = renderAForm FormStandard
+          = renderAForm FormStandard $ (, mempty) . First . Just
-                $  (, mempty) . First . Just
               <$> multiActionA acts (fslI MsgTableAction) Nothing
       , dbParamsFormEvaluate = liftHandler . runFormPost
       , dbParamsFormResult   = id
@@ -574,7 +573,8 @@ postQualificationR sid qsh = do
               <$> apreq (textField & cfStrip & addDatalist suggestionsBlock)    (fslI MsgQualificationBlockReason)             Nothing
               <*> areq  (boolField . Just $ SomeMessage MsgBoolIrrelevant)      (fslI MsgQualificationBlockNotify)            (Just False)
               <*> areq  (boolField . Just $ SomeMessage MsgBoolIrrelevant)      (fslI MsgQualificationBlockRemoveSupervisor)  (Just False)
-          , singletonMap QualificationActRenew           $ pure QualificationActRenewData
+          , singletonMap QualificationActRenew           $      QualificationActRenewData
+              <$> apreq (textField & cfStrip & addDatalist suggestionsBlock)    (fslI MsgQualificationRenewReason)             Nothing
           , singletonMap QualificationActGrant           $      QualificationActGrantData 
                 <$> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry
                 <*  aformMessage msgGrantWarning
@@ -586,15 +586,12 @@ postQualificationR sid qsh = do
           , colUserNameModalHdr MsgLmsUser linkUserName
           , colUserEmail          
           , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultCompanyUser -> cmps) ->
-              let icnSuper = text2markup " " <> icon IconSupervisor
+              let cs =  [ companyCell (unCompanyKey cmpId) cmpName cmpSpr
-                  cs =  [ (cmpName, cmpSpr) 
                         | Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps
                         , let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap                        
                         ]
-                  companies = intercalate (text2markup ", ") $
+              in intercalate spacerCell cs
-                    (\(cmpName, cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> cs
+          , guardMonoid isAdmin $ colUserMatriclenr isAdmin
-              in wgtCell companies
-          , guardMonoid isAdmin colUserMatriclenr
           -- , sortable (Just "validity")      (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser)
           , sortable (Just "first-held")    (i18nCell MsgTableQualificationFirstHeld)  $    \(   view $ resultQualUser . _entityVal . _qualificationUserFirstHeld   -> d)  -> dayCell d
           , sortable (Just "last-refresh")  (i18nCell MsgTableQualificationLastRefresh)$    \(   view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d)  -> dayCell d          
@@ -612,8 +609,8 @@ postQualificationR sid qsh = do
     return (tbl, qent)
   
   formResult lmsRes $ \case
-    (QualificationActRenewData, selectedUsers) | isAdmin -> do
+    (QualificationActRenewData renewReason, selectedUsers) | isAdmin -> do
-      noks <- runDB $ renewValidQualificationUsers qid Nothing $ Set.toList selectedUsers      
+      noks <- runDB $ renewValidQualificationUsers qid (canonical $ Just $ Left renewReason) 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      

src/Handler/SAP.hs

@@ -16,6 +16,7 @@ import Handler.Utils
 import Handler.Utils.Csv
 import Handler.Utils.Profile
 
+import qualified Data.Text as Text (intercalate)
 -- import qualified Data.CaseInsensitive as CI
 import qualified Data.Csv as Csv
 import           Database.Esqueleto.Experimental ((:&)(..))
@@ -138,9 +139,12 @@ getQualificationSAPDirectR = do
       csvSheetName = "fradrive_sap_" <> fdate <> ".csv"
       nr  = length qualUsers
       msg = "Qualification download file " <> csvSheetName <> " containing " <> tshow nr <> " rows"
+      quals = Text.intercalate ", " $ nubOrd $ mapMaybe (view (_2 . E._unValue)) qualUsers
   $logInfoS "SAP" msg
+  let logInt = runDB $ logInterface "SAP" quals True (Just nr) ""
   addHeader "Content-Disposition" $ "attachment; filename=\"" <> csvSheetName <> "\""
-  csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered  
+  csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered <* logInt
+  
 
 -- direct Download see:
 -- https://ersocon.net/blog/2017/2/22/creating-csv-files-in-yesod

src/Handler/Submission/Helper/ArchiveTable.hs

@@ -74,7 +74,7 @@ mkSubmissionArchiveTable tid ssh csh shn showCorrection smid = do
               isFile' = origIsFile <|> corrIsFile
             in maybeCell ((,) <$> fileTitle'' <*> isFile') $ \(fileTitle', isFile) -> if
               | Just True <- origIsFile -> anchorCell (subDownloadLink SubmissionOriginal fileTitle') [whamlet|#{fileTitle'}|]
-              | otherwise               -> textCell $ bool (<> "/") id isFile fileTitle'
+              | otherwise               -> stringCell $ bool (<> "/") id isFile fileTitle'
         , guardOn showCorrection . sortable (toNothing "state") (i18nCell MsgTableCorState) $ \t -> case t ^? resultCorrected of
             Nothing -> cell mempty
             Just (Entity _ SubmissionFile{..}) -> tellCell (Any True) $ if

src/Handler/Submission/List.hs

@@ -397,7 +397,7 @@ colSubmissionLink = sortable (Just "submission") (i18nCell MsgTableSubmission) $
       csh = x ^. resultCourseShorthand
       shn = x ^. resultSheet . _entityVal . _sheetName
       subCID = x ^. resultCryptoID
-   in anchorCellC $cacheIdentHere (CSubmissionR tid ssh csh shn subCID SubShowR) (toPathPiece subCID)
+   in anchorCell (CSubmissionR tid ssh csh shn subCID SubShowR) (toPathPiece subCID)
 
 colSelect :: forall act h epId. (Semigroup act, Monoid act, Headedness h, Ord epId) => Colonnade h CorrectionTableData (DBCell _ (FormResult (act, DBFormResult CryptoFileNameSubmission Bool CorrectionTableData), SheetTypeSummary epId))
 colSelect = dbSelect (_1 . applying _2) id $ views resultCryptoID return

src/Handler/Tutorial/Communication.hs

@@ -32,9 +32,10 @@ postTCommR tid ssh csh tutn = do
              )
     return (tutData, usertuts)
 
-
+  let heading = SomeMessage . prependCourseTitle tid ssh csh $ SomeMessage MsgCommTutorialHeading
   commR CommunicationRoute
-    { crHeading    = SomeMessage . prependCourseTitle tid ssh csh $ SomeMessage MsgCommTutorialHeading
+    { crHeading    = heading
+    , crTitle      = heading
     , crUltDest    = SomeRoute $ CTutorialR tid ssh csh tutn TCommR
     , crJobs       = crJobsCourseCommunication cid
     , crTestJobs   = crTestJobsCourseCommunication cid

src/Handler/Tutorial/Users.hs

@@ -71,8 +71,8 @@ postTUsersR tid ssh csh tutn = do
         colChoices  = mconcat $ catMaybes
           [ pure $ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
           , pure $ colUserNameModalHdr MsgTableCourseMembers ForProfileDataR          
-          , pure  colUserEmail
+          , pure   colUserEmail
-          , pure  colUserMatriclenr
+          , pure $ colUserMatriclenr isAdmin
           , pure $ colUserQualifications nowaday
           , pure $ colUserQualificationBlocked isAdmin nowaday
           ]
@@ -146,7 +146,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 Nothing $ Set.toList selectedUsers      
+        noks <- runDB $ renewValidQualificationUsers tuQualification Nothing 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/Users.hs

@@ -100,21 +100,22 @@ postUsersR = do
       , sortable (Just "name") (i18nCell MsgName) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM
           (AdminUserR <$> encrypt uid)
           (nameWidget userDisplayName userSurname)
-      , sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \DBRow{ dbrOutput = entUsr } -> cellHasMatrikelnummerLinked entUsr
+      , sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \DBRow{ dbrOutput = entUsr } -> cellHasMatrikelnummerLinkedAdmin entUsr
       , sortable (Just "user-company") (i18nCell MsgTableCompanies)   $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX"
             companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
               E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
               E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid
               E.orderBy [E.asc (comp E.^. CompanyName)]
-              return (comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor)
+              return (comp E.^. CompanyShorthand, comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor)            
-            let companies = intersperse (text2markup ", ") $
+            let icnSuper  = toWidget $ text2markup " " <> icon IconSupervisor
-                  (\(E.Value cmpName, E.Value cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> companies'
+                companies = 
-                icnSuper = text2markup " " <> icon IconSupervisor
+                  (\(E.Value cmpSh, E.Value cmpName, E.Value cmpSpr) -> simpleLink (citext2widget cmpName) (FirmUsersR cmpSh) <> bool mempty icnSuper cmpSpr) <$> companies'
-            pure $ toWgt $ mconcat companies
+            pure $ intercalate (text2widget "; ") companies
-      , sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM
+      -- , sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM
-          (AdminUserR <$> encrypt uid)
+      --     (AdminUserR <$> encrypt uid)
-          (toWgt userCompanyPersonalNumber)
+      --     (toWgt userCompanyPersonalNumber)
-      , sortable (Just "company-department") (i18nCell MsgCompanyDepartment) $ \DBRow{ dbrOutput = Entity _uid User{..} } -> cellMaybe textCell userCompanyDepartment
+      , sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \DBRow{ dbrOutput = Entity _uid User{..} } -> cellMaybe textCell userCompanyPersonalNumber
+      , sortable (Just "company-department") (i18nCell MsgCompanyDepartment)  $ \DBRow{ dbrOutput = Entity _uid User{..} } -> cellMaybe textCell userCompanyDepartment
 --       , sortable (Just "last-name") (i18nCell MsgName) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM
 --           (AdminUserR <$> encrypt uid)
 --           (toWidget . display $ last $ impureNonNull $ words $ userDisplayName)
@@ -128,8 +129,9 @@ postUsersR = do
                   (\(usr, E.Value reroutCom) -> linkUserWidget ForProfileDataR usr <> bool mempty icnReroute reroutCom) <$> supervisors'
                 icnReroute = text2widget " " <> toWgt (icon IconLetter)
             pure $ mconcat supervisors
-      , sortable (Just "auth-ldap") (i18nCell MsgAuthMode) $ \DBRow{ dbrOutput = Entity _ User{..} } -> i18nCell userAuthentication
+      , sortable (Just "last-login") (i18nCell MsgLastLogin)  $ \DBRow{ dbrOutput = Entity _ User{..} } -> maybe mempty dateTimeCell userLastAuthentication
-      , sortable (Just "ldap-sync") (i18nCell MsgLdapSynced) $ \DBRow{ dbrOutput = Entity _ User{..} } -> maybe mempty dateTimeCell userLastLdapSynchronisation
+      , sortable (Just "auth-ldap")  (i18nCell MsgAuthMode)   $ \DBRow{ dbrOutput = Entity _ User{..} } -> i18nCell userAuthentication      
+      , sortable (Just "ldap-sync")  (i18nCell MsgLdapSynced) $ \DBRow{ dbrOutput = Entity _ User{..} } -> maybe mempty dateTimeCell userLastLdapSynchronisation
       , flip foldMap universeF $ \function ->
           sortable (Just $ SortingKey $ CI.mk $ toPathPiece function) (i18nCell function) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do
             schools <- liftHandler . runDB . E.select . E.from $ \(school `E.InnerJoin` userFunction) -> do
@@ -227,6 +229,9 @@ postUsersR = do
           , ( "auth-ldap"
             , SortColumn $ \user -> user E.^. UserAuthentication E.!=. E.val AuthLDAP
             )
+          , ( "last-login"
+            , SortColumn $ \user -> user E.^. UserLastAuthentication
+            )
           , ( "ldap-sync"
             , SortColumn $ \user -> user E.^. UserLastLdapSynchronisation
             )

src/Handler/Utils.hs

@@ -35,6 +35,8 @@ import Handler.Utils.Qualification as Handler.Utils
 
 import Handler.Utils.Term as Handler.Utils
 
+-- import Handler.Utils.Concurrent as Handler.Utils -- only imported when needed
+
 import Control.Monad.Logger
 
 
@@ -146,7 +148,7 @@ redirectAlternatives = go
 reload :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route (HandlerSite m) -> m a
 reload r = getCurrentRoute >>= redirect . fromMaybe r
 
--- | like `reload`, preserving all GET parameters
+-- | like `reload` to current route, but also preserving all GET parameters, using the current route, if known
 reloadKeepGetParams :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route (HandlerSite m) -> m a
 reloadKeepGetParams r = liftHandler $ do 
   getps <- reqGetParams <$> getRequest
@@ -155,7 +157,7 @@ reloadKeepGetParams r = liftHandler $ do
   -- RECALL: redirect GET parameters are used like so: -- redirect (UsersR, [("users-user-company","fraport")])
   redirect (route, getps) 
 
--- | redirect preserving all GET parameters
+-- | like `reloadKeepGetParams`, but always leading to the specific route instead of the current route
 redirectKeepGetParams :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route (HandlerSite m) -> m a
 redirectKeepGetParams route = liftHandler $ do 
   getps <- reqGetParams <$> getRequest  

src/Handler/Utils/Avs.hs

@@ -494,7 +494,7 @@ upsertAvsUserById api = do
         whenIsJust pinCard $ \pCard -> -- update pin, but only if it was unset or set to the value of an old card
           unlessM (exists [UserAvsCardCardNo ==. getFullCardNo pCard]) $ do
             let oldPins = Just . personCard2pin . userAvsCardCard . entityVal <$> oldCards
-            updateWhere [UserId ==. uid, UserPinPassword !=. userPin, UserPinPassword <-. Nothing:oldPins]
+            updateWhere [UserId ==. uid, UserPinPassword !=. userPin, UserPinPassword <-. oldPins] -- check for old pin ensures that unset/manually set passwords remain unchanged
                         [UserPinPassword =. userPin]
             insert_ $ UserAvsCard api (getFullCardNo pCard) pCard now
         upsertUserCompany uid mbCompany userFirmAddr

src/Handler/Utils/Communication.hs

@@ -8,12 +8,14 @@ module Handler.Utils.Communication
   , Communication(..)
   , commR
   , crJobsCourseCommunication, crTestJobsCourseCommunication
+  , crJobsFirmCommunication, crTestFirmCommunication
   -- * Re-Exports
   , Job(..)
   ) where
 
 import Import
 import Handler.Utils
+import Handler.Utils.Users 
 
 import Jobs.Queue
 
@@ -27,9 +29,11 @@ import qualified Data.Conduit.Combinators as C
 
 
 data RecipientGroup = RGCourseParticipants | RGCourseLecturers | RGCourseCorrectors | RGCourseTutors | RGCourseParticipantsInTutorial | RGCourseUnacceptedApplicants
+  -- WARNING: no RenderMessage instance, but a pattern match in templates/widgets/communication/recipientLayout.hamlet that needs to be extended
                     | RGTutorialParticipants CryptoUUIDTutorial
                     | RGExamRegistered CryptoUUIDExam
                     | RGSheetSubmittor CryptoUUIDSheet
+                    | RGFirmSupervisor CompanyShorthand | RGFirmEmployees CompanyShorthand | RGFirmIndependent
   deriving (Eq, Ord, Read, Show, Generic)
 
 instance LowerBounded RecipientGroup where
@@ -77,6 +81,7 @@ data CommunicationRoute = CommunicationRoute
   , crRecipientAuth :: Maybe (UserId -> DB AuthResult) -- ^ Only resolve userids given as GET-Parameter if they fulfil this criterion
   , crJobs, crTestJobs :: Communication -> ConduitT () Job (YesodDB UniWorX) ()
   , crHeading       :: SomeMessage UniWorX
+  , crTitle         :: SomeMessage UniWorX
   , crUltDest       :: SomeRoute UniWorX
   }
 
@@ -91,123 +96,151 @@ makeLenses_ ''Communication
 crJobsCourseCommunication, crTestJobsCourseCommunication :: CourseId -> Communication -> ConduitT () Job (YesodDB UniWorX) ()
 crJobsCourseCommunication jCourse Communication{..} = do
   jSender <- requireAuthId
-  let jMailContent = cContent
-      allRecipients = Set.toList $ Set.insert (Right jSender) cRecipients
   jMailObjectUUID <- liftIO getRandom
-  jAllRecipientAddresses <- lift . fmap Set.fromList . forM allRecipients $ \case
+  let jMailContent = cContent
-    Left email -> return . Address Nothing $ CI.original email
+      (rawReceiverMails, rawReceiverIds) = setPartitionEithers cRecipients
-    Right rid  -> userAddress <$> getJust rid
+      adrReceiverMails = Set.map (Address Nothing . CI.original) rawReceiverMails
-  forM_ allRecipients $ \jRecipientEmail ->
+  netReceiverAddresses <- lift $ do
-    yield JobSendCourseCommunication{..}
+    netReceiverIds <- getReceiversFor $ jSender : Set.toList rawReceiverIds -- ensure supervisors get only one email
+    (userAddress . entityVal) <<$>> selectList [UserId <-. netReceiverIds] []
+  -- let jAllRecipientAddresses = Set.fromList netReceiverAddresses <> adrReceiverMails
+  let jAllRecipientAddresses = Set.map getAddress (Set.fromList (AddressEqIgnoreName <$> netReceiverAddresses) <> Set.map AddressEqIgnoreName adrReceiverMails)
+  forM_ jAllRecipientAddresses $ \raddr ->
+    yield JobSendCourseCommunication{jRecipientEmail = Left $ CI.mk $ addressEmail raddr, ..} -- using Left UserMail ensures that no further reroutes are used, thus supervised supervisors also receive an email
+
 crTestJobsCourseCommunication jCourse comm = do
   jSender <- requireAuthId
-
   MsgRenderer mr <- getMsgRenderer
   let comm' = comm & _cContent . _ccSubject %~ Just . mr . MsgCommCourseTestSubject . fromMaybe (mr MsgUtilCommCourseSubject)
   crJobsCourseCommunication jCourse comm' .| C.filter ((== Right jSender) . jRecipientEmail)
 
 
+crJobsFirmCommunication, crTestFirmCommunication :: Companies -> Communication -> ConduitT () Job (YesodDB UniWorX) ()
+crJobsFirmCommunication jCompanies Communication{..} = do
+  jSender <- requireAuthId
+  jMailObjectUUID <- liftIO getRandom
+  let jMailContent = cContent
+      (rawReceiverMails, rawReceiverIds) = setPartitionEithers cRecipients
+      adrReceiverMails = Set.map (Address Nothing . CI.original) rawReceiverMails
+  netReceiverAddresses <- lift $ do
+    netReceiverIds <- getReceiversFor $ jSender : Set.toList rawReceiverIds -- ensure supervisors get only one email
+    (userAddress . entityVal) <<$>> selectList [UserId <-. netReceiverIds] []
+  -- let jAllRecipientAddresses = Set.fromList netReceiverAddresses <> adrReceiverMails
+  let jAllRecipientAddresses = Set.map getAddress (Set.fromList (AddressEqIgnoreName <$> netReceiverAddresses) <> Set.map AddressEqIgnoreName adrReceiverMails)
+  forM_ jAllRecipientAddresses $ \raddr ->
+    yield JobSendFirmCommunication{jRecipientEmail = Left $ CI.mk $ addressEmail raddr, ..} -- using Left UserMail ensures that no further reroutes are used, thus supervised supervisors also receive an email
+
+crTestFirmCommunication jCompanies comm = do
+  jSender <- requireAuthId
+  MsgRenderer mr <- getMsgRenderer
+  let comm' = comm & _cContent . _ccSubject %~ Just . mr . MsgCommCourseTestSubject . fromMaybe (mr MsgUtilCommFirmSubject)
+  crJobsFirmCommunication jCompanies comm' .| C.filter ((== Right jSender) . jRecipientEmail)
+
+
+
+
 commR :: CommunicationRoute -> Handler Html
 commR CommunicationRoute{..} =  do
-  cUser <- maybeAuth
+  let decrypt' :: CryptoUUIDUser -> DB (Maybe (Entity User))
-
-  MsgRenderer mr <- getMsgRenderer
-  mbCurrentRoute <- getCurrentRoute
-
-  (suggestedRecipients, chosenRecipients) <- runDB $ do
-    suggestedUsers <- for crRecipients $ \(_,user) -> E.select user
-    let suggested = zip (view _1 <$> crRecipients) suggestedUsers
-
-    let
-      decrypt' :: CryptoUUIDUser -> DB (Maybe (Entity User))
       decrypt' cID = do
         uid <- decrypt cID
         whenIsJust crRecipientAuth $ guardAuthResult <=< ($ uid)
         getEntity uid  
+  cUser <- maybeAuth
+  (chosenRecipients, suggestedRecipients) <- runDB $ (,)
+    <$> (maybe id cons cUser . catMaybes <$> (mapM decrypt' =<< lookupGlobalGetParams GetRecipient))
+    <*> (filter (notNull . snd) <$> for crRecipients (\(grp,usrQry) -> (grp,) <$> E.select usrQry))
+  $logWarnS "COMM" ("Communication handlerwith (sugg:" <> tshow (length suggestedRecipients) <> ", chosen:" <> tshow (length chosenRecipients) <> ")")
 
-    chosen' <- fmap (maybe id cons cUser . catMaybes) $ mapM decrypt' =<< lookupGlobalGetParams GetRecipient
+  MsgRenderer mr <- getMsgRenderer
-
+  mbCurrentRoute <- getCurrentRoute
-    return (suggested, chosen')
+  globalCC <- getsYesod $ view _appCommunicationGlobalCC
   
   let
-    lookupUser :: UserId -> User
+    lookupUser :: UserId -> (UserDisplayName,UserSurname)
-    lookupUser lId
+    lookupUser =
-      = entityVal . unsafeHead . filter ((== lId) . entityKey) $ concat (view _2 <$> suggestedRecipients) ++ chosenRecipients
+      let usrMap  = Map.fromList $ fmap (\u -> (entityKey u, entityVal u)) $ chosenRecipients ++ concatMap (view _2) suggestedRecipients
+          usrNames Nothing = ("???","???") -- this case only happens during runFormPost when POST Data is present and no form is display
+          usrNames (Just User{userDisplayName, userSurname}) = (userDisplayName, userSurname)
+      in usrNames . flip Map.lookup usrMap
   
-  let chosenRecipients' = Map.fromList $
+    chosenRecipients' = Map.fromList $
-        [ ( (BoundedPosition $ RecipientGroup g, pos)
+      [ ( (BoundedPosition $ RecipientGroup g, pos)
-          , (Right recp, recp `elem` map entityKey chosenRecipients)
+        , (Right recp, recp `elem` map entityKey chosenRecipients)
+        )
+      | (g, recps) <- suggestedRecipients
+      , (pos, recp) <- zip [0..] $ map entityKey recps
+      ] ++
+      [ ( (BoundedPosition   RecipientCustom, pos)
+        , (recp, True)
+        )
+      | (pos, recp) <- zip [0..] 
+          ( mcons (Left <$> globalCC)
+            (Right <$> Set.toList (Set.fromList (map entityKey chosenRecipients) \\ Set.fromList (concatMap (map entityKey) $ view _2 <$> suggestedRecipients)))
           )
-        | (g, recps) <- suggestedRecipients
+      ]
-        , (pos, recp) <- zip [0..] $ map entityKey recps
+    activeCategories = map RecipientGroup (view _1 <$> suggestedRecipients) `snoc` RecipientCustom
-        ] ++
-        [ ( (BoundedPosition   RecipientCustom, pos)
-          , (Right recp, True)
-          )
-        | (pos, recp) <- zip [0..] . Set.toList $ Set.fromList (map entityKey chosenRecipients) \\ Set.fromList (concatMap (map entityKey) $ view _2 <$> suggestedRecipients)
-        ]
-      activeCategories = map RecipientGroup (view _1 <$> suggestedRecipients) `snoc` RecipientCustom
 
-  let recipientAForm :: AForm Handler (Set (Either UserEmail UserId))
+    recipientAForm :: AForm Handler (Set (Either UserEmail UserId))
-      recipientAForm = postProcess <$> massInputA MassInput{..} (fslI MsgCommRecipients & setTooltip MsgCommRecipientsTip) True (Just chosenRecipients')
+    recipientAForm = postProcess <$> massInputA MassInput{..} (fslI MsgCommRecipients & setTooltip MsgCommRecipientsTip) True (Just chosenRecipients')
-        where
+      where
-          miAdd pos@(BoundedPosition RecipientCustom, 0) dim@1 liveliness nudge submitView = guardOn (miAllowAdd pos dim liveliness) $ \csrf -> do
+        miAdd pos@(BoundedPosition RecipientCustom, 0) dim@1 liveliness nudge submitView = guardOn (miAllowAdd pos dim liveliness) $ \csrf -> do
-            (addRes, addView) <- mpreq (multiUserField True Nothing) (fslpI MsgUtilEMail (mr MsgUtilEMail) & setTooltip MsgUtilMultiEmailFieldTip & addName (nudge "email")) Nothing
+          (addRes, addView) <- mpreq (multiUserField True Nothing) (fslpI MsgUtilEMail (mr MsgUtilEMail) & setTooltip MsgUtilMultiEmailFieldTip & addName (nudge "email")) Nothing
-            let
+          let
-              addRes' = addRes <&> \nEmails ((Map.elems &&& maybe 0 (succ . snd . fst) . Map.lookupMax) . Map.filterWithKey (\(BoundedPosition c, _) _ -> c == RecipientCustom) -> (oEmails, kStart)) -> FormSuccess . Map.fromList . zip (map (BoundedPosition RecipientCustom, ) [kStart..]) . Set.toList $ nEmails `Set.difference` Set.fromList oEmails
+            addRes' = addRes <&> \nEmails ((Map.elems &&& maybe 0 (succ . snd . fst) . Map.lookupMax) . Map.filterWithKey (\(BoundedPosition c, _) _ -> c == RecipientCustom) -> (oEmails, kStart)) -> FormSuccess . Map.fromList . zip (map (BoundedPosition RecipientCustom, ) [kStart..]) . Set.toList $ nEmails `Set.difference` Set.fromList oEmails
-            return (addRes', $(widgetFile "widgets/communication/recipientAdd"))
+          return (addRes', $(widgetFile "widgets/communication/recipientAdd"))
-          miAdd _ _ _ _ _ = Nothing
+        miAdd _ _ _ _ _ = Nothing
-          miCell _ (Left (CI.original -> email)) initRes nudge csrf = do
+        miCell _ (Left (CI.original -> email)) initRes nudge csrf = do
-            (tickRes, tickView) <- mpreq checkBoxField ("" & addName (nudge "tick")) $ initRes <|> Just True
+          (tickRes, tickView) <- mpreq checkBoxField ("" & addName (nudge "tick")) $ initRes <|> Just True
-            return (tickRes, $(widgetFile "widgets/communication/recipientEmail"))
+          return (tickRes, $(widgetFile "widgets/communication/recipientEmail"))
-          miCell _ (Right uid@(lookupUser -> User{..})) initRes nudge csrf = do
+        miCell _ (Right uid@(lookupUser -> (userDisplayName, userSurname))) initRes nudge csrf = do
-            (tickRes, tickView) <- if
+          (tickRes, tickView) <- if
-              | fmap entityKey cUser == Just uid
+            | fmap entityKey cUser == Just uid
-                -> mforced checkBoxField ("" & addName (nudge "tick"))   True
+              -> mforced checkBoxField ("" & addName (nudge "tick"))   True
-              | otherwise
+            | otherwise
-                -> mpreq   checkBoxField ("" & addName (nudge "tick")) $ initRes <|> Just True
+              -> mpreq   checkBoxField ("" & addName (nudge "tick")) $ initRes <|> Just True
-            return (tickRes, $(widgetFile "widgets/communication/recipientName"))
+          return (tickRes, $(widgetFile "widgets/communication/recipientName"))
-          miAllowAdd (BoundedPosition RecipientCustom, 0) 1 _ = True
+        miAllowAdd (BoundedPosition RecipientCustom, 0) 1 _ = True
-          miAllowAdd _ _ _ = False
+        miAllowAdd _ _ _ = False
-          miAddEmpty _ 0 _ = Set.singleton (BoundedPosition RecipientCustom, 0)
+        miAddEmpty _ 0 _ = Set.singleton (BoundedPosition RecipientCustom, 0)
-          miAddEmpty _ _ _ = Set.empty
+        miAddEmpty _ _ _ = Set.empty
-          miButtonAction :: forall p . PathPiece p => p -> Maybe (SomeRoute UniWorX)
+        miButtonAction :: forall p . PathPiece p => p -> Maybe (SomeRoute UniWorX)
-          miButtonAction anchor = SomeRoute . (:#: anchor) <$> mbCurrentRoute
+        miButtonAction anchor = SomeRoute . (:#: anchor) <$> mbCurrentRoute
-          miLayout :: MapLiveliness (BoundedLiveliness RecipientCategory) ListLength
+        miLayout :: MapLiveliness (BoundedLiveliness RecipientCategory) ListLength
-                   -> Map (BoundedPosition RecipientCategory, ListPosition) (_, FormResult Bool)
+                  -> Map (BoundedPosition RecipientCategory, ListPosition) (_, FormResult Bool)
-                   -> Map (BoundedPosition RecipientCategory, ListPosition) Widget
+                  -> Map (BoundedPosition RecipientCategory, ListPosition) Widget
-                   -> Map (BoundedPosition RecipientCategory, ListPosition) (FieldView UniWorX)
+                  -> Map (BoundedPosition RecipientCategory, ListPosition) (FieldView UniWorX)
-                   -> Map (Natural, (BoundedPosition RecipientCategory, ListPosition)) Widget
+                  -> Map (Natural, (BoundedPosition RecipientCategory, ListPosition)) Widget
-                   -> Widget
+                  -> Widget
-          miLayout liveliness cState cellWdgts _delButtons addWdgts = do
+        miLayout liveliness cState cellWdgts _delButtons addWdgts = do
-            checkedIdentBase <- newIdent
+          checkedIdentBase <- newIdent
-            let checkedCategories = Set.mapMonotonic (unBoundedPosition . fst) . Set.filter (\k' -> Map.foldrWithKey (\k (_, checkState) -> (||) $ k == k' && checkState /= FormSuccess False && (checkState /= FormMissing || maybe True snd (chosenRecipients' !? k))) False cState) $ Map.keysSet cState
+          let checkedCategories = Set.mapMonotonic (unBoundedPosition . fst) . Set.filter (\k' -> Map.foldrWithKey (\k (_, checkState) -> (||) $ k == k' && checkState /= FormSuccess False && (checkState /= FormMissing || maybe True snd (chosenRecipients' !? k))) False cState) $ Map.keysSet cState
-                checkedIdent c = checkedIdentBase <> "-" <> toPathPiece c
+              checkedIdent c = checkedIdentBase <> "-" <> toPathPiece c
-                hasContent c = not (null $ categoryIndices c) || Map.member (1, (BoundedPosition c, 0)) addWdgts
+              hasContent c = not (null $ categoryIndices c) || Map.member (1, (BoundedPosition c, 0)) addWdgts
-                categoryIndices c = Set.filter ((== c) . unBoundedPosition . fst) $ review liveCoords liveliness
+              categoryIndices c = Set.filter ((== c) . unBoundedPosition . fst) $ review liveCoords liveliness
-                rgTutorialParticipantsCaption :: CryptoUUIDTutorial -> Widget
+              rgTutorialParticipantsCaption :: CryptoUUIDTutorial -> Widget
-                rgTutorialParticipantsCaption cID = do
+              rgTutorialParticipantsCaption cID = do
-                  tutId <- decrypt cID
+                tutId <- decrypt cID
-                  Tutorial{..} <- liftHandler . runDBRead $ get404 tutId
+                Tutorial{..} <- liftHandler . runDBRead $ get404 tutId
-                  i18n $ MsgRGTutorialParticipants tutorialName
+                i18n $ MsgRGTutorialParticipants tutorialName
-                rgExamRegisteredCaption :: CryptoUUIDExam -> Widget
+              rgExamRegisteredCaption :: CryptoUUIDExam -> Widget
-                rgExamRegisteredCaption cID = do
+              rgExamRegisteredCaption cID = do
-                  eId <- decrypt cID
+                eId <- decrypt cID
-                  Exam{..} <- liftHandler . runDBRead $ get404 eId
+                Exam{..} <- liftHandler . runDBRead $ get404 eId
-                  i18n $ MsgRGExamRegistered examName
+                i18n $ MsgRGExamRegistered examName
-                rgSheetSubmittorCaption :: CryptoUUIDSheet -> Widget
+              rgSheetSubmittorCaption :: CryptoUUIDSheet -> Widget
-                rgSheetSubmittorCaption cID = do
+              rgSheetSubmittorCaption cID = do
-                  sId <- decrypt cID
+                sId <- decrypt cID
-                  Sheet{..} <- liftHandler . runDBRead $ get404 sId
+                Sheet{..} <- liftHandler . runDBRead $ get404 sId
-                  i18n $ MsgRGSheetSubmittor sheetName
+                i18n $ MsgRGSheetSubmittor sheetName
-            $(widgetFile "widgets/communication/recipientLayout")
+          $(widgetFile "widgets/communication/recipientLayout")
-          miDelete :: Map (BoundedPosition RecipientCategory, ListPosition) (Either UserEmail UserId) -> (BoundedPosition RecipientCategory, ListPosition) -> MaybeT (MForm Handler) (Map (BoundedPosition RecipientCategory, ListPosition) (BoundedPosition RecipientCategory, ListPosition))
+        miDelete :: Map (BoundedPosition RecipientCategory, ListPosition) (Either UserEmail UserId) -> (BoundedPosition RecipientCategory, ListPosition) -> MaybeT (MForm Handler) (Map (BoundedPosition RecipientCategory, ListPosition) (BoundedPosition RecipientCategory, ListPosition))
-          -- miDelete liveliness@(MapLiveliness lMap) (BoundedPosition RecipientCustom, delPos) = mappend (Map.fromSet id . Set.filter (\(BoundedPosition c, _) -> c /= RecipientCustom) $ review liveCoords liveliness) . fmap (BoundedPosition RecipientCustom, ) . Map.mapKeysMonotonic (BoundedPosition RecipientCustom, ) <$> miDeleteList (lMap ! BoundedPosition RecipientCustom) delPos
+        -- miDelete liveliness@(MapLiveliness lMap) (BoundedPosition RecipientCustom, delPos) = mappend (Map.fromSet id . Set.filter (\(BoundedPosition c, _) -> c /= RecipientCustom) $ review liveCoords liveliness) . fmap (BoundedPosition RecipientCustom, ) . Map.mapKeysMonotonic (BoundedPosition RecipientCustom, ) <$> miDeleteList (lMap ! BoundedPosition RecipientCustom) delPos
-          miDelete _ _ = mzero
+        miDelete _ _ = mzero
-          miIdent :: Text
+        miIdent :: Text
-          miIdent = "recipients"
+        miIdent = "recipients"
-          postProcess :: Map (BoundedPosition RecipientCategory, ListPosition) (Either UserEmail UserId, Bool) -> Set (Either UserEmail UserId)
+        postProcess :: Map (BoundedPosition RecipientCategory, ListPosition) (Either UserEmail UserId, Bool) -> Set (Either UserEmail UserId)
-          postProcess = Set.fromList . map fst . filter snd . Map.elems
+        postProcess = Set.fromList . map fst . filter snd . Map.elems
 
   recipientsListMsg <- messageI Info MsgCommRecipientsList
   
@@ -221,13 +254,15 @@ commR CommunicationRoute{..} =  do
         , fieldMaxFileSize = Nothing, fieldMaxCumulativeSize = attachmentsMaxSize
         , fieldAllEmptyOk = True
         }
+
   ((commRes,commWdgt),commEncoding) <- runFormPost . identifyForm FIDCommunication . withButtonForm' universeF . renderAForm FormStandard $ Communication
     <$> recipientAForm
     <*  aformMessage recipientsListMsg
     <*> ( CommunicationContent
             <$> aopt textField (fslI MsgCommSubject & addAttr "uw-enter-as-tab" "") Nothing
             <*> (markupOutput <$> areq htmlField (fslI MsgCommBody) Nothing)
-            <*> fmap fold (aopt (convertFieldM (runConduit . (.| C.foldMap Set.singleton)) yieldMany attachmentField) (fslI MsgCommAttachments & setTooltip MsgCommAttachmentsTip) Nothing)
+            <*> fmap fold (aopt (convertFieldM (runConduit . (.| C.foldMap Set.singleton)) yieldMany attachmentField) 
+                              (fslI MsgCommAttachments & setTooltip MsgCommAttachmentsTip) Nothing)
         )    
   formResult commRes $ \case
     (comm, BtnCommunicationSend) -> do
@@ -245,7 +280,7 @@ commR CommunicationRoute{..} =  do
         , formSubmit   = FormNoSubmit
         }  
   siteLayoutMsg crHeading $ do
-    setTitleI crHeading
+    setTitleI crTitle
     let commTestTip = $(i18nWidgetFile "comm-test-tip")
     [whamlet|
        $newline never

src/Handler/Utils/Company.hs

@@ -40,14 +40,14 @@ upsertCompany cName cAddr =
       Nothing  -> do
         let cShort  = companyShorthandFromName cName            
         cShort' <- findShort cName' $ CI.mk cShort
-        let compy  = Company cName' cShort' 0 False cAddr -- TODO: Fix this once AVS CR3 SCF-165 is implemented
+        let compy  = Company cName' cShort' 0 False cAddr Nothing -- TODO: Fix this once AVS CR3 SCF-165 is implemented
         either entityKey id <$> insertBy compy
   where 
     findShort :: CompanyName -> CompanyShorthand -> DB CompanyShorthand    
     findShort fna fsh = aux 0
       where 
         aux n = let fsh' = if n==0 then fsh else fsh <> CI.mk (tshow n) in
-                checkUnique (Company fna fsh' 0 False Nothing) >>= \case
+                checkUnique (Company fna fsh' 0 False Nothing Nothing) >>= \case
                   Nothing -> return fsh'
                   _other  -> aux (n+1)
 

src/Handler/Utils/Concurrent.hs

@@ -0,0 +1,38 @@
+-- SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
+--
+-- SPDX-License-Identifier: AGPL-3.0-or-later
+
+module Handler.Utils.Concurrent
+  ( module Handler.Utils.Concurrent  
+  ) where
+
+-- NOTE: use `retrySTM` and `checkSTM` instead of `retry` or `check`
+
+import Import
+import UnliftIO.Concurrent as Handler.Utils.Concurrent hiding (yield)
+
+
+
+-- | Run a handler action until it finishes or if it exceeds a given number of microseconds via `registerDelay`
+timeoutHandler :: Int -> HandlerFor site a -> HandlerFor site (Maybe a)
+timeoutHandler maxWait act = do
+    innerAct <- handlerToIO
+    (hresult, tid) <- liftIO $ do
+      hresult <- newTVarIO Nothing
+      tid <- forkIO $ do
+        res <- innerAct act
+        atomically $ writeTVar hresult $ Just res
+      return (hresult, tid)
+    res <- liftIO $ do
+      flag <- registerDelay maxWait
+      atomically $ do
+        out <- readTVar flag
+        res <- readTVar hresult
+        checkSTM $ out || isJust res
+        return res
+    case res of
+      Nothing -> liftIO $ do
+        killThread tid
+        readTVarIO hresult     -- read once more after kill to ensure that any result is noticed
+      _ -> return res
+

src/Handler/Utils/DateTime.hs

@@ -93,8 +93,8 @@ toMorning = toTimeOfDay 6 0 0
 toTimeOfDay :: Int -> Int -> Pico -> Day -> UTCTime
 toTimeOfDay todHour todMin todSec d = localTimeToUTCTZ appTZ $ LocalTime d TimeOfDay{..}
 
-addHours :: Integer -> UTCTime -> UTCTime
+addHours :: Integral n => n -> UTCTime -> UTCTime
-addHours = addUTCTime . secondsToNominalDiffTime . fromInteger . (* 3600)
+addHours = addUTCTime . secondsToNominalDiffTime . fromIntegral . (* 3600)
 
 instance HasLocalTime UTCTime where
   toLocalTime = utcToLocalTime

src/Handler/Utils/Form.hs

@@ -1498,7 +1498,20 @@ boolField mkNone = radioGroupField mkNone $ do
       _other -> Nothing
     }
 
-
+-- | like `boolField` but with custom labels
+boolFieldCustom :: (MonadHandler m, HandlerSite m ~ UniWorX)
+  => SomeMessage UniWorX -> SomeMessage UniWorX -> Maybe (SomeMessage UniWorX) -> Field m Bool
+boolFieldCustom mkTrue mkFalse mkNone  = radioGroupField mkNone $ do
+  mr <- getMessageRender
+  return OptionList
+    { olOptions = [ Option (mr mkFalse) False "false"
+                  , Option (mr mkTrue)  True  "true"
+                  ]
+    , olReadExternal = \case
+      "false" -> Just False
+      "true"  -> Just True
+      _other  -> Nothing
+    }
 
 sectionedFuncForm  :: forall f k v m sec.
                       ( TraversableWithIndex k f

src/Handler/Utils/LMS.hs

@@ -19,8 +19,6 @@ module Handler.Utils.LMS
   , csvLmsLock
   , csvLmsResult
   , csvFilenameLmsUser
-  , csvFilenameLmsUserlist
-  , csvFilenameLmsResult
   , csvFilenameLmsReport
   , lmsDeletionDate
   , lmsUserToDelete     , _lmsUserToDelete      , lmsUserToDeleteExpr
@@ -109,14 +107,6 @@ csvLmsResult = fromString "result" -- LmsStatus: 0=Versuche aufgebraucht, 1=Offe
 csvFilenameLmsUser :: MonadHandler m => QualificationShorthand -> m Text
 csvFilenameLmsUser = makeLmsFilename "user"
 
--- | 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 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"

src/Handler/Utils/Mail.hs

@@ -4,7 +4,8 @@
 
 module Handler.Utils.Mail
   ( addRecipientsDB
-  , userAddress, userAddressFrom
+  , userAddress, userAddress'
+  , userAddressFrom
   , userMailT, userMailTdirect
   , addFileDB
   , addHtmlMarkdownAlternatives
@@ -52,6 +53,11 @@ userAddress :: User -> Address
 userAddress User{userEmail, userDisplayEmail, userDisplayName}
   = Address (Just userDisplayName) $ CI.original $ pickValidEmail userDisplayEmail userEmail
 
+userAddress' :: UserEmail -> UserEmail -> UserDisplayName -> Address
+-- Like userAddress', but does not require a complete entity
+userAddress' userEmail  userDisplayEmail userDisplayName
+  = Address (Just userDisplayName) $ CI.original $ pickValidEmail userDisplayEmail userEmail
+
 userAddressError :: (MonadHandler m, HandlerSite m ~ UniWorX) => User -> m (Bool, Address)
 userAddressError User{userEmail, userDisplayEmail, userDisplayName} 
   | Just okEmail <- pickValidEmail' userDisplayEmail userEmail = pure (True, Address (Just userDisplayName) $ CI.original okEmail)

src/Handler/Utils/Qualification.hs

@@ -24,10 +24,10 @@ statusQualificationBlock s = statusHtml (bool Error Success s) $ iconQualificati
 
 
 -- needs refactoring, probbably no longer helpful
-mkQualificationBlocked :: QualificationBlockStandardReason -> UTCTime -> QualificationUserId -> QualificationUserBlock
+mkQualificationBlocked :: QualificationStandardReason -> UTCTime -> QualificationUserId -> QualificationUserBlock
 mkQualificationBlocked reason qualificationUserBlockFrom qualificationUserBlockQualificationUser = QualificationUserBlock{..}
    where 
-     qualificationUserBlockReason = qualificationBlockedReasonText reason    
+     qualificationUserBlockReason  = tshow reason    
      qualificationUserBlockUnblock = False 
      qualificationUserBlockBlocker = Nothing
 
@@ -158,6 +158,7 @@ upsertQualificationUser  qualificationUserQualification startTime qualificationU
     , transactionUser                         = qualificationUserUser
     , transactionQualificationValidUntil      = qualificationUserValidUntil
     , transactionQualificationScheduleRenewal = mbScheduleRenewal
+    , transactionNote                         = canonical $ Just reason
     }
 
 -- | Renew an existing valid qualification, ignoring all blocks otherwise
@@ -174,8 +175,8 @@ renewValidQualificationUsers ::
   , HasAppSettings (HandlerSite m)
   , MonadHandler m
   , MonadCatch m  
-  ) => QualificationId -> Maybe UTCTime -> [UserId] -> ReaderT (YesodPersistBackend (HandlerSite m)) m Int
+  ) => QualificationId -> Maybe QualificationChangeReason -> Maybe UTCTime -> [UserId] -> ReaderT (YesodPersistBackend (HandlerSite m)) m Int
-renewValidQualificationUsers qid renewalTime uids =
+renewValidQualificationUsers qid reason 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
@@ -199,6 +200,7 @@ renewValidQualificationUsers qid renewalTime uids =
           , transactionUser                         = qualificationUserUser
           , transactionQualificationValidUntil      = newValidTo
           , transactionQualificationScheduleRenewal = Nothing
+          , transactionNote                         = qualificationChangeReasonText <$> reason
           }
       return $ length quEnts
     _ -> return (-1) -- qualificationId not found, isNothing qualificationValidDuration, etc.
@@ -217,8 +219,8 @@ qualificationUserBlocking ::
   , MonadHandler m
   , MonadCatch m
   , Num n
-  ) => QualificationId -> [UserId] -> Bool -> Maybe UTCTime -> QualificationBlockReason -> Bool -> ReaderT (YesodPersistBackend (HandlerSite m)) m n
+  ) => QualificationId -> [UserId] -> Bool -> Maybe UTCTime -> QualificationChangeReason -> Bool -> ReaderT (YesodPersistBackend (HandlerSite m)) m n
-qualificationUserBlocking qid uids unblock mbBlockTime (qualificationBlockReasonText -> reason) notify = do
+qualificationUserBlocking qid uids unblock mbBlockTime (qualificationChangeReasonText -> reason) notify = do
   $logInfoS "BLOCK" $ Text.intercalate " - " [tshow qid, tshow uids, tshow unblock, tshow mbBlockTime, tshow reason, tshow notify]
   authUsr <- liftHandler maybeAuthId
   now <- liftIO getCurrentTime
@@ -269,8 +271,8 @@ qualificationUserUnblockByReason ::
   , MonadHandler m
   , MonadCatch m
   , Num n
-  ) => QualificationId -> [UserId] -> Maybe UTCTime -> QualificationBlockReason -> QualificationBlockReason -> Bool -> ReaderT (YesodPersistBackend (HandlerSite m)) m n
+  ) => QualificationId -> [UserId] -> Maybe UTCTime -> QualificationChangeReason -> QualificationChangeReason -> Bool -> ReaderT (YesodPersistBackend (HandlerSite m)) m n
-qualificationUserUnblockByReason qid uids mbUnblockTime (qualificationBlockReasonText -> reason) undo_reason notify = do
+qualificationUserUnblockByReason qid uids mbUnblockTime (qualificationChangeReasonText -> reason) undo_reason notify = do
   cutoff <- maybe (liftIO getCurrentTime) return mbUnblockTime 
   toUnblock <- E.select $ do
     quser <- E.from $ E.table @QualificationUser

src/Handler/Utils/StudyFeatures.hs

@@ -137,7 +137,7 @@ cacheStudyFeatureRelevance fFilter = do
         E.on E.true
         E.where_ $ fFilter studyFeatures
         E.where_ $ isRelevantStudyFeature (E.val now) TermId term studyFeatures
-        return $ RelevantStudyFeatures E.<# (term E.^. TermId) E.<&> (studyFeatures E.^. StudyFeaturesId)
+        E.distinct $ return $ RelevantStudyFeatures E.<# (term E.^. TermId) E.<&> (studyFeatures E.^. StudyFeaturesId)
     )
     ( \_current _excluded -> [] )
 

src/Handler/Utils/Table/Cells.hs

@@ -29,6 +29,9 @@ type CourseLink = (TermId, SchoolId, CourseShorthand) -- TODO: Refactor with Wit
 spacerCell :: IsDBTable m a => DBCell m a
 spacerCell = cell [whamlet| |]
 
+semicolonCell :: IsDBTable m a => DBCell m a
+semicolonCell = cell [whamlet|; |]
+
 tellCell :: IsDBTable m a => a -> DBCell m a -> DBCell m a
 tellCell = flip mappend . writerCell . tell
 
@@ -91,6 +94,7 @@ guardAuthCell mkParams = over cellContents $ \act -> do
 ---------------------
 -- Icon cells
 
+-- to be used with icons directly, for results of `icon`, use either `wgtCell` or `iconFixedCell`
 iconCell :: IsDBTable m a => Icon -> DBCell m a
 iconCell = cell . toWidget . icon
 
@@ -154,8 +158,8 @@ modalCell content = cell $ modal (toWidget $ hasComment True) (Right $ toWidget
 -- | 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
+  | length content > 32 = modalCell  content
-  | otherwise           = textCell  content
+  | otherwise           = stringCell content
 
 markupCellLargeModal :: IsDBTable m a => StoredMarkup -> DBCell m a
 markupCellLargeModal mup
@@ -214,7 +218,7 @@ cellHasUserLink toLink user =
       nWdgt = nameWidget (userEntity ^. _entityVal . _userDisplayName) (userEntity ^.  _entityVal . _userSurname)
   in  anchorCellM (toLink <$> encrypt uid) nWdgt
 
--- | like `cellHasUserLink` but opens the user in a modal instead
+-- | like `cellHasUserLink` but opens the user in a modal instead; link is only displayed if the user has sufficient rights
 cellHasUserModal :: (IsDBTable m c, HasEntity u User) => (CryptoUUIDUser -> Route UniWorX) -> u -> DBCell m c
 cellHasUserModal toLink user = 
   let userEntity = user ^. hasEntityUser
@@ -222,14 +226,58 @@ cellHasUserModal toLink user =
       nWdgt = nameWidget (userEntity ^. _entityVal . _userDisplayName) (userEntity ^.  _entityVal . _userSurname)
       lWdgt = do 
                 uuid <- liftHandler $ encrypt uid
-                modal nWdgt (Left $ SomeRoute $ toLink uuid)
+                modalAccess nWdgt nWdgt False $ toLink uuid                
+  in cell lWdgt
+
+-- | like `cellHasUserModal` but but always display link without prior access rights checks
+cellHasUserModalAdmin :: (IsDBTable m c, HasEntity u User) => (CryptoUUIDUser -> Route UniWorX) -> u -> DBCell m c
+cellHasUserModalAdmin toLink user = 
+  let userEntity = user ^. hasEntityUser
+      uid   = userEntity ^. _entityKey
+      nWdgt = nameWidget (userEntity ^. _entityVal . _userDisplayName) (userEntity ^.  _entityVal . _userSurname)
+      lWdgt = do 
+                uuid <- liftHandler $ encrypt uid
+                modal nWdgt $ Left $ SomeRoute $ toLink uuid                
+  in cell lWdgt
+
+-- | like `cellHasUserModal` but with fixed route and showing an edit icon instead; link is only displayed if the user has sufficient rights
+cellEditUserModal :: (IsDBTable m c, HasEntity u User) => u -> DBCell m c
+cellEditUserModal user = 
+  let userEntity = user ^. hasEntityUser
+      uid   = userEntity ^. _entityKey
+      nWdgt = toWidget $ icon IconUserEdit      
+      lWdgt = do 
+                uuid <- liftHandler $ encrypt uid
+                modalAccess mempty nWdgt True $ ForProfileR uuid
+  in cell lWdgt
+
+-- | like `cellEditUserModal` but always displays the link without prior access rights checks
+cellEditUserModalAdmin :: (IsDBTable m c, HasEntity u User) => u -> DBCell m c
+cellEditUserModalAdmin user = 
+  let userEntity = user ^. hasEntityUser
+      uid   = userEntity ^. _entityKey
+      nWdgt = toWidget $ icon IconUserEdit      
+      lWdgt = do 
+                uuid <- liftHandler $ encrypt uid
+                modal nWdgt (Left $ SomeRoute $ ForProfileR uuid)
   in cell lWdgt
 
 cellHasMatrikelnummer :: (IsDBTable m a, HasUser u) => u -> DBCell m a
 cellHasMatrikelnummer = maybe mempty textCell . view _userMatrikelnummer
 
-cellHasMatrikelnummerLinked :: (IsDBTable m a, HasEntity u User) => u -> DBCell m a
+cellHasMatrikelnummerLinked :: (IsDBTable m a, HasEntity u User) => Bool -> u -> DBCell m a
-cellHasMatrikelnummerLinked usr 
+cellHasMatrikelnummerLinked isAdmin usr 
+    | Just matNr <- usrEntity ^. _userMatrikelnummer = cell $ do 
+        uuid <- liftHandler $ encrypt $ usrEntity ^. _entityKey
+        if isAdmin
+          then modal (text2widget matNr) (Left $ SomeRoute $ AdminAvsUserR uuid)
+          else modalAccess mempty (text2widget matNr) False (AdminAvsUserR uuid)
+    | otherwise = mempty
+  where 
+    usrEntity = usr ^. hasEntityUser
+
+cellHasMatrikelnummerLinkedAdmin :: (IsDBTable m a, HasEntity u User) => u -> DBCell m a
+cellHasMatrikelnummerLinkedAdmin usr 
     | Just matNr <- usrEntity ^. _userMatrikelnummer = cell $ do 
         uuid <- liftHandler $ encrypt $ usrEntity ^. _entityKey
         modal (text2widget matNr) (Left $ SomeRoute $ AdminAvsUserR uuid)        
@@ -307,6 +355,16 @@ courseCell Course{..} = anchorCell link name `mappend` desc
                 ^{modal "Beschreibung" (Right $ toWidget descr)}
               |]
 
+companyCell :: IsDBTable m a => CompanyShorthand -> CompanyName -> Bool -> DBCell m a
+companyCell cid cname isSupervisor = anchorCell link name
+  where
+    link = FirmUsersR cid
+    corg = ciOriginal cname
+    name 
+      | isSupervisor = text2markup (corg <> " ") <> icon IconSupervisor
+      | otherwise    = text2markup  corg
+
+
 qualificationCell :: (IsDBTable m c, HasQualification a) => a -> DBCell m c
 qualificationCell (view hasQualification -> Qualification{..}) = anchorCell link name
   where
@@ -340,7 +398,7 @@ 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)
+      let modalWgt = modalAccess dateWgt dateWgt False $ toLink uuid
       headWgt <> modalWgt
   where       
     dateWgt = formatTimeW SelFormatDate (qu ^. hasQualificationUser . _qualificationUserValidUntil)
@@ -361,7 +419,8 @@ qualificationValidReasonCell' mbToLink showReason d qb qu = ic <> foldMap blc qb
     dc tstamp 
       | Just toLink <- mbToLink = cell $ do
           uuid <- liftHandler $ encrypt uid
-          modal (formatTimeW SelFormatDate tstamp) (Left $ SomeRoute $ toLink uuid)        
+          let dWgt = formatTimeW SelFormatDate tstamp
+          modalAccess dWgt dWgt False $ toLink uuid
         --  anchorCellM (toLink <$> encrypt uid) 
       | otherwise = dateCell tstamp
     uid = qu ^. hasQualificationUser . _qualificationUserUser
@@ -379,7 +438,8 @@ qualificationValidReasonCell'' mbToLink showReason d qb qu extValid = ic <> icEr
     dc tstamp 
       | Just toLink <- mbToLink = cell $ do
           uuid <- liftHandler $ encrypt uid
-          modal (formatTimeW SelFormatDate tstamp) (Left $ SomeRoute $ toLink uuid)        
+          let dWgt = formatTimeW SelFormatDate tstamp
+          modalAccess dWgt dWgt False $ toLink uuid
         --  anchorCellM (toLink <$> encrypt uid) 
       | otherwise = dateCell tstamp
     uid = qu ^. hasQualificationUser . _qualificationUserUser
@@ -439,7 +499,14 @@ avsPersonNoCell = numCell . view _userAvsNoPerson
 avsPersonNoLinkedCell :: (IsDBTable m c, HasUserAvs a) => a -> DBCell m c
 avsPersonNoLinkedCell a = cell $ do
   uuid <- liftHandler $ encrypt $ a ^. _userAvsUser
-  modal (toWgt $ toMessage $ a ^. _userAvsNoPerson) (Left $ SomeRoute $ AdminAvsUserR uuid)
+  let nWgt = toWgt $ toMessage $ a ^. _userAvsNoPerson
+  modalAccess nWgt nWgt False $ AdminAvsUserR uuid
+
+avsPersonNoLinkedCellAdmin :: (IsDBTable m c, HasUserAvs a) => a -> DBCell m c
+avsPersonNoLinkedCellAdmin a = cell $ do
+  uuid <- liftHandler $ encrypt $ a ^. _userAvsUser
+  let nWgt = toWgt $ toMessage $ a ^. _userAvsNoPerson
+  modal nWgt (Left $ SomeRoute $ AdminAvsUserR uuid)
 
 avsPersonCardCell :: (IsDBTable m c) => Set AvsDataPersonCard -> DBCell m c
 avsPersonCardCell cards = wgtCell 

src/Handler/Utils/Table/Columns.hs

@@ -336,6 +336,10 @@ colUserNameLinkHdr colHeader userLink = sortable (Just "user-name") (i18nCell co
 colUserNameModalHdr :: (IsDBTable m c, HasEntity a User, RenderMessage UniWorX msg) => msg -> (CryptoUUIDUser -> Route UniWorX) -> Colonnade Sortable a (DBCell m c)
 colUserNameModalHdr colHeader userLink = sortable (Just "user-name") (i18nCell colHeader) (cellHasUserModal userLink)
 
+-- | like `colUserNameModalHdr` but without checking access rights before displaying the link (no risk, but non-admins may see links that are unusable for them)
+colUserNameModalHdrAdmin :: (IsDBTable m c, HasEntity a User, RenderMessage UniWorX msg) => msg -> (CryptoUUIDUser -> Route UniWorX) -> Colonnade Sortable a (DBCell m c)
+colUserNameModalHdrAdmin colHeader userLink = sortable (Just "user-name") (i18nCell colHeader) (cellHasUserModalAdmin userLink)
+
 -- | Intended to work with @nameWidget@, showing highlighter Surname within Displayname
 sortUserName :: IsString a => (t -> E.SqlExpr (Entity User)) -> (a, SortColumn t r')
 sortUserName = ("user-name",) . sortUserNameBare
@@ -442,8 +446,8 @@ fltrUserMatriculationUI :: DBFilterUI
 fltrUserMatriculationUI mPrev = prismAForm (singletonFilter "user-matriculation") mPrev $ aopt textField (fslI MsgTableUserMatriculation)
 
 
-colUserMatriclenr ::  (IsDBTable m c, HasEntity a User) => Colonnade Sortable a (DBCell m c)
+colUserMatriclenr ::  (IsDBTable m c, HasEntity a User) => Bool -> Colonnade Sortable a (DBCell m c)
-colUserMatriclenr = sortable (Just "user-matriclenumber") (i18nCell MsgTableMatrikelNr) cellHasMatrikelnummerLinked
+colUserMatriclenr isAdmin = sortable (Just "user-matriclenumber") (i18nCell MsgTableMatrikelNr) $ cellHasMatrikelnummerLinked isAdmin
 
 sortUserMatriclenr :: IsString d => (t -> E.SqlExpr (Entity User)) -> (d, SortColumn t r')
 sortUserMatriclenr queryUser = ("user-matriclenumber", SortColumn $ queryUser >>> (E.^. UserMatrikelnummer))
@@ -753,6 +757,49 @@ sortUserCompany queryUser = ( "user-company"
                 return (comp E.^. CompanyName)
             ))
 
+-- | Search companies by name or shorthand
+fltrCompanyName :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d)
+   => (a -> E.SqlExpr (Entity Company))
+   -> (d, FilterColumn t fs)
+fltrCompanyName query = ( "company-name", FilterColumn $ anyFilter
+    [ mkContainsFilterWithComma CI.mk $ query >>> (E.^. CompanyName)
+    , mkContainsFilterWithComma CI.mk $ query >>> (E.^. CompanyShorthand)
+    -- , mkExactFilterWithComma    id    $ query >>> (E.num2text . (E.^. CompanyAvsId))
+    ]
+  )
+
+fltrCompanyNameUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
+fltrCompanyNameUI = fltrCompanyNameNrHdrUI MsgTableCompany
+
+fltrCompanyNameHdrUI :: (RenderMessage UniWorX msg) => msg -> Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
+fltrCompanyNameHdrUI msg mPrev =
+  prismAForm (singletonFilter "company-name") mPrev $ aopt textField (fslI msg & setTooltip MsgTableFilterCommaNameNr)
+
+
+
+fltrCompanyNameNr :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d)
+   => (a -> E.SqlExpr (Entity Company))
+   -> (d, FilterColumn t fs)
+fltrCompanyNameNr query = ("company-name-number", FilterColumn $ \needle (setFoldMap commaSeparatedText -> criterias) ->
+    let numCrits    = setMapMaybe readMay criterias
+        fltrCName   = mkContainsFilterWith CI.mk (query >>> (E.^. CompanyName))      needle criterias
+        fltrCShort  = mkContainsFilterWith CI.mk (query >>> (E.^. CompanyShorthand)) needle criterias
+        fltrCno     = mkExactFilter              (query >>> (E.^. CompanyAvsId))     needle numCrits       
+    in if null numCrits
+        then fltrCName E.||. fltrCShort
+        else fltrCName E.||. fltrCShort E.||. fltrCno      
+    )
+  where 
+    setFoldMap :: (Text -> Set.Set Text) -> Set.Set Text -> Set.Set Text
+    setFoldMap = foldMap
+
+fltrCompanyNameNrUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
+fltrCompanyNameNrUI = fltrCompanyNameNrHdrUI MsgTableCompanyFilter
+
+fltrCompanyNameNrHdrUI :: (RenderMessage UniWorX msg) => msg -> Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
+fltrCompanyNameNrHdrUI msg mPrev =
+  prismAForm (singletonFilter "company-name-number") mPrev $ aopt textField (fslI msg & setTooltip MsgTableFilterCommaNameNr)
+
 
 ----------------------------
 -- Colonnade manipulation --

src/Handler/Utils/Table/Pagination.hs

@@ -1,10 +1,20 @@
--- SPDX-FileCopyrightText: 2022 Felix Hamann <felix.hamann@campus.lmu.de>,Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
+-- SPDX-FileCopyrightText: 2022-23 Felix Hamann <felix.hamann@campus.lmu.de>,Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
 {-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
 
+
+{- FOP - Frequently occurring problems using dbTable:
+
+  - When changing a dbTable to a form, eg. using `dbSelect` then change the colonnade defnition from `dbColonnade` to `formColonnade`!
+    Both functions are equal to id, but the types are quite different.
+
+  - Don't mix up the row type alias traditionally ending with ...Data and the Action-Result-Type also ending with ...Data
+
+-}
+
 module Handler.Utils.Table.Pagination
   ( module Handler.Utils.Table.Pagination.Types
   , dbFilterKey
@@ -27,7 +37,7 @@ module Handler.Utils.Table.Pagination
   , dbtProjFilteredPostId, dbtProjFilteredPostSimple
   , noCsvEncode, simpleCsvEncode, simpleCsvEncodeM
   , withCsvExtraRep
-  , singletonFilter
+  , singletonFilter, multiFilter
   , DBParams(..)
   , cellAttrs, cellContents
   , addCellClass
@@ -637,6 +647,13 @@ singletonFilter key = prism' fromInner (fmap Just . fromOuter)
       fromInner = maybe Map.empty $ Map.singleton key . pure
       fromOuter = Map.lookup key >=> listToMaybe
 
+multiFilter :: Ord k => k -> Prism' (Map k [v]) (Maybe [v])
+-- ^ for use with @prismAForm@
+multiFilter key = prism' fromInner fromOuter
+    where
+      -- prism' :: (Maybe [v] -> (Map k [v])) -> ((Map k [v]) -> Maybe (Maybe [v])) -> Prism' (Map k [v]) (Maybe [v])
+      fromInner = maybe Map.empty (Map.singleton key)
+      fromOuter = Just . Map.lookup key
   
 data DBTCsvEncode r' k' csv = forall exportData filename sheetName.
   ( ToNamedRecord csv, CsvColumnsExplained csv
@@ -752,7 +769,7 @@ dbtProjFilteredPostId :: forall fs r r'.
                       => ReaderT (DBTProjCtx fs r) (MaybeT (ReaderT SqlBackend (HandlerFor UniWorX))) r'
 dbtProjFilteredPostId = withFilteredPost dbtProjId'
 
--- | Kombination aus `dbtProjFilteredPostId` und `dbtProjSimple`, d.h. Ergeniszeilen in Haskell transformieren und filtern
+-- | Kombination aus `dbtProjFilteredPostId` und `dbtProjSimple`, d.h. Ergebniszeilen in Haskell transformieren und filtern
 dbtProjFilteredPostSimple :: forall fs r r' r''.
                              ( fs ~ DBTProjFilterPost r', DBRow r'' ~ r' )
                           => (r -> DB r'')
@@ -1654,10 +1671,12 @@ widgetColonnade :: Colonnade h r (DBCell (HandlerFor UniWorX) x)
                 -> Colonnade h r (DBCell (HandlerFor UniWorX) x)
 widgetColonnade = id
 
+-- | force the column list type for tables that cotain forms, especially those constructed with dbSelect, avoids explicit type signatures
 formColonnade :: Colonnade h r (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) (FormResult a))
               -> Colonnade h r (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) (FormResult a))
 formColonnade = id
 
+-- | force the column list type for simple tables that do not contain forms, and especially no dbSelect, avoids explicit type signatures
 dbColonnade :: Colonnade h r (DBCell DB x)
             -> Colonnade h r (DBCell DB x)
 dbColonnade = id
@@ -1692,9 +1711,11 @@ cell wgt = dbCell # ([], return wgt)
 wgtCell :: (IsDBTable m a, ToWidget UniWorX wgt) => wgt -> DBCell m a
 wgtCell = cell . toWidget
 
-textCell, stringCell :: (MonoFoldable msg, Element msg ~ Char, IsDBTable m a) => msg -> DBCell m a
+textCell :: (IsDBTable m a) => Text -> DBCell m a
-textCell = cell . toWidget . (pack :: String -> Text) . otoList
+textCell = wgtCell
-stringCell = textCell
+
+stringCell :: (MonoFoldable msg, Element msg ~ Char, IsDBTable m a) => msg -> DBCell m a
+stringCell = wgtCell . (pack :: String -> Text) . otoList
 
 i18nCell :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a
 i18nCell msg = cell $ do
@@ -1704,6 +1725,7 @@ i18nCell msg = cell $ do
 cellTooltip :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a -> DBCell m a
 cellTooltip = cellTooltipIcon Nothing
 
+-- note that you can also use `cellTooltip` with `SomeMessages`, which uses ' ' for separation only
 cellTooltips :: (RenderMessage UniWorX msg, IsDBTable m a) => [msg] -> DBCell m a -> DBCell m a
 cellTooltips msgs = cellTooltipWgt Nothing [whamlet|
   $forall msg <- msgs

src/Handler/Utils/Users.hs

@@ -1,7 +1,9 @@
--- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
+-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
+{-# LANGUAGE TypeApplications #-}
+
 -- NOTE: Also see Handler.Utils.Profile for similar utilities
 module Handler.Utils.Users
   ( computeUserAuthenticationDigest
@@ -17,7 +19,7 @@ module Handler.Utils.Users
   , getEmailAddress
   , getPostalAddress, getPostalPreferenceAndAddress
   , abbrvName
-  , getReceivers
+  , getReceivers, getReceiversFor
   , getSupervisees
   ) where
 
@@ -38,7 +40,9 @@ import qualified Data.Set as Set
 -- import qualified Data.List as List
 import qualified Data.CaseInsensitive as CI
 
-import qualified Database.Esqueleto.Legacy as E
+import           Database.Esqueleto.Experimental ((:&)(..))
+import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
+import qualified Database.Esqueleto.Legacy as EL (on,from)
 import qualified Database.Esqueleto.PostgreSQL as E
 import qualified Database.Esqueleto.Utils as E
 
@@ -111,6 +115,14 @@ getReceivers uid = do
         then directResult
         else return (underling, receivers, uid `elem` (entityKey <$> receivers))
 
+-- | For user with mailTdirect, since this query will also return supervisors that have reroute supervisors themselves, who would then receive multiple duplicates
+getReceiversFor :: (MonoFoldable mono, UserId ~ Element mono) => mono -> DB [UserId]
+getReceiversFor uids = (E.unValue <<$>>) $ E.select $ E.distinct $ do
+  usr :& spr <- E.from $ E.table @User `E.leftJoin` E.table @UserSupervisor
+    `E.on` (\(usr :& spr) -> usr E.^. UserId E.=?. spr E.?. UserSupervisorUser E.&&. E.isTrue (spr E.?. UserSupervisorRerouteNotifications))
+  E.where_ $ usr E.^. UserId `E.in_` E.vals uids
+  return $ E.coalesceDefault [spr E.?. UserSupervisorSupervisor] $ usr E.^. UserId
+
 -- | return underlings for currently logged in user
 getSupervisees :: DB (Set UserId)
 getSupervisees = do 
@@ -177,7 +189,7 @@ guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria)
 
     containsAsSet x y = E.and . map (\y' -> x `E.hasInfix` E.val y') $ asWords y
 
-    toSql user pl = bool id E.not_ (is _PLNegated pl) $ case pl ^. _plVar of
+    toSql user pl = bool id E.not__ (is _PLNegated pl) $ case pl ^. _plVar of
       GuessUserMatrikelnummer         userMatriculation' -> user E.^. UserMatrikelnummer  E.==.          E.val (Just userMatriculation')
       GuessUserEduPersonPrincipalName userEPPN'          -> user E.^. UserLdapPrimaryKey  E.==.          E.val (Just userEPPN')
       GuessUserDisplayName            userDisplayName'   -> user E.^. UserDisplayName    `containsAsSet` userDisplayName'
@@ -185,7 +197,7 @@ guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria)
       GuessUserFirstName              userFirstName'     -> user E.^. UserFirstName      `containsAsSet` userFirstName'
 
     go didLdap = do
-      let retrieveUsers = E.select . E.from $ \user -> do
+      let retrieveUsers = E.select . EL.from $ \user -> do
             E.where_ . E.or $ map (E.and . map (toSql user)) criteria
             when (is _Just mQueryLimit) $ (E.limit . fromJust) mQueryLimit
             return user
@@ -307,7 +319,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
 
   E.insertSelectWithConflict
     UniqueCourseFavourite
-    (E.from $ \courseFavourite -> do
+    (EL.from $ \courseFavourite -> do
         E.where_ $ courseFavourite E.^. CourseFavouriteUser E.==. E.val oldUserId
         return $ CourseFavourite
           E.<#  E.val newUserId
@@ -320,7 +332,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
 
   E.insertSelectWithConflict
     UniqueCourseNoFavourite
-    (E.from $ \courseNoFavourite -> do
+    (EL.from $ \courseNoFavourite -> do
         E.where_ $ courseNoFavourite E.^. CourseNoFavouriteUser E.==. E.val oldUserId
         return $ CourseNoFavourite
           E.<#  E.val newUserId
@@ -331,7 +343,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
 
   E.insertSelectWithConflict
     UniqueExamOfficeField
-    (E.from $ \examOfficeField -> do
+    (EL.from $ \examOfficeField -> do
         E.where_ $ examOfficeField E.^. ExamOfficeFieldOffice E.==. E.val oldUserId
         return $ ExamOfficeField
           E.<#  E.val newUserId
@@ -343,7 +355,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
 
   E.insertSelectWithConflict
     UniqueExamOfficeUser
-    (E.from $ \examOfficeUser -> do
+    (EL.from $ \examOfficeUser -> do
         E.where_ $ examOfficeUser E.^. ExamOfficeUserOffice E.==. E.val oldUserId
         return $ ExamOfficeUser
           E.<#  E.val newUserId
@@ -353,7 +365,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
   deleteWhere [ ExamOfficeUserOffice ==. oldUserId ]
   E.insertSelectWithConflict
     UniqueExamOfficeUser
-    (E.from $ \examOfficeUser -> do
+    (EL.from $ \examOfficeUser -> do
         E.where_ $ examOfficeUser E.^. ExamOfficeUserUser E.==. E.val oldUserId
         return $ ExamOfficeUser
           E.<#  (examOfficeUser E.^. ExamOfficeUserOffice)
@@ -362,7 +374,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
     (\_current _excluded -> [])
   deleteWhere [ ExamOfficeUserUser ==. oldUserId ]
 
-  E.insertSelect . E.from $ \examOfficeResultSynced -> do
+  E.insertSelect . EL.from $ \examOfficeResultSynced -> do
     E.where_ $ examOfficeResultSynced E.^. ExamOfficeResultSyncedOffice E.==. E.val oldUserId
     return $ ExamOfficeResultSynced
           E.<#  (examOfficeResultSynced E.^. ExamOfficeResultSyncedSchool)
@@ -371,7 +383,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
           E.<&> (examOfficeResultSynced E.^. ExamOfficeResultSyncedTime)
   deleteWhere [ ExamOfficeResultSyncedOffice ==. oldUserId ]
 
-  E.insertSelect . E.from $ \examOfficeExternalResultSynced -> do
+  E.insertSelect . EL.from $ \examOfficeExternalResultSynced -> do
     E.where_ $ examOfficeExternalResultSynced E.^. ExamOfficeExternalResultSyncedOffice E.==. E.val oldUserId
     return $ ExamOfficeExternalResultSynced
           E.<#  (examOfficeExternalResultSynced E.^. ExamOfficeExternalResultSyncedSchool)
@@ -400,7 +412,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
 
   E.insertSelectWithConflict
     UniqueExternalExamStaff
-    (E.from $ \externalExamStaff -> do
+    (EL.from $ \externalExamStaff -> do
        E.where_ $ externalExamStaff E.^. ExternalExamStaffUser E.==. E.val oldUserId
        return $ ExternalExamStaff
          E.<#  E.val newUserId
@@ -415,7 +427,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
 
   E.insertSelectWithConflict
     UniqueSubmissionUser
-    (E.from $ \submissionUser -> do
+    (EL.from $ \submissionUser -> do
        E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val oldUserId
        return $ SubmissionUser
          E.<#  E.val newUserId
@@ -425,19 +437,19 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
   deleteWhere [ SubmissionUserUser ==. oldUserId ]
 
   do
-    collisions <- E.select . E.from $ \((submissionGroupUserA `E.InnerJoin` submissionGroupA) `E.InnerJoin` (submissionGroupUserB `E.InnerJoin` submissionGroupB)) -> do
+    collisions <- E.select . EL.from $ \((submissionGroupUserA `E.InnerJoin` submissionGroupA) `E.InnerJoin` (submissionGroupUserB `E.InnerJoin` submissionGroupB)) -> do
-      E.on $ submissionGroupB E.^. SubmissionGroupId E.==. submissionGroupUserB E.^. SubmissionGroupUserSubmissionGroup
+      EL.on $ submissionGroupB E.^. SubmissionGroupId E.==. submissionGroupUserB E.^. SubmissionGroupUserSubmissionGroup
-      E.on $ submissionGroupUserA E.^. SubmissionGroupUserSubmissionGroup E.!=. submissionGroupUserB E.^. SubmissionGroupUserSubmissionGroup
+      EL.on $ submissionGroupUserA E.^. SubmissionGroupUserSubmissionGroup E.!=. submissionGroupUserB E.^. SubmissionGroupUserSubmissionGroup
        E.&&. submissionGroupUserA E.^. SubmissionGroupUserUser E.==. E.val oldUserId
        E.&&. submissionGroupUserB E.^. SubmissionGroupUserUser E.==. E.val newUserId
-      E.on $ submissionGroupA E.^. SubmissionGroupId E.==. submissionGroupUserA E.^. SubmissionGroupUserSubmissionGroup
+      EL.on $ submissionGroupA E.^. SubmissionGroupId E.==. submissionGroupUserA E.^. SubmissionGroupUserSubmissionGroup
       E.where_ $ submissionGroupA E.^. SubmissionGroupCourse E.==. submissionGroupB E.^. SubmissionGroupCourse
       return (submissionGroupUserA, submissionGroupUserB)
     forM_ collisions $ \(submissionGroupUserA, submissionGroupUserB) ->
       tellWarning $ UserAssimilateSubmissionGroupUserMultiple submissionGroupUserA submissionGroupUserB
   E.insertSelectWithConflict
     UniqueSubmissionGroupUser
-    (E.from $ \submissionGroupUser -> do
+    (EL.from $ \submissionGroupUser -> do
        E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val oldUserId
        return $ SubmissionGroupUser
          E.<#  (submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup)
@@ -454,7 +466,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
 
   E.insertSelectWithConflict
     UniqueLecturer
-    (E.from $ \lecturer -> do
+    (EL.from $ \lecturer -> do
         E.where_ $ lecturer E.^. LecturerUser E.==. E.val oldUserId
         return $ Lecturer
           E.<#  E.val newUserId
@@ -466,7 +478,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
 
   E.insertSelectWithConflict
     UniqueParticipant
-    (E.from $ \courseParticipant -> do
+    (EL.from $ \courseParticipant -> do
         E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val oldUserId
         return $ CourseParticipant
           E.<#  (courseParticipant E.^. CourseParticipantCourse)
@@ -496,7 +508,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
 
   E.insertSelectWithConflict
     UniqueCourseUserExamOfficeOptOut
-    (E.from $ \examOfficeOptOut -> do
+    (EL.from $ \examOfficeOptOut -> do
         E.where_ $ examOfficeOptOut E.^. CourseUserExamOfficeOptOutUser E.==. E.val oldUserId
         return $ CourseUserExamOfficeOptOut
           E.<#  (examOfficeOptOut E.^. CourseUserExamOfficeOptOutCourse)
@@ -508,7 +520,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
 
   E.insertSelectWithConflict
     UniqueUserFunction
-    (E.from $ \userFunction -> do
+    (EL.from $ \userFunction -> do
         E.where_ $ userFunction E.^. UserFunctionUser E.==. E.val oldUserId
         return $ UserFunction
           E.<#  E.val newUserId
@@ -520,7 +532,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
 
   E.insertSelectWithConflict
     UniqueUserSystemFunction
-    (E.from $ \userSystemFunction -> do
+    (EL.from $ \userSystemFunction -> do
         E.where_ $ userSystemFunction E.^. UserSystemFunctionUser E.==. E.val oldUserId
         return $ UserSystemFunction
           E.<#  E.val newUserId
@@ -533,7 +545,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
 
   E.insertSelectWithConflict
     UniqueUserExamOffice
-    (E.from $ \userExamOffice -> do
+    (EL.from $ \userExamOffice -> do
         E.where_ $ userExamOffice E.^. UserExamOfficeUser E.==. E.val oldUserId
         return $ UserExamOffice
           E.<#  E.val newUserId
@@ -544,7 +556,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
 
   E.insertSelectWithConflict
     UniqueUserSchool
-    (E.from $ \userSchool -> do
+    (EL.from $ \userSchool -> do
         E.where_ $ userSchool E.^. UserSchoolUser E.==. E.val oldUserId
         return $ UserSchool
           E.<#  E.val newUserId
@@ -557,7 +569,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
   updateWhere [ UserGroupMemberUser ==. oldUserId, UserGroupMemberPrimary ==. Active ] [ UserGroupMemberUser =. newUserId ]
   E.insertSelectWithConflict
     UniqueUserGroupMember
-    (E.from $ \userGroupMember -> do
+    (EL.from $ \userGroupMember -> do
         E.where_ $ userGroupMember E.^. UserGroupMemberUser E.==. E.val oldUserId
         return $ UserGroupMember
           E.<#  (userGroupMember E.^. UserGroupMemberGroup)
@@ -568,8 +580,8 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
   deleteWhere [ UserGroupMemberUser ==. oldUserId ]
 
   do
-    collisions <- E.select . E.from $ \(examRegistrationA `E.InnerJoin` examRegistrationB) -> do
+    collisions <- E.select . EL.from $ \(examRegistrationA `E.InnerJoin` examRegistrationB) -> do
-      E.on $ examRegistrationA E.^. ExamRegistrationExam E.==. examRegistrationB E.^. ExamRegistrationExam
+      EL.on $ examRegistrationA E.^. ExamRegistrationExam E.==. examRegistrationB E.^. ExamRegistrationExam
        E.&&. examRegistrationA E.^. ExamRegistrationUser E.==. E.val oldUserId
        E.&&. examRegistrationB E.^. ExamRegistrationUser E.==. E.val newUserId
       E.where_ $ examRegistrationA E.^. ExamRegistrationOccurrence E.!=. examRegistrationB E.^. ExamRegistrationOccurrence
@@ -580,7 +592,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
       -> tellWarning $ UserAssimilateExamRegistrationDifferentOccurrence oldExamRegistration newExamRegistration
   E.insertSelectWithConflict
     UniqueExamRegistration
-    (E.from $ \examRegistration -> do
+    (EL.from $ \examRegistration -> do
         E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val oldUserId
         return $ ExamRegistration
           E.<#  (examRegistration E.^. ExamRegistrationExam)
@@ -592,8 +604,8 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
   deleteWhere [ ExamRegistrationUser ==. oldUserId ]
 
   do
-    collision <- E.selectMaybe . E.from $ \(examPartResultA `E.InnerJoin` examPartResultB) -> do
+    collision <- E.selectMaybe . EL.from $ \(examPartResultA `E.InnerJoin` examPartResultB) -> do
-      E.on $ examPartResultA E.^. ExamPartResultExamPart E.==. examPartResultB E.^. ExamPartResultExamPart
+      EL.on $ examPartResultA E.^. ExamPartResultExamPart E.==. examPartResultB E.^. ExamPartResultExamPart
        E.&&. examPartResultA E.^. ExamPartResultUser E.==. E.val oldUserId
        E.&&. examPartResultB E.^. ExamPartResultUser E.==. E.val newUserId
       E.where_ $ examPartResultA E.^. ExamPartResultResult E.!=. examPartResultB E.^. ExamPartResultResult
@@ -602,7 +614,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
       -> tellError $ UserAssimilateExamPartResultDifferentResult oldExamPartResult newExamPartResult
   E.insertSelectWithConflict
     UniqueExamPartResult
-    (E.from $ \examPartResult -> do
+    (EL.from $ \examPartResult -> do
         E.where_ $ examPartResult E.^. ExamPartResultUser E.==. E.val oldUserId
         return $ ExamPartResult
           E.<#  (examPartResult E.^. ExamPartResultExamPart)
@@ -614,8 +626,8 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
   deleteWhere [ ExamPartResultUser ==. oldUserId ]
 
   do
-    collision <- E.selectMaybe . E.from $ \(examBonusA `E.InnerJoin` examBonusB) -> do
+    collision <- E.selectMaybe . EL.from $ \(examBonusA `E.InnerJoin` examBonusB) -> do
-      E.on $ examBonusA E.^. ExamBonusExam E.==. examBonusB E.^. ExamBonusExam
+      EL.on $ examBonusA E.^. ExamBonusExam E.==. examBonusB E.^. ExamBonusExam
        E.&&. examBonusA E.^. ExamBonusUser E.==. E.val oldUserId
        E.&&. examBonusB E.^. ExamBonusUser E.==. E.val newUserId
       E.where_ $ examBonusA E.^. ExamBonusBonus E.!=. examBonusB E.^. ExamBonusBonus
@@ -624,7 +636,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
       -> tellError $ UserAssimilateExamBonusDifferentBonus oldExamBonus newExamBonus
   E.insertSelectWithConflict
     UniqueExamBonus
-    (E.from $ \examBonus -> do
+    (EL.from $ \examBonus -> do
         E.where_ $ examBonus E.^. ExamBonusUser E.==. E.val oldUserId
         return $ ExamBonus
           E.<#  (examBonus E.^. ExamBonusExam)
@@ -657,8 +669,8 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
         Entity newECId _ <- upsert examCorrector{ examCorrectorUser = newUserId } []
         E.insertSelectWithConflict
           UniqueExamPartCorrector
-          (E.from $ \(examPartCorrector `E.InnerJoin` examCorrector') -> do
+          (EL.from $ \(examPartCorrector `E.InnerJoin` examCorrector') -> do
-              E.on $ examCorrector' E.^. ExamCorrectorId E.==. examPartCorrector E.^. ExamPartCorrectorCorrector
+              EL.on $ examCorrector' E.^. ExamCorrectorId E.==. examPartCorrector E.^. ExamPartCorrectorCorrector
               E.where_ $ examCorrector' E.^. ExamCorrectorUser E.==. E.val oldUserId
                    E.&&. examCorrector' E.^. ExamCorrectorExam E.==. E.val (examCorrectorExam examCorrector)
               return $ ExamPartCorrector
@@ -704,8 +716,8 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
    in runConduit $ getSheetCorrectors .| C.mapM_ upsertSheetCorrector
 
   do
-    collision <- E.selectMaybe . E.from $ \(personalisedSheetFileA `E.InnerJoin` personalisedSheetFileB) -> do
+    collision <- E.selectMaybe . EL.from $ \(personalisedSheetFileA `E.InnerJoin` personalisedSheetFileB) -> do
-      E.on $ personalisedSheetFileA E.^. PersonalisedSheetFileSheet E.==. personalisedSheetFileB E.^. PersonalisedSheetFileSheet
+      EL.on $ personalisedSheetFileA E.^. PersonalisedSheetFileSheet E.==. personalisedSheetFileB E.^. PersonalisedSheetFileSheet
        E.&&. personalisedSheetFileA E.^. PersonalisedSheetFileType E.==. personalisedSheetFileB E.^. PersonalisedSheetFileType
        E.&&. personalisedSheetFileA E.^. PersonalisedSheetFileTitle E.==. personalisedSheetFileB E.^. PersonalisedSheetFileTitle
        E.&&. personalisedSheetFileA E.^. PersonalisedSheetFileUser E.==. E.val oldUserId
@@ -716,7 +728,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
       -> tellError $ UserAssimilatePersonalisedSheetFileDifferentContent oldPersonalisedSheetFile newPersonalisedSheetFile
   E.insertSelectWithConflict
     UniquePersonalisedSheetFile
-    (E.from $ \personalisedSheetFile -> do
+    (EL.from $ \personalisedSheetFile -> do
         E.where_ $ personalisedSheetFile E.^. PersonalisedSheetFileUser E.==. E.val oldUserId
         return $ PersonalisedSheetFile
           E.<#  (personalisedSheetFile E.^. PersonalisedSheetFileSheet)
@@ -731,7 +743,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
 
   E.insertSelectWithConflict
     UniqueTutor
-    (E.from $ \tutor -> do
+    (EL.from $ \tutor -> do
         E.where_ $ tutor E.^. TutorUser E.==. E.val oldUserId
         return $ Tutor
           E.<#  (tutor E.^. TutorTutorial)
@@ -740,12 +752,12 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
     (\_current _excluded -> [])
 
   do
-    collision <- E.selectMaybe . E.from $ \((tutorialA `E.InnerJoin` tutorialParticipantA) `E.InnerJoin` (tutorialB `E.InnerJoin` tutorialParticipantB)) -> do
+    collision <- E.selectMaybe . EL.from $ \((tutorialA `E.InnerJoin` tutorialParticipantA) `E.InnerJoin` (tutorialB `E.InnerJoin` tutorialParticipantB)) -> do
-      E.on $ tutorialParticipantB E.^. TutorialParticipantTutorial E.==. tutorialB E.^. TutorialId
+      EL.on $ tutorialParticipantB E.^. TutorialParticipantTutorial E.==. tutorialB E.^. TutorialId
-      E.on $ tutorialA E.^. TutorialCourse E.==. tutorialB E.^. TutorialCourse
+      EL.on $ tutorialA E.^. TutorialCourse E.==. tutorialB E.^. TutorialCourse
        E.&&. tutorialParticipantB E.^. TutorialParticipantUser E.==. E.val newUserId
        E.&&. tutorialParticipantA E.^. TutorialParticipantUser E.==. E.val oldUserId
-      E.on $ tutorialParticipantA E.^. TutorialParticipantTutorial E.==. tutorialA E.^. TutorialId
+      EL.on $ tutorialParticipantA E.^. TutorialParticipantTutorial E.==. tutorialA E.^. TutorialId
       E.where_ $ tutorialA E.^. TutorialId E.!=. tutorialB E.^. TutorialId
            E.&&. tutorialA E.^. TutorialRegGroup E.==. tutorialB E.^. TutorialRegGroup
       return (tutorialParticipantA, tutorialParticipantB)
@@ -753,7 +765,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
       -> tellError $ UserAssimilateTutorialParticipantCollidingRegGroups tutorialUserA tutorialUserB
   E.insertSelectWithConflict
     UniqueTutorialParticipant
-    (E.from $ \tutorialParticipant -> do
+    (EL.from $ \tutorialParticipant -> do
         E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. E.val oldUserId
         return $ TutorialParticipant
           E.<#  (tutorialParticipant E.^. TutorialParticipantTutorial)
@@ -764,7 +776,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
 
   E.insertSelectWithConflict
     UniqueSystemMessageHidden
-    (E.from $ \systemMessageHidden -> do
+    (EL.from $ \systemMessageHidden -> do
         E.where_ $ systemMessageHidden E.^. SystemMessageHiddenUser E.==. E.val oldUserId
         return $ SystemMessageHidden
           E.<#  (systemMessageHidden E.^. SystemMessageHiddenMessage)
@@ -789,7 +801,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
               ]
             E.insertSelectWithConflict
               UniqueRelevantStudyFeatures
-              (E.from $ \relevantStudyFeatures -> do
+              (EL.from $ \relevantStudyFeatures -> do
                   E.where_ $ relevantStudyFeatures E.^. RelevantStudyFeaturesStudyFeatures E.==. E.val oldSFId
                   return $ RelevantStudyFeatures
                     E.<#  (relevantStudyFeatures E.^. RelevantStudyFeaturesTerm)
@@ -815,8 +827,8 @@ 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 ]
-  usrQualis <- E.select $ E.from $ \(oldQual `E.LeftOuterJoin` newQual) -> do
+  usrQualis <- E.select $ EL.from $ \(oldQual `E.LeftOuterJoin` newQual) -> do
-      E.on (      newQual E.?. QualificationUserQualification E.?=. oldQual E.^. QualificationUserQualification
+      EL.on (      newQual E.?. QualificationUserQualification E.?=. oldQual E.^. QualificationUserQualification
             E.&&. newQual E.?. QualificationUserUser          E.?=. E.val newUserId
             )
       E.where_ $  oldQual E.^. QualificationUserUser          E.==. E.val oldUserId          
@@ -835,10 +847,14 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
       delete oldQKey
   -- deleteWhere [ QualificationUserUser ==. oldUserId ] -- no longer needed  
 
+  -- PrintJobs
+  updateWhere [ PrintJobRecipient ==. Just oldUserId ] [ PrintJobRecipient =. Just newUserId ]
+  updateWhere [ PrintJobSender    ==. Just oldUserId ] [ PrintJobSender    =. Just newUserId ]
+
   -- Supervision is fully merged
   E.insertSelectWithConflict
     UniqueUserSupervisor
-    (E.from $ \userSupervisor -> do
+    (EL.from $ \userSupervisor -> do
       E.where_ $ userSupervisor E.^. UserSupervisorSupervisor E.==. E.val oldUserId
       return $ UserSupervisor
         E.<#  E.val newUserId
@@ -850,7 +866,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
 
   E.insertSelectWithConflict
     UniqueUserSupervisor
-    (E.from $ \userSupervisor -> do
+    (EL.from $ \userSupervisor -> do
       E.where_ $ userSupervisor E.^. UserSupervisorUser E.==. E.val oldUserId
       return $ UserSupervisor
         E.<#  (userSupervisor E.^. UserSupervisorSupervisor)
@@ -863,7 +879,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
   -- Companies, in conflict, keep the newUser-Company as is
   E.insertSelectWithConflict
     UniqueUserCompany
-    (E.from $ \userCompany -> do
+    (EL.from $ \userCompany -> do
       E.where_ $ userCompany E.^. UserCompanyUser E.==. E.val oldUserId
       return $ UserCompany
         E.<#  E.val newUserId

src/Handler/Utils/Widgets.hs

@@ -123,6 +123,14 @@ editedByW fmt tm usr  = do
   [whamlet|_{MsgUtilEditedBy usr ft}|]
 
 
+-- | like `modal`, but only conditionally displays the modal link only after checking access rights. WARNING: this might be too slow for large dbTable. Use `modalAccessCheckOnClick` instead
+modalAccess :: Widget -> Widget -> Bool -> Route UniWorX -> Widget
+modalAccess wdgtNo wdgtYes writeAccess route = do
+  authOk <- liftHandler $ bool hasReadAccessTo hasWriteAccessTo writeAccess route
+  if authOk
+    then modal wdgtYes (Left $ SomeRoute route)
+    else       wdgtNo
+
 ----------
 -- HEAT --
 ----------

src/Jobs.hs

@@ -47,7 +47,7 @@ import qualified Control.Monad.Catch as Exc
 
 import Data.Time.Zones
 
-import Control.Concurrent.STM (stateTVar, retry)
+import Control.Concurrent.STM (stateTVar)
 import Control.Concurrent.STM.Delay
 
 import UnliftIO.Concurrent (forkIO, myThreadId, threadDelay)
@@ -260,7 +260,7 @@ manageJobPool foundation@UniWorX{..} unmask = shutdownOnException $ \routeExc ->
                   (nextVal, newQueue) <- MaybeT . lift . fmap jqDequeue $ readTVar chan
                   lift . lift $ writeTVar chan newQueue
                   jobWorkers' <- lift . lift $ jobWorkers <$> readTMVar appJobState
-                  receiver <- maybe (lift $ lift retry) return =<< uniformMay jobWorkers'
+                  receiver <- maybe (lift $ lift retrySTM) return =<< uniformMay jobWorkers'
                   return (nextVal, receiver)
                 whenIsJust next $ \(nextVal, receiver) -> do
                   atomically $ readTVar receiver >>= jqInsert nextVal >>= (writeTVar receiver $!)
@@ -373,8 +373,8 @@ execCrontab = do
     State.modify . HashMap.filterWithKey $ \k _ -> HashMap.member k crontab
     prevExec <- State.get
     case earliestJob settings prevExec crontab refT of
-      Nothing -> liftBase retry
+      Nothing -> liftBase retrySTM
-      Just (_, MatchNone) -> liftBase retry
+      Just (_, MatchNone) -> liftBase retrySTM
       Just x -> return (crontab, x, prevExec)
 
   do

src/Jobs/Crontab.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
+-- SPDX-FileCopyrightText: 2022-2023 Sarah Vaupel <sarah.vaupel@uniworx.de>, David Mosbach <david.mosbach@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -392,28 +392,31 @@ determineCrontab = execWriterT $ do
     --         , cronNotAfter  = Right . CronTimestamp . utcToLocalTimeTZ appTZ $ addUTCTime appStudyFeaturesRecacheRelevanceInterval nextIntervalTime
     --         }
 
-    whenIsJust appQualificationCheckHour $ \hour -> tell $ HashMap.singleton
+
+    whenIsJust appJobLmsQualificationsEnqueueHour $ \hour -> tell $ HashMap.singleton
       (JobCtlQueue JobLmsQualificationsEnqueue)
       Cron
         { cronInitial   = CronAsap  -- time after scheduling 
-        , cronRepeat    = CronRepeatScheduled $ cronCalendarAny { cronHour   = cronMatchOne hour -- cronHour = CronMatchSome (impureNonNull $ Set.fromList [3,15] ) 
+        , cronRepeat    = CronRepeatScheduled $ cronCalendarAny { cronDayOfWeek = CronMatchSome . impureNonNull . Set.fromList $ [1..5]
-                                                                , cronMinute = cronMatchOne 3
+                                                                , cronHour   = cronMatchOne hour -- cronHour = CronMatchSome (impureNonNull $ Set.fromList [3,15] ) 
+                                                                , cronMinute = cronMatchOne 2
                                                                 , cronSecond = cronMatchOne 27
                                                                 }
-        , cronRateLimit = nominalDay / 2        -- minimal time between two executions, before the second job is skipped
+        , cronRateLimit = 600        -- minimal time between two executions, before the second job is skipped
-        , cronNotAfter  = Left nominalDay       -- maximal delay of an execution, before it is skipped entirely
+        , cronNotAfter  = Right CronNotScheduled       -- maximal delay of an execution, before it is skipped entirely
         }      
 
-    whenIsJust appQualificationCheckHour $ \hour -> tell $ HashMap.singleton
+    whenIsJust appJobLmsQualificationsDequeueHour $ \hour -> tell $ HashMap.singleton
       (JobCtlQueue JobLmsQualificationsDequeue)
       Cron
         { cronInitial   = CronAsap  -- time after scheduling 
-        , cronRepeat    = CronRepeatScheduled $ cronCalendarAny { cronHour   = cronMatchOne hour -- cronHour = CronMatchSome (impureNonNull $ Set.fromList [3,15] ) 
+        , cronRepeat    = CronRepeatScheduled $ cronCalendarAny { cronDayOfWeek = CronMatchSome . impureNonNull . Set.fromList $ [1..5]
-                                                                , cronMinute = cronMatchOne 33
+                                                                , cronHour   = cronMatchOne hour -- cronHour = CronMatchSome (impureNonNull $ Set.fromList [3,15] ) 
+                                                                , cronMinute = cronMatchOne 7
                                                                 , cronSecond = cronMatchOne 27
                                                                 }
-        , cronRateLimit = nominalDay / 2        -- minimal time between two executions, before the second job is skipped
+        , cronRateLimit = 600        -- minimal time between two executions, before the second job is skipped
-        , cronNotAfter  = Left nominalDay       -- maximal delay of an execution, before it is skipped entirely
+        , cronNotAfter  = Right CronNotScheduled       -- maximal delay of an execution, before it is skipped entirely
         }   
 
     let
@@ -442,28 +445,26 @@ determineCrontab = execWriterT $ do
                         )
       .| C.fold collateSubmissionsByCorrector Map.empty
 
-    submissionRatedNotificationsSince <- lift $ getMigrationTime Migration20210318CrontabSubmissionRatedNotification 
+    let submissionsSelect = E.selectSource . E.from $ \(submission `E.InnerJoin` sheet) -> do
-    whenIsJust submissionRatedNotificationsSince $ \notifySince
+          E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
-      -> let submissionsSelect = E.selectSource . E.from $ \(submission `E.InnerJoin` sheet) -> do
+          E.where_ $ sqlSubmissionRatingDone submission
-               E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
+              E.&&. submission E.^. SubmissionRatingTime E.>=. E.justVal (toMidnight $ fromGregorian 2024 1 1) -- no submissions used in FRADrive as of this date, previously cut off by an old legacy migration
-               E.where_ $ sqlSubmissionRatingDone submission
+          return (submission, sheet E.^. SheetType)
-                    E.&&. submission E.^. SubmissionRatingTime E.>=. E.justVal notifySince
+        submissionJobs (Entity subId Submission{..}, E.Value sType) = maybeT_ $ do
-               return (submission, sheet E.^. SheetType)
+          examFinishedTime <- hoist lift . for (sType ^? _examPart . from _SqlKey) $ \epId -> do
-             submissionJobs (Entity subId Submission{..}, E.Value sType) = maybeT_ $ do
+            ExamPart{examPartExam} <- MaybeT . $cachedHereBinary epId $ get epId
-               examFinishedTime <- hoist lift . for (sType ^? _examPart . from _SqlKey) $ \epId -> do
+            Exam{..} <- MaybeT . $cachedHereBinary examPartExam $ get examPartExam
-                 ExamPart{examPartExam} <- MaybeT . $cachedHereBinary epId $ get epId
+            return examFinished
-                 Exam{..} <- MaybeT . $cachedHereBinary examPartExam $ get examPartExam
+          notifyTime <- hoistMaybe . nBot $ maybe NTop (max `on` NTop) examFinishedTime submissionRatingTime 
-                 return examFinished
+          tell $ HashMap.singleton
-               notifyTime <- hoistMaybe . nBot $ maybe NTop (max `on` NTop) examFinishedTime submissionRatingTime 
+            (JobCtlQueue . JobQueueNotification $ NotificationSubmissionRated subId)
-               tell $ HashMap.singleton
+            Cron
-                 (JobCtlQueue . JobQueueNotification $ NotificationSubmissionRated subId)
+              { cronInitial   = CronTimestamp $ utcToLocalTimeTZ appTZ notifyTime
-                 Cron
+              , cronRepeat    = CronRepeatNever
-                   { cronInitial   = CronTimestamp $ utcToLocalTimeTZ appTZ notifyTime
+              , cronRateLimit = appNotificationRateLimit
-                   , cronRepeat    = CronRepeatNever
+              , cronNotAfter  = Left appNotificationExpiration
-                   , cronRateLimit = appNotificationRateLimit
+              }
-                   , cronNotAfter  = Left appNotificationExpiration
+    runConduit $ transPipe lift submissionsSelect .| C.mapM_ submissionJobs
-                   }
-          in runConduit $ transPipe lift submissionsSelect .| C.mapM_ submissionJobs
 
     let
       examSelect = E.selectSource . E.from $ \(exam `E.InnerJoin` course `E.InnerJoin` school) -> do

src/Jobs/Handler/LMS.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022-23 Steffen Jost <s.jost@fraport.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
+-- SPDX-FileCopyrightText: 2022-24 Steffen Jost <s.jost@fraport.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -10,8 +10,6 @@ module Jobs.Handler.LMS
   , dispatchJobLmsEnqueue, dispatchJobLmsEnqueueUser
   , dispatchJobLmsDequeue
   , dispatchJobLmsReports
-  , dispatchJobLmsResults
-  , dispatchJobLmsUserlist
   ) where
 
 import Import
@@ -28,7 +26,7 @@ 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 qualified Data.Time.Zones as TZ
 import Handler.Utils.DateTime
 import Handler.Utils.LMS (randomLMSIdentBut, randomLMSpw, maxLmsUserIdentRetries)
 import Handler.Utils.Qualification
@@ -119,6 +117,7 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act
                               NotificationQualificationExpiry { nQualification = qid, nExpiry = uex }
                          }
           forM_ renewalUsers (queueDBJob . usr_job)
+          logInterface "LMS" (qshort <> "-enq") True (Just $ length renewalUsers) ""
 
 dispatchJobLmsEnqueueUser :: QualificationId -> UserId -> JobHandler UniWorX
 dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act
@@ -134,14 +133,11 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act
           ( (E.^. LmsUserIdent)     <$> E.from (E.table @LmsUser    ) ) -- no filter by Qid, since LmsIdents must be unique across all
           `E.union_`
           ( (E.^. LmsReportIdent)   <$> E.from (E.table @LmsReport  ) ) -- V2
-          `E.union_`
-          ( (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
       let identsInUse = Set.fromList (E.unValue <$> identsInUseVs)
+          uniqLmsUse  = UniqueLmsQualificationUser qid uid
           mkLmsUser lpin lid = LmsUser
             { lmsUserQualification = qid
             , lmsUserUser          = uid
@@ -165,18 +161,24 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act
             -- runMaybeT $ do
             --   lid <- MaybeT $ randomLMSIdentBu qprefix identsInUse
             --   MaybeT $ E.insertUniqueEntity $ mkLmsUser lpw lid
-      inserted <- untilJustMaxM maxLmsUserIdentRetries startLmsUser
+      getBy uniqLmsUse >>= \case
-      case inserted of
+        Just Entity{entityVal=LmsUser{..}} 
-        Nothing  -> do
+          | isNothing lmsUserEnded, isNothing lmsUserStatus || lmsUserStatus == Just LmsSuccess -> do 
-          uuid :: CryptoUUIDUser <- encrypt uid
+            uuid :: CryptoUUIDUser <- encrypt uid
-          $logErrorS "LMS" $ "Generating and inserting fresh LmsIdent failed for uuid " <> tshow uuid <> " and qid " <> tshow qid <> "!"
+            $logErrorS "LMS" $ "Generating fresh LmsIdent failed for uuid " <> tshow uuid <> " and qid " <> tshow qid <> " due to LMS still existing!"
-        (Just Entity{entityKey=lkey, entityVal=LmsUser{lmsUserIdent=lid, lmsUserUser=luid, lmsUserQualification=lqid}}) -> -- lmsUser started, but not yet notified
+        other -> do 
-          audit $ TransactionLmsStart
+          when (isJust other) $ deleteBy uniqLmsUse
-            { transactionQualification = lqid
+          untilJustMaxM maxLmsUserIdentRetries startLmsUser >>= \case
-            , transactionLmsIdent      = lid
+            Nothing  -> do
-            , transactionLmsUser       = luid
+              uuid :: CryptoUUIDUser <- encrypt uid
-            , transactionLmsUserKey    = lkey
+              $logErrorS "LMS" $ "Generating and inserting fresh LmsIdent failed for uuid " <> tshow uuid <> " and qid " <> tshow qid <> " for unknown reason!"
-            }
+            (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
@@ -197,10 +199,10 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
                               luser E.?. LmsUserUser           E.?=. quser   E.^. QualificationUserUser
                         E.&&. luser E.?. LmsUserQualification  E.?=. quser   E.^. QualificationUserQualification)
           E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid
-              -- E.&&.  luser E.?. LmsUserQualification           E.?=. E.val qid
+              -- E.&&.  luser E.?. LmsUserQualification        E.?=. E.val qid
               -- E.&&.  E.isNothing (luser E.^. LmsUserStatus)
               -- E.&&.  E.isNothing (luser E.^. LmsUserEnded)
-              E.&&.  E.not_ (validQualification now quser)
+              E.&&.  E.not__ (validQualification now quser)
           pure (luser E.?. LmsUserId, quser E.^. QualificationUserUser)
       nrBlocked <- qualificationUserBlocking qid (E.unValue . snd <$> expiredUsers) False (Just now) (Right QualificationBlockExpired) True -- essential that blocks occur only once
       let expiredLearners = [ luid | (E.Value (Just luid), _) <- expiredUsers ]
@@ -210,7 +212,8 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
         E.where_ $ E.isNothing (luser E.^. LmsUserStatus)
              E.&&.  luser E.^. LmsUserQualification E.==. E.val qid
              E.&&. (luser E.^. LmsUserId) `E.in_` E.valList expiredLearners
-      $logInfoS "LMS" $ "Expired qualification holders " <> tshow nrBlocked <> " and expired lms users " <> tshow nrExpired <> " for qualification " <> qshort
+      let dequeueInfo = "Blocked qualification holders " <> tshow nrBlocked <> " out of expired lms users " <> tshow nrExpired <> " for qualification " <> qshort             
+      $logInfoS "LMS" dequeueInfo
 
       when (quali ^. _qualificationExpiryNotification) $ do -- notifies expired and previously lms-failed drivers
         notifyInvalidDrivers <- E.select $ do
@@ -220,7 +223,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
               `E.on` (\(quser :& qblock) -> qblock E.?. QualificationUserBlockQualificationUser E.?=. quser E.^. QualificationUserId
                         E.&&. qblock `isLatestBlockBefore` E.val now
                      )
-            E.where_ $ -- E.not_ (validQualification now quser)                   -- currently invalid
+            E.where_ $ -- E.not__ (validQualification now quser)                   -- currently invalid
                     quser E.^. QualificationUserQualification E.==. E.val qid  -- correct qualification
               E.&&. quserToNotify now quser qblock                            -- recently became invalid or blocked
             pure (quser E.^. QualificationUserUser)
@@ -254,9 +257,9 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
           when (numdel > 0) $ do
             $logInfoS "LMS" $ "Deleting " <> tshow numdel <> " LmsIdents due to audit duration expiry for qualification " <> qshort
             deleteWhere [LmsUserQualification     ==. qid, LmsUserIdent     <-. delusers]
-            deleteWhere [LmsUserlistQualification ==. qid, LmsUserlistIdent <-. delusers]
-            deleteWhere [LmsResultQualification   ==. qid, LmsResultIdent   <-. delusers]
             -- deleteWhere [LmsAuditQualification    ==. qid, LmsAuditIdent    <-. delusers]
+          deleteWhere [LmsReportLogQualification ==. qid, LmsReportLogTimestamp <. auditCutoff ]
+      logInterface "LMS" (qshort <> "-deq") True (Just nrBlocked) (tshow nrExpired <> " expired")
 
 
 dispatchJobLmsReports :: QualificationId -> JobHandler UniWorX
@@ -310,14 +313,15 @@ dispatchJobLmsReports qid = JobHandlerAtomic act
                         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
+        let luserFltrNew luser =  E.isNothing (luser E.^. LmsUserReceived)  -- not seen before, just starting
+                            E.||. E.isNothing (luser E.^. LmsUserNotified)  -- a previous notification has failed
             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), notified during expiry
         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
+                ok_block <- qualificationUserBlocking qid [lmsUserUser luser] False (lmsReportDate lreport) (Right $ QualificationBlockFailedELearningBy $ lmsUserIdent luser) True -- only valid qualifications are blocked; transcribes to audit log
                 update luid [LmsUserStatus =. Just LmsBlocked, LmsUserStatusDay =. repDay]
                 return $ Sum ok_block
           in lrepQry lrFltrBlock
@@ -327,12 +331,13 @@ dispatchJobLmsReports qid = JobHandlerAtomic act
         let lrFltrSuccess luser lreport = E.isNothing (luser E.^. LmsUserStatus) E.&&. lreport E.^. LmsReportResult E.==. E.val LmsPassed
             procRenew (Entity luid luser, Entity _ lreport) = do
                 let repDay = lmsReportDate lreport <|> Just now
+                    reason = Just $ Right $ QualificationRenewELearningBy $ lmsUserIdent luser
                 -- 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
+                ok_renew <- renewValidQualificationUsers qid reason 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
@@ -378,123 +383,49 @@ dispatchJobLmsReports qid = JobHandlerAtomic act
           >>= \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
+        -- G) Truncate LmsReport for qid, after updating log
+        E.insertSelect $ do
+          lreport <- E.from $ E.table @LmsReport
+          let samelog = E.subSelect $ do
+                  lrl <- E.from $ E.table @LmsReportLog
+                  E.where_ $ lrl E.^. LmsReportLogQualification E.==. E.val qid
+                      E.&&.  lrl E.^. LmsReportLogIdent         E.==. lreport E.^. LmsReportIdent
+                  E.orderBy [E.desc $ lrl E.^. LmsReportLogTimestamp]
+                  return $ lreport E.^. LmsReportResult E.==. lrl E.^. LmsReportLogResult
+                    E.&&.  lreport E.^. LmsReportLock   E.==. lrl E.^. LmsReportLogLock
+                    E.&&.  E.not_ (lrl E.^. LmsReportLogMissing)
+          E.where_ $ lreport E.^. LmsReportQualification E.==. E.val qid
+              E.&&. E.not_ (E.isTrue samelog)
+          return (LmsReportLog
+            E.<#  (lreport E.^. LmsReportQualification)
+            E.<&> (lreport E.^. LmsReportIdent        )
+            E.<&> (lreport E.^. LmsReportDate         )
+            E.<&> (lreport E.^. LmsReportResult       )
+            E.<&> (lreport E.^. LmsReportLock         )
+            E.<&> (lreport E.^. LmsReportTimestamp    )
+            E.<&> E.false)
+        E.insertSelect $ do
+          lrl <- E.from $ E.table @LmsReportLog
+          E.where_ $ E.not_ (lrl E.^. LmsReportLogMissing)
+                E.&&. lrl E.^. LmsReportLogQualification            E.==. E.val qid
+                E.&&. E.notExists (do
+                  lreport <- E.from $ E.table @LmsReport
+                  E.where_ $ lreport E.^. LmsReportQualification    E.==. E.val qid
+                      E.&&.  lreport E.^. LmsReportIdent            E.==. lrl E.^. LmsReportLogIdent
+                )
+                E.&&. E.notExists (do
+                  lrl_old <- E.from $ E.table @LmsReportLog
+                  E.where_ $ lrl_old E.^. LmsReportLogQualification E.==. E.val qid
+                    E.&&.    lrl_old E.^. LmsReportLogIdent         E.==. lrl E.^. LmsReportLogIdent
+                    E.&&.    lrl_old E.^. LmsReportLogTimestamp     E.>.  lrl E.^. LmsReportLogTimestamp
+                  )
+          return (LmsReportLog
+            E.<#  (lrl E.^. LmsReportLogQualification)
+            E.<&> (lrl E.^. LmsReportLogIdent        )
+            E.<&> E.nothing
+            E.<&> (lrl E.^. LmsReportLogResult       )
+            E.<&> (lrl E.^. LmsReportLogLock         )
+            E.<&> E.val now
+            E.<&> E.true)
         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
-    -- act :: YesodJobDB UniWorX ()
-    act = hoist lift $ do
-        results <- E.select $ do
-          (quser :& luser :& lresult) <- E.from $
-              E.table @QualificationUser  -- table not needed if renewal from lms completion day is used TODO: decide!
-              `E.innerJoin` E.table @LmsUser
-              `E.on` (\(quser :& luser) ->
-                              luser E.^. LmsUserUser           E.==. quser   E.^. QualificationUserUser
-                        E.&&. luser E.^. LmsUserQualification  E.==. quser   E.^. QualificationUserQualification)
-              `E.innerJoin` E.table @LmsResult
-              `E.on` (\(_ :& luser :& lresult) ->
-                              luser E.^. LmsUserIdent          E.==. lresult E.^. LmsResultIdent
-                        E.&&. luser E.^. LmsUserQualification  E.==. lresult E.^. LmsResultQualification)
-          E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid
-            E.&&.    luser E.^. LmsUserQualification           E.==. E.val qid
-            -- E.&&. E.isNothing (luser E.^. LmsUserStatus)  -- do not process learners already having a result WORKAROUND LMS-Bug: LMS may send blocked & success simultanesouly or within a few hours; in this case, success is the correct meaning
-            E.&&. E.isNothing (luser E.^. LmsUserEnded)   -- do not process closed learners
-          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
-          -- 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
-              -- newValidTo  = addGregorianMonthsRollOver (toInteger renewalMonths) qualificationUserValidUntil -- renew from old validUntil onwards
-          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
-              let reason_undo = Left $ "LMS Workaround undoing: " <> qualificationBlockedReasonText QualificationBlockFailedELearning
-              ok_unblock <- qualificationUserUnblockByReason qid [qualificationUserUser] Nothing (Right QualificationBlockFailedELearning) reason_undo False -- affects audit log
-              when (ok_unblock > 0) ($logWarnS "LMS" [st|LMS Result: workaround triggered, unblocking #{tshow ok_unblock} e-learners for #{tshow qid}|])
-
-              _ok_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     =. Just LmsSuccess
-                , LmsUserStatusDay  =. Just (utctDayMidnight lmsResultSuccess)
-                , LmsUserReceived   =. Just lmsResultTimestamp
-                ]
-              return Nothing
-            else do
-              let errmsg = [st|LMS Result: success with insane date #{tshow lmsResultSuccess} received for #{tshow lmsUserIdent}  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        = utctDayMidnight lmsResultSuccess
-            , transactionLmsUser       = lmsUserUser
-            , transactionNote          = note
-            , transactionReceived      = lmsResultTimestamp
-            }
-          delete lrid
-        $logInfoS "LMS" [st|Processed #{tshow (length results)} LMS results|]
-
-
--- DEPRECATED processes received input and block qualifications, if applicable
-dispatchJobLmsUserlist :: QualificationId -> JobHandler UniWorX
-dispatchJobLmsUserlist qid = JobHandlerAtomic act
-  where
-    act :: YesodJobDB UniWorX ()
-    act = whenM (exists [LmsUserlistQualification ==. qid]) $ do -- safeguard against multiple calls, which would close all learners due to first case below
-      now <- liftIO getCurrentTime
-      -- result :: [(Entity LmsUser, Entity LmsUserlist)]
-      results <- E.select $ do
-        (luser :& lulist) <- E.from $
-            E.table @LmsUser `E.leftJoin` E.table @LmsUserlist
-            `E.on` (\(luser :& lulist) ->  luser E.^. LmsUserIdent         E.=?. lulist E.?. LmsUserlistIdent
-                                     E.&&. luser E.^. LmsUserQualification E.=?. lulist E.?. LmsUserlistQualification)
-        E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid
-                  E.&&. E.isNothing (luser E.^. LmsUserEnded) -- do not process closed learners
-        return (luser, lulist)
-      forM_ results $ \case
-        (Entity luid luser, Nothing)
-          | isJust    $ lmsUserReceived luser          -- mark all previuosly reported, but now unreported users as ended (LMS deleted them as expected)
-          , isNothing $ lmsUserEnded    luser ->
-              update luid [LmsUserEnded =. Just now]
-          | otherwise -> return ()                     -- users likely not yet started
-
-        (Entity luid luser, Just (Entity _lulid lulist)) -> do
-          let lReceived = lmsUserlistTimestamp lulist              
-          update luid [LmsUserReceived =. Just lReceived] -- LmsUserNotified is only updated upon sending notifications
-
-          when (isNothing $ lmsUserNotified luser) $ do -- notify users that lms is available
-            queueDBJob JobUserNotification
-              { jRecipient    = lmsUserUser luser
-              , jNotification = NotificationQualificationRenewal { nQualification = qid, nReminder = False }
-              }
-
-          let isBlocked = lmsUserlistFailed lulist
-              oldStatus = lmsUserStatus luser
-              updateStatus = isBlocked && oldStatus /= Just LmsSuccess
-          when updateStatus $ do
-            update luid [LmsUserStatus =. Just LmsBlocked, LmsUserStatusDay =. Just lReceived]
-            ok <- qualificationUserBlocking qid [lmsUserUser luser] False Nothing (Right QualificationBlockFailedELearning)  True
-            when (ok /= 1) $ do
-              uuid :: CryptoUUIDUser <- encrypt $ lmsUserUser luser
-              $logWarnS "LmsUserlist" [st|Blocking by failed E-learning failed for learner #{tshow uuid} and qualification #{tshow qid}]
-            audit TransactionLmsBlocked
-              { transactionQualification = qid
-              , transactionLmsIdent      = lmsUserIdent luser
-              , transactionLmsDay        = lReceived
-              , transactionLmsUser       = lmsUserUser luser
-              , transactionNote          = Just $ "Old status was " <> tshow oldStatus
-              , transactionReceived      = lReceived
-              }
-          delete lulid
-      $logInfoS "LMS" [st|Processed LMS Userlist with #{tshow (length results)} entries|]

src/Jobs/Handler/SendCourseCommunication.hs

@@ -4,6 +4,7 @@
 
 module Jobs.Handler.SendCourseCommunication
   ( dispatchJobSendCourseCommunication
+  , dispatchJobSendFirmCommunication
   ) where
 
 import Import
@@ -30,14 +31,42 @@ dispatchJobSendCourseCommunication jRecipientEmail jAllRecipientAddresses jCours
   (sender, Course{..}) <- runDB $ (,)
     <$> getJust jSender
     <*> getJust jCourse
-  either (\email -> mailT def . (assign _mailTo (pure . Address Nothing $ CI.original email) *>)) userMailT jRecipientEmail $ do
+  either (\email -> mailT def . (assign _mailTo (pure . Address Nothing $ CI.original email) *>)) userMailT jRecipientEmail $ do -- userMailT obeys reroutes, userMailT direct does not
     MsgRenderer mr <- getMailMsgRenderer
 
     void $ setMailObjectUUID jMailObjectUUID
     _mailFrom .= userAddressFrom sender
     addMailHeader "Cc" [st|#{mr MsgCommUndisclosedRecipients}:;|]
     addMailHeader "Auto-Submitted" "no"
-    setSubjectI . prependCourseTitle courseTerm courseSchool courseShorthand $ maybe (SomeMessage MsgCommCourseSubject) SomeMessage ccSubject
+    setSubjectI . prependCourseTitle courseTerm courseSchool courseShorthand $ maybe (SomeMessage MsgUtilCommCourseSubject) SomeMessage ccSubject
+    addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/courseCommunication.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
+    forM_ ccAttachments $ addPart' . toMailPart
+    when (jRecipientEmail == Right jSender) $
+      addPart' $ do
+        partIsAttachmentCsv MsgCommAllRecipients
+        toMailPart (MsgCommAllRecipientsSheet, toDefaultOrderedCsvRendered jAllRecipientAddresses)
+
+
+dispatchJobSendFirmCommunication :: Either UserEmail UserId
+                                   -> Set Address
+                                   -> Companies
+                                   -> UserId
+                                   -> UUID
+                                   -> CommunicationContent
+                                   -> JobHandler UniWorX
+dispatchJobSendFirmCommunication jRecipientEmail jAllRecipientAddresses _jCompanies jSender jMailObjectUUID CommunicationContent{..} = JobHandlerException $ do
+  -- (sender,mbComp) <- runDB $ (,)
+  --   <$> getJust jSender
+  --   <*> ifMaybeM jCompany Nothing get
+  sender <- runDB $ getJust jSender    
+  either (\email -> mailT def . (assign _mailTo (pure . Address Nothing $ CI.original email) *>)) userMailT jRecipientEmail $ do -- userMailT obeys reroutes, userMailT direct does not
+    MsgRenderer mr <- getMailMsgRenderer
+
+    void $ setMailObjectUUID jMailObjectUUID
+    _mailFrom .= userAddressFrom sender
+    addMailHeader "Cc" [st|#{mr MsgCommUndisclosedRecipients}:;|]
+    addMailHeader "Auto-Submitted" "no"
+    setSubjectI $ maybe (SomeMessage MsgUtilCommFirmSubject) SomeMessage ccSubject
     addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/courseCommunication.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
     forM_ ccAttachments $ addPart' . toMailPart
     when (jRecipientEmail == Right jSender) $

src/Jobs/Handler/SendNotification/Qualification.hs

@@ -81,7 +81,7 @@ dispatchNotificationQualificationExpired nQualification jRecipient = do
               $logInfoS  "LMS" $ "Notified " <> tshow encRecipient <> " about expired qualification " <> qname
             else
               $logErrorS "LMS" $ "Failed to notify " <> tshow encRecipient <> " about expired qualification " <> qname
-        else  $logErrorS "LMS" $ "Suppressed repeated notification " <> tshow encRecipient <> " about expired qualification " <> qname
+        else  $logInfoS  "LMS" $ "Suppressed repeated notification " <> tshow encRecipient <> " about expired qualification " <> qname
     _ ->  $logErrorS "LMS" $ "Failed to notify " <> tshow encRecipient <> " about expired qualification " <> tshow nQualification
 
 

src/Jobs/Handler/SynchroniseAvs.hs

@@ -27,6 +27,7 @@ dispatchJobSynchroniseAvs numIterations epoch iteration pause
       now <- liftIO getCurrentTime
       todos <- runConduit $ readUsers .| filterIteration now .| sinkList
       putMany todos
+      void $ queueJob JobSynchroniseAvsQueue
   where
     readUsers :: ConduitT () UserId _ ()
     readUsers = selectKeys [] []

src/Jobs/Types.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022-23 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
+-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -74,6 +74,13 @@ data Job
                                , jMailObjectUUID :: UUID
                                , jMailContent :: CommunicationContent
                                }
+  | JobSendFirmCommunication   { jRecipientEmail :: Either UserEmail UserId
+                               , jAllRecipientAddresses :: Set Address
+                               , jCompanies :: Companies
+                               , jSender :: UserId
+                               , jMailObjectUUID :: UUID
+                               , jMailContent :: CommunicationContent
+                               }
   | JobInvitation { jInviter :: Maybe UserId
                   , jInvitee :: UserEmail
                   , jInvitationUrl :: Text
@@ -128,8 +135,6 @@ data Job
   | JobLmsEnqueueUser { jQualification :: QualificationId, jUser :: UserId }
   | JobLmsQualificationsDequeue
   | JobLmsDequeue     { jQualification :: QualificationId }
-  | JobLmsUserlist    { jQualification :: QualificationId } -- Deprecated, remove together with routes
-  | JobLmsResults     { jQualification :: QualificationId } -- Deprecated, remove together with routes
   | JobLmsReports     { jQualification :: QualificationId }
   | JobPrintAck
   | JobPrintAckAgain
@@ -362,8 +367,6 @@ jobNoQueueSame = \case
   JobLmsEnqueueUser {}                -> Just JobNoQueueSame
   JobLmsQualificationsDequeue         -> Just JobNoQueueSame
   JobLmsDequeue     {}                -> Just JobNoQueueSame  
-  JobLmsUserlist    {}                -> Just JobNoQueueSame
-  JobLmsResults     {}                -> Just JobNoQueueSame
   JobLmsReports     {}                -> Just JobNoQueueSame
   JobPrintAck       {}                -> Just JobNoQueueSame
   JobPrintAckAgain  {}                -> Just JobNoQueueSame
@@ -372,6 +375,8 @@ jobNoQueueSame = \case
 notifyNoQueueSame :: Notification -> Maybe JobNoQueueSame
 notifyNoQueueSame = \case 
   NotificationQualificationRenewal{} -> Just JobNoQueueSame -- send one at once; safe, since the job is rescheduled if sending was not acknowledged
+  NotificationQualificationExpiry{}  -> Just JobNoQueueSame -- do not send multiple expiry messages to the same person at once
+  NotificationQualificationExpired{} -> Just JobNoQueueSame 
   _                                  -> Nothing
 
 jobMovable :: JobCtl -> Bool

src/Mail.hs

@@ -10,6 +10,7 @@
 module Mail
   ( -- * Structured MIME emails
     module Network.Mail.Mime
+  , AddressEqIgnoreName(..)
     -- * MailT
   , MailT, defMailT
   , MailSmtpData(..), _smtpEnvelopeFrom, _smtpRecipients
@@ -137,6 +138,14 @@ import Network.HTTP.Types.Header (hETag)
 import Web.HttpApiData (ToHttpApiData(toHeader))
 
 
+newtype AddressEqIgnoreName = AddressEqIgnoreName { getAddress :: Address }
+  deriving (Show, Generic)
+instance Eq AddressEqIgnoreName where 
+  (==)    = (==)    `on` (addressEmail . getAddress)
+instance Ord AddressEqIgnoreName where 
+  compare = compare `on` (addressEmail . getAddress)
+
+
 makeLenses_ ''Address
 makeLenses_ ''Mail
 makeLenses_ ''Part
@@ -339,8 +348,8 @@ defMailT ls (MailT mailC) = do
     return $ mail0
       & _mailFrom     .~ fromAddress
       & _mailReplyTo  .~ sender
-  mailRerouteTo' <- mailRerouteTo
+  mailRerouteTo' <- mailRerouteTo -- this is the general reroute, e.g. for test instances, not for supervisors
-  let (mail2, smtpData1) = maybe (mail1,smtpData0) switchRecipient mailRerouteTo'   -- switch receiver on enveloper, if rerouting is active
+  let (mail2, smtpData1) = maybe (mail1,smtpData0) switchRecipient mailRerouteTo'   -- switch receiver on envelope, if rerouting is active
       switchRecipient rerouteTo = (Mime.addPart switchInfo mail1, smtpData0 { smtpRecipients = Set.singleton rerouteTo } )
       switchInfo = [plainPart $ LT.fromStrict $ "Due to setting 'mail-reroute-to', this mail was diverted; it was intended to be sent to: " <> tshow (smtpRecipients smtpData0)]
   mail3 <- liftIO $ LBS.toStrict <$> renderMail' mail2

src/Model/Migration.hs

@@ -31,59 +31,20 @@ import Control.Monad.Except (MonadError(..))
 
 import Web.ServerSession.Backend.Persistent.Memcached (migrateMemcachedSqlStorage)
   
-import qualified Control.Monad.State.Class as State
+-- import qualified Control.Monad.State.Class as State
 
 
-_manualMigration :: Fold (Legacy.MigrationVersion, Legacy.Version) ManualMigration
+-- _manualMigration :: Fold (Legacy.Migration Version, Legacy.Version) ManualMigration
-_manualMigration = folding $ \case
+-- _manualMigration = folding $ \case
-  ([Legacy.migrationVersion|initial|], [Legacy.version|0.0.0|])  -> Just Migration20180813SimplifyUserTheme
+--   ([Legacy.migrationVersion|initial|], [Legacy.version|0.0.0|])  -> Just Migration20180813SimplifyUserTheme
-  ([Legacy.migrationVersion|0.0.0|],   [Legacy.version|1.0.0|])  -> Just Migration20180813SheetJSONB
+--   ([Legacy.migrationVersion|44.0.0|],  [Legacy.version|45.0.0|]) -> Just Migration20201119RoomTypes
-  ([Legacy.migrationVersion|1.0.0|],   [Legacy.version|2.0.0|])  -> Just Migration20180823SchoolShorthandPrimaryKey
+--   _other -> Nothing
-  ([Legacy.migrationVersion|2.0.0|],   [Legacy.version|3.0.0|])  -> Just Migration20180918SheetCorrectorLoadJSON
-  ([Legacy.migrationVersion|3.0.0|],   [Legacy.version|3.1.0|])  -> Just Migration20180918UserSurnames
-  ([Legacy.migrationVersion|3.1.0|],   [Legacy.version|3.2.0|])  -> Just Migration20180918SheetUploadMode
-  ([Legacy.migrationVersion|3.2.0|],   [Legacy.version|4.0.0|])  -> Just Migration20180928UserAuthentication
-  ([Legacy.migrationVersion|4.0.0|],   [Legacy.version|5.0.0|])  -> Just Migration20181011UserNotificationSettings
-  ([Legacy.migrationVersion|5.0.0|],   [Legacy.version|6.0.0|])  -> Just Migration20181031SheetTypeRefactor
-  ([Legacy.migrationVersion|6.0.0|],   [Legacy.version|7.0.0|])  -> Just Migration20181129EncodedSecretBoxes
-  ([Legacy.migrationVersion|7.0.0|],   [Legacy.version|8.0.0|])  -> Just Migration20181130SheetTypeRefactor
-  ([Legacy.migrationVersion|8.0.0|],   [Legacy.version|9.0.0|])  -> Just Migration20190319CourseParticipantField
-  ([Legacy.migrationVersion|9.0.0|],   [Legacy.version|10.0.0|]) -> Just Migration20190320BetterStudyShorthands
-  ([Legacy.migrationVersion|10.0.0|],  [Legacy.version|11.0.0|]) -> Just Migration20190421MixedSheetSubmissions
-  ([Legacy.migrationVersion|11.0.0|],  [Legacy.version|12.0.0|]) -> Just Migration20190429Tutorials
-  ([Legacy.migrationVersion|12.0.0|],  [Legacy.version|13.0.0|]) -> Just Migration20190515Exams
-  ([Legacy.migrationVersion|13.0.0|],  [Legacy.version|14.0.0|]) -> Just Migration20190715ExamOccurrenceName
-  ([Legacy.migrationVersion|14.0.0|],  [Legacy.version|15.0.0|]) -> Just Migration20190726UserFirstNamesTitles
-  ([Legacy.migrationVersion|15.0.0|],  [Legacy.version|16.0.0|]) -> Just Migration20190806TransactionLogIds
-  ([Legacy.migrationVersion|18.0.0|],  [Legacy.version|19.0.0|]) -> Just Migration20190828UserFunction
-  ([Legacy.migrationVersion|19.0.0|],  [Legacy.version|20.0.0|]) -> Just Migration20190912UserDisplayEmail
-  ([Legacy.migrationVersion|20.0.0|],  [Legacy.version|21.0.0|]) -> Just Migration20190916ExamPartNumber
-  ([Legacy.migrationVersion|21.0.0|],  [Legacy.version|22.0.0|]) -> Just Migration20190918ExamRulesRefactor
-  ([Legacy.migrationVersion|22.0.0|],  [Legacy.version|23.0.0|]) -> Just Migration20190919ExamBonusRounding
-  ([Legacy.migrationVersion|23.0.0|],  [Legacy.version|24.0.0|]) -> Just Migration20191002FavouriteReason
-  ([Legacy.migrationVersion|26.0.0|],  [Legacy.version|27.0.0|]) -> Just Migration20191125UserLanguages
-  ([Legacy.migrationVersion|27.0.0|],  [Legacy.version|28.0.0|]) -> Just Migration20191126ExamPartCorrector
-  ([Legacy.migrationVersion|28.0.0|],  [Legacy.version|29.0.0|]) -> Just Migration20191128StudyFeaturesSuperField
-  ([Legacy.migrationVersion|29.0.0|],  [Legacy.version|30.0.0|]) -> Just Migration20200111ExamOccurrenceRuleRefactor
-  ([Legacy.migrationVersion|30.0.0|],  [Legacy.version|31.0.0|]) -> Just Migration20200218ExamResultPassedGrade
-  ([Legacy.migrationVersion|31.0.0|],  [Legacy.version|32.0.0|]) -> Just Migration20200218ExamGradingModeMixed
-  ([Legacy.migrationVersion|32.0.0|],  [Legacy.version|33.0.0|]) -> Just Migration20200218ExternalExamGradingModeMixed
-  ([Legacy.migrationVersion|34.0.0|],  [Legacy.version|35.0.0|]) -> Just Migration20200424SubmissionGroups
-  ([Legacy.migrationVersion|35.0.0|],  [Legacy.version|36.0.0|]) -> Just Migration20200504CourseParticipantState
-  ([Legacy.migrationVersion|36.0.0|],  [Legacy.version|37.0.0|]) -> Just Migration20200506SessionFile
-  ([Legacy.migrationVersion|37.0.0|],  [Legacy.version|38.0.0|]) -> Just Migration20200627FileRefactor
-  ([Legacy.migrationVersion|39.0.0|],  [Legacy.version|40.0.0|]) -> Just Migration20200825StudyFeaturesFirstObserved
-  ([Legacy.migrationVersion|40.0.0|],  [Legacy.version|41.0.0|]) -> Just Migration20200902FileChunking
-  ([Legacy.migrationVersion|41.0.0|],  [Legacy.version|42.0.0|]) -> Just Migration20200916ExamMode
-  ([Legacy.migrationVersion|43.0.0|],  [Legacy.version|44.0.0|]) -> Just Migration20201106StoredMarkup
-  ([Legacy.migrationVersion|44.0.0|],  [Legacy.version|45.0.0|]) -> Just Migration20201119RoomTypes
-  _other -> Nothing
-
 
+-- AppliedMigrationMigration changed vom ManualMigration to Text (via PathPiece) so that removed extra migrations within DB are harmless (before achieved through where-clause)
 share [mkPersist sqlSettings, mkMigrate "migrateDBVersioning"]
   [persistLowerCase|
     AppliedMigration json
-      migration ManualMigration
+      migration Text
       time UTCTime
       Primary migration
       deriving Show Eq Ord
@@ -99,7 +60,7 @@ migrateAll' = sequence_
 migrateAll :: ( MonadLogger m
               , MonadResource m
               , MonadUnliftIO m
-              , MonadReader UniWorX m
+              -- , MonadReader UniWorX m
               )
            => ReaderT SqlBackend m ()
 migrateAll = do
@@ -108,8 +69,9 @@ migrateAll = do
 
   missingMigrations <- getMissingMigrations
   let
-    doCustomMigration acc appliedMigrationMigration migration = acc <* do
+    doCustomMigration acc manualMigration migration = acc <* do
-      $logInfoS "Migration" $ toPathPiece appliedMigrationMigration
+      let appliedMigrationMigration = toPathPiece manualMigration
+      $logInfoS "Migration" appliedMigrationMigration
       appliedMigrationTime <- liftIO getCurrentTime
       _ <- migration
       insert AppliedMigration{..}
@@ -154,9 +116,9 @@ initialMigration = do
   mapM_ migrateEnableExtension ["citext", "pgcrypto"]
   lift . lift . hoist runResourceT . whenM (columnExists "applied_migration" "from") $ do
     let getAppliedMigrations = [queryQQ|SELECT "from", "to", "time" FROM "applied_migration"|]
-        migrateAppliedMigration [ fromPersistValue -> Right (fromV :: Legacy.MigrationVersion), fromPersistValue -> Right (toV :: Legacy.Version), fromPersistValue -> Right (time :: UTCTime) ] = do
+        migrateAppliedMigration [ fromPersistValue -> Right (fromV :: Legacy.MigrationVersion), fromPersistValue -> Right (toV :: Legacy.Version), fromPersistValue -> Right (_time :: UTCTime) ] = do
           lift [executeQQ|DELETE FROM "applied_migration" WHERE "from" = #{fromV} AND "to" = #{toV}|]
-          State.modify . Map.unionWith min . Map.fromSet (const time) $ setOf _manualMigration (fromV, toV)
+          -- State.modify . Map.unionWith min . Map.fromSet (const time) $ setOf _manualMigration (fromV, toV)
         migrateAppliedMigration _ = return ()
         insertMigrations ms = do
           [executeQQ|
@@ -174,15 +136,16 @@ getMissingMigrations :: forall m m'.
                         ( MonadLogger m
                         , MonadIO m
                         , MonadResource m'
-                        , MonadReader UniWorX m'
+                        -- , MonadReader UniWorX m'
                         )
                      => ReaderT SqlBackend m (Map ManualMigration (ReaderT SqlBackend m' ()))
 getMissingMigrations = do
   $logDebugS "Migration" "Retrieve applied migrations"
   appliedMigrations <- fmap (map E.unValue) . E.select . E.from $ \appliedMigration -> do    
-    E.where_ $ appliedMigration E.^. AppliedMigrationMigration `E.in_` E.valList universeF
     return $ appliedMigration E.^. AppliedMigrationMigration
-  return $ customMigrations `Map.withoutKeys` Set.fromList appliedMigrations
+  let migNotDone m _ = toPathPiece m `Set.notMember` Set.fromList appliedMigrations
+  return $ Map.filterWithKey migNotDone customMigrations
+    
 
 getMigrationTime :: ( MonadIO m
                     , BaseBackend backend ~ SqlBackend
@@ -190,4 +153,4 @@ getMigrationTime :: ( MonadIO m
                     )
                  => ManualMigration
                  -> ReaderT backend m (Maybe UTCTime)
-getMigrationTime = fmap (fmap appliedMigrationTime) . get . AppliedMigrationKey
+getMigrationTime = fmap (fmap appliedMigrationTime) . get . AppliedMigrationKey . toPathPiece

src/Model/Migration/Definitions.hs

@@ -1,7 +1,9 @@
--- 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-FileCopyrightText: 2022-24 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
 
+{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
+
 module Model.Migration.Definitions
   ( ManualMigration(..)
   , migrateManual
@@ -14,8 +16,8 @@ import Import.NoModel hiding (Max(..), Last(..))
 import Model
 import Model.Types.TH.PathPiece
 import Settings
-import Foundation.Type
+-- import Foundation.Type
-import Audit.Types
+-- import Audit.Types
 import qualified Model.Migration.Types as Legacy
 import qualified Data.Map as Map
 
@@ -28,16 +30,14 @@ import qualified Data.Conduit.List as C
 import Database.Persist.Sql
 import Database.Persist.Sql.Raw.QQ
 
-import Text.Read (readMaybe)
+-- import Text.Read (readMaybe)
 
-import Network.IP.Addr
+-- import Network.IP.Addr
 
-import qualified Data.Char as Char
+-- import qualified Data.Char as Char
-import qualified Data.CaseInsensitive as CI
+-- import qualified Data.CaseInsensitive as CI
 
-import qualified Data.Aeson as Aeson
+-- import qualified Data.Aeson as Aeson
-
-import Data.Conduit.Algorithms.FastCDC (FastCDCParameters(fastCDCMinBlockSize))
 
 import Data.Time.Format.ISO8601 (iso8601Show)
 import Data.Time.Format
@@ -47,53 +47,9 @@ import qualified Data.Time.Zones as TZ
 
 
 data ManualMigration
-  = Migration20180813SimplifyUserTheme
+  = Migration20230524QualificationUserBlock
-  | Migration20180813SheetJSONB
-  | Migration20180823SchoolShorthandPrimaryKey
-  | Migration20180918SheetCorrectorLoadJSON
-  | Migration20180918UserSurnames
-  | Migration20180918SheetUploadMode
-  | Migration20180928UserAuthentication
-  | Migration20181011UserNotificationSettings
-  | Migration20181031SheetTypeRefactor
-  | Migration20181129EncodedSecretBoxes
-  | Migration20181130SheetTypeRefactor
-  | Migration20190319CourseParticipantField
-  | Migration20190320BetterStudyShorthands
-  | Migration20190421MixedSheetSubmissions
-  | Migration20190429Tutorials
-  | Migration20190515Exams
-  | Migration20190715ExamOccurrenceName
-  | Migration20190726UserFirstNamesTitles
-  | Migration20190806TransactionLogIds
-  | Migration20190828UserFunction
-  | Migration20190912UserDisplayEmail
-  | Migration20190916ExamPartNumber
-  | Migration20190918ExamRulesRefactor
-  | Migration20190919ExamBonusRounding
-  | Migration20191002FavouriteReason
-  | Migration20191125UserLanguages
-  | Migration20191126ExamPartCorrector
-  | Migration20191128StudyFeaturesSuperField
-  | Migration20200111ExamOccurrenceRuleRefactor
-  | Migration20200218ExamResultPassedGrade
-  | Migration20200218ExamGradingModeMixed
-  | Migration20200218ExternalExamGradingModeMixed
-  | Migration20200424SubmissionGroups
-  | Migration20200504CourseParticipantState
-  | Migration20200506SessionFile
-  | Migration20200627FileRefactor
-  | Migration20200825StudyFeaturesFirstObserved
-  | Migration20200902FileChunking
-  | Migration20200916ExamMode
-  | Migration20201106StoredMarkup
-  | Migration20201119RoomTypes
-  | Migration20210115ExamPartsFrom
-  | Migration20210208StudyFeaturesRelevanceCachedUUIDs
-  | Migration20210318CrontabSubmissionRatedNotification
-  | Migration20210608SeparateTermActive
-  | Migration20230524QualificationUserBlock
   | Migration20230703LmsUserStatus
+  | Migration20240212InitInterfaceHealth        -- create table interface_health and fill with default values
   deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)
   deriving anyclass (Universe, Finite)
 
@@ -140,6 +96,9 @@ migrateManual = do
     , ("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\")")
+    , ("idx_lms_report_log_q_ident_time"     ,"CREATE INDEX idx_lms_report_log_q_ident_time ON \"lms_report_log\" (\"qualification\",\"ident\",\"timestamp\")")
+    , ("idx_user_company_company"            ,"CREATE INDEX idx_user_company_company ON \"user_company\" (\"company\")") -- composed index from unique cannot be used for frequently used filters on company
+    , ("idx_user_supervisor_user"            ,"CREATE INDEX idx_user_supervisor_user ON \"user_supervisor\" (\"user\")") -- composed index from unique cannot be used for frequently used filters on user
     ]
   where
     addIndex :: Text -> Sql -> Migration
@@ -176,692 +135,10 @@ migrateAlwaysSafe = do
 
 customMigrations :: forall m.
                     ( MonadResource m
-                    , MonadReader UniWorX m
+                    -- , MonadReader UniWorX m
                     )
                  => Map ManualMigration (ReaderT SqlBackend m ())
 customMigrations = mapF $ \case
-  Migration20180813SimplifyUserTheme -> whenM (columnExists "user" "theme") $ do -- New theme format
-    userThemes <- [sqlQQ| SELECT "id", "theme" FROM "user"; |]
-    forM_ userThemes $ \(uid, Single str) -> case stripPrefix "theme--" str of
-      Just v
-        | Just theme <- fromPathPiece v -> update uid [UserTheme =. theme]
-      other -> error $ "Could not parse theme: " <> show other
-
-  Migration20180813SheetJSONB -> whenM (tableExists "sheet") -- Better JSON encoding
-    [executeQQ|
-      ALTER TABLE "sheet" ALTER COLUMN "type" TYPE jsonb USING "type"::jsonb;
-      ALTER TABLE "sheet" ALTER COLUMN "grouping" TYPE jsonb USING "grouping"::jsonb;
-    |]
-
-  Migration20180823SchoolShorthandPrimaryKey -> whenM (columnExists "school" "id") $ do -- SchoolId is the Shorthand CI Text now
-    -- Read old table into memory
-    schoolTable <- [sqlQQ| SELECT "id", "shorthand" FROM "school"; |]
-    let _sT = schoolTable :: [(Single Int64, Single (CI Text))] -- Types needed
-    -- Convert columns containing SchoolId
-    whenM (tableExists "user_admin") $ do
-        [executeQQ|
-          ALTER TABLE "user_admin" DROP CONSTRAINT "user_admin_school_fkey";
-          ALTER TABLE "user_admin" ALTER COLUMN "school" TYPE citext USING "school"::citext;
-          |]
-        forM_ schoolTable $ \(Single idnr, Single ssh) ->
-          [executeQQ|
-            UPDATE "user_admin" SET "school" = #{ssh} WHERE "school" = #{tshow idnr};
-          |]
-        [executeQQ|
-          ALTER TABLE "user_admin" ADD CONSTRAINT "user_admin_school_fkey"
-            FOREIGN KEY (school) REFERENCES school(shorthand);
-          |]
-    whenM (tableExists "user_lecturer") $ do
-        [executeQQ|
-          ALTER TABLE "user_lecturer" DROP CONSTRAINT "user_lecturer_school_fkey";
-          ALTER TABLE "user_lecturer" ALTER COLUMN "school" TYPE citext USING "school"::citext;
-          |]
-        forM_ schoolTable $ \(Single idnr, Single ssh) ->
-          [executeQQ|
-            UPDATE "user_lecturer" SET "school" = #{ssh} WHERE "school" = #{tshow idnr};
-          |]
-        [executeQQ|
-          ALTER TABLE "user_lecturer" ADD CONSTRAINT "user_lecturer_school_fkey"
-              FOREIGN KEY (school) REFERENCES school(shorthand);
-          |]
-    whenM (tableExists "course") $ do
-        [executeQQ|
-          ALTER TABLE "course" DROP CONSTRAINT "course_school_fkey";
-          ALTER TABLE "course" ALTER COLUMN "school" TYPE citext USING "school"::citext;
-          |]
-        forM_ schoolTable $ \(Single idnr, Single ssh) ->
-          [executeQQ|
-            UPDATE "course" SET "school" = #{ssh} WHERE "school" = #{tshow idnr};
-          |]
-        [executeQQ|
-          ALTER TABLE "course" ADD CONSTRAINT "course_school_fkey"
-              FOREIGN KEY (school) REFERENCES school(shorthand);
-          |]
-    [executeQQ|
-      ALTER TABLE "school" DROP COLUMN "id";
-      ALTER TABLE "school" ADD PRIMARY KEY (shorthand);
-    |]
-
-  Migration20180918SheetCorrectorLoadJSON -> whenM (tableExists "sheet_corrector") $ do -- Load is encoded as JSON now.
-    correctorLoads <- [sqlQQ| SELECT "id", "load" FROM "sheet_corrector"; |]
-    forM_ correctorLoads $ \(uid, Single str) -> case readMaybe str of
-      Just load -> update uid [SheetCorrectorLoad =. load]
-      _other -> error $ "Could not parse Load: " <> show str
-    [executeQQ|
-      ALTER TABLE "sheet_corrector" ALTER COLUMN "load" TYPE jsonb USING "load"::jsonb;
-    |]
-
-  Migration20180918UserSurnames -> whenM (tableExists "user") $ do
-    userDisplayNames <- [sqlQQ| SELECT "id", "display_name" FROM "user"; |]
-    [executeQQ|
-      ALTER TABLE "user" ADD COLUMN IF NOT EXISTS "surname" text DEFAULT '';
-    |]
-    forM_ userDisplayNames $ \(uid, Single str) -> case lastMaybe $ words str of
-      Just name -> update uid [UserSurname =. name]
-      _other    -> error "Empty userDisplayName found"
-
-  Migration20180918SheetUploadMode -> whenM (tableExists "sheet")
-    [executeQQ|
-      ALTER TABLE "sheet" ADD COLUMN IF NOT EXISTS "upload_mode" jsonb DEFAULT '{ "tag": "Upload", "unpackZips": true }';
-    |]
-
-  Migration20180928UserAuthentication -> whenM (columnExists "user" "plugin")
-    -- <> is standard sql for /=
-    [executeQQ|
-      DELETE FROM "user" WHERE "plugin" <> 'LDAP';
-      ALTER TABLE "user" DROP COLUMN "plugin";
-      ALTER TABLE "user" ADD COLUMN IF NOT EXISTS "authentication" jsonb DEFAULT '"ldap"';
-    |]
-
-  Migration20181011UserNotificationSettings -> whenM (tableExists "user")
-    [executeQQ|
-      ALTER TABLE "user" ADD COLUMN IF NOT EXISTS "notification_settings" jsonb NOT NULL DEFAULT '[]';
-    |]
-
-  Migration20181031SheetTypeRefactor -> whenM (tableExists "sheet") $ do
-    sheets <- [sqlQQ| SELECT "id", "type" FROM "sheet"; |]
-    forM_ sheets $ \(sid, Single lsty) -> update sid [SheetType =. Legacy.sheetType lsty]
-  
-  Migration20181129EncodedSecretBoxes -> whenM (tableExists "cluster_config")
-    [executeQQ|
-       UPDATE "cluster_config" SET "setting" = 'secret-box-key' WHERE "setting" = 'error-message-key';
-    |]
-
-  Migration20181130SheetTypeRefactor -> whenM (tableExists "sheet")
-    [executeQQ|
-       UPDATE "sheet" SET "type" = json_build_object('type', "type"->'type', 'grading', "type"->'') WHERE jsonb_exists("type", '');
-       UPDATE "sheet" SET "type" = json_build_object('type', "type"->'type', 'grading', json_build_object('type', "type"->'grading'->'type', 'max', "type"->'grading'->'points')) WHERE ("type"->'grading'->'type') = '"points"' AND jsonb_exists("type"->'grading', 'points');
-       UPDATE "sheet" SET "type" = json_build_object('type', "type"->'type', 'grading', json_build_object('type', "type"->'grading'->'type', 'max', "type"->'grading'->'points', 'passing', 0)) WHERE ("type"->'grading'->'type') = '"pass-points"' AND jsonb_exists("type"->'grading', 'points');
-    |]
-
-  Migration20190319CourseParticipantField -> whenM ((\a b c -> a && b && not c) <$> tableExists "study_features" <*> tableExists "course_participant" <*> columnExists "course_participant" "field") $ do
-    [executeQQ|
-      ALTER TABLE "course_participant" ADD COLUMN "field" bigint DEFAULT null REFERENCES study_features(id);
-      ALTER TABLE "study_features" ADD COLUMN IF NOT EXISTS "valid" boolean NOT NULL DEFAULT true;
-    |]
-    users <- [sqlQQ| SELECT DISTINCT ON ("user"."id") "user"."id", "study_features"."id" FROM "user", "study_features" WHERE "study_features"."user" = "user"."id" AND "study_features"."valid" AND "study_features"."type" = 'FieldPrimary' ORDER BY "user"."id", random(); |]
-    forM_ users $ \(uid :: UserId, sfid :: StudyFeaturesId) -> [executeQQ| UPDATE "course_participant" SET "field" = #{sfid} WHERE "user" = #{uid} AND "field" IS NULL; |]
-
-  Migration20190320BetterStudyShorthands -> do
-    whenM (columnExists "study_degree" "shorthand") [executeQQ| UPDATE "study_degree" SET "shorthand" = NULL WHERE "shorthand" = '' |]
-    whenM (columnExists "study_degree" "name") [executeQQ| UPDATE "study_degree" SET "name" = NULL WHERE "shorthand" = '' |]
-    whenM (columnExists "study_terms" "shorthand") [executeQQ| UPDATE "study_terms" SET "shorthand" = NULL WHERE "shorthand" = '' |]
-    whenM (columnExists "study_terms" "name") [executeQQ| UPDATE "study_terms" SET "name" = NULL WHERE "shorthand" = '' |]
-
-  Migration20190421MixedSheetSubmissions -> whenM ((&&) <$> columnExists "sheet" "upload_mode" <*> columnExists "sheet" "submission_mode") $ do
-    sheetModes <- [sqlQQ| SELECT "id", "upload_mode", "submission_mode" FROM "sheet"; |]
-    [executeQQ|
-      ALTER TABLE "sheet" DROP COLUMN "upload_mode";
-      ALTER TABLE "sheet" ALTER COLUMN "submission_mode" DROP DEFAULT;
-      ALTER TABLE "sheet" ALTER COLUMN "submission_mode" TYPE jsonb USING 'null'::jsonb;
-    |]
-    forM_ sheetModes $ \(shid :: SheetId, unSingle -> uploadMode :: Legacy.UploadMode, unSingle -> submissionMode :: Legacy.SheetSubmissionMode ) -> do
-      let submissionMode' = case (submissionMode, uploadMode) of
-            ( Legacy.NoSubmissions       , _                   ) -> SubmissionMode False Nothing
-            ( Legacy.CorrectorSubmissions, _                   ) -> SubmissionMode True Nothing
-            ( Legacy.UserSubmissions     , Legacy.NoUpload     ) -> SubmissionMode False (Just NoUpload)
-            ( Legacy.UserSubmissions     , Legacy.Upload True  ) -> SubmissionMode False (Just $ UploadAny True defaultExtensionRestriction True)
-            ( Legacy.UserSubmissions     , Legacy.Upload False ) -> SubmissionMode False (Just $ UploadAny False defaultExtensionRestriction True)
-      [executeQQ| UPDATE "sheet" SET "submission_mode" = #{submissionMode'} WHERE "id" = #{shid}; |]
-
-  Migration20190429Tutorials -> whenM ((&&) <$> tableExists "tutorial" <*> tableExists "tutorial_user") $ do -- Tutorials were an unused stub before
-    tableDropEmpty "tutorial"
-    tableDropEmpty "tutorial_user"
-
-  Migration20190515Exams -> whenM (tableExists "exam") $ -- Exams were an unused stub before
-    tableDropEmpty "exam"
-
-  Migration20190715ExamOccurrenceName -> whenM ((&&) <$> tableExists "exam_occurrence" <*> (not <$> columnExists "exam_occurrence" "name")) $ do
-    examOccurrences <- [sqlQQ| SELECT "id" FROM "exam_occurrence" ORDER BY "exam"; |]
-    [executeQQ|
-      ALTER TABLE "exam_occurrence" ADD COLUMN "name" citext DEFAULT null;
-    |]
-    forM_ (zip [0..] examOccurrences) $ \(n :: Natural, Single eoId :: Single ExamOccurrenceId) -> do
-      let name = [st|occ-#{tshow n}|]
-      [executeQQ| UPDATE "exam_occurrence" SET "name" = #{name} WHERE "id" = #{eoId} |]
-    [executeQQ|
-      ALTER TABLE "exam_occurrence" ALTER COLUMN "name" DROP DEFAULT;
-      ALTER TABLE "exam_occurrence" ALTER COLUMN "name" SET NOT NULL;
-    |]
-
-  Migration20190726UserFirstNamesTitles -> whenM (tableExists "user") $ do
-    [executeQQ|
-      ALTER TABLE "user" ADD COLUMN "first_name" text NOT NULL DEFAULT '';
-      ALTER TABLE "user" ADD COLUMN "title" text DEFAULT null;
-    |]
-    let getUsers = rawQuery [st|SELECT "id", "display_name", "surname" FROM "user"|] []
-        updateUser (uid, firstName) = [executeQQ|UPDATE "user" SET "first_name" = #{firstName} WHERE "id" = #{uid}|]
-        splitFirstName :: [PersistValue] -> Maybe (UserId, Text)
-        splitFirstName [fromPersistValue -> Right uid, fromPersistValue -> Right displayName, fromPersistValue -> Right surname] = Just . (uid, ) $ if
-          | Just givenName <- Text.stripSuffix surname displayName
-                          <|> Text.stripPrefix surname displayName
-            -> Text.strip givenName
-          | otherwise
-            -> Text.replace surname "…" displayName
-        splitFirstName _ = Nothing
-    runConduit $ getUsers .| C.mapMaybe splitFirstName .| C.mapM_ updateUser
-
-  Migration20190806TransactionLogIds -> whenM (tableExists "transaction_log") $ do
-    [executeQQ|
-      UPDATE transaction_log SET remote = null WHERE remote = #{IPv4 loopbackIP4 :: IP} OR remote = #{IPv6 loopbackIP6 :: IP}
-    |]
-
-    [executeQQ|
-      ALTER TABLE transaction_log ADD COLUMN "initiator_id" bigint DEFAULT null;
-    |]
-
-    whenM (tableExists "user")
-      [executeQQ|
-        UPDATE transaction_log SET initiator_id = "user".id FROM "user" WHERE transaction_log.initiator = "user".ident;
-      |]
-
-    [executeQQ|
-      ALTER TABLE transaction_log DROP COLUMN initiator;
-      ALTER TABLE transaction_log RENAME COLUMN initiator_id TO initiator;
-      ALTER TABLE transaction_log ALTER COLUMN initiator DROP DEFAULT;
-    |]
-
-    let getLogEntries = rawQuery [st|SELECT id, info FROM transaction_log|] []
-        updateTransactionInfo [fromPersistValue -> Right lid, fromPersistValue -> Right (oldT :: Legacy.Transaction)] = do
-          newT <- case oldT of
-            Legacy.TransactionTermEdit tid
-              -> return . Just . TransactionTermEdit $ TermKey tid
-            Legacy.TransactionExamRegister (TermKey -> tid) (SchoolKey -> ssh) csh examn uident
-              -> runMaybeT $ do
-                guardM . lift $ tablesExist ["user", "exam", "course"]
-
-                cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
-                eid <- MaybeT . getKeyBy $ UniqueExam cid examn
-                uid <- MaybeT . getKeyBy $ UniqueAuthentication uident
-                return $ TransactionExamRegister eid uid
-            Legacy.TransactionExamDeregister (TermKey -> tid) (SchoolKey -> ssh) csh examn uident
-              -> runMaybeT $ do
-                guardM . lift $ tablesExist ["user", "exam", "course"]
-
-                cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
-                eid <- MaybeT . getKeyBy $ UniqueExam cid examn
-                uid <- MaybeT . getKeyBy $ UniqueAuthentication uident
-                return $ TransactionExamRegister eid uid
-          whenIsJust newT $ \newT' ->
-            update lid [ TransactionLogInfo =. toJSON newT' ]
-        updateTransactionInfo _ = return ()
-    runConduit $ getLogEntries .| C.mapM_ updateTransactionInfo
-
-  Migration20190828UserFunction -> do
-    [executeQQ|
-      CREATE TABLE IF NOT EXISTS "user_function" ( "id" serial8 primary key, "user" bigint, "school" citext, "function" text );
-    |]
-
-    whenM (tableExists "user_admin") $ do
-      let getAdminEntries = rawQuery [st|SELECT user_admin.id, user_admin.user, user_admin.school FROM user_admin;|] []
-          moveAdminEntry [fromPersistValue -> Right (eId :: Int64), fromPersistValue -> Right (uid :: UserId), fromPersistValue -> Right (sid :: SchoolId)] =
-            [executeQQ|
-              INSERT INTO "user_function" ("user", "school", "function") VALUES (#{uid}, #{sid}, #{SchoolAdmin});
-              DELETE FROM "user_admin" WHERE "id" = #{eId};
-            |]
-          moveAdminEntry _ = return ()
-      runConduit $ getAdminEntries .| C.mapM_ moveAdminEntry
-      tableDropEmpty "user_admin"
-    whenM (tableExists "user_lecturer") $ do
-      let getLecturerEntries = rawQuery [st|SELECT user_lecturer.id, user_lecturer.user, user_lecturer.school FROM user_lecturer;|] []
-          moveLecturerEntry [fromPersistValue -> Right (eId :: Int64), fromPersistValue -> Right (uid :: UserId), fromPersistValue -> Right (sid :: SchoolId)] =
-            [executeQQ|
-              INSERT INTO "user_function" ("user", "school", "function") VALUES (#{uid}, #{sid}, #{SchoolLecturer});
-              DELETE FROM "user_lecturer" WHERE "id" = #{eId};
-            |]
-          moveLecturerEntry _ = return ()
-      runConduit $ getLecturerEntries .| C.mapM_ moveLecturerEntry
-      tableDropEmpty "user_lecturer"
-    whenM (tableExists "invitation") $ do
-      [executeQQ|
-        DELETE FROM "invitation" WHERE "for"->'junction' = '"UserLecturer"';
-      |]
-
-  Migration20190912UserDisplayEmail -> whenM (tableExists "user") $ do
-    [executeQQ|
-      ALTER TABLE "user" ADD COLUMN IF NOT EXISTS "display_email" citext;
-      UPDATE "user" SET "display_email" = "email" WHERE "display_email" IS NULL;
-      ALTER TABLE "user" ALTER COLUMN "display_email" SET NOT NULL;
-    |]
-
-  Migration20190916ExamPartNumber -> whenM (tableExists "exam_part") $ do
-    [executeQQ|
-      ALTER TABLE "exam_part" ADD COLUMN IF NOT EXISTS "number" citext;
-    |]
-
-    let getExamEntries = rawQuery [st|SELECT DISTINCT exam FROM exam_part ORDER BY exam;|] []
-        renameExamParts [fromPersistValue -> Right (eId :: ExamId)] = do
-          partNames' <- [sqlQQ|SELECT id, name FROM "exam_part" WHERE exam = #{eId};|]
-          let
-            partNames :: [(ExamPartId, ExamPartName)]
-            partNames = foldMap (\(Single epId, Single pName) -> singletonMap epId pName) partNames'
-
-            partsSorted = partNames
-              & sortOn ( map (\x -> maybe (Left x) Right (readMay x :: Maybe Integer))
-                       . groupBy ((==) `on` Char.isDigit)
-                       . CI.foldedCase
-                       . snd
-                       )
-              & map fst
-          forM_ (zip [_ExamPartNumber' # 1..] partsSorted) $ \(num :: ExamPartNumber, pId) ->
-            [executeQQ|
-              UPDATE "exam_part" SET "number" = #{num} WHERE "id" = #{pId};
-            |]
-        renameExamParts _ = return ()
-    runConduit $ getExamEntries .| C.mapM_ renameExamParts
-
-  Migration20190918ExamRulesRefactor -> whenM (tableExists "exam") $ do
-    oldVersion <- columnExists "exam" "grading_key"
-    if
-      | oldVersion -> do
-        -- Major changes happend to the structure of exams without appropriate
-        -- migration, try to remedy that here
-        tableDropEmpty "exam_part_corrector"
-        tableDropEmpty "exam_corrector"
-        tableDropEmpty "exam_result"
-        tableDropEmpty "exam_registration"
-        tableDropEmpty "exam_occurrence"
-        tableDropEmpty "exam_part"
-        tableDropEmpty "exam"
-      | otherwise ->
-        [executeQQ|
-          ALTER TABLE "exam" ALTER COLUMN "grading_rule" DROP NOT NULL;
-          ALTER TABLE "exam" ALTER COLUMN "bonus_rule" DROP NOT NULL;
-          ALTER TABLE "exam" ALTER COLUMN "occurrence_rule" DROP NOT NULL;
-
-          UPDATE "exam" SET "grading_rule" = NULL WHERE "grading_rule"->>'rule' = 'manual';
-          UPDATE "exam" SET "bonus_rule" = NULL WHERE "bonus_rule"->>'rule' = 'no-bonus';
-          UPDATE "exam" SET "occurrence_rule" = NULL WHERE "occurrence_rule" = '"manual"';
-
-          UPDATE "exam" SET "occurrence_rule" = json_build_object('rule', "occurrence_rule");
-        |]
-
-  Migration20190919ExamBonusRounding -> whenM (tableExists "exam")
-    [executeQQ|
-      UPDATE "exam" SET "bonus_rule" = jsonb_insert("bonus_rule", '{round}' :: text[], '0.01' :: jsonb) WHERE "bonus_rule"->>'rule' = 'bonus-points';
-    |]
-
-  Migration20191002FavouriteReason -> whenM (tableExists "course_favourite")
-    [executeQQ|
-      ALTER TABLE "course_favourite" RENAME COLUMN "time" TO "last_visit";
-      ALTER TABLE "course_favourite" ADD COLUMN "reason" jsonb DEFAULT '"visited"'::jsonb;
-    |]
-
-  Migration20191125UserLanguages -> whenM (tableExists "user")
-    [executeQQ|
-      ALTER TABLE "user" ADD COLUMN "languages" jsonb;
-      UPDATE "user" SET "languages" = "mail_languages" where "mail_languages" <> '[]';
-      ALTER TABLE "user" DROP COLUMN "mail_languages";
-    |]
-
-  Migration20191126ExamPartCorrector -> whenM (tableExists "exam_part_corrector") $
-    tableDropEmpty "exam_part_corrector"
-
-  Migration20191128StudyFeaturesSuperField -> whenM (tableExists "study_features")
-    [executeQQ|
-      ALTER TABLE "study_features" ADD COLUMN "super_field" bigint;
-      UPDATE "study_features" SET "super_field" = "field", "field" = "sub_field" WHERE NOT ("sub_field" IS NULL);
-      ALTER TABLE "study_features" DROP COLUMN "sub_field";
-    |]
-
-  Migration20200111ExamOccurrenceRuleRefactor -> whenM (tableExists "exam")
-    [executeQQ|
-      UPDATE "exam" SET "occurrence_rule" = #{ExamRoomManual} WHERE "occurrence_rule" IS NULL;
-      ALTER TABLE "exam" ALTER COLUMN "occurrence_rule" SET NOT NULL;
-    |]
-
-  Migration20200218ExamResultPassedGrade -> whenM ((&&) <$> tableExists "exam" <*> tableExists "exam_result") $ do
-    queryRes <- [sqlQQ|SELECT exam_result.id, exam_result.result FROM exam_result INNER JOIN exam ON exam_result.exam = exam.id WHERE NOT exam.show_grades;|]
-    forM_ queryRes $ \(resId :: ExamResultId, Single (res :: ExamResultGrade)) ->
-      let res' :: ExamResultPassedGrade
-          res' = Left . view passingGrade <$> res
-       in [executeQQ|UPDATE exam_result SET result = #{res'} WHERE id = #{resId};|]
-
-  Migration20200218ExamGradingModeMixed -> whenM (tableExists "exam")
-    [executeQQ|
-      ALTER TABLE "exam" ADD COLUMN "grading_mode" character varying;
-      UPDATE "exam" SET "grading_mode" = 'grades' WHERE "show_grades";
-      UPDATE "exam" SET "grading_mode" = 'pass' WHERE NOT "show_grades";
-      ALTER TABLE "exam" DROP COLUMN "show_grades";
-      ALTER TABLE "exam" ALTER COLUMN "grading_mode" SET NOT NULL;
-    |]
-
-  Migration20200218ExternalExamGradingModeMixed -> whenM (tableExists "external_exam")
-    [executeQQ|
-      ALTER TABLE "external_exam" ADD COLUMN "grading_mode" character varying;
-      UPDATE "external_exam" SET "grading_mode" = 'grades' WHERE "show_grades";
-      UPDATE "external_exam" SET "grading_mode" = 'pass' WHERE NOT "show_grades";
-      ALTER TABLE "external_exam" DROP COLUMN "show_grades";
-      ALTER TABLE "external_exam" ALTER COLUMN "grading_mode" SET NOT NULL;
-    |]
-
-  Migration20200424SubmissionGroups -> do
-    whenM (tableExists "submission_group") $
-      tableDropEmpty "submission_group"
-    whenM (tableExists "submission_group_edit") $
-      tableDropEmpty "submission_group_edit"
-
-  Migration20200504CourseParticipantState -> whenM (tableExists "course_participant") $ do
-    [executeQQ|
-      ALTER TABLE "course_participant" ADD COLUMN "state" text NOT NULL DEFAULT 'active';
-      ALTER TABLE "course_participant" ALTER COLUMN "state" DROP DEFAULT;
-    |]
-    let getAuditLog = rawQuery [st|SELECT DISTINCT ON ("info") "info", max("time") FROM "transaction_log" GROUP BY "info" ORDER BY "info";|] []
-        ensureParticipant :: [PersistValue] -> ReaderT SqlBackend m ()
-        ensureParticipant [fmap Aeson.fromJSON . fromPersistValue -> Right (Aeson.Success TransactionCourseParticipantEdit{..}), fromPersistValue -> Right (time :: UTCTime)] = do
-          whenM (existsKey transactionCourse `and2M` existsKey transactionUser)
-            [executeQQ|INSERT INTO "course_participant" ("course", "user", "registration", "state") VALUES (#{transactionCourse}, #{transactionUser}, #{time}, #{CourseParticipantInactive False}) ON CONFLICT DO NOTHING;|]
-        ensureParticipant _ = return ()
-    runConduit $ getAuditLog .| C.mapM_ ensureParticipant
-
-  Migration20200506SessionFile -> whenM (tableExists "session_file") $
-    tableDropEmpty "session_file"
-
-  Migration20200627FileRefactor -> whenM (tableExists "file") $ do
-    [executeQQ|
-      ALTER TABLE "file" ADD COLUMN "hash" BYTEA;
-      UPDATE "file" SET "hash" = digest("content", 'sha3-512');
-    |]
-
-    let
-      migrateFromFile :: forall fRef.
-                         ( HasFileReference fRef
-                         , PersistRecordBackend fRef SqlBackend
-                         )
-                      => ([PersistValue] -> (Key fRef, FileReferenceResidual fRef))
-                      -> (Entity fRef -> ReaderT SqlBackend m ())
-                      -> [PersistValue]
-                      -> ReaderT SqlBackend m ()
-      migrateFromFile toResidual doUpdate ((fromPersistValue -> Right (fId :: Int64)):rest) = do
-        let (fRefKey, residual) = toResidual rest
-        fileDat <- [sqlQQ|
-          SELECT "file".title, "file".modified, "file".hash FROM "file" WHERE "id" = #{fId};
-        |]
-        forM_ fileDat $ \case
-          (fromPersistValue . unSingle -> Right (fileReferenceTitle' :: FilePath), fromPersistValue . unSingle -> Right fileReferenceModified, fromPersistValue . unSingle -> Right fileReferenceContent) -> do
-            let fileRef fileReferenceTitle = _FileReference # (FileReference{..}, residual)
-                candidateTitles = fileReferenceTitle' : [ fName <.> ("old-" <> show n) <.> ext | n <- [1..1000] ]
-                  where (fName, ext) = splitExtension fileReferenceTitle'
-            validTitles <- dropWhileM (fmap (is _Just) . checkUnique . fileRef) candidateTitles
-            case validTitles of
-              fTitle : _ -> doUpdate . Entity fRefKey $ fileRef fTitle
-              _other -> error "Could not make validTitle"
-          _other -> return ()
-      migrateFromFile _ _ _ = return ()
-
-    whenM (tableExists "submission_file") $ do
-      [executeQQ|
-        ALTER TABLE "submission_file" ADD COLUMN "title" VARCHAR;
-        ALTER TABLE "submission_file" ADD COLUMN "content" BYTEA NULL;
-        ALTER TABLE "submission_file" ADD COLUMN "modified" TIMESTAMP WITH TIME ZONE;
-        ALTER TABLE "submission_file" DROP CONSTRAINT "unique_submission_file";
-        ALTER TABLE "submission_file" ADD CONSTRAINT "unique_submission_file" UNIQUE("submission", "title", "is_update");
-      |]
-      let getSubmissionFiles = [queryQQ|SELECT "file", "submission_file"."id", "submission", "is_update", "is_deletion" FROM "submission_file" LEFT OUTER JOIN "file" ON "submission_file"."file" = "file".id ORDER BY "file"."modified" DESC;|]
-          toResidual [ fromPersistValue -> Right sfId
-                     , fromPersistValue -> Right submissionFileResidualSubmission
-                     , fromPersistValue -> Right submissionFileResidualIsUpdate
-                     , fromPersistValue -> Right submissionFileResidualIsDeletion
-                     ]
-                     = (sfId, SubmissionFileResidual{..})
-          toResidual _ = error "Could not convert SubmissionFile to residual"
-      runConduit $ getSubmissionFiles .| C.mapM_ (migrateFromFile @SubmissionFile toResidual replaceEntity)
-      [executeQQ|
-        ALTER TABLE "submission_file" DROP COLUMN "file";
-      |]
-
-    whenM (tableExists "sheet_file") $ do
-      [executeQQ|
-        ALTER TABLE "sheet_file" ADD COLUMN "title" VARCHAR;
-        ALTER TABLE "sheet_file" ADD COLUMN "content" BYTEA NULL;
-        ALTER TABLE "sheet_file" ADD COLUMN "modified" TIMESTAMP WITH TIME ZONE;
-        ALTER TABLE "sheet_file" DROP CONSTRAINT "unique_sheet_file";
-        ALTER TABLE "sheet_file" ADD CONSTRAINT "unique_sheet_file" UNIQUE("sheet", "type", "title");
-      |]
-      let getSheetFiles = [queryQQ|SELECT "file", "sheet_file"."id", "sheet", "type" FROM "sheet_file" LEFT OUTER JOIN "file" ON "sheet_file"."file" = "file".id ORDER BY "file"."modified" DESC;|]
-          toResidual [ fromPersistValue -> Right shfId
-                     , fromPersistValue -> Right sheetFileResidualSheet
-                     , fromPersistValue -> Right sheetFileResidualType
-                     ]
-                     = (shfId, SheetFileResidual{..})
-          toResidual _ = error "Could not convert SheetFile to residual"
-      runConduit $ getSheetFiles .| C.mapM_ (migrateFromFile @SheetFile toResidual replaceEntity)
-      [executeQQ|
-        ALTER TABLE "sheet_file" DROP COLUMN "file";
-      |]
-
-    whenM (tableExists "course_news_file") $ do
-      [executeQQ|
-        ALTER TABLE "course_news_file" ADD COLUMN "title" VARCHAR;
-        ALTER TABLE "course_news_file" ADD COLUMN "content" BYTEA NULL;
-        ALTER TABLE "course_news_file" ADD COLUMN "modified" TIMESTAMP WITH TIME ZONE;
-        ALTER TABLE "course_news_file" DROP CONSTRAINT "unique_course_news_file";
-        ALTER TABLE "course_news_file" ADD CONSTRAINT "unique_course_news_file" UNIQUE("news", "title");
-      |]
-      let getCourseNewsFiles = [queryQQ|SELECT "file", "course_news_file"."id", "news" FROM "course_news_file" LEFT OUTER JOIN "file" ON "course_news_file"."file" = "file".id ORDER BY "file"."modified" DESC;|]
-          toResidual [ fromPersistValue -> Right cnfId
-                     , fromPersistValue -> Right courseNewsFileResidualNews
-                     ]
-                     = (cnfId, CourseNewsFileResidual{..})
-          toResidual _ = error "Could not convert CourseNewsFile to residual"
-      runConduit $ getCourseNewsFiles .| C.mapM_ (migrateFromFile @CourseNewsFile toResidual replaceEntity)
-      [executeQQ|
-        ALTER TABLE "course_news_file" DROP COLUMN "file";
-      |]
-
-    whenM (tableExists "material_file") $ do
-      [executeQQ|
-        ALTER TABLE "material_file" ADD COLUMN "title" VARCHAR;
-        ALTER TABLE "material_file" ADD COLUMN "content" BYTEA NULL;
-        ALTER TABLE "material_file" ADD COLUMN "modified" TIMESTAMP WITH TIME ZONE;
-        ALTER TABLE "material_file" DROP CONSTRAINT "unique_material_file";
-        ALTER TABLE "material_file" ADD CONSTRAINT "unique_material_file" UNIQUE("material", "title");
-      |]
-      let getMaterialFiles = [queryQQ|SELECT "file", "material_file"."id", "material" FROM "material_file" LEFT OUTER JOIN "file" ON "material_file"."file" = "file".id ORDER BY "file"."modified" DESC;|]
-          toResidual [ fromPersistValue -> Right shfId
-                     , fromPersistValue -> Right materialFileResidualMaterial
-                     ]
-                     = (shfId, MaterialFileResidual{..})
-          toResidual _ = error "Could not convert MaterialFile to residual"
-      runConduit $ getMaterialFiles .| C.mapM_ (migrateFromFile @MaterialFile toResidual replaceEntity)
-      [executeQQ|
-        ALTER TABLE "material_file" DROP COLUMN "file";
-      |]
-
-    whenM (tableExists "session_file")
-      [executeQQ|
-        ALTER TABLE "session_file" ADD COLUMN "content" BYTEA;
-        UPDATE "session_file" SET "content" = (SELECT "hash" FROM "file" WHERE "file".id = "session_file"."file");
-        ALTER TABLE "session_file" DROP COLUMN "file";
-      |]
-
-    [executeQQ|
-      ALTER TABLE "file" RENAME TO "file_content";
-      DELETE FROM "file_content" WHERE "content" IS NULL OR "hash" IS NULL;
-    |]
-    [executeQQ|
-      DELETE FROM "file_content"
-      WHERE "id" IN (
-          SELECT
-              "id"
-          FROM (
-              SELECT
-                  "id",
-                  ROW_NUMBER() OVER w AS rnum
-              FROM "file_content"
-              WINDOW w AS (
-                  PARTITION BY "hash"
-                  ORDER BY "id"
-              )
-          ) as t
-      WHERE t.rnum > 1);
-    |]
-    [executeQQ|
-      ALTER TABLE "file_content" DROP COLUMN "title";
-      ALTER TABLE "file_content" DROP COLUMN "modified";
-      ALTER TABLE "file_content" DROP COLUMN "id";
-    |]
-
-  Migration20200825StudyFeaturesFirstObserved -> whenM (tableExists "study_features")
-    [executeQQ|
-      ALTER TABLE study_features RENAME updated TO last_observed;
-      ALTER TABLE study_features ADD COLUMN first_observed timestamp with time zone;
-      UPDATE study_features SET first_observed = (SELECT MAX(last_observed) FROM study_features as other WHERE other."user" = study_features."user" AND other.degree = study_features.degree AND other.field = study_features.field AND other.type = study_features.type AND other.semester = study_features.semester - 1);
-    |]
-
-  Migration20200902FileChunking -> whenM (tableExists "file_content") $ do
-    chunkingParams <- lift $ view _appFileChunkingParams
-
-    [executeQQ|
-      ALTER TABLE file_content RENAME TO file_content_chunk;
-      ALTER INDEX file_content_pkey RENAME TO file_content_chunk_pkey;
-
-      CREATE TABLE file_content_chunk_unreferenced (id bigserial, hash bytea NOT NULL, since timestamp with time zone NOT NULL);
-      INSERT INTO file_content_chunk_unreferenced (since, hash) (SELECT unreferenced_since as since, hash FROM file_content_chunk WHERE NOT (unreferenced_since IS NULL));
-      ALTER TABLE file_content_chunk DROP COLUMN unreferenced_since;
-
-      ALTER TABLE file_content_chunk ADD COLUMN content_based boolean NOT NULL DEFAULT false;
-      UPDATE file_content_chunk SET content_based = true WHERE length(content) <= #{fastCDCMinBlockSize chunkingParams};
-
-      CREATE TABLE file_content_entry (id bigserial NOT NULL PRIMARY KEY, hash bytea NOT NULL, ix bigint NOT NULL, chunk_hash bytea NOT NULL);
-      INSERT INTO file_content_entry (hash, chunk_hash, ix) (SELECT hash, hash as chunk_hash, 0 as ix FROM file_content_chunk);
-    |]
-
-  Migration20200916ExamMode -> do
-    whenM (tableExists "exam")
-      [executeQQ|
-        ALTER TABLE exam ADD COLUMN "exam_mode" jsonb NOT NULL DEFAULT #{ExamMode Nothing Nothing Nothing Nothing};
-      |]
-    whenM (tableExists "school")
-      [executeQQ|
-        ALTER TABLE school ADD COLUMN "exam_discouraged_modes" jsonb NOT NULL DEFAULT #{ExamModeDNF predDNFFalse};
-      |]
-
-  Migration20201106StoredMarkup ->
-    [executeQQ|
-      SET client_min_messages TO WARNING;
-      ALTER TABLE IF EXISTS ^{Course} ALTER COLUMN @{CourseDescription} TYPE jsonb USING (CASE WHEN @{CourseDescription} IS NOT NULL THEN to_json(@{CourseDescription}) ELSE NULL END);
-      ALTER TABLE IF EXISTS ^{CourseEvent} ALTER COLUMN @{CourseEventNote} TYPE jsonb USING (CASE WHEN @{CourseEventNote} IS NOT NULL THEN to_json(@{CourseEventNote}) ELSE NULL END);
-      ALTER TABLE IF EXISTS ^{CourseUserNote} ALTER COLUMN @{CourseUserNoteNote} TYPE jsonb USING (CASE WHEN @{CourseUserNoteNote} IS NOT NULL THEN to_json(@{CourseUserNoteNote}) ELSE NULL END);
-      ALTER TABLE IF EXISTS ^{Material} ALTER COLUMN @{MaterialDescription} TYPE jsonb USING (CASE WHEN @{MaterialDescription} IS NOT NULL THEN to_json(@{MaterialDescription}) ELSE NULL END);
-      ALTER TABLE IF EXISTS ^{CourseNews} ALTER COLUMN @{CourseNewsContent} TYPE jsonb USING (CASE WHEN @{CourseNewsContent} IS NOT NULL THEN to_json(@{CourseNewsContent}) ELSE NULL END);
-      ALTER TABLE IF EXISTS ^{CourseNews} ALTER COLUMN @{CourseNewsSummary} TYPE jsonb USING (CASE WHEN @{CourseNewsSummary} IS NOT NULL THEN to_json(@{CourseNewsSummary}) ELSE NULL END);
-      ALTER TABLE IF EXISTS ^{Exam} ALTER COLUMN @{ExamDescription} TYPE jsonb USING (CASE WHEN @{ExamDescription} IS NOT NULL THEN to_json(@{ExamDescription}) ELSE NULL END);
-      ALTER TABLE IF EXISTS ^{ExamOccurrence} ALTER COLUMN @{ExamOccurrenceDescription} TYPE jsonb USING (CASE WHEN @{ExamOccurrenceDescription} IS NOT NULL THEN to_json(@{ExamOccurrenceDescription}) ELSE NULL END);
-      ALTER TABLE IF EXISTS ^{Sheet} ALTER COLUMN @{SheetDescription} TYPE jsonb USING (CASE WHEN @{SheetDescription} IS NOT NULL THEN to_json(@{SheetDescription}) ELSE NULL END);
-      ALTER TABLE IF EXISTS ^{Sheet} ALTER COLUMN @{SheetMarkingText} TYPE jsonb USING (CASE WHEN @{SheetMarkingText} IS NOT NULL THEN to_json(@{SheetMarkingText}) ELSE NULL END);
-      ALTER TABLE IF EXISTS ^{SystemMessage} ALTER COLUMN @{SystemMessageContent} TYPE jsonb USING (CASE WHEN @{SystemMessageContent} IS NOT NULL THEN to_json(@{SystemMessageContent}) ELSE NULL END);
-      ALTER TABLE IF EXISTS ^{SystemMessage} ALTER COLUMN @{SystemMessageSummary} TYPE jsonb USING (CASE WHEN @{SystemMessageSummary} IS NOT NULL THEN to_json(@{SystemMessageSummary}) ELSE NULL END);
-      ALTER TABLE IF EXISTS ^{SystemMessageTranslation} ALTER COLUMN @{SystemMessageTranslationContent} TYPE jsonb USING (CASE WHEN @{SystemMessageTranslationContent} IS NOT NULL THEN to_json(@{SystemMessageTranslationContent}) ELSE NULL END);
-      ALTER TABLE IF EXISTS ^{SystemMessageTranslation} ALTER COLUMN @{SystemMessageTranslationSummary} TYPE jsonb USING (CASE WHEN @{SystemMessageTranslationSummary} IS NOT NULL THEN to_json(@{SystemMessageTranslationSummary}) ELSE NULL END);
-      SET client_min_messages TO NOTICE;
-    |]
-
-  Migration20201119RoomTypes -> do
-    whenM (tableExists "exam_occurrence") $ do
-      [executeQQ|ALTER TABLE "exam_occurrence" ADD COLUMN "room_json" jsonb|]
-      let getExamOccurrences = [queryQQ|SELECT "id", "room" FROM "exam_occurrence"|]
-          migrateExamOccurrence [ fromPersistValue -> Right (eoId :: ExamOccurrenceId), fromPersistValue -> Right roomText ] = [executeQQ|UPDATE "exam_occurrence" SET "room_json" = #{RoomReferenceSimple roomText} WHERE "id" = #{eoId}|]
-          migrateExamOccurrence _ = return ()
-       in runConduit $ getExamOccurrences .| C.mapM_ migrateExamOccurrence
-      [executeQQ|
-        ALTER TABLE "exam_occurrence" DROP COLUMN "room";
-        ALTER TABLE "exam_occurrence" RENAME COLUMN "room_json" TO "room";
-      |]
-    whenM (tableExists "tutorial") $ do
-      [executeQQ|ALTER TABLE "tutorial" ADD COLUMN "room_json" jsonb|]
-      let getTutorials = [queryQQ|SELECT "id", "room" FROM "tutorial"|]
-          migrateTutorial [ fromPersistValue -> Right (tutId :: TutorialId), fromPersistValue -> Right roomText ] = [executeQQ|UPDATE "tutorial" SET "room_json" = #{RoomReferenceSimple roomText} WHERE "id" = #{tutId}|]
-          migrateTutorial _ = return ()
-       in runConduit $ getTutorials .| C.mapM_ migrateTutorial
-      [executeQQ|
-        ALTER TABLE "tutorial" DROP COLUMN "room";
-        ALTER TABLE "tutorial" RENAME COLUMN "room_json" TO "room";
-      |]
-    whenM (tableExists "course_event") $ do
-      [executeQQ|ALTER TABLE "course_event" ADD COLUMN "room_json" jsonb|]
-      let getCourseEvents = [queryQQ|SELECT "id", "room" FROM "course_event"|]
-          migrateCourseEvent [ fromPersistValue -> Right (ceId :: CourseEventId), fromPersistValue -> Right roomText ] = [executeQQ|UPDATE "course_event" SET "room_json" = #{RoomReferenceSimple roomText} WHERE "id" = #{ceId}|]
-          migrateCourseEvent _ = return ()
-       in runConduit $ getCourseEvents .| C.mapM_ migrateCourseEvent
-      [executeQQ|
-        ALTER TABLE "course_event" DROP COLUMN "room";
-        ALTER TABLE "course_event" RENAME COLUMN "room_json" TO "room";
-      |]
-    whenM (tableExists "course") $ do
-      let getCourses = [queryQQ|SELECT "id", "link_external" FROM "course"|]
-          migrateCourse [ fromPersistValue -> Right (cId :: CourseId), fromPersistValue -> Right (uriText :: Maybe Text) ]
-            | Just uri <- parseURI . unpack =<< uriText = [executeQQ|UPDATE "course" SET "link_external" = #{uri} WHERE "id" = #{cId}|]
-            | otherwise = [executeQQ|UPDATE "course" SET "link_external" = NULL WHERE "id" = #{cId}|]
-          migrateCourse _ = return ()
-       in runConduit $ getCourses .| C.mapM_ migrateCourse
-
-  Migration20210115ExamPartsFrom -> do
-    whenM (tableExists "exam") $ do
-      [executeQQ|ALTER TABLE "exam" ADD COLUMN "parts_from" timestamp with time zone|]
-      let getExam = [queryQQ|SELECT "id", "finished" FROM "exam"|]
-          migrateExam [ fromPersistValue -> Right (eId :: ExamId), fromPersistValue -> Right (finished :: Maybe UTCTime) ] = [executeQQ|UPDATE "exam" SET "parts_from" = #{finished} WHERE "id" = #{eId}|]
-          migrateExam _ = return ()
-       in runConduit $ getExam .| C.mapM_ migrateExam
-
-  Migration20210208StudyFeaturesRelevanceCachedUUIDs ->
-    whenM (tableExists "study_features") $ do
-      [executeQQ|
-        ALTER TABLE "study_features" ADD COLUMN "relevance_cached_uuid" uuid
-      |]
-
-      let getStudyFeatures = [queryQQ|SELECT "id" FROM "study_features" WHERE relevance_cached|]
-          migrateStudyFeatures genUUID lift' [ fromPersistValue -> Right (sfId :: StudyFeaturesId) ] = do
-            uuid <- genUUID
-            lift' [executeQQ|UPDATE "study_features" SET "relevance_cached_uuid" = #{uuid} WHERE "id" = #{sfId}|]
-          migrateStudyFeatures _ _ _ = return ()
-       in runConduit $ getStudyFeatures .| randUUIDC (\genUUID lift' -> C.mapM_ $ migrateStudyFeatures genUUID lift')
-
-      [executeQQ|
-        ALTER TABLE "study_features" DROP COLUMN "relevance_cached";
-        ALTER TABLE "study_features" RENAME COLUMN "relevance_cached_uuid" TO "relevance_cached";
-      |]
-
-  -- Placeholder to inform crontab generation when switchover happened so old submissions don't get notified as corrected
-  Migration20210318CrontabSubmissionRatedNotification -> return ()
-
-  Migration20210608SeparateTermActive -> do
-    now <- liftIO getCurrentTime
-
-    whenM (and2M (tableExists "term") (not <$> tableExists "term_active")) $ do
-      [executeQQ|
-        CREATE TABLE "term_active" ("id" SERIAL8 PRIMARY KEY UNIQUE, "term" numeric(5,1) NOT NULL, "from" timestamp with time zone NOT NULL)
-      |]
-
-      let getTerms = [queryQQ|SELECT "name", "active" FROM "term"|]
-          migrateTerms [ fromPersistValue -> Right (tid :: TermId), fromPersistValue -> Right (isActive :: Bool) ] = when isActive
-            [executeQQ|INSERT INTO term_active (term, "from") VALUES (#{tid}, #{now})|]
-          migrateTerms _ = return ()
-       in runConduit $ getTerms .| C.mapM_ migrateTerms
-
-      [executeQQ|
-        ALTER TABLE "term" DROP COLUMN "active";
-      |]
 
   Migration20230524QualificationUserBlock ->
     whenM (andM [ not <$> tableExists "qualification_user_block"
@@ -901,6 +178,25 @@ customMigrations = mapF $ \case
         ;  
       |]
 
+  Migration20240212InitInterfaceHealth ->
+    unlessM (tableExists "interface_health") $ do -- fill health table with some defaults
+      [executeQQ|
+        CREATE TABLE "interface_health"
+          ( id BIGSERIAL NOT NULL 
+          , interface CHARACTER VARYING NOT NULL 
+          , subtype   CHARACTER VARYING 
+          , write     BOOLEAN 
+          , hours     BIGINT NOT NULL 
+          , PRIMARY KEY(id) 
+          , CONSTRAINT unique_interface_health UNIQUE(interface, subtype, write) 
+          ); 
+        INSERT INTO "interface_health" ("interface", "subtype", "write", "hours") 
+        VALUES 
+            ('Printer', 'Acknowledge', True, 168) 
+          , ('AVS'    , 'Synch'      , True , 96) 
+        ON CONFLICT DO NOTHING; 
+      |]    
+
 
 tableExists :: MonadIO m => Text -> ReaderT SqlBackend m Bool
 tableExists table = do

src/Model/Types/Common.hs

@@ -43,6 +43,7 @@ type SchoolShorthand      = CI Text
 
 type CompanyName          = CI Text
 type CompanyShorthand     = CI Text
+type Companies            = [CI Text]
 
 type CourseName           = CI Text
 type CourseShorthand      = CI Text

src/Model/Types/Lms.hs

@@ -12,8 +12,8 @@ module Model.Types.Lms
   ) where
 
 import Import.NoModel
-import qualified Data.Map as Map
+-- import qualified Data.Map as Map
-import Data.Map ((!))
+-- import Data.Map ((!))
 import Database.Persist.Sql 
 import qualified Database.Esqueleto.Experimental as E
 import qualified Data.Csv as Csv
@@ -56,27 +56,37 @@ instance Csv.ToField LmsStatus where
 
 
 -- | Default Block/Unblock reasons
-data QualificationBlockStandardReason
+data QualificationStandardReason
-      = QualificationBlockFailedELearning
+      = QualificationRenewELearningBy       LmsIdent
+      | QualificationBlockFailedELearningBy LmsIdent
+      | QualificationBlockFailedELearning      
       | QualificationBlockReturnedByCompany
       | QualificationBlockExpired
-  deriving (Eq, Ord, Enum, Bounded, Universe, Finite)
       
-instance Show QualificationBlockStandardReason where
+  -- deriving (Eq, Ord, Enum, Bounded, Universe, Finite)
-  show QualificationBlockFailedELearning    = "E-Learning durchgefallen"
-  show QualificationBlockReturnedByCompany  = "Rückgabe Firma"
-  show QualificationBlockExpired            = "Abgelaufen"
 
-qualificationBlockedReasonText :: QualificationBlockStandardReason -> Text
+instance Show QualificationStandardReason where
+  show (QualificationRenewELearningBy       lid) = "E-Learning bestanden für "     <> show lid
+  show (QualificationBlockFailedELearningBy lid) = "E-Learning durchgefallen für " <> show lid
+  show  QualificationBlockFailedELearning        = "E-Learning durchgefallen"  
+  show  QualificationBlockReturnedByCompany      = "Rückgabe Firma"
+  show  QualificationBlockExpired                = "Abgelaufen"
+  
+{-
+qualificationBlockedReasonText :: QualificationStandardReason -> Text
 qualificationBlockedReasonText = 
-  let dictionary :: Map.Map QualificationBlockStandardReason Text = Map.fromList [(r, tshow r) | r <- universeF]
+  let dictionary :: Map.Map QualificationStandardReason Text = Map.fromList [(r, tshow r) | r <- universeF]
   in (dictionary !) -- cannot fail due to universeF
 
-type QualificationBlockReason = Either Text QualificationBlockStandardReason
+qualificationBlockedReasonText :: QualificationStandardReason -> Text
+qualificationBlockedReasonText = tshow
+-}
 
-qualificationBlockReasonText :: QualificationBlockReason -> Text
+type QualificationChangeReason = Either Text QualificationStandardReason
-qualificationBlockReasonText (Left     reason) = reason
+
-qualificationBlockReasonText (Right stdreason) = qualificationBlockedReasonText stdreason
+qualificationChangeReasonText :: QualificationChangeReason -> Text
+qualificationChangeReasonText (Left     reason) = reason
+qualificationChangeReasonText (Right stdreason) = tshow stdreason
 
 -- | LMS interface requires Bool to be encoded by 0 or 1 only
 newtype LmsBool = LmsBool { lms2bool :: Bool }