fix(avs): fix #225 by skipping firm updates entirely if AVS FirmInfo is unchanged for previously seen values for AVS User to be updated

Note: noticed while working on #225

CHANGELOG.md

@@ -2,6 +2,122 @@
 
 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.79](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.78...v27.4.79) (2024-09-10)
+
+
+### Bug Fixes
+
+* **notifications:** fix [#180](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/180) qualification expiry notification are sent only once ([74f7633](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/74f7633837870448f7cab1013719f42ab49941fe))
+* **supervision:** fix [#181](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/181) by unifying deletion of supervision ([6a070a6](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/6a070a67756bd4ef4b9b5efc176f34c7ed183f1a))
+
+## [27.4.78](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.77...v27.4.78) (2024-09-05)
+
+
+### Bug Fixes
+
+* **avs:** acs auto synch had inverted success/failure ([4f7855b](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/4f7855b9ee7133c5ee7e2ca63d63e5d9f060d62f))
+* **avs:** fix [#124](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/124) avs auto synch filter working ([2a27a1e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/2a27a1efa673a4245a7e8667bd30c79ac1891b9c))
+* **avs:** fix [#178](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/178) by deleting old superiors for individual users ([ade27e6](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ade27e647913ffe4432b41d585b3e00d1c68d4a0))
+* **avs:** typo in superior remark, towards [#178](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/178) ([3c5edb1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/3c5edb1b970c8c154d9957837007815b29e23964))
+* **mail:** fix [#179](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/179) by adding download links for PDF attachments ([620e3e4](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/620e3e470080831826ccc960dd876e7bb4fcea03))
+
+## [27.4.77](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.76...v27.4.77) (2024-09-02)
+
+
+### Bug Fixes
+
+* **avs:** attempt LDAP upsert before creating avs users ([cfe2318](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/cfe2318f81c951a7f7310e8bcd9ec25d79417587))
+* **avs:** company superiors are now irregular supervisors and old ones are deleted ([7e5c256](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/7e5c256b4c15a15f7218dd7c1490d5e7add4b1c1))
+* **avs:** fix [#124](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/124) implement automatic avs driving licence synchronisation ([cc5da9a](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/cc5da9a2a9bfc8a29f6fe19260bd6dc5412ad4a1))
+* **avs:** switch company did not always increase priority ([8ec2875](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/8ec2875590718f28c3bab8c10141065e11f1405c))
+* **build:** minor linter fix ([be5e609](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/be5e609b1fe879428784d78fa62a559d0764a85a))
+* **firm:** fix [#174](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/174) by adding address search filter to all company view ([40dadd5](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/40dadd58762156005b5889b93a56ffdc044b4460))
+* **firm:** fix [#175](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/175) by separating superiors in firm tables and selections ([8397c46](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/8397c468a04af42ba3baee2f84a0051adbc74374))
+* **ldap:** no more timeout for ldap synch all button ([f946e99](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/f946e99da3bc37514a4e3621438ac133cdc16732))
+* **linter:** minor bug in exam-correct.hs ([8bc3663](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/8bc3663ee2e4ded19091ebe350de82cd693093fc))
+* **mail:** display html emails no longer distorts page ([b0972bb](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/b0972bb154f453edd545fb4f658d9f5ff79966eb)), closes [#2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/2)
+* **model:** flip erroneous boolean SQL default for CompanyPostalAddress ([b7e5b8f](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/b7e5b8f111b5115d816d984c6ef2f12edfcef5bb))
+* **user:** fix pagination and count for supervision tables ([9c82558](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/9c82558d71a032dad27e892c489c7004d091e088))
+
+## [27.4.76](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.75...v27.4.76) (2024-08-08)
+
+
+### Bug Fixes
+
+* **ap:** disambiguate action message ([8b0466e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/8b0466e74e36e1d0d07518fd317d46b00ab53eff))
+* **avs:** fix [#173](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/173) by not using firm superior email as display email ([43f5c5f](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/43f5c5f4854d1ab2af27b479e72a58e2818a5696))
+* **avs:** towards [#117](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/117) update if current value is Nothing even if oldval == newval ([d1fa01f](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/d1fa01fcc5125c4adee8849f9c944884926f78ad))
+* **avs:** using firm superior as UserEmail is a no-go due to uniqueness constraints ([507a7e0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/507a7e02fc68476d01031dc9f9ee1a669a453ed1))
+* **build:** linter likes it ([f929e03](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/f929e03129378e08c8a08ed4bd6f8e8716401813))
+* **course:**  fix [#150](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/150) course edit for associated qualifications requires school admin or lecturer rights ([5b6e4e6](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/5b6e4e60e7d2957fbce93ee2e2d6d3464b4e3db7))
+* **course:** fix [#148](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/148) course qualification ordering ([cfd2534](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/cfd25348ad3b63ac6bc5031467a3c4ead2e07eed)), closes [#150](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/150)
+* **course:** fix [#149](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/149) course cloning proposes associated qualifications ([e141976](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/e1419766f3a06f702abad0ea42f6552305504ba0))
+* **course:** fix [#150](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/150) no longer allow duplicated associated qualifications and orders due to editing existing ([ec02767](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ec027675525b30198378745ed281f60a42471807))
+* **course:** WIP course cloning should propose same associated qualifications, towards [#149](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/149) ([bc47387](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/bc47387c91dda60a2f12e52dba28ea7b079316f0))
+* **lms:** max e-learning tries default removed and info added to lms overview ([11fdcf0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/11fdcf0d445b8cfe97c3a3c26513a9229937c536))
+* **user:** format userDisplayNames having umlaut substitutes with respect to userSurname correctly ([e35a5e9](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/e35a5e99a6cea0976fd1c28f919e7d0ac0338503))
+
+## [27.4.75](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.74...v27.4.75) (2024-07-12)
+
+
+### Bug Fixes
+
+* **build:** make linter happy again ([c17c18f](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/c17c18f9247ef322bc051602a3cb4a52cd50affa))
+* **build:** minor ([ab28c8c](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ab28c8c2437680023d80e6ab43113d4328b3a151))
+* **firm:** fix [#157](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/157) by removing redundant duplicated code in firm user and supervision handling ([28e2739](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/28e2739e515700d15c75647c0efe2fe9a9cf15b1))
+* **job:** change some queueJob' to queueJob instead ([fa0541a](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/fa0541aa4eaf10f98535a0959593b148b8346109))
+* **lms:** allow 2nd reminders to be independent of renewal period ([d853e85](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/d853e8559b753865ee818bf24764f5c8d2e2303f))
+* **lms:** move lms reuse info from QualificationR to LmsR ([468af9d](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/468af9de9da44a8ad685ca4bb6890a3e630b58be))
+* **lms:** send second reminder indepentently from renewal period ([a97c3a5](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/a97c3a5c9d3cb9dddf90f561712f0845400893bd))
+* **nix:** workaround parsing port numbers failed in nix-shell ([b5215cc](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/b5215cc7e8df3a7ad636271c8e6950979b2b8e42))
+* **users:** nameHtml no longer complains about differing case for surname and displayname ([a1668f8](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/a1668f891a36b887439afb098f016ef22535af42))
+* **users:** remove users with company post address from list of unreachable users ([c813c66](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/c813c665ed306135b7813d91d23310341c689f41))
+
+## [27.4.74](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.73...v27.4.74) (2024-07-04)
+
+
+### Bug Fixes
+
+* **lms:** fix [#161](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/161) lms for multiple joint qualifications ([f869a82](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/f869a829d2c1a726930864b3af62d1f0fbebe955))
+
+## [27.4.73](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.72...v27.4.73) (2024-07-03)
+
+
+### Bug Fixes
+
+* **letter:** rephrase some minor letter parts ([0ac75e0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/0ac75e0d5948cb90855d0e36ca8e99c22a0f6fcb))
+
+## [27.4.72](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.71...v27.4.72) (2024-07-02)
+
+
+### Bug Fixes
+
+* **avs:** do not associate users by AvsInfoPersonEmail ([9e2f221](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/9e2f2214ce5c7ee1e8d80e6fa75298b7a70d9043))
+* **avs:** fix superfluous quotes for matriculation numbers on newly created users ([ff9014c](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ff9014ce05d197c1dc0fce0774a640789cb38b26))
+* **avs:** towards [#169](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/169) - superiors are elevated to max priority for that company ([5bf8539](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/5bf85394d4db6de8f10b4e318d667130d37601ac))
+* **firm:** supervisor secondary did not work as intended ([d4f3ce7](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/d4f3ce7bf3d208b16f95ab81971b47dfa752939a))
+
+## [27.4.71](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.70...v27.4.71) (2024-06-27)
+
+
+### Bug Fixes
+
+* **avs:** company superior emails become company wide supervisors ([37efc89](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/37efc89e0723452e6d271ba5b43d6bd026642190))
+* **avs:** match mobile number better between LDAP and AVS ([f108c6c](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/f108c6cfec2d94d866e7c1605b0abe5471fd0f2b))
+* **avs:** new AVS from existing LDAP user no longer misses fields ([2559346](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/2559346d963ede802321dfc8cbd2088d9a5de685))
+* **avs:** priority for picking primary email demote superior ([e4fa1dd](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/e4fa1ddd6873910bef82d569fe16aca936efc567))
+* **build:** add missing license file ([8721bdb](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/8721bdb3f349658baab144d64c19942bfd7fa49a))
+* **build:** hlint wants a newtype instead ([18cdc52](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/18cdc52df094b9dbccd4f015561367cea59e33fe))
+* **doc:**  fix erroneous unintentional haddock annotations ([3dfc7f8](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/3dfc7f8c8b12dd6ef87848a75f1669d700fffe4c))
+* **i18n:** add missing translation for new primary company ([c212f2e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/c212f2e8d735616e59c9b8111a34118e3a48fd47))
+* **i18n:** add missing translation for new primary company ([2cc529b](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/2cc529be39655c317ca028f8f09fa80826ec668d))
+* **ldap:** match mobile number better between LDAP and AVS ([47e5628](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/47e56280fce4ad37e6bc3b9f1c61cb7867069cc5))
+* **letter:** adjust spacing, pin location and interpolation ([d4a0e1f](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/d4a0e1f201151f76e8e9afd67b456cc878d2afde))
+* **letter:** convenience links working again ([5f1af13](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/5f1af130edae7ada2f0c7f7829890bbe0d4f395a))
+* **letter:** expiry and valid dates were wrong ([f8c3663](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/f8c36636ff1f2591507e993af32ed01af94cf1fc))
+* **letter:** switch markdown for renewal letter too ([c38e87e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/c38e87e1e0e9285a10c00521b7440cd8246af88a))
+* **print:** fix [#167](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/167) by sotring affected user in PrintJob ([73aecc2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/73aecc2df833bdeed93a113b6c756e36b50491b7))
+
 ## [27.4.70](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.69...v27.4.70) (2024-06-21)
 
 

config/settings.yml

@@ -279,8 +279,8 @@ user-defaults:
   max-favourites:      0
   max-favourite-terms: 2
   theme:               Default
-  date-time-format:    "%d %b %y %R"
-  date-format:         "%d %b %Y"
+  date-time-format:    "%d.%m.%Y %R"
+  date-format:         "%d.%m.%y"
   time-format:         "%R"
   download-files:      false
   warning-days:        1209600

frontend/src/utils/exam-correct/exam-correct.js

@@ -301,7 +301,7 @@ export class ExamCorrect {
       users: [user],
       status: STATUS.LOADING,
     };
-    if (results && results !== {}) rowInfo.results = results;
+    if (results && Object.keys(results).length > 0) rowInfo.results = results;
     if (result !== undefined) rowInfo.result = result;
     this._addRow(rowInfo);
 

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

@@ -67,6 +67,7 @@ BearerTokenExpiresTip: Wird der Ablaufzeitpunkt überschrieben und kein Ablaufze
 BearerTokenOverrideStart: Startzeitpunkt
 BearerTokenOverrideStartTip: Wird kein Startzeitpunkt angegeben, wird bei Verwendung des Tokens nur der Ablaufzeitpunkt überprüft.
 HeadingAdminTokens: Tokens ausstellen
+UserUnknown: Unbekannter Benutzer:in
 
 #templates adminFeautures
 StudyFeaturesDegrees: Abschlüsse
@@ -101,7 +102,7 @@ ProblemsHeadingDrivers: Fahrberechtigungen
 ProblemsHeadingNotifications: Benachrichtigungen
 ProblemsHeadingMisc: Allgemein
 ProblemsAvsProblem: Synchronisation mit AVS/MoBaKo komplett fehlgeschlagen
-ProblemsDriverSynch n@Int: #{pluralDEeN n "Diskrepanze"} zwischen AVS und FRADrive
+ProblemsDriverSynch n@Int: #{n} #{pluralDE n "Diskrepanz" "Diskrepanzen"} zwischen AVS und FRADrive
 ProblemsDriverSynch0: Alle Sperrungen von Vorfeld-Fahrberechtigungen 'F' sind im AVS eingetragen
 ProblemsDriverSynch1down: Alle Sperrungen von Rollfeld-Fahrberechtigungen 'R' sind im AVS eingetragen
 ProblemsDriverSynch1up: Alle gültigen Vorfeld-Fahrberechtigungen 'F' sind im AVS eingetragen
@@ -113,6 +114,7 @@ ProblemsNoStalePrintJobs n@Integer: Alle Briefversandaufträge #{pluralDE n "des
 ProblemsNoBadAPCIds: Alle kürzlich empfangenen Druckauftragsbestätigungen waren gültig
 ProblemsUnreachableHeading: Unerreichbare Benutzer
 ProblemsUnreachableBody: Benutzer ohne E-Mail oder Postadresse, welche z.B. bei ablaufenden Berechtigungen nicht benachrichtigt werden können:
+ProblemsUnreachableButtons: Synchronisation für Unerreichbare starten
 ProblemsRWithoutFHeading: Fahrer mit R ohne F
 ProblemsRWithoutFBody: Diese Fahrer sind wegen einer ungültigen Vorfeld-Fahrberechtigung komplett gesperrt, obwohl eine gültige Rollfeld-Fahrberechtigung besteht:
 ProblemsNoAvsIdHeading: Fahrer ohne AVS-Id
@@ -120,16 +122,20 @@ ProblemsNoAvsIdBody: Fahrer mit gültiger Fahrberechtigung in FRADrive, welche t
 ProblemsAvsSynchHeading: Synchronisation AVS Fahrberechtigungen
 ProblemsAvsErrorHeading: Fehlermeldungen
 ProblemsInterfaceSince: Berücksichtigt werden nur Erfolge und Fehler seit 
+ProblemAvsUsrHadR: Momentan gültiges R im AVS
 
 AdminProblemSolved: Erledigt
 AdminProblemSolver: Bearbeitet von
 AdminProblemCreated: Erkannt
 AdminProblemInfo: Problembeschreibung
-AdminProblemsSolved n@Int: #{pluralDEeN n "Admin Probleme"} als erledigt markiert
-AdminProblemsReopened n@Int: #{pluralDEeN n "Admin Probleme"} erneut eröffnet
-AdminProblemNewCompany: Neue Firma aus AVS automatisch erstellt; prüfen und ggf. Standardansprechpartner eintragen
-AdminProblemSupervisorNewCompany b@Bool: Dieser Standardansprechpartner #{boolText mempty "mit Standardumleitung" b} wechselte zu neuer Firma 
+AdminProblemsSolved n@Int: #{pluralDEeN n "Admin Problem"} als erledigt markiert
+AdminProblemsReopened n@Int: #{pluralDEeN n "Admin Problem"} erneut eröffnet
+AdminProblemNewCompany: Neue Firma über AVS automatisch erstellt; prüfen und ggf. Standardansprechpartner eintragen
+AdminProblemSupervisorNewCompany b@Bool: Standardansprechpartner #{boolText mempty "mit Standardumleitung" b} wechselte zu neuer Firma 
 AdminProblemSupervisorLeftCompany b@Bool: Einziger Standardansprechpartner #{boolText mempty "mit Standardumleitung" b} dieses Fahrers wechselte zu neuer Firma 
+AdminProblemCompanySuperiorChange: Neuer firmenweiter Vorgesetzter.
+AdminProblemCompanySuperiorNotFound t@Text: Neuer unbekannter firmenweiter Vorgesetzter mit E-Mail #{t}, keine Ansprechpartnerbeziehungen eingerichtet.
+AdminProblemCompanySuperiorPrevious: Ehemaliger Vorgesetzter: 
 AdminProblemNewlyUnsupervised: Fahrer hat keinen Firmenansprechpartner mehr nach AVS Firmenwechsel zu Firma 
 AdminProblemUser: Betroffener
 ProblemTableMarkSolved: Als erledigt markieren
@@ -144,4 +150,13 @@ InterfaceSubtype: Betreffend
 InterfaceWrite: Schreibend
 InterfaceSuccess: Rückmeldung
 InterfaceInfo: Nachricht
-InterfaceFreshness: Prüfungszeitraum (h)
+InterfaceFreshness: Maximale Zugriffsfrist
+InterfaceFreshnessTooltip: Zeitspanne innerhalb der ein erneuter erfolgreicher Schnittstellenzugriff erfolgen muss, ohne Warnungen auszulösen
+ConfigInterfacesHeading: Konfiguration Zugriffsfristen
+
+IWTActAdd: Hinzufügen/Ändern
+IWTActDelete: Entfernen
+InterfaceWarningAdded: Schnittstellenwarnungszeit hinzugefügt oder geändert
+InterfaceWarningDeleted n@Int: #{pluralDEeN n "Schnittstellenwarnungszeit"} gelöscht
+InterfaceWarningDisabledEntirely: Alle Fehler ignorieren
+InterfaceWarningDisabledInterval: Keine Zugriffsfrist

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

@@ -67,6 +67,7 @@ BearerTokenExpiresTip: If no expiration time is given, the token will not expire
 BearerTokenOverrideStart: Start time
 BearerTokenOverrideStartTip: If no start time is given, only the expiration time will be checked when the token is used.
 HeadingAdminTokens: Issue tokens
+UserUnknown: User unknown
 
 #templates adminfeatures
 StudyFeaturesDegrees: Degrees
@@ -113,13 +114,15 @@ ProblemsNoStalePrintJobs n: All requests for letter mailing within the last #{pl
 ProblemsNoBadAPCIds: All recently received print job ids from Airport Print Center were legit
 ProblemsUnreachableHeading: Unreachable Users
 ProblemsUnreachableBody: Users without Email nor postal address, who thus cannot be notified about expiring qualifications:
+ProblemsUnreachableButtons: Start synchronisation for unreachable users only
 ProblemsRWithoutFHeading: Drivers having 'R' but not 'F'
 ProblemsRWithoutFBody: Drivers without apron driving licence are prohibited from driving, even if they own a valid maneuvering driving licence:
 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 
+ProblemsInterfaceSince: Only considering successes and errors since
+ProblemAvsUsrHadR: Currenlt R valid in AVS
 
 AdminProblemSolved: Done
 AdminProblemSolver: Solved by
@@ -128,8 +131,11 @@ AdminProblemInfo: Problem
 AdminProblemsSolved n: #{pluralENsN n "admin problem"} marked as solved
 AdminProblemsReopened n: #{pluralENsN n "admin problem"} reopened
 AdminProblemNewCompany: New company from AVS; verify and add default supervisors
-AdminProblemSupervisorNewCompany b: This default company supervisor #{boolText mempty "with reroute" b} changed to new company 
+AdminProblemSupervisorNewCompany b: Default company supervisor #{boolText mempty "with reroute" b} changed to new company 
 AdminProblemSupervisorLeftCompany b: Only default company supervisor #{boolText mempty "with reroute" b} for this user changed to new company 
+AdminProblemCompanySuperiorChange: New company wide superior.
+AdminProblemCompanySuperiorNotFound t: Unable to set supervision for new unknown company wide superior having Email #{t}.
+AdminProblemCompanySuperiorPrevious: Previous superior: 
 AdminProblemNewlyUnsupervised: Driver has no longer a company default supervisor after AVS update at new company
 AdminProblemUser: Affected
 ProblemTableMarkSolved: Mark done
@@ -144,4 +150,13 @@ InterfaceSubtype: Affecting
 InterfaceWrite: Write
 InterfaceSuccess: Returned
 InterfaceInfo: Message
-InterfaceFreshness: Check hours
+InterfaceFreshness: Maximum usage period
+InterfaceFreshnessTooltip: Time period within which the next successful interface access must occur to avoid a warning
+ConfigInterfacesHeading: Configure interface usage warnings
+
+IWTActAdd: Add/Edit
+IWTActDelete: Delete
+InterfaceWarningAdded: Interface warning time added/changed
+InterfaceWarningDeleted n: #{pluralENsN n "interface warning time"} deleted
+InterfaceWarningDisabledEntirely: Ignore all errors
+InterfaceWarningDisabledInterval: No maximum usage period

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

@@ -4,7 +4,9 @@
 AvsPersonInfo: AVS Personendaten
 AvsPersonId: AVS Personen Id
 AvsPersonNo: AVS Personennummer
+AvsPersonNoNotId: AVS Personennummer dient zur menschlichen Kommunikation mit der Ausweisstelle und darf nicht verwechselt werden mit der maschinell verwendeten AVS Personen Id
 AvsPersonNoMismatch: AVS Personennummer hat sich geändert und wurde in FRADrive noch nicht aktualisiert
+AvsPersonNoDiffers: Es sind derzeit zwei verschiedene AVS Personennummern zugeordnet. Bitte einen Administrator kontaktieren.
 AvsCardNo: Ausweiskartennummer 
 AvsFirstName: Vorname
 AvsLastName: Nachname
@@ -15,7 +17,6 @@ AvsQueryNeeded: Benötigt Verbindung zum AVS.
 AvsQueryEmpty: Bitte mindestens ein Anfragefeld ausfüllen!
 AvsQueryStatusInvalid t@Text: Nur numerische IDs eingeben, durch Komma getrennt! Erhalten: #{show t}
 AvsLicence: Fahrberechtigung
-AvsPersonNoNotId: AVS Personennummer dient zur menschlichen Kommunikation mit der Ausweisstelle und darf nicht verwechselt werden mit der maschinell verwendeten AVS Personen Id
 AvsTitleLicenceSynch: Abgleich Fahrberechtigungen zwischen AVS und FRADrive
 BtnAvsRevokeUnknown: Fahrberechtigungen im AVS sofort entziehen
 BtnAvsImportUnknown: AVS Daten unbekannter Personen importieren
@@ -45,6 +46,7 @@ AvsCardColorBlue: Blau
 AvsCardColorRed: Rot
 AvsCardColorYellow: Gelb
 LastAvsSynchronisation: Letzte AVS-Synchronisation
+LastAvsSyncedBefore: Letzte AVS-Synchronisation vor
 LastAvsSynchError: Letzte AVS-Fehlermeldung
 
 AvsInterfaceUnavailable: AVS Schnittstelle nicht richtig konfiguriert oder antwortet nicht

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

@@ -4,7 +4,9 @@
 AvsPersonInfo: AVS person info
 AvsPersonId: AVS person id
 AvsPersonNo: AVS person number
+AvsPersonNoNotId: AVS person number is used in human communication only and must not be mistaken for the AVS personen id used in machine communications
 AvsPersonNoMismatch: AVS person number has changed and was not yet updated in FRADrive
+AvsPersonNoDiffers: There are currently two differing AVS person numbers associated with this user. Please contact an administrator to resolve this.
 AvsCardNo: Card number
 AvsFirstName: First name
 AvsLastName: Last name
@@ -15,7 +17,7 @@ AvsQueryNeeded: AVS connection required.
 AvsQueryEmpty: At least one query field must be filled!
 AvsQueryStatusInvalid t: Numeric IDs only, comma seperated! #{show t}
 AvsLicence: Driving Licence
-AvsPersonNoNotId: AVS person number is used in human communication only and must not be mistaken for the AVS personen id used in machine communications
+
 AvsTitleLicenceSynch: Synchronisation driving licences between AVS and FRADrive
 BtnAvsRevokeUnknown: Revoke AVS driving licences for unknown persons immediately
 BtnAvsImportUnknown: Import AVS data for unknown persons
@@ -45,6 +47,7 @@ AvsCardColorBlue: Blue
 AvsCardColorRed: Red
 AvsCardColorYellow: Yellow
 LastAvsSynchronisation: Last AVS synchronisation
+LastAvsSyncedBefore: Last AVS synchronisation before
 LastAvsSynchError: Last AVS Error
 
 AvsInterfaceUnavailable: AVS interface was not configured correctly or does not respond

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

@@ -70,6 +70,10 @@ CourseInvalidInput: Eingaben bitte korrigieren.
 CourseEditTitle: Kursart editieren/anlegen
 CourseEditOk       tid@TermId ssh@SchoolId csh@CourseShorthand: Kursart #{tid}-#{ssh}-#{csh} wurde erfolgreich geändert.
 CourseEditDupShort tid@TermId ssh@SchoolId csh@CourseShorthand: Kursart #{tid}-#{ssh}-#{csh} konnte nicht geändert werden: Es gibt bereits einen andere Kursart mit dem selben Kürzel oder Titel in diesem Jahr und Bereich.
+CourseEditQualificationFail: Eine Qualifikation konnte uas unbekanntem Grund nicht mit diesem Kurs assoziert werden.
+CourseEditQualificationFailRights qsh@QualificationShorthand ssh@SchoolId: Qualifikation #{qsh} konnte nicht mit diesem Kurs assoziert werden, da Ihre Berechtigungen für Bereich #{ssh} dazu nicht ausreichen.
+CourseEditQualificationFailExists: Diese Qualifikation ist bereits assoziert
+CourseEditQualificationFailOrder: Diese Sortierpriorität existiert bereits
 CourseLecturer: Kursverwalter:in
 MailSubjectParticipantInvitation tid@TermId ssh@SchoolId csh@CourseShorthand: [#{tid}-#{ssh}-#{csh}] Einladung zur Kursartteilnahme
 CourseParticipantInviteHeading courseName@Text: Einladung zum Kursartteilnahmer für #{courseName}

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

@@ -70,8 +70,12 @@ CourseInvalidInput: Invalid input
 CourseEditTitle: Edit/Create course
 CourseEditOk tid ssh csh: Successfully edited course type #{tid}-#{ssh}-#{csh} 
 CourseEditDupShort tid ssh csh: Could not edit course type #{tid}-#{ssh}-#{csh}. Another course type with the same shorthand or title already exists for the given year and school.
+CourseEditQualificationFail: A qualifikation could not be associated with this course for unknown reasons.
+CourseEditQualificationFailRights qsh ssh: Qualification #{qsh} could not be associated with this course, due to your insufficient rights for department #{ssh}.
+CourseEditQualificationFailExists: This qualification is already associated
+CourseEditQualificationFailOrder: This sort order priority is used already
 CourseLecturer: Course administrator
-MailSubjectParticipantInvitation tid@TermId ssh@SchoolId csh@CourseShorthand: [#{tid}-#{ssh}-#{csh}] Invitaion to join the course
+MailSubjectParticipantInvitation tid ssh csh: [#{tid}-#{ssh}-#{csh}] Invitaion to join the course
 CourseParticipantInviteHeading courseName: Invitation to enrol for #{courseName}
 CourseParticipantInviteExplanation: You were invited to be a participant of a course.
 CourseParticipantInviteField: Email addresses to invite

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

@@ -1,4 +1,4 @@
-# SPDX-FileCopyrightText: 2023 Steffen Jost <s.jost@fraport.de>
+# SPDX-FileCopyrightText: 2023-24 Steffen Jost <s.jost@fraport.de>
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -7,7 +7,6 @@ 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
@@ -16,11 +15,15 @@ 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?
+FirmActRemoveSupers: Alle rein firmenbezogenen Ansprechpartnerbeziehungen für diese Personen entfernen?
 FirmActResetMutualSupervision: Ansprechpartner beaufsichtigen sich gegenseitig
-FirmActAddSupersvisors: Ansprechpartner hinzufügen
+FirmActResetSupersKeepAll: Alle behalten
+FirmActResetSupersRemoveAps: Nur Standardansprechpartner entfernen
+FirmActResetSupersRemoveAll: Alle entfernen
+FirmActAddSupervisors: 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)}
+RemoveSupervisors ndef@Int64: #{ndef} Standardansprechpartner entfernt. 
 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.
@@ -28,17 +31,23 @@ FirmActChangeContactFirmResult: Firmenkontaktinformationen geändert. Betrifft n
 FirmUserActNotify: Mitteilung versenden
 FirmUserActResetSupervision: Ansprechpartner auf Firmenstandard zurücksetzen
 FirmUserActSetSupervisor: Ansprechpartner ändern
+FirmUserActChangeContact: Kontaktinformationen für ausgewählte Firmenangehörige ändern
+FirmUserActChangeDetails: Firmenassoziation bearbeiten
+FirmUserActRemove: Firmenassoziation entfernen
+FirmUserActMkSuper: Zum Firmenansprechpartner ernennen
+FirmUserActChangeDetailsResult n@Int64 t@Int64: Firmenassoziation von #{n}/#{t} #{pluralDE n "Firmenangehörigen" "Firmenangehörige"} wurden aktualisiert
+FirmUserActChangeResult n@Int64 t@Int64: Benachrichtigungseinstellung für #{n}/#{t} #{pluralDE n "Firmenangehörigen" "Firmenangehörige"} wurden geändert
+FirmUserActRemoveResult uc@Int64: #{uc} #{pluralDE uc "Firmenassoziation" "Firmenassoziationen"} entfernt. 
+FirmRemoveSupervision sup@Int64 sub@Int64: #{noneMoreDE sup "" (tshow sup <> " Ansprechpartnerbeziehungen wegen entferntem Ansprechpartner gelöscht. ")} #{noneOneMoreDE sub "Keine Ansprechpartnerbeziehung" "Eine Ansprechpartnerbeziehung" (tshow sup <> " Ansprechpartnerbeziehungen")} wegen entferntem Angesprochenem gelöscht.
 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
+FirmSuperActRMSuperActive: Aktive Ansprechpartnerbeziehungen innerhalb dieser Firma beenden?
 FirmsNotification: Firmen E-Mail versenden
 FirmNotification fsh@CompanyShorthand: E-Mail an #{fsh} senden
 FirmsNotificationTitle: Firmen benachrichtigen
@@ -47,7 +56,9 @@ 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
+FilterIsForeignSupervisee: Ist Ansprechpartner für Firmenfremde
 FilterFirmExtern: Externe Firma
+FilterFirmExternTooltip: Hat die Firma eine Postanschrift im AVS?
 FilterFirmPrimary: Ist primäre Firma in FRADrive
 FilterHasQualification: Hat Firmenangehörige mit aktuell gültiger Qualifikation
 FirmSupervisorOf fsh@CompanyShorthand: Ansprechpartner #{fsh} angehörig
@@ -55,8 +66,13 @@ FirmSupervisorIndependent: Ansprechpartner ohne jegliche Firmenzugehörigkeit
 FirmEmployeeOf fsh@CompanyShorthand: Firmenangehörige #{fsh}
 NoCompanySelected: Bitte wählen Sie mindestens eine Firma aus.
 TableIsDefaultSupervisor: Standardansprechpartner
+TableSuperior: Vorgesetzter
 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
+FirmSupervisionKeyData: Kennzahlen Ansprechpartner
+CompanyUserPriority: Firmenpriorität
+CompanyUserPriorityTip: Firmenpriorität ist lediglich relativ zu anderen Firmenassoziation der Person
+CompanyUserUseCompanyAddress: Verwendet Firmenkontaktaddresse
+CompanyUserUseCompanyAddressTip: sofern im Benutzer keine Postanschrift hinterlegt ist
+CompanyUserUseCompanyPostalError: Postalische Adresse muss leer bleiben, damit die Firmenanschrift genutzt wird!

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

@@ -1,4 +1,4 @@
-# SPDX-FileCopyrightText: 2023 Steffen Jost <s.jost@fraport.de>
+# SPDX-FileCopyrightText: 2023-24 Steffen Jost <s.jost@fraport.de>
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -7,7 +7,6 @@ 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
@@ -16,11 +15,15 @@ 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?
+FirmActRemoveSupers: Terminate all company related supervisonships?
 FirmActResetMutualSupervision: Supervisors supervise each other
-FirmActAddSupersvisors: Add supervisors
+FirmActResetSupersKeepAll: Keep all
+FirmActResetSupersRemoveAps: Remove default supervisors only
+FirmActResetSupersRemoveAll: Remove all
+FirmActAddSupervisors: 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)}
+RemoveSupervisors ndef: #{ndef} default supervisors removed.
 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.
@@ -28,17 +31,23 @@ FirmActChangeContactFirmResult: Company contact data changed, affecting future c
 FirmUserActNotify: Send message
 FirmUserActResetSupervision: Reset supervisors to company default
 FirmUserActSetSupervisor: Change supervision
+FirmUserActChangeContact: Change contact data for selected company associates
+FirmUserActChangeDetails: Edit company association
+FirmUserActRemove: Delete company association
+FirmUserActMkSuper: Mark as company supervisor
+FirmUserActChangeDetailsResult n t: #{n}/#{t} #{pluralENs n "company association"} updated
+FirmUserActChangeResult n t: Notification settings changed for #{n}/#{t} company #{pluralENs n "associate"}
+FirmUserActRemoveResult uc: #{pluralENsN uc "Company association"} deleted. 
+FirmRemoveSupervision sup sub: #{noneMoreEN sup "" ((pluralENsN sup "supervision") <> " removed due to eliminated supervisors.")} #{noneMoreEN sub "No supervision" (pluralENsN sub "supervision")} removed due to eliminated supervisees.
 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)}
+FirmSetSupersReport nusr nspr nrem: #{nspr} individual 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.
+FirmSuperActSwitchSuperInfo: Does not affect company-external supervisors and does not change any active individual supervisions. Additionally use reset action, if desired.
 FirmSuperActRMSuperDef: Remove default supervisor
-FirmSuperActRMSuperActive: Also remove active supervisions within this company
+FirmSuperActRMSuperActive: Terminate active supervisions within this company?
 FirmsNotification: Send company notification e-mail
 FirmNotification fsh: Send e-mail to #{fsh}
 FirmsNotificationTitle: Company notification
@@ -47,7 +56,9 @@ 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
+FilterIsForeignSupervisee: Supervisor for company external users
 FilterFirmExtern: External company
+FilterFirmExternTooltip: i.e. is a postal address registered within AVS?
 FilterFirmPrimary: Is primary company in FRADrive
 FilterHasQualification: Has company associates with currently valid qualification
 FirmSupervisorOf fsh@CompanyShorthand: Supervisors belonging to #{fsh}
@@ -55,8 +66,13 @@ FirmSupervisorIndependent: Independent supervisors
 FirmEmployeeOf fsh@CompanyShorthand: #{fsh} associated users
 NoCompanySelected: Select at least one company, please.
 TableIsDefaultSupervisor: Default supervisor
+TableSuperior: Superior
 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
+FirmSupervisionKeyData: Supervision key data
+CompanyUserPriority: Company priority
+CompanyUserPriorityTip: Company priority is relative to other company associations for a user
+CompanyUserUseCompanyAddress: Use company postal address
+CompanyUserUseCompanyAddressTip: if and only if the postal address of the user is empty
+CompanyUserUseCompanyPostalError: Individual postal address must left empty for the company address to be used!

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

@@ -18,6 +18,7 @@ PrintJobAcknowledgeFailed: Keine Druckaufträge bestätigt aufgrund zwischenzeit
 PrintJobAcknowledgeQuestion n@Int d@Text: #{n} #{pluralDE n "Druckauftrag" "Druckaufräge"} vom #{d} als gedruckt und versendet bestätigen?
 PrintJobAcknowledgements: Versanddatum von Briefen an
 PrintRecipient: Empfänger
+PrintAffected: Betroffener
 PrintSender !ident-ok: Sender
 PrintCourse: Kursarten
 PrintQualification: Qualifikation
@@ -25,4 +26,7 @@ PrintPDF !ident-ok: PDF
 PrintManualRenewal: Vorfeldführerschein Renewal-Brief testweise versenden
 PrintLmsUser: E‑Learning Id
 PrintJobs: Druckaufräge
-PrintLetterType: Brieftypkürzel
+PrintLetterType: Brieftypkürzel
+
+MCActDummy: Platzhalter
+CCActDummy: Platzhalter

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

@@ -18,6 +18,7 @@ PrintJobAcknowledgeFailed: No print-jobs acknowledged, due to intermediate chang
 PrintJobAcknowledgeQuestion n d: Mark #{n} #{pluralENs n "print-job"} issued on #{d} as printed and mailed already?
 PrintJobAcknowledgements: Sent-dates for Letter to
 PrintRecipient: Recipient
+PrintAffected: Affetcted
 PrintSender: Sender
 PrintCourse: Course type
 PrintQualification: Qualification
@@ -25,4 +26,7 @@ PrintPDF: PDF
 PrintManualRenewal: Manual sending of an apron driver's licence renewal letter
 PrintLmsUser: E‑learning id
 PrintJobs: Print jobs
-PrintLetterType: Letter type shorthand
+PrintLetterType: Letter type shorthand
+
+MCActDummy: Placeholder
+CCActDummy: Placeholder

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

@@ -9,16 +9,23 @@ QualificationValidIndicator: Gültigkeit
 QualificationValidDuration: Gültigkeitsdauer
 QualificationAuditDuration: Aufbewahrung Audit Log
 QualificationAuditDurationTooltip n@Int: Optionaler Zeitraum zur Löschung von E‑Learning Daten. Hinweis: Der E‑Learning Server kann seine anonymisierten Daten schon früher löschen, aber spätestens #{n} Tage nach Abschluss.
+QualificationAuditDurationReuseError: Diese Qualifikation nutzt das E‑Learning einer anderen Qualifikation, für die derzeit keinen Löschzeitraum konfiguriert wurde.
 QualificationRefreshWithin: Erneurerungszeitraum
-QualificationRefreshWithinTooltip: Optionaler Zeitraum vor Ablauf für automatischen Start des E‑Learnings und Versand einer Benachrichtigung per Brief oder Email.
-QualificationRefreshReminder: 2. Erinnerung
-QualificationRefreshReminderTooltip: Optionaler Zeitraum vor Ablauf zur Versendung einer zweiten Erinnerung per Brief oder Email mit identischen Zugangsdaten, sofern in diesem Zeitraum vor Ablauf noch keine Ablaufbenachrichtigung versendet wurde.
+QualificationRefreshWithinTooltip: Optionaler Zeitraum vor Ablauf für eine Benachrichtigung per Email. Bei aktiviertem automatischem E‑Learning wird dieses gestartet und die Benachrichtigung erfolgt per Brief oder Email.
+QualificationRefreshReminder: Zweite Erinnerung
+QualificationRefreshReminderTooltip: Optionaler Zeitraum vor Ablauf zur Versendung einer zweiten Erinnerung per Brief oder Email mit identischen E‑Learning Zugangsdaten, sofern die Qualifikation noch gültig und das E‑Learning noch offen ist.
 QualificationElearningStart: Wird das E‑Learning automatisch gestartet?
+QualificationElearningRenew: Verlängert ein erfolgreiches E‑Learning die Qualifikation automatisch um die reguläre Gültigkeitsdauer?
+QualificationElearningLimit: Ist die Anzahl der E‑Learning Versuche limitiert?
+QualificationElearningLimitMax n@Int: Maximal #{n} Versuche
+QualificationElearningNoLimit: Nicht limitiert
 QualificationExpiryNotification: Ungültigkeitsbenachrichtigung?
 QualificationExpiryNotificationTooltip: Nutzer werden benachrichtigt, wenn die Qualifikation ungültig wird, sofern der jeweilige Nutzer in seinen Benutzereinstellungen diese Art Benachrichtigung aktiviert hat.
 TableQualificationCountActive: Aktive
 TableQualificationCountActiveTooltip: Anzahl Personen mit momentan gültiger Qualifikation
 TableQualificationCountTotal: Gesamt
+TableQualificationLmsReuses: LMS nutzt
+TableQualificationLmsReusesTooltip: Diese Qualifikation hat kein eigenes E‑Learning, sondern wird über das E‑Learning der angegebenen Qualifikation abgewickelt.
 TableQualificationIsAvsLicence: AVS
 TableQualificationIsAvsLicenceTooltip: Unter welchem Namen wird diese Qualifikation mit dem Ausweisverwaltungssystem (AVS) synchronisiert? Betrifft nur Benutzer mit AVS PersonenID.
 TableQualificationSapExport: SAP
@@ -47,11 +54,13 @@ QualificationExpired: Ungültig seit
 LmsUser: Inhaber
 LmsURL: Link E‑Learning
 TableLmsEmail: E‑Mail
-TableLmsIdent: E-Learning Benutzer
+TableLmsIdent: E‑Learning Benutzer
 TableLmsElearning: E‑Learning
+TableLmsElearningRenews: Automatische Verlängerung
+TableLmsElearningLimit: Maximale Versuche
 TableLmsPin: E‑Learning Passwort
-TableLmsResetPin: E-Learning Passwort zurücksetzen?
-TableLmsDatePin: E-Learning Passwort erstellt
+TableLmsResetPin: E‑Learning Passwort zurücksetzen?
+TableLmsDatePin: E‑Learning Passwort erstellt
 TableLmsDate: Datum
 TableLmsDelete: Löschen?
 TableLmsStaff: Interner Mitarbeiter?
@@ -89,7 +98,8 @@ LmsReportInsert: Neues LMS Ereignis
 LmsReportUpdate: LMS Ereignis Aktualisierung
 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.
+LmsErrorNoRefreshElearning: Fehler: E‑Learning wird nicht automatisch gestartet, da die Zeitspanne für den Erneurerungszeitraum nicht festgelegt wurde!
+LmsErrorNoRenewElearning: Fehler: Erfoglreiches E‑Learning verlängert die Qualifikation nicht automatisch, da die Gültigkeitsdauer nicht festgelegt wurde!
 MailSubjectQualificationRenewal qname@Text: Qualifikation #{qname} muss demnächst erneuert werden
 MailSubjectQualificationExpiry qname@Text: Qualifikation #{qname} läuft demnächst ab
 MailSubjectQualificationExpired qname@Text: Qualifikation #{qname} ist ab sofort ungültig
@@ -107,11 +117,13 @@ QualificationActUnblock: Entzug aufheben
 QualificationActRenew: Qualifikation regulär verlängern
 QualificationActGrant: Qualifikation vergeben
 QualificationActGrantWarning: Diese Funktion ist nur für seltene Ausnahmefälle vorgesehen! Ein Entzug wird ggf. aufgehoben.
+QualificationActStartELearning: E‑Learning für gültige Inhaber (neu) starten
+QualificationActStartELearningStatus l@QualificationShorthand n@Int m@Int: E‑Learning #{l} für #{n}/#{m} Teilnehmer (neu) gestartet. Hinweis: Es kann länger dauern, bis das LMS tatsächlich startet.
 QualificationStatusBlock   l@QualificationShorthand n@Int m@Int: #{n}/#{m} #{l} entzogen
 QualificationStatusUnblock l@QualificationShorthand n@Int m@Int: #{n}/#{m} #{l} reaktiviert
 LmsInactive: Aktuell kein E‑Learning aktiv
 LmsRenewalInstructions: Weitere Anweisungen zur Verlängerung finden Sie im angehängten PDF. Um Missbrauch zu verhindern wurde das PDF mit dem im FRADrive hinterlegten PDF-Passwort des Prüflings verschlüsselt. Falls kein PDF-Passwort manuell hinterlegt wurde, ist das PDF-Passwort die Flughafen Ausweisnummer, inklusive Punkt und der Ziffer danach.
-LmsNoRenewal: Leider kann diese Qualifikation nicht alleine durch E‑Learning verlängert werden.
+LmsNoRenewal: Leider kann diese Qualifikation nicht alleine durch E‑Learning verlängert werden. Bitte setzen Sie sich mit uns in Verbindung, wenn Sie die Qualifikation verlängern möchten und noch nicht wissen, wie Sie das tun können. Ignorieren Sie diese automatisch generierte Erinnerung, falls Sie sich bereits um die Verlängerung gekümmert haben
 LmsRenewalReminder: Erinnerung
 LmsActNotify: Benachrichtigung E‑Learning erneut per Post oder E-Mail versenden
 LmsActRenewPin: Neues zufällige E‑Learning Passwort zuweisen
@@ -120,7 +132,7 @@ LmsActReset: E‑Learning Fehlversuche zurücksetzen und entsperren
 LmsActResetInfo: E‑Learning Login, Passwort und Fortschritt bleiben unverändert, eine neue Benachrichtigung ist nicht notwendig. Nur möglich für bereits gesperrte Lerner. Es kann bis zu 2 Stunden dauern, bis das LMS die Anfrage umgesetzt hat.
 LmsActResetFeedback n@Int m@Int: Für #{n}/#{m} E‑Learning Nutzer wurden alle Fehlversuche zurückgesetzt.
 LmsActRestart: E‑Learning komplett neu starten
-LmsActRestartWarning: Das vorhandene E‑Learning wird komplett gelöscht! Für Inhaber einer gültigen Fahrlizenz werden später Benutzer und Passwort neu vergeben und es sollte eine neue Benachrichtigung versendet werden. Hinweis: Es kann mehrere Stunden dauern, bis das LMS diese Anfrage umgesetzt hat.
+LmsActRestartWarning: Das vorhandene E‑Learning wird komplett gelöscht! Für Inhaber einer gültigen Lizenz werden später Benutzer und Passwort neu vergeben und es sollte eine neue Benachrichtigung versendet werden. Hinweis: Es kann mehrere Stunden dauern, bis das LMS diese Anfrage umgesetzt hat.
 LmsActRestartFeedback n@Int m@Int: #{n}/#{m} E‑Learning Nutzer wurden komplett neu gestartet mit neuem Login und Passwort.
 LmsActRestartExtend: Gültig bis ggf. erhöhen für die nächsten # Tage
 LmsActRestartUnblock: Entzug ggf. aufheben

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

@@ -9,16 +9,23 @@ QualificationValidIndicator: Validity
 QualificationValidDuration: Validity period
 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.
+QualificationAuditDurationReuseError: This qualification reuses the e‑learning from another qualification, which has no audit duration configured.
 QualificationRefreshWithin: Refresh within
-QualificationRefreshWithinTooltip: Optional period before expiry to start e‑learning and send a notification by post or email.
-QualificationRefreshReminder: 2. Reminder
-QualificationRefreshReminderTooltip: Optional period before expiry to send a second notification by post or email once more, provided that no renewal notification was sent in this period before expiry.
+QualificationRefreshWithinTooltip: Optional period before expiry to send a notification by email. If e‑learning is set to start automatically, it will be started and e‑learning credentials are send with this notification by post or email.
+QualificationRefreshReminder: Second reminder
+QualificationRefreshReminderTooltip: Optional period before expiry to send a second notification by post or email once more, including the existing credentials, provided that the e‑learning is still undecided and the qualification has not yet expired.
 QualificationElearningStart: Is e‑learning automatically started?
+QualificationElearningRenew: Does successful e‑learning automatically extend a qualification by the default validity period?
+QualificationElearningLimit: Is the number of e‑learning attempts limited?
+QualificationElearningLimitMax n: #{n} attempts maximum
+QualificationElearningNoLimit: No limit
 QualificationExpiryNotification: Invalidity notification?
 QualificationExpiryNotificationTooltip: Qualification holder are notfied upon invalidity, provided they have activated such notification in their user settings.
 TableQualificationCountActive: Active
 TableQualificationCountActiveTooltip: Number of currently valid qualification holders
 TableQualificationCountTotal: Total
+TableQualificationLmsReuses: Reuse LMS 
+TableQualificationLmsReusesTooltip: This qualification reuses the e‑learning of the given qualification, instead of having a separate e‑learning of its own.
 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
@@ -50,6 +57,8 @@ TableLmsEmail: Email
 TableLmsIdent: E‑learning user
 TableLmsPin: E‑learning password
 TableLmsElearning: E‑learning
+TableLmsElearningRenews: Automatic renewal
+TableLmsElearningLimit: Max attempts
 TableLmsResetPin: Reset E‑learning password?
 TableLmsDatePin: E‑learning password created
 TableLmsDate: Date
@@ -89,7 +98,8 @@ LmsReportInsert: New LMS event
 LmsReportUpdate: Update of LMS event
 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.
+LmsErrorNoRefreshElearning: Error: E‑learning will not be started automatically due to refresh-within time period not being set!
+LmsErrorNoRenewElearning: Error: E‑learning will not automatically extend validity due to validity duration not being set!
 MailSubjectQualificationRenewal qname: Qualification #{qname} must be renewed shortly
 MailSubjectQualificationExpiry qname: Qualification #{qname} expires soon
 MailSubjectQualificationExpired qname: Qualification #{qname} is no longer valid
@@ -107,11 +117,13 @@ QualificationActUnblock: Clear revocation
 QualificationActRenew: Renew qualification
 QualificationActGrant: Grant qualification
 QualificationActGrantWarning: Use with caution in rare exceptional cases only! Any revocation will be undone.
+QualificationActStartELearning: Manually (re)start e‑learning for valid qualification holders
+QualificationActStartELearningStatus l n m: E‑learning #{l} (re)started for #{n}/#{m} users. Note: It may take a while, until the e‑learning is activated.
 QualificationStatusBlock   l n m: #{n}/#{m} #{l} revoked
 QualificationStatusUnblock l n m: #{n}/#{m} #{l} reactivated
 LmsInactive: Currently no active e‑learning
 LmsRenewalInstructions: Instruction on how to accomplish the renewal are enclosed in the attached PDF. In order to avoid misuse, the PDF is encrypted with the FRADrive PDF-password of the examinee. If no PDF-password had been chosen yet, then the password is the Fraport id card number of the examinee, including the punctuation mark and the digit thereafter.
-LmsNoRenewal: Unfortunately, this particular qualification cannot be renewed through e‑learning only.
+LmsNoRenewal: Unfortunately, this particular qualification cannot be renewed through e‑learning only. Please contact us, if you do not yet know how to renew this qualification. Ignore this automatically generated reminder email, if you have made arrangements for the renewal of this qualification already.
 LmsRenewalReminder: Reminder
 LmsActNotify: Resend e‑learning notification by post or email
 LmsActRenewPin: Randomly replace e‑learning password

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

@@ -25,10 +25,14 @@ PersonalInfoTutorialsWip: Die Anzeige von Kurse, zu denen Sie angemeldet sind wi
 ProfileGroupSubmissionDates: Bei Gruppenabgaben wird kein Datum angezeigt, wenn Sie die Gruppenabgabe nie selbst hochgeladen haben.
 ProfileCorrectorRemark: Die oberhalb angezeigte Tabelle zeigt nur prinzipielle Einteilungen als Korrektor zu einem Übungsblatt. Auch ohne Einteilung können Korrekturen einzeln zugewiesen werden, welche hier dann nicht aufgeführt werden.
 ProfileCorrections: Auflistung aller zugewiesenen Korrekturen
-Remarks: Hinweise
+Remarks: Hinweis:
 
-ProfileSupervisor: Übergeordnete Ansprechpartner
-ProfileSupervisee: Ist Ansprechpartner für
+ProfileNoSupervisor: Keine übergeordneten Ansprechpartner vorhanden
+ProfileSupervisor n@Int m@Int: #{n} #{pluralDE n "übergeordneter" "übergeordnete"} Ansprechpartner#{noneMoreDE m "" (", davon " <> tshow m <> " mit Benachrichtigungsumleitung")}
+ProfileSupervisorRemark n@Int m@Int l@Int: #{m} von #{n} #{pluralDE m "übergeordneter" "übergeordnete"} Ansprechpartner mit Benachrichtigungsumleitung#{noneMoreDE l "" (", davon " <> tshow l <> " mit postalischer Benachrichtigung")}
+ProfileNoSupervisee: Ist kein Ansprechpartner für irgendjemand
+ProfileSupervisee n@Int m@Int: Ist Ansprechpartner für #{n} #{pluralDE n "Person" "Personen"}#{noneMoreDE m "" (", davon " <> tshow m <> " mit Benachrichtigungsumleitung")}
+ProfileSuperviseeRemark n@Int m@Int: Dieser Nutzer ist Ansprechpartner für #{n} #{pluralDE n "Person" "Personen"}#{noneMoreDE m "" (", davon " <> tshow m <> " mit Benachrichtigungsumleitung")}
 
 UserTelephone: Telefon
 UserMobile: Mobiltelefon

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

@@ -25,10 +25,14 @@ PersonalInfoTutorialsWip: The feature to display courses you have registered for
 ProfileGroupSubmissionDates: No date is shown for group submissions if you have never uploaded the submission yourself.
 ProfileCorrectorRemark: The table above only shows registration as a corrector in principle. Even without registration corrections can be assigned individually and are not listed.
 ProfileCorrections: List of all assigned corrections
-Remarks: Remarks
+Remarks: Remark:
 
-ProfileSupervisor: Supervised by
-ProfileSupervisee: Supervises
+ProfileNoSupervisor: Is not supervised by anynone
+ProfileSupervisor n m: #{pluralENsN n "supervisor"} #{noneMoreEN m "" ("with " <> tshow m <> " active notification rerouting")}
+ProfileSupervisorRemark n@Int m@Int l@Int: #{m} of #{n} #{pluralENs m "supervisor"} with active notification rerouting#{noneMoreEN l "" (", and " <> tshow l <> "of these prefer postal notifications")}
+ProfileNoSupervisee: Does not supervise anynone
+ProfileSupervisee n m: Supervises  #{pluralENsN n "person"} #{noneMoreEN m "" ("with " <> tshow m <> " active notification rerouting")}
+ProfileSuperviseeRemark n m: This person supervises #{pluralENsN n "person"}#{noneMoreEN m "" (" with " <> tshow m <> " having active notifications rerouting to this user")}
 
 UserTelephone: Phone
 UserMobile: Mobile

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

@@ -22,6 +22,7 @@ AdminUserPostAddress: Postalische Anschrift
 AdminUserPrefersPostal: Briefe anstatt Email bevorzugt
 AdminUserPinPassword: Passwort zur Verschlüsselung von PDF Anhängen in Emails
 AdminUserNoPassword: Kein Passwort gesetzt
+AdminUserPinPassNotIncluded: Hinweis: Das Passwort wird hier zur Bequemlichkeit zusätzlich angezeigt und ist selbstverständlich nicht im originalem Inhalt enthalten.
 AdminUserAssimilate: Diesen Benutzer assimilieren von
 UserAdded: Benutzer erfolgreich angelegt
 UserCollision: Benutzer konnte wegen Eindeutigkeit nicht angelegt werden
@@ -37,10 +38,10 @@ AuthPWHashAlreadyConfigured: Nutzer:in meldet sich bereits mit FRADrive spezifis
 AuthPWHashConfigured: Nutzer:in meldet sich nun mit FRADrive spezifischer Kennung an
 UsersCourseSchool: Bereich
 ActionNoUsersSelected: Keine Benutzer:innen ausgewählt
-SynchroniseAvsUserQueued n@Int: AVS-Synchronisation von #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} zwingend angestoßen
-SynchroniseAvsAllUsersQueued n@Int64: AVS-Synchronisation von allen #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} angestoßen, welche heute noch nicht synchronisiert wurden
-SynchroniseLdapUserQueued n@Int: LDAP-Synchronisation von #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} angestoßen
-SynchroniseLdapAllUsersQueued: LDAP-Synchronisation von allen Benutzer:innen angestoßen
+SynchroniseAvsUserQueued n@Int: AVS-Synchronisation von #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} zwingend angestoßen, die Ausführung wird mehrere Minuten benötigen!
+SynchroniseAvsAllUsersQueued n@Int64: AVS-Synchronisation von allen #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} angestoßen, welche heute noch nicht synchronisiert wurden, die Ausführung wird eine Weile brauchen!
+SynchroniseLdapUserQueued n@Int: LDAP-Synchronisation von #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} angestoßen, die Ausführung wird mehrere Minuten benötigen!
+SynchroniseLdapAllUsersQueued: LDAP-Synchronisation von allen Benutzer:innen angestoßen, die Ausführung kann eine Weile brauchen!
 UserListTitle: Komprehensive Benutzerliste
 AccessRightsSaved: Berechtigungen erfolgreich verändert
 AccessRightsNotChanged: Berechtigungen wurden nicht verändert
@@ -94,11 +95,15 @@ UserHijack: Sitzung übernehmen
 UserAddSupervisor: Ansprechpartner hinzufügen
 UserSetSupervisor: Ansprechpartner ersetzen
 UserRemoveSupervisor: Alle Ansprechpartner entfernen
+UserRemoveSubordinates: Alle Ansprechpartnerbeziehungen zu Untergebenen beenden
 UserIsSupervisor: Ist Ansprechpartner
 UserAvsSwitchCompany: Als Primärfirma verwenden
+UserAvsSwitchCompanyField: Primärfirma auswählen
 UserAvsCompanySwitched c@CompanyShorthand: Primärfirma gewechselt zu #{tshow c}
 AllUsersLdapSync: Alle LDAP-Synchronisieren
 AllUsersAvsSync: Alle AVS-Synchronisieren
+ThisUserLdapSync: LDAP Synchronisation
+ThisUserAvsSync: AVS Synchronisation
 AuthKindLDAP: Fraport AG Kennung
 AuthKindPWHash: FRADrive Kennung
 AuthKindNoLogin: Kein Login möglich
@@ -106,4 +111,9 @@ Name !ident-ok: Name
 UsersChangeSupervisorsSuccess usr@Int spr@Int: #{tshow spr} Ansprechpartner für #{tshow usr} Benutzer gesetzt.
 UsersChangeSupervisorsWarning usr@Int spr@Int bad@Int: Nur _{MsgUsersChangeSupervisorsSuccess usr spr} #{tshow bad} Ansprechpartner #{pluralDE bad "wurde" "wurden"} nicht gefunden!
 UsersRemoveSupervisors usr@Int: Alle Ansprechpartner für #{tshow usr} Benutzer gelöscht.
-SupervisorReason: Begründung
+UsersRemoveSubordinates usr@Int: Alle Ansprechpartnerbeziehungen für #{tshow usr} #{pluralDE usr "ehemaligen" "ehemalige"} Ansprechpartner gelöscht.
+UserCompanyReason: Begründung der Firmenassoziation
+UserCompanyReasonTooltip: Optionale Notiz für besondere Fälle. Kann ggf. autmatische Entfernung bei AVS Firmenwechsel verhindern.
+UserSupervisorReason: Begründung Ansprechpartner
+UserSupervisorReasonTooltip: Optionale Notiz für besondere Fälle. Kann ggf. autmatische Entfernung bei AVS Firmenwechsel verhindern.
+AdminUserAllNotifications: Alle Benachrichtigungen and diesen Benutzer

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

@@ -22,6 +22,7 @@ AdminUserPostAddress: Postal Address
 AdminUserPrefersPostal: Prefers postal letters over email
 AdminUserPinPassword: Password used for PDF attachments to emails
 AdminUserNoPassword: No password set
+AdminUserPinPassNotIncluded: Note: the password is shown here only for convenience, but is not contained in the original content, of course.
 AdminUserAssimilate: Assimilate user by another user
 UserAdded: Successfully added user
 UserCollision: Could not create user due to uniqueness constraint
@@ -37,10 +38,10 @@ AuthPWHashAlreadyConfigured: User already logs in using their FRADrive specific
 AuthPWHashConfigured: User now logs in using their FRADrive specific account
 UsersCourseSchool: Department
 ActionNoUsersSelected: No users selected
-SynchroniseAvsUserQueued n: Triggered forced AVS synchronisation of #{n} #{pluralEN n "user" "users"}
-SynchroniseAvsAllUsersQueued n: Triggered AVS synchronisation of all #{n} #{pluralEN n "user" "users"} that were not already synchronised today
-SynchroniseLdapUserQueued n: Triggered LDAP synchronisation of #{n} #{pluralEN n "user" "users"}
-SynchroniseLdapAllUsersQueued: Triggered LDAP synchronisation of all users
+SynchroniseAvsUserQueued n: Triggered forced AVS synchronisation of #{n} #{pluralEN n "user" "users"}, which may take several minutes to complete.
+SynchroniseAvsAllUsersQueued n: Triggered AVS synchronisation of all #{n} #{pluralEN n "user" "users"} that were not already synchronised today, which may take quite a while to complete.
+SynchroniseLdapUserQueued n: Triggered LDAP synchronisation of #{n} #{pluralEN n "user" "users"}, which may take several minutes to complete.
+SynchroniseLdapAllUsersQueued: Triggered LDAP synchronisation of all users, which may take quite a while to complete.
 UserListTitle: Comprehensive list of users
 AccessRightsSaved: Successfully updated permissions
 AccessRightsNotChanged: Permissions left unchanged
@@ -94,11 +95,15 @@ UserHijack: Hijack session
 UserAddSupervisor: Add supervisor
 UserSetSupervisor: Replace supervisors
 UserRemoveSupervisor: Set to unsupervised
+UserRemoveSubordinates: Remove all subordinates
 UserIsSupervisor: Is supervisor
 UserAvsSwitchCompany: Use as primary company
+UserAvsSwitchCompanyField: Select primary company
 UserAvsCompanySwitched c: Primary company switched to #{tshow c}
 AllUsersLdapSync: Synchronise all with LDAP
 AllUsersAvsSync: Synchronise all with AVS
+ThisUserLdapSync: Synchronise user with LDAP
+ThisUserAvsSync: Synchronise user with AVS
 AuthKindLDAP: Fraport AG account
 AuthKindPWHash: FRADrive account
 AuthKindNoLogin: No login
@@ -106,4 +111,9 @@ Name: Name
 UsersChangeSupervisorsSuccess usr spr: #{pluralENsN spr "supervisor"} for #{pluralENsN usr "user"} set.
 UsersChangeSupervisorsWarning usr spr bad: Only _{MsgUsersChangeSupervisorsSuccess usr spr} #{pluralENsN bad "supervisors"} could not be identified!
 UsersRemoveSupervisors usr: Removed all supervisors for #{pluralENsN usr "user"}.
-SupervisorReason: Reason
+UsersRemoveSubordinates usr: Removed all subordinates for #{pluralENsN usr "previous supervisor"}.
+UserCompanyReason: Reason for company association
+UserCompanyReasonTooltip: Optional note for special cases. In some case this may prevent automatic removel upon AVS user company changes.
+UserSupervisorReason: Reason for supervision
+UserSupervisorReasonTooltip: Optional note for special cases. In some case this may prevent automatic removel upon AVS user company changes.
+AdminUserAllNotifications: All notification sent to this user

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

@@ -12,10 +12,12 @@ FieldSecondary: Nebenfach
 MultiEmailFieldTip: Es sind mehrere, Komma-separierte, E-Mail-Adressen möglich
 MultiSelectTip: Mehrfachauswahl und Abwählen mit Strg-Klick
 WeekDay: Wochentag
+Hours: Stunden
 LdapIdentificationOrEmail: Fraport AG-Kennung / E-Mail-Adresse
 Months num@Int64: #{num} #{pluralDE num "Monat" "Monate"}
 Days num@Int64: #{num} #{pluralDE num "Tag" "Tage"}
 NoAutomaticUpdateTip: Dieser Wert wurde manuell editiert und wird daher nicht mehr automatisch durch as AVS aktualisiert.
+AddressIsLinkedTip: Verlinkte Postaddresse: Für diesen Benutzer ist keine individuelle Postadresse gespeichert, die Adresse wurde stattdessen aus der Firmenzugehörigkeit abgeleitet.
 
 ClusterVolatileQuickActionsEnabled: Schnellzugriffsmenü aktiv
 
@@ -26,4 +28,7 @@ AvsNoLicenceGuest: Keine Fahrberechtigung (Gast, Fahrberechtigungserwerb nicht m
 
 PaginationSize: Einträge pro Seite
 PaginationPage: Angzeigte Seite
-PaginationError: Paginierung Parameter dürfen nicht negativ sein
+PaginationError: Paginierung Parameter dürfen nicht negativ sein
+
+NullDeletes: Zum Löschen NULL eingeben.
+SortPriority: Sortierungspriorität

messages/uniworx/misc/en-eu.msg

@@ -12,10 +12,12 @@ FieldSecondary: Minor
 MultiEmailFieldTip: Multiple emails addresses may be specified (comma-separated)
 MultiSelectTip: Multiple selection and desection via Ctrl-Click
 WeekDay: Day of the week
+Hours: Hours
 LdapIdentificationOrEmail: Fraport AG-Kennung / email address
 Months num: #{num} #{pluralEN num "Month" "Months"}
 Days num: #{num} #{pluralEN num "Day" "Days"}
 NoAutomaticUpdateTip: This particular value receives no automatic AVS updates, since it has been edited manually.
+AddressIsLinkedTip: Linked postal address: No individual postal address is stored for this user, instead a postal address was inferred from the user's company association.
 
 ClusterVolatileQuickActionsEnabled: Quick actions enabled
 
@@ -26,4 +28,7 @@ AvsNoLicenceGuest: No driving licence (Guest account, cannot acquire a diriving
 
 PaginationSize: Rows per Page
 PaginationPage: Page to show
-PaginationError: Pagination parameter must not be negative
+PaginationError: Pagination parameter must not be negative
+
+NullDeletes:  Enter NULL to delete.
+SortPriority: Sort order priority

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

@@ -151,5 +151,3 @@ BreadcrumbSubmissionAuthorshipStatements: Eigenständigkeitserklärungen
 BreadcrumbExternalApis: Externe APIs
 BreadcrumbApiDocs: API Dokumentation
 BreadcrumbSwagger !ident-ok: OpenAPI 2.0 (Swagger)
-BreadcrumbSynchLdap !ident-ok: LDAP Synch
-BreadcrumbSynchAvs !ident-ok: AVS Synch

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

@@ -151,5 +151,3 @@ BreadcrumbSubmissionAuthorshipStatements: Statements of Authorship
 BreadcrumbExternalApis: External APIs
 BreadcrumbApiDocs: API documentation
 BreadcrumbSwagger: OpenAPI 2.0 (Swagger)
-BreadcrumbSynchLdap: Synch LDAP
-BreadcrumbSynchAvs: Synch AVS

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

@@ -143,12 +143,18 @@ MenuSap: SAP Schnittstelle
 MenuAvs: AVS Schnittstelle
 MenuAvsSynchError: AVS Problemübersicht
 MenuLdap: LDAP Schnittstelle
-MenuApc: Druckerei
+MenuApc: Druck
 MenuPrintSend: Manueller Briefversand
 MenuPrintDownload: Brief herunterladen
 MenuPrintLog: LPR Schnittstelle
 MenuPrintAck: Druckbestätigung
 
+MenuCommCenter: Benachrichtigungen
+MenuMailCenter: E‑Mails
+MenuMailHtml !ident-ok: Html
+MenuMailPlain !ident-ok: Text
+MenuMailAttachment: Anhang
+
 MenuApiDocs: API-Dokumentation (Englisch)
 MenuSwagger !ident-ok: OpenAPI 2.0 (Swagger)
 

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

@@ -143,12 +143,18 @@ MenuSap: SAP Interface
 MenuAvs: AVS Interface
 MenuAvsSynchError: AVS Problem Overview
 MenuLdap: LDAP Interface
-MenuApc: Printing
+MenuApc: Print
 MenuPrintSend: Send Letter
 MenuPrintDownload: Download Letter
 MenuPrintLog: LPR Interface
 MenuPrintAck: Acknowledge Printing
 
+MenuCommCenter: Notifications
+MenuMailCenter: Email
+MenuMailHtml: Html
+MenuMailPlain: Text
+MenuMailAttachment: Attachment
+
 MenuApiDocs: API documentation
 MenuSwagger: OpenAPI 2.0 (Swagger)
 

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

@@ -79,10 +79,13 @@ TableCompany: Firma
 TableCompanyFilter: Firma oder Nummer
 TableCompanyShort: Firmenkürzel
 TableCompanies: Firmen
+TablePrimeCompany: Primäre Firma
 TableCompanyNo: Firmennummer
 TableCompanyNos: Firmennummern
 TableCompanyUser: Firmenangehöriger
 TableCompanyNrUsers: Firmenangehörige
+TableCompanyNrSecondaryUsers: Sekundäre Firmenangehörige
+TableCompanyReason: Notiz
 TableCompanyNrSupers: Ansprechpartner
 TableCompanyNrEmpSupervised: Firmenangehörige mit Ansprechpartner
 TableCompanyNrEmpRerouted: Firmenangehörige mit Umleitung
@@ -96,6 +99,7 @@ TableRerouteActive: Umleitung
 TableCompanyPostalPreference: Benachrichtigungspräferenz neue Firmenangehörige
 TableSupervisor: Ansprechpartner
 TableSupervisee: Ansprechpartner für
+TableReason: Begründung
 TableCreationTime: Erstellungszeit
 TableJob !ident-ok: Job
 TableJobContent !ident-ok: Parameter
@@ -107,6 +111,7 @@ ActJobDeleteForce n@Int: Auch vor #{pluralDEnN n "Minute"} gesperrte Jobs entfer
 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.
+TableFilterCommaPlusShort: Unterstützt mehrere Kriterien mit Komma-Plus, siehe oben.
 TableFilterCommaName: Mehrere Namen mit Komma trennen.
 TableFilterCommaNameNr: Mehrere Namen oder Nummern mit Komma trennen. Nummern werden nur exakt gesucht.
 TableUserEdit: Benutzer bearbeiten

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

@@ -79,10 +79,13 @@ TableCompany: Company
 TableCompanyFilter: Company/Nr
 TableCompanyShort: Company shorthand
 TableCompanies: Companies
+TablePrimeCompany: Primary company
 TableCompanyNo: Company number
 TableCompanyNos: Company numbers
 TableCompanyUser: Associate
 TableCompanyNrUsers: Associates
+TableCompanyNrSecondaryUsers: Secondary Associates
+TableCompanyReason: Note
 TableCompanyNrSupers: Supervisors
 TableCompanyNrEmpSupervised: Supervised employees 
 TableCompanyNrEmpRerouted: Employees having reroute
@@ -96,6 +99,7 @@ TableRerouteActive: Reroute
 TableCompanyPostalPreference: Default notification preference
 TableSupervisor: Supervisor
 TableSupervisee: Supervisor for
+TableReason: Reason
 TableCreationTime: Creation
 TableJob !ident-ok: Job
 TableJobContent !ident-ok: Parameters
@@ -107,6 +111,7 @@ ActJobDeleteForce n: Also delete jobs locked #{pluralENsN n "minute"} ago
 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.
+TableFilterCommaPlusShort: Support multiple criteria with comma/plus, see above.
 TableFilterCommaName: Separate names by comma.
 TableFilterCommaNameNr: Separate names and numbers by comma. Numbers have to match exact.
 TableUserEdit: Edit user

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

@@ -25,6 +25,7 @@ RGTutorialParticipants tutn@TutorialName: Kursteilnehmer:innen (#{tutn})
 RGExamRegistered examn@ExamName: Angemeldet zur Prüfung „#{examn}“
 RGSheetSubmittor shn@SheetName: Abgebende für das Übungsblatt „#{shn}“
 CommSubject: Betreff
+CommContent: Inhalt
 CommAttachments: Anhänge
 CommAttachmentsTip: Im Allgemeinen ist es vorzuziehen Dateien, die Sie mit den Empfängern teilen möchten, als Material hochzuladen (und ggf. in der Nachricht zu verlinken). So ist die Datei für die Empfänger dauerhaft abrufbar und auch Personen, die sich z.B. erst später zur Kursart anmelden, haben Zugriff auf die Datei.
 CommSuccess n@Int: Nachricht wurde an #{n} Empfänger versandt
@@ -82,6 +83,7 @@ MultiUserFieldInvitationExplanationAlways: Es wird an alle Adressen, die Sie hie
 AmbiguousEmail: E-Mail-Adresse nicht eindeutig
 InvalidEmailAddress: E-Mail-Adresse ist ungültig
 InvalidEmailAddressWith e@Text: E-Mail-Adresse #{show e} ist ungültig
+MailFileAttachment: Dateianhang
 UtilExamResultGrade: Note
 UtilExamResultPass: Bestanden/Nicht Bestanden
 UtilExamResultNoShow: Nicht erschienen
@@ -96,6 +98,7 @@ RoomReferenceLinkLink !ident-ok: Link
 RoomReferenceLinkLinkPlaceholder !ident-ok: URL
 RoomReferenceLinkInstructions: Anweisungen
 RoomReferenceLinkInstructionsPlaceholder: Anweisungen
+UtilNoneSet: Keine angegeben
 UtilEmptyChoice: Auswahl war leer
 UtilEmptyNoChangeTip: Eine leere Eingabe belässt den vorherigen Wert unverändert.
 MultiNoSelection: Keine Auswahl

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

@@ -25,6 +25,7 @@ RGTutorialParticipants tutn: Course participants (#{tutn})
 RGExamRegistered examn: Registered for exam “#{examn}”
 RGSheetSubmittor shn: Submitted for exercise sheet “#{shn}”
 CommSubject: Subject
+CommContent: Content
 CommAttachments: Attachments
 CommAttachmentsTip: In general it is preferable to upload files as course type material instead of sending them as attachments. You can then link to the material from the message. The file is then permanently accessable to the recipients and to persons that, for example, register for the Course type at a later date.
 CommSuccess n: Message was sent to #{n} #{pluralEN n "recipient" "recipients"}
@@ -82,6 +83,7 @@ MultiUserFieldInvitationExplanationAlways: An invitation will be sent via email
 AmbiguousEmail: Email address is ambiguous
 InvalidEmailAddress: Email address is invalid
 InvalidEmailAddressWith e: Email asdress #{show e} is invalid
+MailFileAttachment: Attached file
 UtilExamResultGrade: Grade
 UtilExamResultPass: Passed/Failed
 UtilExamResultNoShow: Not present
@@ -96,6 +98,7 @@ RoomReferenceLinkLink: Link
 RoomReferenceLinkLinkPlaceholder: URL
 RoomReferenceLinkInstructions: Instructions
 RoomReferenceLinkInstructionsPlaceholder: Instructions
+UtilNoneSet: None set
 UtilEmptyChoice: Empty selection
 UtilEmptyNoChangeTip: Existing values remain unchanged if this field is left empty.
 MultiNoSelection: No selection

models/audit.model

@@ -26,7 +26,7 @@ InterfaceHealth
   interface Text
   subtype   Text Maybe
   write     Bool Maybe
-  hours     Int  
+  hours     Int                   -- negative number: never expires, i.e. if the last entry is a success, this remains indefinitely
   UniqueInterfaceHealth interface subtype write !force -- Note that nullable fields must be either empty or unique
   deriving Eq Read Show Generic
 

models/company.model

@@ -8,7 +8,7 @@ Company
   name            CompanyName             -- == (CI Text) -- NOTE: Fraport department name may carry additional information; use the Shorthand with respect to UserCompanyDepartment
   shorthand       CompanyShorthand        -- == (CI Text) and CompanyKey :: CompanyShorthand -> CompanyId   A change to AvsId as primary key is too much work and not strictly necessary due to Uniqueness
   avsId           Int     default=0       -- primary key from avs, use negative numbers for non-AVS companies 
-  prefersPostal   Bool    default=false   -- new company users prefers letters by post instead of email
+  prefersPostal   Bool    default=true    -- new company users prefers letters by post instead of email
   postAddress     StoredMarkup Maybe      -- default company postal address, including company name 
   email           UserEmail Maybe         -- Case-insensitive generic company eMail address  
   -- UniqueCompanyName name               -- Should be Unique in AVS, but we do not yet need to enforce it

models/lms.model

@@ -13,14 +13,16 @@ Qualification
   refreshWithin       CalendarDiffDays Maybe    -- notify users about renewal within this number of month/days before expiry; to be used with addGregorianDurationClip
   refreshReminder     CalendarDiffDays Maybe    -- send a second notification about renewal within this number of month/days before expiry
   elearningStart      Bool                      -- automatically schedule e-refresher
-  -- elearningOnly       Bool                   -- successful E-learing automatically increases validity. NO!  
+  elearningRenews     Bool default=true         -- successful e-learing automatically increases validity automatically by validDuration
+  elearningLimit      Int Maybe                 -- limit of e-learning attempts, currently only for informative purposes, as it is enforced by LMS only
+  lmsReuses           QualificationId Maybe     -- if set, lms is also included within the given qualification's lms, but only for direct routes. AuditDuration is used from this Qualification instead.
   expiryNotification  Bool default=true         -- should expiryNotification be generated for this qualification?
   avsLicence          AvsLicence Maybe          -- if set, valid QualificationUsers are synchronized to AVS as a driving licence
-  sapId               Text Maybe                -- if set, valid QualificationUsers with userCompanyPersonalNumber are transmitted via SAP interface under this id
+  sapId               Text Maybe                -- if set, valid QualificationUsers with userCompanyPersonalNumber are transmitted via SAP interface under this id  
   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 -- either empty or unique
+    -- across all schools, only one qualification may be a driving licence -- NO LONGER TRUE
+    -- UniqueQualificationAvsLicence avsLicence      !force -- either empty or unique 
     -- NOTE: two NULL values are not equal for the purpose of Uniqueness constraints!
   deriving Show Eq Generic
 
@@ -40,19 +42,20 @@ Qualification
 --  - PinReset==1 mit bestehendem Passwort kann problemlos erneut gesendet werden
 --  - Flag "interner Mitarbeiter" wird von Know-How ignoriert / nicht ausgewertet (legacy)
 
-QualificationPrecondition                       -- NOTE: this can only be enforced through a background job adding or removing qualifications
-  qualification     QualificationId OnDeleteCascade OnUpdateCascade -- AND: not unique, ie. qualification can have multiple required preconditions
-  required          [QualificationId]           -- OR : alternatives, any one will suffice
-  continuous        Bool                        -- expiring precondition blocks qualification
-  deriving Generic Show
+-- QualificationPrecondition                       -- NOTE: this can only be enforced through a background job adding or removing qualifications
+--  qualification     QualificationId OnDeleteCascade OnUpdateCascade -- AND: not unique, ie. qualification can have multiple required preconditions
+--  required          [QualificationId]           -- OR : alternatives, any one will suffice -- we don't want array, since we have recursive CTEs
+--  continuous        Bool                        -- expiring precondition blocks qualification
+--  deriving Generic Show
 
 -- Maybe an alternative for online qualification validity checking, transitivity through recursive CTEs? (already available in our version)
--- QualificationRequirement
---   qualification     QualificationId OnDeleteCascade OnUpdateCascade
---   requirement       QualificationId OnDeleteCascade OnUpdateCascade
---   group             Text -- OR: several requirements within the same group are considered equivalent
---   UniqueQualificationRequirement qualification requirement
---
+QualificationRequirement
+ qualification     QualificationId OnDeleteCascade OnUpdateCascade
+ requirement       QualificationId OnDeleteCascade OnUpdateCascade
+ group             Int        -- OR: several requirements within the same group are considered equivalent; no order between groups
+ note              Text       -- for humans only, no semantical effect
+ UniqueQualificationRequirement qualification requirement
+ deriving Generic Show
 
 -- TODO: connect Qualification with Exams!
 

models/print.model

@@ -10,6 +10,7 @@ PrintJob
   created         UTCTime
   acknowledged    UTCTime Maybe
   recipient       UserId Maybe          OnDeleteSetNull OnUpdateCascade   -- optional as some letters may contain just an address
+  affected        UserId Maybe          OnDeleteSetNull OnUpdateCascade   -- subject of the letter
   sender          UserId Maybe          OnDeleteSetNull OnUpdateCascade   -- senders and associations are optional
   course          CourseId Maybe        OnDeleteCascade OnUpdateCascade
   qualification   QualificationId Maybe OnDeleteCascade OnUpdateCascade

models/users.model

@@ -91,8 +91,9 @@ UserCompany
     company               CompanyId  OnDeleteCascade OnUpdateCascade
     supervisor            Bool       default=false -- should this user be made supervisor for all _new_ users associated with this company?        
     supervisorReroute     Bool       default=false -- if supervisor is true, should this supervisor receive email for _new_ company users?
-    priority              Int        default=0     -- higher number, higher priority
+    priority              Int        default=0     -- higher number, higher priority; default=1 for Haskell-Code
     useCompanyAddress     Bool       default=true  -- if true, CompanyPostalAddress and CompanyEmail are used if UserPostalAddress/UserDisplayEmail are Nothing, respects priority
+    reason                Text Maybe -- miscellaneous note, e.g. Superior
     UniqueUserCompany user company   -- a user may belong to multiple companies, but to each one only once
     deriving Generic Show
 UserSupervisor

nix/docker/version.json

@@ -1,3 +1,3 @@
 {
-  "version": "27.4.70"
+  "version": "27.4.79"
 }

package-lock.json

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

package.json

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

package.yaml

@@ -1,5 +1,5 @@
 name: uniworx
-version: 27.4.70
+version: 27.4.79
 dependencies:
   - base
   - yesod

routes

@@ -55,8 +55,6 @@
 /users/#CryptoUUIDUser                AdminUserR       GET POST
 /users/#CryptoUUIDUser/delete         AdminUserDeleteR     POST
 /users/#CryptoUUIDUser/hijack         AdminHijackUserR GET POST       !adminANDno-escalation
-/users/#CryptoUUIDUser/sync/ldap      AdminUserSyncLdapR          GET
-/users/#CryptoUUIDUser/sync/avs       AdminUserSyncAvsR           GET
 /users/#CryptoUUIDUser/notifications  UserNotificationR           GET POST   !self
 /users/#CryptoUUIDUser/password       UserPasswordR               GET POST   !selfANDis-pw-hash
 !/users/functionary-invite/new        AdminNewFunctionaryInviteR  GET POST
@@ -73,11 +71,18 @@
 /admin/avs/#CryptoUUIDUser    AdminAvsUserR    GET POST
 /admin/ldap                   AdminLdapR       GET POST
 /admin/problems               AdminProblemsR			 GET POST 
-/admin/problems/no-contact    ProblemUnreachableR  GET
+/admin/problems/no-contact    ProblemUnreachableR  GET POST
 /admin/problems/no-avs-id     ProblemWithoutAvsId  GET
 /admin/problems/r-without-f   ProblemFbutNoR       GET
 /admin/problems/avs  					ProblemAvsSynchR 		 GET POST
 /admin/problems/avs/errors		ProblemAvsErrorR 		 GET
+/admin/config/interfaces      ConfigInterfacesR		 GET POST 
+
+/comm                                 CommCenterR     GET 
+/comm/email                           MailCenterR     GET POST
+/comm/email/html/#CryptoUUIDSentMail  MailHtmlR       GET
+/comm/email/plain/#CryptoUUIDSentMail MailPlainR      GET
+/comm/email/attachment/#CryptoUUIDSentMail/#Text MailAttachmentR GET
 
 /print                                PrintCenterR    GET POST  !system-printer
 /print/acknowledge/#Day/#Int/#Int     PrintAckR       GET POST  !system-printer

shell.nix

@@ -197,9 +197,9 @@ let
     UPLOAD_S3_KEY_ID=''${MINIO_ACCESS_KEY}
     UPLOAD_S3_KEY=''${MINIO_SECRET_KEY}
 
-    SMTPHOST=''${SMTPHOST}
-    SMTPPORT=''${SMTPPORT}
-    SMTPSSL=''${SMTPSSL}
+    # SMTPHOST=''${SMTPHOST}
+    # SMTPPORT=''${SMTPPORT}
+    # SMTPSSL=''${SMTPSSL}
     EOF
 
     set +xe

src/Application.hs

@@ -157,6 +157,8 @@ import Handler.Upload
 import Handler.Qualification
 import Handler.LMS
 import Handler.SAP
+import Handler.CommCenter
+import Handler.MailCenter
 import Handler.PrintCenter
 import Handler.ApiDocs
 import Handler.Swagger
@@ -352,15 +354,15 @@ makeFoundation appSettings''@AppSettings{..} = do
           handleIf isBucketExists (const $ return ()) $ Minio.makeBucket appUploadTmpBucket Nothing
         return conn
 
-      appAvsQuery <- case appAvsConf of 
+      appAvsQuery <- case appAvsConf of
         Nothing -> do
           $logErrorS "avsPrepare" "appAvsConfig is empty, i.e. invalid AVS configuration settings."
           return Nothing
-          -- error "AvsConfig is empty, i.e. invalid AVS configuration settings."          
-          
-        Just avsConf -> do          
+          -- error "AvsConfig is empty, i.e. invalid AVS configuration settings."
+
+        Just avsConf -> do
           manager <- newManagerSettings $ mkManagerSettings (def { settingDisableCertificateValidation = True }) Nothing
-          let avsServer = BaseUrl 
+          let avsServer = BaseUrl
                             { baseUrlScheme = Https
                             , baseUrlHost = avsHost avsConf
                             , baseUrlPort = avsPort avsConf
@@ -657,7 +659,7 @@ appMain = runResourceT $ do
                    notifyWatchdog = forever' Nothing $ \pResults -> do
                      let delay = floor $ wInterval % 4
                      d <- liftIO $ newDelay delay
- 
+
                      $logDebugS "Notify" $ "Waiting up to " <> tshow delay <> "µs..."
                      mResults <- atomically $ asum
                        [ pResults <$ waitDelay d

src/Audit.hs

@@ -1,7 +1,9 @@
--- SPDX-FileCopyrightText: 2023 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
+-- SPDX-FileCopyrightText: 2023-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
+{-# LANGUAGE TypeApplications #-}
+
 module Audit
   ( module Audit.Types
   , AuditException(..)
@@ -17,6 +19,8 @@ import Import.NoModel
 import Settings
 import Model
 import Database.Persist.Sql
+import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
+import qualified Database.Esqueleto.Utils        as E
 import Audit.Types
 
 import qualified Data.Text          as Text
@@ -129,7 +133,7 @@ logInterface :: ( AuthId (HandlerSite m) ~ Key User
       -> 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 
+logInterface interfaceLogInterface interfaceLogSubtype interfaceLogSuccess interfaceLogRows interfaceLogInfo = do
   interfaceLogWrite <- (methodGet /=) . Wai.requestMethod . reqWaiRequest <$> getRequest
   logInterface' interfaceLogInterface interfaceLogSubtype interfaceLogWrite interfaceLogSuccess interfaceLogRows interfaceLogInfo
 
@@ -173,20 +177,25 @@ logInterface' (Text.strip -> interfaceLogInterface) (Text.strip -> interfaceLogS
 
 reportAdminProblem ::  ( IsSqlBackend (YesodPersistBackend (HandlerSite m))
                   , SqlBackendCanWrite (YesodPersistBackend (HandlerSite m))
-                  , MonadHandler m                 
+                  , MonadHandler m
                   -- , HasCallStack
                   )
-      => AdminProblem -- ^ Problem to record 
+      => AdminProblem -- ^ Problem to record
       -> ReaderT (YesodPersistBackend (HandlerSite m)) m ()
--- ^ Log a problem that needs interventions by admins 
+-- ^ Log a problem that needs interventions by admins, provided this problem has not already been reported and is still unsolved
 --
 --   - `problemLogTime` is now
 --   - `problemSolver` is Nothing, we do not record the person who caused it
-reportAdminProblem problem@(toJSON -> problemLogInfo) = do
-  problemLogTime <- liftIO getCurrentTime
+reportAdminProblem problem = do
   let problemLogSolved = Nothing
       problemLogSolver = Nothing
-  insert_ ProblemLog{..}
+      problemLogInfo   = toJSON problem
+  problemLogTime <- liftIO getCurrentTime
+  isKnown <- E.selectExists $ do
+    pl <- E.from $ E.table @ProblemLog
+    E.where_ $ E.isNothing (pl E.^. ProblemLogSolved)
+        E.&&. E.val problemLogInfo E.==. pl E.^. ProblemLogInfo
+  unless isKnown $ insert_ ProblemLog{..}
   $logWarnS "Problem" $ Text.filter (/= '\n') $ tshow problem -- <> " - " <> pack (prettyCallStack callStack)
 
 

src/Audit/Types.hs

@@ -185,7 +185,7 @@ data Transaction
     }
   | TransactionLmsStart
     { transactionQualification :: QualificationId
-    , transactionLmsIdent      :: LmsIdent    
+    , transactionLmsIdent      :: LmsIdent
     , transactionLmsUser       :: UserId
     , transactionLmsUserKey    :: LmsUserId
     }
@@ -216,7 +216,7 @@ data Transaction
   | TransactionQualificationUserEdit  -- Note that a renewal always entails unblocking as well!
     { transactionUser                         :: UserId                 -- qualification holder that is updated
     , transactionQualificationUser            :: QualificationUserId    -- not really necessary, maybe remove?
-    , transactionQualification                :: QualificationId    
+    , transactionQualification                :: QualificationId
     , transactionQualificationValidUntil      :: Day
     , transactionQualificationScheduleRenewal :: Maybe Bool -- Maybe, because some update may leave it unchanged (also avoids DB Migration)
     , transactionNote                         :: Maybe Text
@@ -261,11 +261,12 @@ derivePersistFieldJSON ''Transaction
 -- Datatype for raising admin awareness to certain problems
 -- Database stores generic Value in table ProblemLog, such that changes do not disturb old entries
 -- Note that there is no RenderMessage instance, instead see @Handler.Admin.adminProblemCell dealing with special cases instead
+-- Note: Adjust MsgAdminProblemInfoTooltip as well
 data AdminProblem
   = AdminProblemNewCompany                                      -- new company was noticed, presumably without supervisors
     { adminProblemCompany           :: CompanyId
     }
-  | AdminProblemSupervisorNewCompany                            
+  | AdminProblemSupervisorNewCompany
     { adminProblemUser              :: UserId                   -- a default supervisor has changed company
     , adminProblemCompany           :: CompanyId                -- old company where the user had default supervisor rights
     , adminProblemCompanyNew        :: CompanyId                -- new company of the user
@@ -276,13 +277,23 @@ data AdminProblem
     , adminProblemCompany           :: CompanyId                -- old company
     , adminProblemSupervisorReroute :: Bool                     -- reroute included?
     }
-  | AdminProblemNewlyUnsupervised  
+  | AdminProblemCompanySuperiorChange                           -- a company received a new superior user through AVS
+    { adminProblemUser              :: UserId                   -- new superior user
+    , adminProblemCompany           :: CompanyId                -- affected company
+    , adminProblemUserOld           :: Maybe UserId             -- previous superior
+    }
+  | AdminProblemCompanySuperiorNotFound                         -- a company received a new superior user through AVS, but user could not be created from email
+    { adminProblemEmail             :: Maybe Text               -- new superior user's email, not found in LDAP
+    , adminProblemCompany           :: CompanyId                -- affected company
+    , adminProblemUserOld           :: Maybe UserId             -- previous superior
+    }
+  | AdminProblemNewlyUnsupervised
     { adminProblemUser              :: UserId                   -- user who had a supervisor but no longer has, due to user company change
     , adminProblemCompanyOld        :: Maybe CompanyId          -- old company
     , adminProblemCompanyNew        :: CompanyId                -- new company of the user
     }
   | AdminProblemUnknown                                         -- miscellanous problem, just displaying text
-    { adminProblemText              :: Text    
+    { adminProblemText              :: Text
     }
   deriving (Eq, Ord, Read, Show, Generic)
 

src/Auth/Dummy.hs

@@ -34,7 +34,7 @@ dummyForm = do
   mr <- getMessageRender
   wreq (ciField & addDatalist userList) (fslpI MsgDummyIdent (mr MsgDummyIdentPlaceholder) & addAttr "autocomplete" "username" & addName PostLoginDummy) Nothing
   where
-    userList = fmap mkOptionList . runDB $ withReaderT projectBackend (map toOption <$> selectList [] [Asc UserIdent] :: ReaderT SqlBackend _ [Option UserIdent])
+    userList = fmap mkOptionList . runDB $ withReaderT projectBackend (map toOption <$> selectList [UserId <=. UserKey 12] [Asc UserIdent] :: ReaderT SqlBackend _ [Option UserIdent])
     toOption (Entity _ User{..}) = Option userDisplayName userIdent (CI.original userIdent)
 
 apDummy :: Text

src/CryptoID.hs

@@ -59,6 +59,7 @@ decCryptoIDs [ ''SubmissionId
              , ''MaterialFileId
              , ''PrintJobId
              , ''QualificationId
+             , ''SentMailId
              ]
 
 decCryptoIDKeySize

src/Database/Esqueleto/Utils.hs

@@ -15,6 +15,7 @@ module Database.Esqueleto.Utils
   , (=?.), (?=.)
   , (=~.), (~=.)
   , (>~.), (<~.)
+  , (~.), (~*.), (!~.), (!~*.)
   , or, and
   , any, all
   , not__, parens
@@ -26,6 +27,7 @@ module Database.Esqueleto.Utils
   , mkContainsFilterWithSet, mkContainsFilterWithComma, mkContainsFilterWithCommaPlus
   , mkDayFilter, mkDayFilterFrom, mkDayFilterTo
   , mkExistsFilter, mkExistsFilterWithComma
+  --  , mkRegExFilterWith
   , anyFilter, allFilter
   , ascNullsFirst, descNullsLast
   , orderByList
@@ -48,11 +50,13 @@ module Database.Esqueleto.Utils
   , subSelectCountDistinct
   , selectCountRows, selectCountDistinct
   , selectMaybe
+  , str2text, str2text'
   , num2text --, text2num
   , day, day', dayMaybe, interval, diffDays, diffTimes
   , exprLift
   , explicitUnsafeCoerceSqlExprValue
-  -- , truncateTable
+  , psqlVersion_
+  , truncateTable
   , module Database.Esqueleto.Utils.TH
   ) where
 
@@ -63,6 +67,8 @@ import qualified Data.Set as Set
 import qualified Data.List as List
 import qualified Data.Foldable as F
 import Data.List.NonEmpty (NonEmpty(..))
+import qualified Database.Persist as P
+import qualified Database.Persist.EntityDef.Internal as P (entityDB)
 import qualified Database.Esqueleto.Legacy as E
 import qualified Database.Esqueleto.Experimental as Ex
 import qualified Database.Esqueleto.PostgreSQL as E
@@ -160,6 +166,24 @@ infixl 4 <~.
 (<~.) ::  PersistField typ => E.SqlExpr (E.Value typ) -> E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value Bool)
 (<~.) a b = E.isNothing b E.||. (E.just a E.<. b)
 
+infixr 2 ~., ~*., !~., !~*.
+
+-- | PostgreSQL regular expression match, case sensitive. Works, but may throw SQL error for unblanced parenthesis, etc. Not suitable for dbTable filters
+(~.) :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value Bool)
+(~.) = E.unsafeSqlBinOp    " ~ "
+
+-- | PostgreSQL regular expression match, case insensitive. Works, but may throw SQL errors
+(~*.) :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value Bool)
+(~*.) = E.unsafeSqlBinOp    " ~* "
+
+-- | PostgreSQL regular expression does not match, case sensitive. Works, but may throw SQL error for unblanced parenthesis, etc. Not suitable for dbTable filters
+(!~.) :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value Bool)
+(!~.) = E.unsafeSqlBinOp    " !~ "
+
+-- | PostgreSQL regular expression does not match, case insensitive. Works, but may throw SQL errors
+(!~*.) :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value Bool)
+(!~*.) = E.unsafeSqlBinOp    " !~* "
+
 
 -- | Negation of `isNothing` which is missing
 isJust :: PersistField typ => E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value Bool)
@@ -326,7 +350,7 @@ mkExactFilterLastWith :: (PersistField b)
                       -> Last a                        -- ^ needle
                       -> E.SqlExpr (E.Value Bool)
 mkExactFilterLastWith cast lenslike row criterias
-  | Last (Just crit) <- criterias = lenslike row E.==. E.val (cast crit)  
+  | Last (Just crit) <- criterias = lenslike row E.==. E.val (cast crit)
   | otherwise = true
 
 -- | like `mkExactFilterLast` but deals with Nothing being a filter criterion as well
@@ -407,11 +431,23 @@ mkContainsFilterWithCommaPlus cast lenslike row (foldMap commaSeparatedText -> c
   | Set.null compulsories = cond_optional
   | Set.null alternatives = cond_compulsory
   | otherwise             = cond_compulsory E.&&. cond_optional
-  where    
+  where
     (Set.mapMonotonic (Text.stripStart . Text.drop 1) -> compulsories, alternatives) = Set.partition (Text.isPrefixOf "+") criterias
     cond_compulsory = all (hasInfix (lenslike row) . E.val . cast) compulsories
     cond_optional   = any (hasInfix (lenslike row) . E.val . cast) alternatives
 
+-- like `mkContainsFilterWith` but allows regular expression criterias
+-- This works, but throws SQL errors for unbalanced parenthesis and similar invalid regex expressions
+-- mkRegExFilterWith :: (E.SqlString b, Ord a)
+--                      => (a -> b)
+--                      -> (t -> E.SqlExpr (E.Value b))  -- ^ getter from query to searched element
+--                      -> t                             -- ^ query row
+--                      -> Set.Set a                     -- ^ needle collection
+--                      -> E.SqlExpr (E.Value Bool)
+-- mkRegExFilterWith cast lenslike row criterias
+--   | Set.null criterias = true
+--   | otherwise = any ((~.) (lenslike row) . E.val . cast) criterias
+
 mkDayFilter :: (t -> E.SqlExpr (E.Value UTCTime))  -- ^ getter from query to searched element
             -> t                                   -- ^ query row
             -> Last Day                            -- ^ a day to filter for
@@ -514,7 +550,7 @@ selectExists query = do
     _other      -> error "SELECT EXISTS ... returned zero or more than one rows"
 selectNotExists = fmap not . selectExists
 
-filterExists :: (MonadIO m, PersistEntity val, MonoFoldable mono, PersistField (Element mono)) 
+filterExists :: (MonadIO m, PersistEntity val, MonoFoldable mono, PersistField (Element mono))
              => EntityField val (Element mono) -> mono -> E.SqlReadT m [Element mono]
 filterExists prj vs = fmap (fmap Ex.unValue) <$> Ex.select $ do
   ent <- Ex.from Ex.table
@@ -653,7 +689,8 @@ infixl 8 ->.
 
 infixl 8 ->>.
 
-(->>.) :: E.SqlExpr (E.Value a) -> Text -> E.SqlExpr (E.Value Text) 
+-- Unsafe variant, see Database.Esqueleto.PostgreSQL.JSON for a safe version!
+(->>.) :: E.SqlExpr (E.Value a) -> Text -> E.SqlExpr (E.Value Text)
 (->>.) expr t = E.unsafeSqlBinOp "->>" expr $ E.val t
 
 infixl 8 ->>>.
@@ -680,7 +717,7 @@ 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)
 
@@ -705,6 +742,13 @@ 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)
 
+-- | convert something that is like a text to text
+str2text :: E.SqlString a => E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value Text)
+str2text = E.unsafeSqlCastAs "text"
+
+str2text' :: E.SqlString a => E.SqlExpr (E.Value (Maybe a)) -> E.SqlExpr (E.Value (Maybe Text))
+str2text' = E.unsafeSqlCastAs "text"
+
 -- | 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"
@@ -724,9 +768,9 @@ dayMaybe :: E.SqlExpr (E.Value (Maybe UTCTime)) -> E.SqlExpr (E.Value (Maybe Day
 dayMaybe = E.unsafeSqlCastAs "date"
 
 interval :: CalendarDiffDays -> E.SqlExpr (E.Value Day) -- E.+=.  requires both types to be the same, so we use Day
--- interval _ = E.unsafeSqlCastAs "interval" $ E.unsafeSqlValue "'P2Y'" -- tested working example 
+-- interval _ = E.unsafeSqlCastAs "interval" $ E.unsafeSqlValue "'P2Y'" -- tested working example
 interval = E.unsafeSqlCastAs "interval". E.unsafeSqlValue . wrapSqlString . Text.Builder.fromString . iso8601Show
-  where 
+  where
     singleQuote     = Text.Builder.singleton '\''
     wrapSqlString b = singleQuote <> b <> singleQuote
 
@@ -771,8 +815,16 @@ instance (PersistField a1, PersistField a2, PersistField b, Finite a1, Finite a2
     ]
     (E.else_ $ E.else_ $ E.veryUnsafeCoerceSqlExprValue (E.nothing :: E.SqlExpr (E.Value (Maybe ()))))
 
+psqlVersion_ :: E.SqlExpr (E.Value Text)
+psqlVersion_ = E.unsafeSqlFunction "VERSION" ()
 
 -- Suspected to cause trouble. Needs more testing!
--- truncateTable :: (MonadIO m, BackendCompatible SqlBackend backend, PersistEntity record) 
+-- truncateTable :: (MonadIO m, BackendCompatible SqlBackend backend, PersistEntity record)
 --               => record -> ReaderT backend m ()
--- truncateTable tbl = E.rawExecute ("TRUNCATE TABLE " <> P.tableName tbl <> "  RESTART IDENTITY") []
+-- truncateTable tbl = E.rawExecute ("TRUNCATE TABLE " <> P.tableName tbl <> "  RESTART IDENTITY") []
+
+truncateTable :: (MonadIO m, BackendCompatible SqlBackend backend, PersistEntity record) -- TODO: test this code
+                  => proxy record -> ReaderT backend m ()
+truncateTable tbl =
+  let tblName :: Text = P.unEntityNameDB $ P.entityDB $ P.entityDef tbl
+  in  E.rawExecute ("TRUNCATE TABLE " <> tblName <> " RESTART IDENTITY") []

src/Foundation/I18n.hs

@@ -39,7 +39,7 @@ module Foundation.I18n
   , StudyDegreeTerm(..)
   , ShortStudyFieldType(..)
   , StudyDegreeTermType(..)
-  , ErrorResponseTitle(..)  
+  , ErrorResponseTitle(..)
   , UniWorXMessages(..)
   , uniworxMessages
   , unRenderMessage, unRenderMessage', unRenderMessageLenient
@@ -88,15 +88,14 @@ pluralDE num singularForm pluralForm
   | otherwise = pluralForm
 
 pluralDEx :: (Eq a, Num a) => Char -> a -> Text -> Text
--- ^ @pluralENs n "Monat" = pluralEN n "Monat" "Monate"@ 
 pluralDEx c n t = pluralDE n t $ t `snoc` c
 
--- | like `pluralDEe` but also prefixes with the number
+-- | like `pluralDEx` but also prefixes with the number
 pluralDExN :: (Eq a, Num a, Show a) => Char -> a -> Text -> Text
 pluralDExN c n t = tshow n <> cons ' ' (pluralDEx c n t)
 
 pluralDEe :: (Eq a, Num a) => a -> Text -> Text
--- ^ @pluralENs n "Monat" = pluralEN n "Monat" "Monate"@ 
+-- ^ @pluralDEe n "Monat" = pluralDEe n "Monat" "Monate"@
 pluralDEe = pluralDEx 'e'
 
 -- | like `pluralDEe` but also prefixes with the number
@@ -105,7 +104,7 @@ pluralDEeN = pluralDExN 'e'
 
 -- | postfix plural with an 'n'
 pluralDEn :: (Eq a, Num a) => a -> Text -> Text
--- ^ @pluralENs n "Monat" = pluralEN n "Monat" "Monate"@ 
+-- ^ @pluralENs n "Monat" = pluralEN n "Monat" "Monate"@
 pluralDEn = pluralDEx 'n'
 
 -- | like `pluralDEn` but also prefixes with the number
@@ -124,14 +123,14 @@ noneOneMoreDE num noneText singularForm pluralForm
   | num == 1  = singularForm
   | otherwise = pluralForm
 
--- noneMoreDE :: (Eq a, Num a)
---             =>    a -- ^ Count
---             -> Text -- ^ None
---             -> Text -- ^ Some
---             -> Text
--- noneMoreDE num noneText someText
---   | num == 0  = noneText
---   | otherwise = someText
+noneMoreDE :: (Eq a, Num a)
+            =>    a -- ^ Count
+            -> Text -- ^ None
+            -> Text -- ^ Some
+            -> Text
+noneMoreDE num noneText someText
+  | num == 0  = noneText
+  | otherwise = someText
 
 pluralEN :: (Eq a, Num a)
          =>    a -- ^ Count
@@ -146,7 +145,7 @@ pluralENs :: (Eq a, Num a)
           => a -- ^ Count
           -> Text -- ^ Singular
           -> Text
--- ^ @pluralENs n "foo" = pluralEN n "foo" "foos"@ 
+-- ^ @pluralENs n "foo" = pluralEN n "foo" "foos"@
 pluralENs n t = pluralEN n t $ t `snoc` 's'
 
 -- | like `pluralENs` but also prefixes with the number
@@ -164,14 +163,14 @@ noneOneMoreEN num noneText singularForm pluralForm
   | num == 1  = singularForm
   | otherwise = pluralForm
 
--- noneMoreEN :: (Eq a, Num a)
---             =>    a -- ^ Count
---             -> Text -- ^ None
---             -> Text -- ^ Some
---             -> Text
--- noneMoreEN num noneText someText
---   | num == 0  = noneText
---   | otherwise = someText
+noneMoreEN :: (Eq a, Num a)
+            =>    a -- ^ Count
+            -> Text -- ^ None
+            -> Text -- ^ Some
+            -> Text
+noneMoreEN num noneText someText
+  | num == 0  = noneText
+  | otherwise = someText
 
 _ordinalEN :: ToMessage a
           => a
@@ -191,20 +190,20 @@ notEN :: Bool -> Text
 notEN = bool "not" ""
 
 {-  -- TODO: use this is message eventually
--- Commonly used plurals 
+-- Commonly used plurals
 data Thing = Person | Examinee
   deriving (Eq)
 
-thingDE :: Int -> Thing -> Text 
+thingDE :: Int -> Thing -> Text
 thingDE num = (tshow num <>) . Text.cons ' ' . thing
-  where 
+  where
     thing :: Thing -> Text
     thing Person    = pluralDE num "Person"   "Personen"
     thing Examinee  = pluralDE num "Prüfling" "Prüflinge"
-  
-thingEN :: Int -> Thing -> Text 
+
+thingEN :: Int -> Thing -> Text
 thingEN num t = tshow num <> Text.cons ' ' (thing t)
-  where 
+  where
     thing :: Thing -> Text
     thing Person    = pluralENs num "person"
     thing Examinee  = pluralENs num "examinee"
@@ -282,7 +281,7 @@ mkMessageAddition ''UniWorX "Avs" "messages/uniworx/categories/avs" "de-de-forma
 embedRenderMessage ''UniWorX ''LmsStatus (uncurry ((<>) . (<> "Status")) . Text.splitAt 3)
 
 
-newtype SomeMessages master = SomeMessages [SomeMessage master]  
+newtype SomeMessages master = SomeMessages [SomeMessage master]
   deriving newtype (Semigroup, Monoid)
 
 instance master ~ master' => RenderMessage master (SomeMessages master') where
@@ -621,6 +620,6 @@ unRenderMessageLenient = unRenderMessage' cmp
 instance Default DateTimeFormatter where
   def = mkDateTimeFormatter (getTimeLocale' []) def appTZ
 
-instance RenderMessage UniWorX Address where 
+instance RenderMessage UniWorX Address where
   renderMessage s l a@Address{addressName = Just aname} = aname <> cons ' ' (renderMessage s l a{addressName=Nothing})
   renderMessage _ _   Address{addressEmail = mail} = "<" <> mail <> ">"

src/Foundation/Navigation.hs

@@ -88,8 +88,6 @@ breadcrumb (AdminUserR cID) = useRunDB . maybeT (i18nCrumb MsgBreadcrumbUser $ J
   User{..} <- MaybeT $ get uid
   return (userDisplayName, Just UsersR)
 breadcrumb (AdminUserDeleteR    cID) = i18nCrumb MsgBreadcrumbUserDelete  . Just $ AdminUserR cID
-breadcrumb (AdminUserSyncLdapR  cID) = i18nCrumb MsgBreadcrumbSynchLdap   . Just $ AdminUserR cID
-breadcrumb (AdminUserSyncAvsR   cID) = i18nCrumb MsgBreadcrumbSynchAvs    . Just $ AdminUserR cID
 breadcrumb (AdminHijackUserR    cID) = i18nCrumb MsgBreadcrumbUserHijack  . Just $ AdminUserR cID
 breadcrumb (UserNotificationR   cID) = useRunDB $ do
   mayList <- hasReadAccessTo UsersR
@@ -124,6 +122,7 @@ breadcrumb ProblemWithoutAvsId  = i18nCrumb MsgProblemsNoAvsIdHeading     $ Just
 breadcrumb ProblemFbutNoR       = i18nCrumb MsgProblemsRWithoutFHeading   $ Just AdminProblemsR
 breadcrumb ProblemAvsSynchR     = i18nCrumb MsgProblemsAvsSynchHeading    $ Just AdminProblemsR
 breadcrumb ProblemAvsErrorR     = i18nCrumb MsgProblemsAvsErrorHeading    $ Just AdminProblemsR
+breadcrumb ConfigInterfacesR    = i18nCrumb MsgConfigInterfacesHeading    $ Just AdminProblemsR
 
 breadcrumb FirmAllR         = i18nCrumb MsgMenuFirms              Nothing
 breadcrumb FirmsCommR{}     = i18nCrumb MsgMenuFirmsComm        $ Just   FirmAllR
@@ -131,7 +130,13 @@ breadcrumb FirmUsersR{}     = i18nCrumb MsgMenuFirmUsers        $ Just   FirmAll
 breadcrumb (FirmSupersR fsh)= i18nCrumb MsgMenuFirmSupervisors  $ Just $ FirmUsersR fsh
 breadcrumb (FirmCommR   fsh)= i18nCrumb MsgMenuFirmsComm        $ Just $ FirmUsersR fsh
 
-breadcrumb PrintCenterR     = i18nCrumb MsgMenuApc              Nothing
+breadcrumb CommCenterR      = i18nCrumb MsgMenuCommCenter       Nothing
+breadcrumb MailCenterR      = i18nCrumb MsgMenuMailCenter     $ Just CommCenterR
+breadcrumb MailHtmlR{}      = i18nCrumb MsgMenuMailHtml       $ Just MailCenterR
+breadcrumb MailPlainR{}     = i18nCrumb MsgMenuMailPlain      $ Just MailCenterR
+breadcrumb (MailAttachmentR mid _) = i18nCrumb MsgMenuMailAttachment $ Just $ MailHtmlR mid
+
+breadcrumb PrintCenterR     = i18nCrumb MsgMenuApc            $ Just CommCenterR
 breadcrumb PrintSendR       = i18nCrumb MsgMenuPrintSend      $ Just PrintCenterR
 breadcrumb PrintDownloadR{} = i18nCrumb MsgMenuPrintDownload  $ Just PrintCenterR
 breadcrumb PrintAckR{}      = i18nCrumb MsgMenuPrintSend      $ Just PrintCenterR -- never displayed
@@ -1227,14 +1232,6 @@ pageActions (AdminUserR cID) = return
   , NavPageActionPrimary
     { navLink = defNavLink MsgMenuUserEdit $ ForProfileR cID
     , navChildren = []
-    }  
-  , NavPageActionPrimary
-    { navLink = defNavLink MsgUserLdapSync $ AdminUserSyncLdapR cID
-    , navChildren = []
-    }
-  , NavPageActionPrimary
-    { navLink = defNavLink MsgUserAvsSync $ AdminUserSyncAvsR cID
-    , navChildren = []
     }
   , NavPageActionPrimary
     { navLink = defNavLinkModal MsgUserHijack $ AdminHijackUserR cID
@@ -1467,6 +1464,12 @@ pageActions (ForProfileR cID) = return
     , navChildren = []
     }
   ]
+pageActions (ForProfileDataR cID) = return
+  [ NavPageActionPrimary
+    { navLink = defNavLink MsgAdminUserHeading $ AdminUserR cID
+    , navChildren = []
+    }
+  ]
 pageActions TermShowR = do
   participantsSecondary <- pageQuickActions NavQuickViewPageActionSecondary ParticipantsListR
   return
@@ -2481,6 +2484,50 @@ pageActions PrintCenterR = do
   dayLinks <- mapM toDayAck $ Map.toAscList dayMap
   return $ manualSend : printLog : printAck : take 9 dayLinks
 
+pageActions CommCenterR = return
+  [ NavPageActionPrimary
+    { navLink = defNavLink MsgMenuMailCenter MailCenterR
+    , navChildren = []
+    }
+  , NavPageActionPrimary
+    { navLink = defNavLink MsgMenuApc PrintCenterR
+    , navChildren = []
+    }
+  ]
+
+pageActions (MailHtmlR smid) = do
+  sid <- decrypt smid
+  usrNotiSettings <- useRunDB $ runMaybeT $ do
+    sm <- MaybeT $ get sid
+    uid <- hoistMaybe $ sentMailRecipient sm
+    User{userDisplayName} <- MaybeT $ get uid
+    uuid <- liftHandler $ encrypt uid
+    return NavPageActionPrimary
+        { navLink = defNavLink (MsgNotificationSettingsHeading userDisplayName) $ UserNotificationR uuid
+        , navChildren = []
+        }
+  let linkPlain = NavPageActionPrimary
+        { navLink = defNavLink MsgMenuMailPlain $ MailPlainR smid
+        , navChildren = []
+        }
+  return $ msnoc [linkPlain] usrNotiSettings
+pageActions (MailPlainR smid) = do
+  sid <- decrypt smid
+  usrNotiSettings <- useRunDB $ runMaybeT $ do
+    sm <- MaybeT $ get sid
+    uid <- hoistMaybe $ sentMailRecipient sm
+    User{userDisplayName} <- MaybeT $ get uid
+    uuid <- liftHandler $ encrypt uid
+    return NavPageActionPrimary
+        { navLink = defNavLink (MsgNotificationSettingsHeading userDisplayName) $ UserNotificationR uuid
+        , navChildren = []
+        }
+  let linkHtml = NavPageActionPrimary
+        { navLink = defNavLink MsgMenuMailHtml $ MailHtmlR smid
+        , navChildren = []
+        }
+  return $ msnoc [linkHtml] usrNotiSettings
+
 pageActions AdminCrontabR = return
   [ NavPageActionPrimary
     { navLink = defNavLink MsgMenuAdminJobs AdminJobsR
@@ -2488,6 +2535,20 @@ pageActions AdminCrontabR = return
     }
   ]
 
+pageActions AdminProblemsR = return
+  [ NavPageActionPrimary
+    { navLink = defNavLink MsgConfigInterfacesHeading ConfigInterfacesR
+    , navChildren = []
+    }
+  , NavPageActionPrimary
+    { navLink = defNavLink MsgProblemsAvsSynchHeading ProblemAvsSynchR
+    , navChildren = []
+    }
+  , NavPageActionSecondary
+    { navLink = defNavLink MsgProblemsAvsErrorHeading ProblemAvsErrorR
+    }
+  ]
+
 pageActions _ = return []
 
 submissionList :: ( MonadIO m

src/Foundation/Type.hs

@@ -15,7 +15,7 @@ module Foundation.Type
   , _memcachedLocalARC
   , SMTPPool
   , _appSettings', _appStatic, _appConnPool, _appSmtpPool, _appLdapPool, _appWidgetMemcached, _appHttpManager, _appLogger, _appLogSettings, _appCryptoIDKey, _appClusterID, _appInstanceID, _appJobState, _appSessionStore, _appSecretBoxKey, _appJSONWebKeySet, _appHealthReport, _appMemcached, _appUploadCache, _appVerpSecret, _appAuthKey, _appPersonalisedSheetFilesSeedKey, _appVolatileClusterSettingsCache, _appAvsQuery
-  , DB, Form, MsgRenderer, MailM, DBFile
+  , DB, DBRead, Form, MsgRenderer, MailM, DBFile
   ) where
 
 import Import.NoFoundation
@@ -123,8 +123,9 @@ instance HasCookieSettings RegisteredCookie UniWorX where
 instance (MonadHandler m, HandlerSite m ~ UniWorX) => ReadLogSettings m where
   readLogSettings = liftIO . readTVarIO =<< getsYesod (view _appLogSettings)
 
-  
+
 type DB = YesodDB UniWorX
+type DBRead = ReaderT SqlReadBackend (HandlerFor UniWorX)
 type Form x = Html -> MForm (HandlerFor UniWorX) (FormResult x, WidgetFor UniWorX ())
 type MsgRenderer = MsgRendererS UniWorX -- see Utils
 type MailM a = MailT (HandlerFor UniWorX) a

src/Foundation/Yesod/Auth.hs

@@ -107,7 +107,7 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend
           | not isDummy -> res <$ update uid [ UserLastAuthentication =. Just now ]
         _other -> return res
 
-  $logDebugS "auth" $ tshow Creds{..}  
+  $logDebugS "auth" $ tshow Creds{..}
   ldapPool' <- getsYesod $ view _appLdapPool
 
   flip catches excHandlers $ case ldapPool' of
@@ -153,9 +153,9 @@ _upsertCampusUserMode mMode cs@Creds{..}
 
     defaultOther = apHash
 
-ldapLookupAndUpsert :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX, MonadMask m, MonadUnliftIO m) => Text -> SqlPersistT m (Entity User)                    
-ldapLookupAndUpsert ident = 
-  getsYesod (view _appLdapPool) >>= \case 
+ldapLookupAndUpsert :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX, MonadMask m, MonadUnliftIO m) => Text -> SqlPersistT m (Entity User)
+ldapLookupAndUpsert ident =
+  getsYesod (view _appLdapPool) >>= \case
     Nothing -> throwM $ CampusUserLdapError $ LdapHostNotResolved "No LDAP configuration in Foundation."
     Just ldapPool ->
       campusUser'' ldapPool campusUserFailoverMode ident >>= \case
@@ -182,22 +182,21 @@ upsertCampusUser upsertMode ldapData = do
   userDefaultConf <- getsYesod $ view _appUserDefaults
 
   (newUser,userUpdate) <- decodeUser now userDefaultConf upsertMode ldapData
-  --TODO: newUser should be associated with a company and company supervisor through Handler.Utils.Company.oldUpsertUserCompany, but this is called by upsertAvsUser already - conflict?
 
   oldUsers <- for (userLdapPrimaryKey newUser) $ \pKey -> selectKeysList [ UserLdapPrimaryKey ==. Just pKey ] []
 
   user@(Entity userId userRec) <- case oldUsers of
     Just [oldUserId] -> updateGetEntity oldUserId userUpdate
     _other           -> upsertBy (UniqueAuthentication (newUser ^. _userIdent)) newUser userUpdate
-  unless (validDisplayName (newUser ^. _userTitle) 
+  unless (validDisplayName (newUser ^. _userTitle)
                            (newUser ^. _userFirstName)
-                           (newUser ^. _userSurname) 
+                           (newUser ^. _userSurname)
                            (userRec ^. _userDisplayName)) $
-    update userId [ UserDisplayName   =. (newUser ^. _userDisplayName) ]
-  when (validEmail' (userRec ^. _userEmail)) $ do 
+    update userId [ UserDisplayName   =. (newUser ^. _userDisplayName) ]  -- update invalid display names only
+  when (validEmail' (userRec ^. _userEmail)) $ do                         -- RECALL: userRec already contains basic updates
     let emUps =  [ UserDisplayEmail   =. (newUser ^. _userEmail)  | not (validEmail' (userRec ^. _userDisplayEmail))  ]
               ++ [ UserAuthentication =. AuthLDAP                 | is _AuthNoLogin  (userRec ^. _userAuthentication) ]
-    unless (null emUps) $ update userId emUps
+    update userId emUps -- update already checks whether list is empty
     -- Attempt to update ident, too:
     unless (validEmail' (userRec ^. _userIdent)) $
       void $ maybeCatchAll (update userId [ UserIdent =. (newUser ^. _userEmail) ] >> return (Just ()))
@@ -228,10 +227,10 @@ decodeUserTest mbIdent ldapData = do
 
 
 decodeUser :: (MonadThrow m) =>  UTCTime -> UserDefaultConf -> UpsertCampusUserMode -> Ldap.AttrList [] -> m (User,_)
-decodeUser now UserDefaultConf{..} upsertMode ldapData = do    
+decodeUser now UserDefaultConf{..} upsertMode ldapData = do
     let
-      userTelephone             = decodeLdap ldapUserTelephone
-      userMobile                = decodeLdap ldapUserMobile
+      userTelephone             = decodeLdap ldapUserTelephone <&> canonicalPhone
+      userMobile                = decodeLdap ldapUserMobile    <&> canonicalPhone
       userCompanyPersonalNumber = decodeLdap ldapUserFraportPersonalnummer
       userCompanyDepartment     = decodeLdap ldapUserFraportAbteilung
 
@@ -267,7 +266,7 @@ decodeUser now UserDefaultConf{..} upsertMode ldapData = do
       --      -> return $ CI.mk userEmail
       | otherwise
         -> throwM CampusUserInvalidEmail
-        
+
     userLdapPrimaryKey <- if
       | [bs] <- ldapMap !!! ldapPrimaryKey
       , Right userLdapPrimaryKey'' <- Text.decodeUtf8' bs
@@ -306,13 +305,13 @@ decodeUser now UserDefaultConf{..} upsertMode ldapData = do
         , userPrefersPostal           = userDefaultPrefersPostal
         , ..
         }
-      userUpdate =  
+      userUpdate =
         [ UserLastAuthentication      =. Just now  | isLogin ] ++
         [ UserEmail                   =. userEmail | validEmail' userEmail ] ++
         [
-        -- UserDisplayName             =. userDisplayName -- not updated here, since users are allowed to change their DisplayName; see line 272
+        -- UserDisplayName             =. userDisplayName -- not updated here, since users are allowed to change their DisplayName; see line 191
           UserFirstName               =. userFirstName
-        , UserSurname                 =. userSurname                    
+        , UserSurname                 =. userSurname
         , UserLastLdapSynchronisation =. Just now
         , UserLdapPrimaryKey          =. userLdapPrimaryKey
         , UserMobile                  =. userMobile

src/Handler/Admin.hs

@@ -9,8 +9,9 @@ module Handler.Admin
 import Import
 
 -- import Data.Either
-import qualified Data.Set as Set
-import qualified Data.Map as Map
+import qualified Data.Set  as Set
+import qualified Data.Map  as Map
+import qualified Data.Text as Text
 -- import qualified Data.Text.Lazy.Encoding as LBS
 
 -- import qualified Control.Monad.Catch as Catch
@@ -23,11 +24,13 @@ import qualified Database.Esqueleto.Experimental as E
 import qualified Database.Esqueleto.Legacy as EL (on) -- needed for dbTable
 import qualified Database.Esqueleto.Utils as E
 
+import Jobs
 import Handler.Utils
 import Handler.Utils.Avs
 import Handler.Utils.Users
 -- import Handler.Utils.Company
 import Handler.Health.Interface
+import Handler.Users (AllUsersAction(..))
 
 import Handler.Admin.Test as Handler.Admin
 import Handler.Admin.ErrorMessage as Handler.Admin
@@ -55,7 +58,7 @@ data ProblemTableActionData = ProblemTableMarkSolvedData
   deriving (Eq, Ord, Read, Show, Generic)
 
 
--- Handlers 
+-- Handlers
 getAdminR :: Handler Html
 getAdminR = redirect AdminProblemsR
 
@@ -63,7 +66,7 @@ getAdminProblemsR, postAdminProblemsR :: Handler Html
 getAdminProblemsR = handleAdminProblems Nothing
 
 handleAdminProblems :: Maybe Widget -> Handler Html
-handleAdminProblems mbProblemTable = do 
+handleAdminProblems mbProblemTable = do
   now <- liftIO getCurrentTime
   let nowaday = utctDay now
       cutOffOldDays = 1
@@ -75,25 +78,25 @@ handleAdminProblems mbProblemTable = do
   msgErrorTooltip   <- messageI Error   MsgMessageError
 
   let flagError   = messageTooltip . bool msgErrorTooltip   msgSuccessTooltip
-      flagWarning = messageTooltip . bool msgWarningTooltip msgSuccessTooltip      
+      flagWarning = messageTooltip . bool msgWarningTooltip msgSuccessTooltip
       flagNonZero :: Int -> Widget
       flagNonZero n | n <= 0    = flagError True
-                    | otherwise = messageTooltip =<< handlerToWidget (messageI Error (MsgProblemsDriverSynch n))                                    
+                    | otherwise = messageTooltip =<< handlerToWidget (messageI Error (MsgProblemsDriverSynch n))
 
   (usersAreReachable, driversHaveAvsIds, rDriversHaveFs, noStalePrintJobs, noBadAPCids, (interfaceOks, interfaceTable)) <- runDB $ (,,,,,)
-      <$> areAllUsersReachable 
+      <$> areAllUsersReachable
       <*> allDriversHaveAvsId now
       <*> allRDriversHaveFs now
       <*> (not <$> exists [PrintJobAcknowledged ==. Nothing, PrintJobCreated  <. cutOffOldTime])
-      <*> (not <$> exists [PrintAcknowledgeProcessed ==. False])      
-      <*> mkInterfaceLogTable flagError mempty      
+      <*> (not <$> exists [PrintAcknowledgeProcessed ==. False])
+      <*> mkInterfaceLogTable mempty
   let interfacesBadNr = length $ filter (not . snd) interfaceOks
-      -- interfacesOk = all 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)
-    (Right AvsLicenceDifferences{..}) -> do
+    (Right (AvsLicenceDifferences{..},_)) -> do
       let problemIds = avsLicenceDiffRevokeAll <> avsLicenceDiffGrantVorfeld <> avsLicenceDiffRevokeRollfeld <> avsLicenceDiffGrantRollfeld
       void $ runDB $ queueAvsUpdateByAID problemIds $ Just nowaday
       return $ Right
@@ -104,7 +107,7 @@ handleAdminProblems mbProblemTable = do
         )
   -- Attempt to format results in a nicer way failed, since rendering Html within a modal destroyed the page layout itself
   -- let procDiffLics (to0, to1, to2) = Right (Set.size to0, Set.size to1, Set.size to2)
-  -- diffLics <- (procDiffLics <$> retrieveDifferingLicences) `catches`
+  -- diffLics <- (procDiffLics . fst <$> retrieveDifferingLicences) `catches`
   --   [ Catch.Handler (\case (UnsupportedContentType "text/html;charset=utf-8" Response{responseBody})
   --                                         -> return $ Left $ toWidget $ preEscapedToHtml $ fromRight "Response UTF8-decoding error" $ LBS.decodeUtf8' responseBody
   --                          ex             -> return $ Left $ text2widget $ tshow ex)
@@ -118,13 +121,13 @@ handleAdminProblems mbProblemTable = do
     setTitleI   MsgProblemsHeading
     $(widgetFile "admin-problems")
 
-postAdminProblemsR = do 
-    (problemLogRes, problemLogTable) <- runDB mkProblemLogTable    
+postAdminProblemsR = do
+    (problemLogRes, problemLogTable) <- runDB mkProblemLogTable
     formResult problemLogRes procProblems
     handleAdminProblems $ Just problemLogTable
   where
     procProblems :: (ProblemTableActionData, Set ProblemLogId) -> Handler ()
-    procProblems (ProblemTableMarkSolvedData  , pids) = actUpdate True  pids 
+    procProblems (ProblemTableMarkSolvedData  , pids) = actUpdate True  pids
     procProblems (ProblemTableMarkUnsolvedData, pids) = actUpdate False pids
 
     actUpdate markdone pids = do
@@ -139,14 +142,36 @@ postAdminProblemsR = do
       addMessageI mkind $ msg oks
       when (oks > 0) $ reloadKeepGetParams AdminProblemsR -- reload to update all tables
 
-getProblemUnreachableR :: Handler Html
-getProblemUnreachableR = do
+getProblemUnreachableR,  postProblemUnreachableR :: Handler Html
+getProblemUnreachableR = postProblemUnreachableR
+postProblemUnreachableR = do
   unreachables <- runDB retrieveUnreachableUsers
+
+  -- the following form is a nearly identicaly copy from Handler.Users:
+  ((noreachUsersRes, noreachUsersWgt'), noreachUsersEnctype) <- runFormPost . identifyForm FIDUnreachableUsersAction $ buttonForm
+  let noreachUsersWgt = wrapForm noreachUsersWgt' def
+        { formSubmit = FormNoSubmit
+        , formAction = Just $ SomeRoute ProblemUnreachableR
+        , formEncoding = noreachUsersEnctype
+        }
+  formResult noreachUsersRes $ \case
+    AllUsersLdapSync -> do
+      forM_ unreachables $ \Entity{entityKey=uid} -> void . queueJob $ JobSynchroniseLdapUser uid
+      addMessageI Success . MsgSynchroniseLdapUserQueued $ length unreachables
+      redirect ProblemUnreachableR
+    AllUsersAvsSync -> do
+      n <- runDB $ queueAvsUpdateByUID (entityKey <$> unreachables) Nothing
+      addMessageI Success . MsgSynchroniseAvsUserQueued $ fromIntegral n
+      redirect ProblemUnreachableR
+
   siteLayoutMsg MsgProblemsUnreachableHeading $ do
     setTitleI   MsgProblemsUnreachableHeading
     [whamlet|
       <section>
-        #{length unreachables} _{MsgProblemsUnreachableBody}        
+        <h3>_{MsgProblemsUnreachableButtons}
+        ^{noreachUsersWgt}
+      <section>
+        #{length unreachables} _{MsgProblemsUnreachableBody}
         <ul>
           $forall usr <- unreachables
             <li>
@@ -154,8 +179,8 @@ getProblemUnreachableR = do
     |]
 
 getProblemFbutNoR :: Handler Html
-getProblemFbutNoR = do 
-  now <- liftIO getCurrentTime  
+getProblemFbutNoR = do
+  now <- liftIO getCurrentTime
   rnofs <- runDB $ E.select $ retrieveDriversRWithoutF now
   siteLayoutMsg MsgProblemsRWithoutFHeading $ do
     setTitleI   MsgProblemsRWithoutFHeading
@@ -169,8 +194,8 @@ getProblemFbutNoR = do
     |]
 
 getProblemWithoutAvsId :: Handler Html
-getProblemWithoutAvsId = do 
-  now <- liftIO getCurrentTime  
+getProblemWithoutAvsId = do
+  now <- liftIO getCurrentTime
   rnofs <- runDB $ E.select $ retrieveDriversWithoutAvsId now
   siteLayoutMsg MsgProblemsNoAvsIdHeading $ do
     setTitleI   MsgProblemsNoAvsIdHeading
@@ -185,40 +210,47 @@ getProblemWithoutAvsId = do
 
 {-
 mkUnreachableUsersTable = do
-  let dbtSQLQuery user -> do 
+  let dbtSQLQuery user -> do
         E.where_ $ E.isNothing (user E.^. UserPostAddress)
-          E.&&. E.not_ ((user E.^. UserEmail) `E.like` E.val "%@%.%") 
+          E.&&. E.not_ ((user E.^. UserEmail) `E.like` E.val "%@%.%")
         pure user
       dbtRowKey = (E.^. UserId)
       dbtProj = dbtProjId
-      dbtColonnade = 
+      dbtColonnade =
 -}
 
 areAllUsersReachable :: DB Bool
--- areAllUsersReachable = isNothing <$> E.selectOne retrieveUnreachableUsers'
--- areAllUsersReachable = E.selectNotExists retrieveUnreachableUsers'
+-- areAllUsersReachable = E.selectNotExists retrieveUnreachableUsers' -- works and would be more efficient, but we cannot check proper email validity within DB alone
 areAllUsersReachable = null <$> retrieveUnreachableUsers
-  
+
 -- retrieveUnreachableUsers' :: E.SqlQuery (E.SqlExpr (Entity User))
--- retrieveUnreachableUsers' = do     
+-- retrieveUnreachableUsers' = do
 --     user <- E.from $ E.table @User
 --     E.where_ $   E.isNothing (user E.^. UserPostAddress)
 --           E.&&. (E.isNothing (user E.^. UserCompanyDepartment) E.||. user E.^. UserCompanyPersonalNumber `E.ilike` E.justVal "E%")
 --           E.&&. E.not_ ((user E.^. UserDisplayEmail)  `E.like` E.val "%@%.%")
 --           E.&&. E.not_ ((user E.^. UserEmail)         `E.like` E.val "%@%.%")
---     return user 
+--     return user
 
 retrieveUnreachableUsers :: DB [Entity User]
-retrieveUnreachableUsers = do 
-    emailOnlyUsers <- E.select $ do 
+retrieveUnreachableUsers = do
+    emailOnlyUsers <- E.select $ do
       user <- E.from $ E.table @User
       E.where_ $   E.isNothing (user E.^. UserPostAddress)
-            E.&&. (E.isNothing (user E.^. UserCompanyDepartment) E.||. user E.^. UserCompanyPersonalNumber `E.ilike` E.justVal "E%")    
+            E.&&. (E.isNothing (user E.^. UserCompanyDepartment) E.||. user E.^. UserCompanyPersonalNumber `E.ilike` E.justVal "E%")
+            E.&&. E.notExists (do
+                (cmp :& usrCmp) <- E.from $ E.table @Company `E.innerJoin` E.table @UserCompany
+                  `E.on` (\(cmp :& usrCmp) -> cmp E.^. CompanyId E.==. usrCmp E.^. UserCompanyCompany)
+                E.where_ $ user E.^. UserId E.==. usrCmp E.^. UserCompanyUser
+                    E.&&.  usrCmp E.^. UserCompanyUseCompanyAddress
+                    E.&&.  E.isJust (cmp E.^. CompanyPostAddress)
+              )
       return user
-    filterM hasInvalidEmail emailOnlyUsers    
-  where 
+    filterM hasInvalidEmail emailOnlyUsers
+    -- filterM hasInvalifPostal -- probably not worth it, since Utils.Postal.validPostAddress is pretty weak anyway
+  where
     hasInvalidEmail = fmap isNothing . getUserEmail
-  
+
 
 allDriversHaveAvsId :: UTCTime -> DB Bool
 -- allDriversHaveAvsId = fmap isNothing . E.selectOne . retrieveDriversWithoutAvsId
@@ -227,17 +259,17 @@ allDriversHaveAvsId = E.selectNotExists . retrieveDriversWithoutAvsId
 {-
 -- | Returns users more than once if they own multiple avs-related valid licences, but no AvsID is known
 retrieveDriversWithoutAvsId' :: Day -> E.SqlQuery (E.SqlExpr (Entity User))
-retrieveDriversWithoutAvsId' nowaday = do     
+retrieveDriversWithoutAvsId' nowaday = do
   (usr :& qualUsr :& qual) <- E.from $ E.table @User
     `E.innerJoin`  E.table @QualificationUser
     `E.on` (\(usr :& qualUsr) -> usr E.^. UserId E.==. qualUsr E.^. QualificationUserUser)
-    `E.innerJoin`  E.table @Qualification              
-    `E.on` (\(_usr :& qualUsr :& qual) -> qual E.^. QualificationId E.==. qualUsr E.^. QualificationUserQualification)    
+    `E.innerJoin`  E.table @Qualification
+    `E.on` (\(_usr :& qualUsr :& qual) -> qual E.^. QualificationId E.==. qualUsr E.^. QualificationUserQualification)
   E.where_ $ -- is avs licence
       E.isJust (qual E.^. QualificationAvsLicence)
     E.&&. (qualUsr & validQualification nowaday)
     E.&&. -- AvsId is unknown
-      E.notExists (do 
+      E.notExists (do
         avsUsr <- E.from $ E.table @UserAvs
         E.where_ $ avsUsr E.^. UserAvsUser E.==. usr E.^. UserId
       )
@@ -246,20 +278,20 @@ retrieveDriversWithoutAvsId' nowaday = do
 
 -- | Returns users at most once, even if they own multiple avs-related licences, but no AvsID is known
 retrieveDriversWithoutAvsId :: UTCTime -> E.SqlQuery (E.SqlExpr (Entity User))
-retrieveDriversWithoutAvsId now = do     
+retrieveDriversWithoutAvsId now = do
   usr <- E.from $ E.table @User
-  E.where_ $ 
-      E.exists (do -- a valid avs licence 
-        (qual :& qualUsr) <- E.from (E.table @Qualification 
+  E.where_ $
+      E.exists (do -- a valid avs licence
+        (qual :& qualUsr) <- E.from (E.table @Qualification
               `E.innerJoin` E.table @QualificationUser
               `E.on` (\(qual :& qualUsr) -> qual E.^. QualificationId E.==. qualUsr E.^. QualificationUserQualification))
         E.where_ $ -- is avs licence
             E.isJust (qual E.^. QualificationAvsLicence)
           E.&&. (qualUsr & validQualification now) -- currently valid
-          E.&&. -- matches user 
+          E.&&. -- matches user
             (qualUsr E.^. QualificationUserUser E.==. usr E.^. UserId)
       )
-    E.&&. 
+    E.&&.
       E.notExists (do -- a known AvsId
         avsUsr <- E.from $ E.table @UserAvs
         E.where_ $ avsUsr E.^. UserAvsUser E.==. usr E.^. UserId
@@ -268,20 +300,20 @@ retrieveDriversWithoutAvsId now = do
 
 
 allRDriversHaveFs :: UTCTime -> DB Bool
--- allRDriversHaveFs = fmap isNothing . E.selectOne . retrieveDriversRWithoutF 
-allRDriversHaveFs = E.selectNotExists . retrieveDriversRWithoutF 
+-- allRDriversHaveFs = fmap isNothing . E.selectOne . retrieveDriversRWithoutF
+allRDriversHaveFs = E.selectNotExists . retrieveDriversRWithoutF
 
 -- | Returns users at most once, even if they own multiple avs-related licences, but no AvsID is known
 retrieveDriversRWithoutF :: UTCTime -> E.SqlQuery (E.SqlExpr (Entity User))
-retrieveDriversRWithoutF now = do     
+retrieveDriversRWithoutF now = do
   usr <- E.from $ E.table @User
   let hasValidQual lic = do
-        (qual :& qualUsr) <- E.from (E.table @Qualification 
+        (qual :& qualUsr) <- E.from (E.table @Qualification
               `E.innerJoin` E.table @QualificationUser
               `E.on` (\(qual :& qualUsr) -> qual E.^. QualificationId E.==. qualUsr E.^. QualificationUserQualification))
-        E.where_ $  (qual E.^. QualificationAvsLicence  E.==. E.justVal lic)    -- matches licence 
-              E.&&. (qualUsr E.^. QualificationUserUser E.==. usr E.^. UserId)  -- matches user 
-              E.&&. (qualUsr & validQualification now)                                 -- currently valid            
+        E.where_ $  (qual E.^. QualificationAvsLicence  E.==. E.justVal lic)    -- matches licence
+              E.&&. (qualUsr E.^. QualificationUserUser E.==. usr E.^. UserId)  -- matches user
+              E.&&. (qualUsr & validQualification now)                          -- currently valid
   E.where_ $ E.exists (hasValidQual AvsLicenceRollfeld)
     E.&&. E.notExists (hasValidQual AvsLicenceVorfeld)
   return usr
@@ -309,8 +341,15 @@ resultUser :: Traversal' ProblemLogTableData (Entity User)
 resultUser = _dbrOutput . _3 . _Just
 
 mkProblemLogTable :: DB (FormResult (ProblemTableActionData, Set ProblemLogId), Widget)
-mkProblemLogTable = over _1 postprocess <$> dbTable validator DBTable{..}
+mkProblemLogTable = do
+    -- problem_types <- E.select $ do
+    --   ap <- E.from $ E.table @ProblemLog
+    --   let res = ap E.^. ProblemLogInfo E.->>. "problem"
+    --   E.groupBy res
+    --   return res
+    over _1 postprocess <$> dbTable validator DBTable{..}
   where
+    -- TODO: query to collect all occurring problem types to use as tooltip for the problem filter, so that these don't run out of synch
     dbtIdent = "problem-log" :: Text
     dbtSQLQuery = \(problem `E.LeftOuterJoin` solver `E.LeftOuterJoin` usr) -> do
                     -- EL.on (usr    E.?. UserId E.==. E.text2num (problem E.^. ProblemLogInfo   E.->>. "user")) -- works
@@ -318,7 +357,7 @@ mkProblemLogTable = over _1 postprocess <$> dbTable validator DBTable{..}
                     EL.on (solver E.?. UserId E.==. problem E.^. ProblemLogSolver)
                     return (problem, solver, usr)
     dbtRowKey = queryProblem >>> (E.^. ProblemLogId)
-    dbtProj = dbtProjId
+    dbtProj = dbtProjFilteredPostId
     dbtColonnade = formColonnade $ mconcat
       [ dbSelect (applying _2) id $ return . view (resultProblem . _entityKey)
       , sortable (Just "time")    (i18nCell MsgAdminProblemCreated) $ \(   view $ resultProblem . _entityVal . _problemLogTime   -> t) ->           dateTimeCell t
@@ -339,10 +378,24 @@ mkProblemLogTable = over _1 postprocess <$> dbTable validator DBTable{..}
       , single ("solver", sortUserNameBareM querySolver)
       ]
     dbtFilter = mconcat
-      [ single ("solved" , FilterColumn . E.mkExactFilterLast $ views (to queryProblem) (E.isJust . (E.^. ProblemLogSolved)))
+      [ single ("user"    , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to queryUser)   (E.?. UserDisplayName))
+      , single ("solver"  , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to querySolver) (E.?. UserDisplayName))
+      , single ("company" , FilterColumn . E.mkContainsFilter  $ views (to queryProblem) ((E.->>. "company").(E.^. ProblemLogInfo)))
+      , single ("solved"  , FilterColumn . E.mkExactFilterLast $ views (to queryProblem) (E.isJust . (E.^. ProblemLogSolved)))
+      -- , single ("problem" , FilterColumn . E.mkContainsFilter  $ views (to queryProblem) ((E.->>. "problem").(E.^. ProblemLogInfo))) -- not stored in plaintext!
+      , single ("problem" , mkFilterProjectedPost $ \(getLast -> criterion) dbr -> -- falls es nicht schnell genug ist: in dbtProj den Anzeigetext nur einmal berechnen
+          ifNothingM criterion True $ \(crit::Text) -> do
+            let problem = dbr ^. resultProblem . _entityVal . _problemLogAdminProblem
+            protxt <- adminProblem2Text problem
+            return $ crit `Text.isInfixOf` protxt
+        )
       ]
     dbtFilterUI mPrev = mconcat
-      [ prismAForm (singletonFilter "solved" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgAdminProblemSolved)
+      [ prismAForm (singletonFilter "user"    . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)                        (fslI MsgAdminProblemUser   & setTooltip MsgTableFilterCommaPlus)
+      , prismAForm (singletonFilter "solver"  . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)                        (fslI MsgAdminProblemSolver & setTooltip MsgTableFilterCommaPlusShort)
+      , prismAForm (singletonFilter "problem" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)                        (fslI MsgAdminProblemInfo)
+      , prismAForm (singletonFilter "company" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)                        (fslI MsgTableCompanyShort)
+      , prismAForm (singletonFilter "solved"  . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgAdminProblemSolved)
       ]
     acts :: Map ProblemTableAction (AForm Handler ProblemTableActionData)
     acts = mconcat
@@ -375,28 +428,5 @@ mkProblemLogTable = over _1 postprocess <$> dbTable validator DBTable{..}
       let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap
       return (act, usrSet)
 
--- adminProblemCell :: IsDBTable m a => AdminProblem -> DBCell m a
--- -- note that adminProblemCompany/adminProblemCompanyOld and adminProblemUser are automatically displayed within their own columns
--- adminProblemCell AdminProblemNewCompany{}                                 
---   = i18nCell MsgAdminProblemNewCompany
--- adminProblemCell AdminProblemSupervisorNewCompany{adminProblemCompanyNew, adminProblemSupervisorReroute} 
---   = i18nCell (MsgAdminProblemSupervisorNewCompany adminProblemSupervisorReroute) <> companyIdCell adminProblemCompanyNew
--- adminProblemCell AdminProblemSupervisorLeftCompany{adminProblemSupervisorReroute}
---   = i18nCell (MsgAdminProblemSupervisorLeftCompany adminProblemSupervisorReroute)
--- adminProblemCell AdminProblemNewlyUnsupervised{adminProblemCompanyNew}  
---   = i18nCell MsgAdminProblemNewlyUnsupervised <> companyIdCell adminProblemCompanyNew
--- adminProblemCell AdminProblemUnknown{adminProblemText}  
---   = textCell $ "Problem: " <> adminProblemText
-
-
--- msgAdminProblem :: AdminProblem -> DB (SomeMessages UniWorX) 
--- msgAdminProblem AdminProblemNewCompany{adminProblemCompany=comp} = return $ 
---   SomeMessages [SomeMessage MsgAdminProblemNewCompany, text2message ": ", company2msg comp]
--- msgAdminProblem AdminProblemSupervisorNewCompany{adminProblemCompany=comp, adminProblemCompanyNew=newComp} = return $ 
---   SomeMessages [SomeMessage MsgAdminProblemSupervisorNewCompany, text2message ": ", company2msg  comp, text2message " -> ", company2msg newComp]
--- msgAdminProblem AdminProblemSupervisorLeftCompany{adminProblemCompany=comp} = return $ 
---   SomeMessages [SomeMessage MsgAdminProblemSupervisorLeftCompany, text2message ": ", company2msg  comp]
--- msgAdminProblem AdminProblemNewlyUnsupervised{adminProblemCompanyOld=comp, adminProblemCompanyNew=newComp} = return $ 
---   SomeMessages [SomeMessage MsgAdminProblemNewlyUnsupervised, text2message ": ", maybe (text2message "???") company2msg comp, text2message " -> ", company2msg newComp]
--- msgAdminProblem AdminProblemUnknown{adminProblemText=err} = return $
---   someMessages ["Problem: ", err]
+-- adminProblemCell :: IsDBTable m a => AdminProblem -> DBCell m a -- moved to Handler.Utils
+-- msgAdminProblem :: AdminProblem -> DB (SomeMessages UniWorX) -- moved to Handler.Utils

src/Handler/Admin/Avs.hs

@@ -59,7 +59,7 @@ instance Finite ButtonAvsTest
 nullaryPathPiece ''ButtonAvsTest camelToPathPiece
 
 instance Button UniWorX ButtonAvsTest where
-  btnLabel    BtnCheckLicences = "Check all licences"       -- could be msg
+  btnLabel    BtnCheckLicences = "Show all licence difference to current AVS"       -- could be msg
   -- btnLabel    BtnSynchLicences = "Synchronize all licences" -- could be msg
   btnClasses  BtnCheckLicences = [BCIsButton, BCPrimary]
   -- btnClasses  BtnSynchLicences = [BCIsButton, BCDanger]
@@ -159,16 +159,16 @@ postAdminAvsR = do
           $nothing
             AVS nicht konfiguriert!
         |]
-  
+
   ((presult, pwidget), penctype) <- runFormPost $ makeAvsPersonForm Nothing
 
   let procFormPerson :: AvsQueryPerson -> Handler (Maybe (Maybe Widget, Maybe AvsPersonId))
-      procFormPerson fr = do
+      procFormPerson (fixAvsQueryPerson -> fr) = do
         addMessage Info $ text2Html $ "Query: " <> tshow (toJSON fr)
         try (avsQuery fr) >>= \case
           Left err  -> return $ Just (Just $ exceptionWgt err, Nothing)
           Right (AvsResponsePerson pns) -> do
-            let mapid = case Set.toList pns of 
+            let mapid = case Set.toList pns of
                           [AvsDataPerson{avsPersonPersonID=apid}] -> Just apid
                           _ -> Nothing
                 wgt = [whamlet|
@@ -178,12 +178,12 @@ postAdminAvsR = do
                       |] -- <li>#{decodeUtf8 (Pretty.encodePretty (toJSON p))}
             return $ Just (toMaybe (notNull pns) wgt, mapid)
   (mbPerson,mapid) <- fromMaybe (Nothing,Nothing) <$> formResultMaybe presult procFormPerson
-  
+
   ((sresult', swidget), senctype) <- runFormPost $ makeAvsStatusForm mapid
   let sresult = sresult' <|> maybe FormMissing (FormSuccess . AvsQueryStatus . Set.singleton) mapid -- use unique AvsId from PersonSearch for convenience, if form was empty
       procFormStatus fr = do
         addMessage Info $ text2Html $ "Status Query: " <> tshow (toJSON fr)
-        tryShow $ do 
+        tryShow $ do
           AvsResponseStatus pns <- avsQuery fr
           return [whamlet|
               <ul>
@@ -203,9 +203,9 @@ postAdminAvsR = do
                 $forall AvsDataContact{..} <- pns
                   <li>
                     <ul>
-                      <li>AvsId: #{tshow avsContactPersonID}                      
+                      <li>AvsId: #{tshow avsContactPersonID}
                       <li>^{jsonWidget avsContactPersonInfo}
-                      <li>^{jsonWidget avsContactFirmInfo}              
+                      <li>^{jsonWidget avsContactFirmInfo}
             |] -- <li>#{decodeUtf8 (Pretty.encodePretty (toJSON avsContactPersonInfo))}
   mbContact <- formResultMaybe cresult (Just <<$>> procFormContact)
 
@@ -266,33 +266,128 @@ postAdminAvsR = do
 
 
   (qryLicForm, qryLicRes) <- runButtonForm FIDAvsQueryLicenceDiffs
-  mbQryLic <- case qryLicRes of
-    Nothing -> return Nothing
+  (mbQryLic :: Maybe Widget, mbAutoDiffs :: Maybe Html) <- case qryLicRes of
+    Nothing -> return mempty
     (Just BtnCheckLicences) -> do
       res <- try $ do
-        allLicences <- avsQuery AvsQueryGetAllLicences
+        allLicences <- avsQueryNoCache AvsQueryGetAllLicences
         computeDifferingLicences allLicences
-      case res of
+      basediffs <- case res of
         (Right diffs) -> do
-          let showLics l = Text.intercalate ", " $ fmap (tshow . avsLicencePersonID) $ Set.toList $ Set.filter ((l ==) . avsLicenceRampLicence) diffs
-              r_grant = showLics AvsLicenceRollfeld
-              f_set   = showLics AvsLicenceVorfeld
-              revoke  = showLics AvsNoLicence
+          let showLics l =
+                let chgs = Set.filter ((l ==) . avsLicenceRampLicence) diffs
+                in if Set.null chgs
+                    then ("[ ]", 0)
+                    else (Text.intercalate ", " (tshow . avsLicencePersonID <$> Set.toList chgs), Set.size chgs)
+              (r_grant, rg_size) = showLics AvsLicenceRollfeld
+              (f_set  , fs_size) = showLics AvsLicenceVorfeld
+              (revoke , rv_size) = showLics AvsNoLicence
           return $ Just [whamlet|
-              <h2>Licence check differences:
-              <h3>Grant R:
-              <p>
-                #{r_grant}
-              <h3>Set to F:
-              <p>
-                #{f_set}
-              <h3>Revoke licence:
-              <p>
-                #{revoke}
+              <h2>Licence check AVS-ID differences:
+              <dl .deflist>
+                <dt .deflist__dt>Grant R (#{rg_size}):
+                <dd .deflist__dd>#{r_grant}
+
+                <dt .deflist__dt>Set to F (#{fs_size}):
+                <dd .deflist__dd>#{f_set}
+
+                <dt .deflist__dt>Revoke licence (#{rv_size}):
+                <dd .deflist__dd>#{revoke}
             |]
         (Left e) -> do
           let msg = tshow (e :: SomeException)
           return $ Just [whamlet|<h2>Licence check error:</h2> #{msg}|]
+      autoDiffs <- do
+        -- what follows is copy of the code from Jobs.Handler.SynchroniseAvs.dispatchJobSynchroniseAvsLicences modified to not do anything actually
+        AvsLicenceSynchConf
+          { avsLicenceSynchLevel        = synchLevel   -- SynchLevel corresponds to tables of ProblemAvsSynchR: 4=top grant R, 3= reduce R->F, 2= grant F, 1= revoke F
+          , avsLicenceSynchReasonFilter = reasonFilter
+          , avsLicenceSynchMaxChanges   = maxChanges
+          } <- getsYesod $ view _appAvsLicenceSynchConf
+        guardMonoidM (synchLevel > 0) $ do
+          let showApids apids
+                | null apids = "[ ]"
+                | otherwise = Text.intercalate ", " (tshow <$> Set.toList apids)
+              procLic :: (Ord a, Show a) => AvsLicence -> Bool -> Set a -> Html
+              procLic aLic up apids
+                | n <- Set.size apids, n > 0 =
+                  let subtype   = Text.cons (bool '↧' '↥' up) $ Text.singleton $ licence2char aLic
+                  in if NTop (Just n) <= NTop maxChanges
+                      then
+                        [shamlet|
+                          <dt .deflist__dt>#{subtype} (#{n}):
+                          <dd .deflist__dd>#{showApids apids}
+                        |]
+                      else
+                        [shamlet|
+                          <dt .deflist__dt>#{subtype} (#{n}):
+                          <dd .deflist__dd>Too many changes at once. Consider increasing avs-licence-synch-max-changes #{tshow maxChanges}
+                        |]
+                | otherwise = mempty
+
+          (AvsLicenceDifferences{..}, rsChanged) <- retrieveDifferingLicences
+          -- prevent automatic changes to users blocked with certain reasons and with currently being associated with multiple companies
+          reasonFltrdIds <- ifNothingM reasonFilter mempty $ \reasons -> do
+            now <- liftIO getCurrentTime
+            firmBlocks <- runDBRead $ E.select $ do
+              (uavs :& _qualUser :& qblock) <- X.from $ E.table @UserAvs
+                `E.innerJoin` E.table @QualificationUser      `X.on` (\( uavs :& qualUser) -> uavs E.^. UserAvsUser E.==. qualUser E.^. QualificationUserUser)
+                `E.innerJoin` E.table @QualificationUserBlock `X.on` (\(_uavs :& qualUser :& qblock) ->
+                    qualUser E.^. QualificationUserId E.==. qblock E.^. QualificationUserBlockQualificationUser
+                    E.&&. qblock `isLatestBlockBefore'` E.val now)
+              E.where_ $ (qblock E.^. QualificationUserBlockReason E.~*. E.val reasons)
+                    E.&&.  uavs E.^. UserAvsPersonId `E.in_` E.vals (Set.unions [avsLicenceDiffRevokeAll, avsLicenceDiffRevokeRollfeld, avsLicenceDiffGrantVorfeld, avsLicenceDiffGrantRollfeld])
+              return $ uavs E.^. UserAvsPersonId
+            return $ Set.fromList $ map E.unValue firmBlocks
+
+          let fltrIds
+                | synchLevel >= 5 = id
+                | synchLevel >= 3 = flip Set.difference   reasonFltrdIds
+                | otherwise       = flip Set.difference $ reasonFltrdIds `Set.union` rsChanged
+
+              l1 = guardMonoid (synchLevel >= 1) $ procLic AvsNoLicence       False $ fltrIds avsLicenceDiffRevokeAll        --revoke    Vorfeld and maybe also Rollfeld
+              l2 = guardMonoid (synchLevel >= 2) $ procLic AvsLicenceVorfeld  True  $ fltrIds avsLicenceDiffGrantVorfeld     --grant     Vorfeld
+              l3 = guardMonoid (synchLevel >= 3) $ procLic AvsLicenceVorfeld  False $ fltrIds avsLicenceDiffRevokeRollfeld   --downgrade Rollfeld -> Vorfeld
+              l4 = guardMonoid (synchLevel >= 4) $ procLic AvsLicenceRollfeld True  $ fltrIds avsLicenceDiffGrantRollfeld    --grant     Rollfeld
+              avsIdChanges = [shamlet|
+                  <h3>
+                    Next automatic AVS-ID licence synchronisation:
+                  <dl .deflist>
+                    ^{l4}
+                    ^{l3}
+                    ^{l2}
+                    ^{l1}
+                    $maybe reason <- reasonFilter
+                      <dt .deflist__dt>Filtered "#{reason}" (#{Set.size reasonFltrdIds}):
+                      <dd .deflist__dd>#{showApids reasonFltrdIds}
+                |]
+          ----------------------------------------------------
+          -- translate AVS-IDs to AVS-NOs for convenience only
+          avsidnos <- runDBRead $ E.select $ do
+            ua <- X.from $ E.table @UserAvs
+            E.where_ $ ua E.^. UserAvsPersonId `E.in_` E.vals (Set.unions [avsLicenceDiffRevokeAll, avsLicenceDiffRevokeRollfeld, avsLicenceDiffGrantVorfeld, avsLicenceDiffGrantRollfeld]) -- , reasonFltrdIds])
+            return (ua E.^. UserAvsPersonId, ua E.^. UserAvsNoPerson)
+          let id2no = Map.fromList $ $(E.unValueN 2) <$> avsidnos
+              translate = setMapMaybe (`Map.lookup` id2no)
+              l1' = guardMonoid (synchLevel >= 1) $ procLic AvsNoLicence       False $ translate $ fltrIds avsLicenceDiffRevokeAll        --revoke    Vorfeld and maybe also Rollfeld
+              l2' = guardMonoid (synchLevel >= 2) $ procLic AvsLicenceVorfeld  True  $ translate $ fltrIds avsLicenceDiffGrantVorfeld     --grant     Vorfeld
+              l3' = guardMonoid (synchLevel >= 3) $ procLic AvsLicenceVorfeld  False $ translate $ fltrIds avsLicenceDiffRevokeRollfeld   --downgrade Rollfeld -> Vorfeld
+              l4' = guardMonoid (synchLevel >= 4) $ procLic AvsLicenceRollfeld True  $ translate $ fltrIds avsLicenceDiffGrantRollfeld    --grant     Rollfeld
+              autoNoDiffs =  [shamlet|
+                  <h3>
+                    Next automatic licence changes translated to human readable AVS-Numbers, if known:
+                  <dl .deflist>
+                    ^{l4'}
+                    ^{l3'}
+                    ^{l2'}
+                    ^{l1'}
+                    $maybe reason <- reasonFilter
+                      <dt .deflist__dt>Filtered "#{reason}" (#{Set.size reasonFltrdIds}):
+                      <dd .deflist__dd>#{showApids $ translate reasonFltrdIds}
+                |]
+          return $ Just $ avsIdChanges <> autoNoDiffs
+      return (basediffs, autoDiffs)
+
     -- (Just BtnSynchLicences) -> do
     --   res <- try synchAvsLicences
     --   case res of
@@ -378,8 +473,8 @@ postProblemAvsSynchR = getProblemAvsSynchR
 getProblemAvsSynchR = do
   let catchAllAvs' r = flip catch (\err -> addMessageModal Error (i18n MsgAvsCommunicationError) (Right (text2widget $ tshow (err :: SomeException))) >> redirect r)
       catchAllAvs    = catchAllAvs' ProblemAvsSynchR -- == current route; use only in conditions that are not repeated upon reload; do not call redirect within catchAllAvs actions!
-  (AvsLicenceDifferences{..}, apidStatus) <- catchAllAvs' AdminR retrieveDifferingLicencesStatus
-
+  ((AvsLicenceDifferences{..}, rsChanged), apidStatus) <- catchAllAvs' AdminR retrieveDifferingLicencesStatus
+  let mkLicTbl = mkLicenceTable apidStatus rsChanged
   --
   unknownLicenceOwners' <- whenNonEmpty avsLicenceDiffRevokeAll $ \neZeros ->
     runDB $ E.select $ do
@@ -434,10 +529,10 @@ getProblemAvsSynchR = do
 
   -- licence differences
   ((tres0,tb0),(tres1up,tb1up),(tres1down,tb1down),(tres2,tb2)) <- runDB $ (,,,)
-          <$> mkLicenceTable apidStatus "avsLicDiffRevokeVorfeld"  AvsLicenceVorfeld   avsLicenceDiffRevokeAll
-          <*> mkLicenceTable apidStatus "avsLicDiffGrantVorfeld"   AvsNoLicence        avsLicenceDiffGrantVorfeld
-          <*> mkLicenceTable apidStatus "avsLicDiffRevokeRollfeld" AvsLicenceRollfeld  avsLicenceDiffRevokeRollfeld
-          <*> mkLicenceTable apidStatus "avsLicDiffGrantRollfeld"  AvsNoLicence        avsLicenceDiffGrantRollfeld
+          <$> mkLicTbl "avsLicDiffRevokeVorfeld"  AvsLicenceVorfeld   avsLicenceDiffRevokeAll
+          <*> mkLicTbl "avsLicDiffGrantVorfeld"   AvsNoLicence        avsLicenceDiffGrantVorfeld
+          <*> mkLicTbl "avsLicDiffRevokeRollfeld" AvsLicenceRollfeld  avsLicenceDiffRevokeRollfeld -- downgrade to Vorfeld
+          <*> mkLicTbl "avsLicDiffGrantRollfeld"  AvsNoLicence        avsLicenceDiffGrantRollfeld
 
   now <- liftIO getCurrentTime
   let procRes :: AvsLicence -> (LicenceTableActionData, Set AvsPersonId) -> Handler ()
@@ -450,8 +545,8 @@ getProblemAvsSynchR = do
 
       procRes alic (LicenceTableRevokeFDriveData{..}, apids) = do
         oks <- runDB $ do
-          qId <- getKeyBy404 $ UniqueQualificationAvsLicence $ Just alic
-          if qId /= licenceTableChangeFDriveQId
+          qIds <- selectKeysList [QualificationAvsLicence ==. Just alic] []          -- sanity check
+          if licenceTableChangeFDriveQId `notElem` qIds
             then return (-1)
             else do
               uids <- view _userAvsUser <<$>> selectList [UserAvsPersonId <-. Set.toList apids] []
@@ -476,6 +571,7 @@ getProblemAvsSynchR = do
   formResult tres1up    $ procRes AvsLicenceVorfeld
   formResult tres0      $ procRes AvsNoLicence
 
+  AvsLicenceSynchConf{..} <- getsYesod $ view _appAvsLicenceSynchConf
   siteLayoutMsg MsgAvsTitleLicenceSynch $ do
     setTitleI   MsgAvsTitleLicenceSynch
     $(i18nWidgetFile "avs-synchronisation")
@@ -528,14 +624,17 @@ instance HasUser LicenceTableData where
 -- instance HasQualificationUser LicenceTableData where -- Not possible, since not all rows have a QualificationUser
 --   hasQualificationUser = resultQualUser . _entityVal
 
-mkLicenceTable :: AvsPersonIdMapPersonCard -> Text -> AvsLicence -> Set AvsPersonId -> DB (FormResult (LicenceTableActionData, Set AvsPersonId), Widget)
-mkLicenceTable apidStatus dbtIdent aLic apids = do
-  currentRoute <- fromMaybe (error "mkLicenceTable called from 404-handler") <$> liftHandler getCurrentRoute
-  avsQualifications <- selectList [QualificationAvsLicence !=. Nothing] []
+mkLicenceTable :: AvsPersonIdMapPersonCard -> Set AvsPersonId -> Text -> AvsLicence -> Set AvsPersonId -> DB (FormResult (LicenceTableActionData, Set AvsPersonId), Widget)
+mkLicenceTable apidStatus rsChanged dbtIdent aLic apids = do
+  (currentRoute, usrHasAvsRerr) <- liftHandler $ (,)
+    <$> (fromMaybe (error "mkLicenceTable called from 404-handler") <$> liftHandler getCurrentRoute)
+    <*> (messageTooltip <$> messageI Error MsgProblemAvsUsrHadR)
+  avsQualifications <- selectList [QualificationAvsLicence !=. Nothing] [Asc QualificationName]
   now <- liftIO getCurrentTime
 
   let nowaday = utctDay now
       avsQids = entityKey <$> avsQualifications
+      qualOpts = pure $ qualificationsOptionList avsQualifications
       -- fltrLic qual = if
       --   | aLic == AvsNoLicence -> E.isNothing (qual E.?. QualificationId) E.||. E.isJust (E.joinV $ qual E.?. QualificationAvsLicence)         -- could be R, F, both or none at all, but has licence in AVS
       --   | otherwise            -> E.isNothing (qual E.?. QualificationId) E.||. (E.val aLic E.=?. E.joinV (qual E.?. QualificationAvsLicence)) -- if we suggest granting that licence, this join should deliver a value too
@@ -560,17 +659,28 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do
         , 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
+            companies' <- liftHandler . runDBRead . 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.^. CompanyShorthand, comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor)
             let icnSuper  = toWidget $ text2markup " " <> icon IconSupervisor
-                companies = 
+                companies =
                   (\(E.Value cmpSh, E.Value cmpName, E.Value cmpSpr) -> simpleLink (citext2widget cmpName) (FirmUsersR cmpSh) <> bool mempty icnSuper cmpSpr) <$> companies'
-                
+
             pure $ intercalate (text2widget "; ") companies
-        , sortable (Just "qualification") (i18nCell MsgTableQualifications)          $ \(preview   resultQualification -> q) -> cellMaybe lmsShortCell q
+        , sortable (Just "qualification") (i18nCell MsgTableQualifications) $
+            if aLic /= AvsLicenceVorfeld
+              then
+                \(preview   resultQualification -> q) -> cellMaybe lmsShortCell q
+              else
+                \row ->
+                  let q       = row ^? resultQualification
+                      apid    = row ^. resultUserAvs . _userAvsPersonId
+                      warnCell c = if Set.member apid rsChanged
+                        then c <> spacerCell <> wgtCell usrHasAvsRerr    -- expected to be effectively dead code in practice, but we never know
+                        else c
+                  in warnCell $ 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
         -- , sortable (Just "valid-until")   (i18nCell MsgLmsQualificationValidUntil)   $ \(preview $ resultQualUser . _entityVal . _qualificationUserValidUntil  -> d)  -> cellMaybe dayCell d
@@ -614,14 +724,6 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do
         , prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany)
         ]
 
-      qualOpt :: Entity Qualification -> Handler (Option QualificationId)
-      qualOpt (Entity qualId qual) = do
-        cQualId :: CryptoUUIDQualification <- encrypt qualId
-        return $ Option
-          { optionDisplay       = CI.original $ qualificationName qual
-          , optionInternalValue = qualId
-          , optionExternalValue = tshow cQualId
-          }
       aLicQid = fmap entityKey . headMay $ filter ((== Just aLic) . qualificationAvsLicence . entityVal) avsQualifications
 
       -- Block identical to Handler/Qualifications TODO: refactor
@@ -639,20 +741,20 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do
       mkOption :: E.Value Text -> Option Text
       mkOption (E.unValue -> t) = Option{ optionDisplay = t, optionInternalValue = t, optionExternalValue = toPathPiece t }
       suggestionsBlock :: HandlerFor UniWorX (OptionList Text)
-      suggestionsBlock   = mkOptionList . fmap mkOption <$> runDB (getBlockReasons E.not_)
-      suggestionsUnblock = mkOptionList . fmap mkOption <$> runDB (getBlockReasons id)
+      suggestionsBlock   = mkOptionList . fmap mkOption <$> runDBRead (getBlockReasons E.not__)
+      suggestionsUnblock = mkOptionList . fmap mkOption <$> runDBRead (getBlockReasons id)
 
       acts :: Map LicenceTableAction (AForm Handler LicenceTableActionData)
       acts = mconcat
           [ singletonMap LicenceTableChangeAvs    $ pure LicenceTableChangeAvsData
           , if aLic == AvsNoLicence
               then singletonMap LicenceTableRevokeFDrive $ LicenceTableRevokeFDriveData
-                    <$> apreq (selectField . fmap mkOptionList $ mapM qualOpt avsQualifications) (fslI MsgQualificationName) aLicQid
+                    <$> apreq (selectField qualOpts) (fslI MsgQualificationName) aLicQid
                     <*> apreq (textField & cfStrip & addDatalist suggestionsBlock)    (fslI MsgQualificationBlockReason) Nothing
                     <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant)       (fslI MsgQualificationBlockNotify) (Just False)
 
               else singletonMap LicenceTableGrantFDrive  $ LicenceTableGrantFDriveData
-                    <$> apreq (selectField . fmap mkOptionList $ mapM qualOpt avsQualifications) (fslI MsgQualificationName) aLicQid
+                    <$> apreq (selectField qualOpts) (fslI MsgQualificationName) aLicQid
                     <*> apreq (textField & cfStrip & addDatalist suggestionsUnblock)  (fslI MsgQualificationGrantReason) Nothing
                     <*> apreq dayField (fslI MsgLmsQualificationValidUntil) Nothing -- apreq?!
                     <*> aopt (convertField not not (boolField . Just $ SomeMessage MsgBoolIrrelevant)) (fslI MsgQualificationUserNoRenewal) Nothing
@@ -697,45 +799,45 @@ instance Button UniWorX UserAvsAction where
 
 
 getAdminAvsUserR,  postAdminAvsUserR :: CryptoUUIDUser -> Handler Html
-getAdminAvsUserR = postAdminAvsUserR 
-postAdminAvsUserR uuid = do    
+getAdminAvsUserR = postAdminAvsUserR
+postAdminAvsUserR uuid = do
     isModal <- hasCustomHeader HeaderIsModal
-    
+
     uid <- decrypt uuid
-    Entity{entityVal=UserAvs{..}} <- runDB $ getBy404 $ UniqueUserAvsUser uid 
+    Entity{entityVal=UserAvs{..}} <- runDB $ getBy404 $ UniqueUserAvsUser uid
     -- let fltrById prj = over _Wrapped (Set.filter ((== userAvsPersonId) . prj)) -- not sufficiently polymorphic
     let fltrIdContact = over _Wrapped (Set.filter ((== userAvsPersonId) . avsContactPersonID))
-        -- fltrIdStatus  = over _Wrapped (Set.filter ((== userAvsPersonId) . avsStatusPersonID))      
+        -- fltrIdStatus  = over _Wrapped (Set.filter ((== userAvsPersonId) . avsStatusPersonID))
     mbContact <- try $ fmap fltrIdContact $ avsQuery $ AvsQueryContact $ Set.singleton $ AvsObjPersonId userAvsPersonId
     -- mbStatus  <- try $ fmap fltrIdStatus  $ avsQuery $ AvsQueryStatus  $ Set.singleton                  userAvsPersonId
     mbStatus <- try $ queryAvsFullStatus userAvsPersonId -- TODO: delete Handler.Utils.Avs.lookupAvsUser if no longer needed -- NOTE: currently needed to provide card firms that are missing in AVS status query responses
     let compsUsed :: [CompanyName] = stripCI <$> mbStatus ^.. _Right . _Wrapped . folded . _avsStatusPersonCardStatus . folded . _avsDataFirm . _Just
-    compDict <- if 1 >= length compsUsed 
+    compDict <- if 1 >= length compsUsed
       then return mempty -- switch company only sensible if there is more than one company to choose
-      else do         
+      else do
         let switchCompFormHandler :: [(CompanyName,CompanyId)] -> Maybe CompanyId -> Handler Widget
             switchCompFormHandler availComps      _  | 1 >= length availComps = return mempty    -- don't offer a form if there is only one company
             switchCompFormHandler availComps mbPrime = do
                 let switchCompForm :: AForm (HandlerFor UniWorX) (CryptoUUIDUser,CompanyId)
                     switchCompForm = (,)
                       <$> apopt hiddenField "" (Just uuid)
-                      <*> areq (selectFieldList [(ciOriginal cn, cid) | (cn, cid) <- availComps]) "new primary company" mbPrime
+                      <*> areq (selectFieldList [(ciOriginal cn, cid) | (cn, cid) <- availComps]) (fslI MsgUserAvsSwitchCompanyField) mbPrime
                       <*  aopt (buttonField UserAvsSwitchCompany) "" Nothing
                     switchCompValidate :: FormValidator (CryptoUUIDUser,CompanyId) Handler ()
-                    switchCompValidate = do 
+                    switchCompValidate = do
                       (uuid_rcvd,_) <- State.get
-                      guardValidation MsgWrongButtonValue $ uuid_rcvd == uuid                  
+                      guardValidation MsgWrongButtonValue $ uuid_rcvd == uuid
                 ((spRes, spWgt), spEnc) <- runFormPost . validateForm switchCompValidate . identifyForm ("switch-primary-company"::Text) $ renderAForm FormStandard switchCompForm
                 formResultModal spRes (AdminAvsUserR uuid) (\(_,cid) -> do
                     lift $ $logInfoS "AVS" ("Switch company option result " <> tshow spRes)
-                    problems <- liftHandler . runDB $ do 
+                    problems <- liftHandler . runDB $ do
                       (usrUp, problems) <- switchAvsUserCompany True False uid cid
                       update uid usrUp
                       forM problems $ \p -> reportAdminProblem p >> msgAdminProblem p
-                    forM_ problems (\p -> do 
+                    forM_ problems (\p -> do
                         -- lift $ $logErrorS "AVS" $ "Switch company problem: " <> tshow p -- no instance Show for SomeMessages
                         tell . pure =<< messageI Warning p
-                      )      
+                      )
                     let ok = if null problems then Success else Error
                     tell . pure =<< messageI ok (MsgUserAvsCompanySwitched $ unCompanyKey cid)
                   )
@@ -758,10 +860,10 @@ postAdminAvsUserR uuid = do
       setTitle $ toHtml $ show userAvsNoPerson
       let contactWgt = case mbContact of
             Left err -> exceptionWgt err
-            Right (AvsResponseContact adcs) -> 
+            Right (AvsResponseContact adcs) ->
               if null adcs
                 then [whamlet|_{MsgAvsPersonSearchEmpty}|]
-                else 
+                else
                   let cs = mkContactWgt warnBolt userAvsNoPerson <$> toList adcs
                   in  mconcat cs
           cardsWgt = case mbStatus of
@@ -779,14 +881,14 @@ postAdminAvsUserR uuid = do
           ^{cardsWgt}
         <p>
           _{MsgAvsCurrentData}
-      |]        
-  where 
+      |]
+  where
     mkContactWgt :: Widget -> Int -> AvsDataContact -> Widget
     mkContactWgt warnBolt reqAvsNo AvsDataContact
       { -- avsContactPersonID = _api
         avsContactPersonInfo = AvsPersonInfo{..}
       , avsContactFirmInfo   = AvsFirmInfo{ avsFirmFirm = firmName }
-      } = 
+      } =
       let avsNoOk = readMay avsInfoPersonNo /= Just reqAvsNo in
       [whamlet|
         <section .profile>
@@ -794,8 +896,8 @@ postAdminAvsUserR uuid = do
             $if avsNoOk
               <dt .deflist__dt>
                 _{MsgAvsPersonNo}
-              <dd .deflist__dd>                    
-                #{avsInfoPersonNo} 
+              <dd .deflist__dd>
+                #{avsInfoPersonNo}
                 ^{warnBolt}
                 _{MsgAvsPersonNoMismatch}
             <dt .deflist__dt>
@@ -826,7 +928,7 @@ postAdminAvsUserR uuid = do
 
     -- mkCardsWgt :: (Maybe CompanyName, Map CompanyName Widget, Widget) -> Set AvsDataPersonCard -> Widget
     mkCardsWgt :: (Maybe CompanyName, Widget) -> Set AvsDataPersonCard -> Widget
-    mkCardsWgt (mbPrimName, swForm) crds 
+    mkCardsWgt (mbPrimName, swForm) crds
       | null crds = [whamlet|_{MsgAvsCardsEmpty}|]
       | otherwise = do
         let hasCompany     = isJust $ Set.foldr ((<|>) . avsDataFirm)       Nothing crds -- some if, since a true AVS status query never delivers values for these fields, but queryAvsFullStatus-workaround does
@@ -844,7 +946,7 @@ postAdminAvsUserR uuid = do
                   $if hasIssueDate
                     <th .table__th>_{MsgTableAvsCardIssueDate}
                   $if hasValidToDate
-                    <th .table__th>_{MsgTableAvsCardValidTo}        
+                    <th .table__th>_{MsgTableAvsCardValidTo}
                   $if hasCompany
                     <th .table__th>_{MsgTableCompany}
                     <th .table__th>_{MsgAvsPrimaryCompany}
@@ -865,7 +967,7 @@ postAdminAvsUserR uuid = do
                         <td .table__td>
                           $maybe d <- avsDataIssueDate
                             ^{formatTimeW SelFormatDate d}
-                      $if hasValidToDate                    
+                      $if hasValidToDate
                         <td .table__td>
                           $maybe d <- avsDataValidTo
                             ^{formatTimeW SelFormatDate d}
@@ -903,13 +1005,13 @@ getProblemAvsErrorR = do
           E.where_ $ E.isJust $ usravs E.^. UserAvsLastSynchError
           return (usravs, user) -- , E.substring (usravs E.^. UserAvsLastSynchError) (E.val ("'#\"%#\" %'") (E.val "#")) -- needs a different type on substring
         qerryUsrAvs :: (E.SqlExpr (Entity UserAvs) `E.InnerJoin` E.SqlExpr (Entity User)) -> E.SqlExpr (Entity UserAvs)
-        qerryUsrAvs   = $(E.sqlIJproj 2 1) 
+        qerryUsrAvs   = $(E.sqlIJproj 2 1)
         qerryUser   :: (E.SqlExpr (Entity UserAvs) `E.InnerJoin` E.SqlExpr (Entity User)) -> E.SqlExpr (Entity User)
         qerryUser     = $(E.sqlIJproj 2 2)
         reserrUsrAvs :: Lens' (DBRow (Entity UserAvs, Entity User)) (Entity UserAvs)
         reserrUsrAvs  = _dbrOutput . _1
         -- reserrUser   :: Lens' (DBRow (Entity UserAvs, Entity User)) (Entity User)
-        -- reserrUser    = _dbrOutput . _2        
+        -- reserrUser    = _dbrOutput . _2
         dbtRowKey = qerryUsrAvs >>> (E.^. UserAvsId)
         dbtProj = dbtProjId
         dbtColonnade = dbColonnade $ mconcat
@@ -949,4 +1051,3 @@ getProblemAvsErrorR = do
   siteLayoutMsg MsgMenuAvsSynchError $ do
     setTitleI MsgMenuAvsSynchError
     [whamlet|^{avsSyncErrTbl}|]
-    

src/Handler/Admin/Test.hs

@@ -28,7 +28,9 @@ import Text.Hamlet
 -- import Handler.Utils.I18n
 
 import Handler.Admin.Test.Download (testDownload)
-
+import qualified Database.Esqueleto.Experimental as E (selectOne, unValue)
+import qualified Database.Esqueleto.PostgreSQL as E  (now_)
+import qualified Database.Esqueleto.Utils as E (psqlVersion_)
 
 -- BEGIN - Buttons needed only here
 data ButtonCreate = CreateMath | CreateInf | CrashApp -- Dummy for Example
@@ -226,10 +228,13 @@ postAdminTestR = do
 
   UniWorX{ appSettings' = AppSettings{..} } <- getYesod
 
+  psqlVersion <- runDBRead $ E.selectOne $ return E.psqlVersion_
+  dbTime      <- runDBRead $ E.selectOne $ return E.now_
+
   let locallyDefinedPageHeading = [whamlet|Admin TestPage for Uni2work|]
   siteLayout locallyDefinedPageHeading $ do
   -- defaultLayout $ do
-    setTitle "Uni2work Admin Testpage"    
+    setTitle "Uni2work Admin Testpage"
 
     $(i18nWidgetFile "admin-test")
 
@@ -327,19 +332,30 @@ postAdminTestR = do
           <dd .deflist__dd>#{tshow appSynchroniseAvsUsersWithin}
     |]
 
+    [whamlet|
+      <section>
+        <h2> PostgreSQL Information
+        <dl .deflist>
+          $maybe pver <- psqlVersion
+            <dt .deflist__dt>DB Version
+            <dd .deflist__dd>#{E.unValue pver}
+          $maybe ptme <- dbTime
+            <dt .deflist__dt>DB Time
+            <dd .deflist__dd>#{tshow (E.unValue ptme)}
+    |]
 
 
 
 getAdminTestPdfR :: Handler TypedContent
 getAdminTestPdfR = do
-  usr  <- requireAuth -- to determine language and recipient for test 
+  usr  <- requireAuth -- to determine language and recipient for test
   qual <- fromMaybeM
             (addMessage Error "Keine Qualifikation in der Datenbank zur Erzeugung eines Test-PDFs gefunden." >> redirect AdminTestR)
             (runDB $ selectFirst [] [Asc QualificationAvsLicence, Asc QualificationShorthand])
   encRecipient :: CryptoUUIDUser <- encrypt $ usr ^. _entityKey
   now <- liftIO getCurrentTime
   let nowaday = utctDay now
-      letter  = LetterRenewQualificationF
+      letter  = LetterRenewQualification
         { lmsLogin      = LmsIdent "abcdefgh"
         , lmsPin        = "12345678"
         , qualHolderID  = usr ^. _entityKey
@@ -351,8 +367,10 @@ getAdminTestPdfR = do
         , qualShort     = qual ^. _qualificationShorthand . _CI
         , qualSchool    = qual ^. _qualificationSchool
         , qualDuration  = qual ^. _qualificationValidDuration
+        , qualRenewAuto = qual ^. _qualificationElearningRenews
+        , qualELimit    = qual ^. _qualificationElearningLimit
         , isReminder    = False
-        }  
+        }
   apcIdent <- letterApcIdent letter encRecipient now
   renderLetterPDF usr letter apcIdent Nothing >>= \case
     Left err  -> sendResponseStatus internalServerError500 $ "PDF generation failed: \n" <> err
@@ -360,6 +378,6 @@ getAdminTestPdfR = do
       liftIO $ LBS.writeFile "/tmp/generated.pdf" pdf
       encryptPDF "tomatenmarmelade" pdf >>= \case
         Left err      -> sendResponseStatus internalServerError500 $ "PDFtk error: \n" <> err
-        Right encPdf  -> do 
+        Right encPdf  -> do
           liftIO $ LBS.writeFile "/tmp/crypted.pdf" encPdf
           sendByteStringAsFile "demoPDF.pdf" (LBS.toStrict pdf) now

src/Handler/CommCenter.hs

@@ -0,0 +1,152 @@
+-- SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
+--
+-- SPDX-License-Identifier: AGPL-3.0-or-later
+
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Handler.CommCenter
+  ( getCommCenterR
+  ) where
+
+import Import
+import Handler.Utils
+
+-- import qualified Data.Set as Set
+import qualified Data.Map as Map
+-- import qualified Data.Text as Text
+import Data.Text.Lens (packed)
+
+-- import Database.Persist.Sql (updateWhereCount)
+-- import           Database.Esqueleto.Experimental ((:&)(..))
+import qualified Database.Esqueleto.Legacy as EL (on) -- only `on` and `from` are different, needed for dbTable using Esqueleto.Legacy
+import qualified Database.Esqueleto.Experimental as E
+import qualified Database.Esqueleto.Utils as E
+import qualified Database.Esqueleto.PostgreSQL as E
+import Database.Esqueleto.Utils.TH
+
+
+-- avoids repetition of local definitions
+single :: (k,a) -> Map k a
+single = uncurry Map.singleton
+
+
+data CCTableAction = CCActDummy -- just a dummy, since we don't now yet which actions we will be needing
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
+
+instance Universe CCTableAction
+instance Finite CCTableAction
+nullaryPathPiece ''CCTableAction $ camelToPathPiece' 2
+embedRenderMessage ''UniWorX ''CCTableAction id
+
+data CCTableActionData  = CCActDummyData
+  deriving (Eq, Ord, Read, Show, Generic)
+
+
+-- SJ: I don't know how to use E.unionAll_ with dbTable, so we simulate it by a FullOuterJoin with constant False ON-clause instead
+type CCTableExpr =
+  (                   (E.SqlExpr (Maybe (Entity User))  `E.InnerJoin` E.SqlExpr (Maybe (Entity SentMail)))
+    `E.FullOuterJoin` (E.SqlExpr (Maybe (Entity User))  `E.InnerJoin` E.SqlExpr (Maybe (Entity PrintJob)))
+  )
+
+queryRecipientMail :: CCTableExpr -> E.SqlExpr (Maybe (Entity User))
+queryRecipientMail = $(sqlIJproj 2 1) . $(sqlFOJproj 2 1)
+
+queryMail :: CCTableExpr -> E.SqlExpr (Maybe (Entity SentMail))
+queryMail = $(sqlIJproj 2 2) . $(sqlFOJproj 2 1)
+
+queryRecipientPrint :: CCTableExpr -> E.SqlExpr (Maybe (Entity User))
+queryRecipientPrint = $(sqlIJproj 2 1) . $(sqlFOJproj 2 2)
+
+queryPrint :: CCTableExpr -> E.SqlExpr (Maybe (Entity PrintJob))
+queryPrint = $(sqlIJproj 2 2) . $(sqlFOJproj 2 2)
+
+type CCTableData = DBRow (Maybe (Entity User), Maybe (Entity SentMail), Maybe (Entity User), Maybe (Entity PrintJob))
+
+resultRecipientMail :: Traversal' CCTableData (Entity User)
+resultRecipientMail = _dbrOutput . _1 . _Just
+
+resultMail :: Traversal' CCTableData (Entity SentMail)
+resultMail = _dbrOutput . _2 . _Just
+
+resultRecipientPrint :: Traversal' CCTableData (Entity User)
+resultRecipientPrint = _dbrOutput . _3 . _Just
+
+resultPrint :: Traversal' CCTableData (Entity PrintJob)
+resultPrint = _dbrOutput . _4 . _Just
+
+
+mkCCTable :: DB (Any, Widget)
+mkCCTable = do
+  let
+    dbtSQLQuery :: CCTableExpr -> E.SqlQuery (E.SqlExpr (Maybe (Entity User)), E.SqlExpr (Maybe (Entity SentMail)), E.SqlExpr (Maybe (Entity User)), E.SqlExpr (Maybe (Entity PrintJob)))
+    dbtSQLQuery  ((recipientMail `E.InnerJoin` mail) `E.FullOuterJoin` (recipientPrint `E.InnerJoin` printJob)) = do
+      EL.on $ recipientMail  E.?. UserId E.==. E.joinV (mail     E.?. SentMailRecipient)
+      EL.on $ recipientPrint E.?. UserId E.==. E.joinV (printJob E.?. PrintJobRecipient)
+      -- EL.on $ recipientMail  E.?. UserId E.==. recipientPrint E.?. UserId E.&&. E.false -- simulating E.unionAll_ by a constant false full outer join, since it is unclear how dbTable could handle E.unionAll_
+      EL.on E.false -- simulating E.unionAll_ by a constant false full outer join, since it is unclear how dbTable could handle E.unionAll_
+      -- E.where_ $ E.isJust (recipientMail E.?. UserId) E.||. E.isJust (recipientPrint E.?. UserId) -- not needed for full outer join
+      -- return (E.coalesce[recipientMail, recipientPrint], mail, print) -- coalesce only works on values, not entities
+      return (recipientMail,  mail, recipientPrint, printJob)
+    -- dbtRowKey = (,) <$> views (to queryMail) (E.?. SentMailId) <*> views (to queryPrint) (E.?. PrintJobId)
+    dbtRowKey ((_recipientMail `E.InnerJoin` mail) `E.FullOuterJoin` (_recipientPrint `E.InnerJoin` printJob)) = (mail E.?. SentMailId, printJob E.?. PrintJobId)
+
+    dbtProj = dbtProjId
+    dbtColonnade = dbColonnade $ mconcat -- prefer print over email in the impossible case that both are Just
+      [ sortable (Just "date")      (i18nCell MsgPrintJobCreated)       $ \row ->
+          let tprint  = row ^? resultPrint  . _entityVal . _printJobCreated
+              tmail   = row ^? resultMail   . _entityVal . _sentMailSentAt
+          in maybeCell (tprint <|> tmail) dateTimeCell
+      , sortable (Just "recipient") (i18nCell MsgPrintRecipient)        $ \row ->
+          let uprint = row ^? resultRecipientPrint
+              umail  = row ^? resultRecipientMail
+          in  maybeCell (uprint <|> umail) $ cellHasUserLink AdminUserR
+      , sortable Nothing (i18nCell MsgCommBody) $ \row -> if
+          | (Just k) <- row ^? resultPrint . _entityKey
+            -> anchorCellM (PrintDownloadR <$> encrypt k) $ toWgt (iconLetterOrEmail True ) <> text2widget "-link"
+          | (Just k) <- row ^? resultMail  . _entityKey
+            -> anchorCellM (MailHtmlR      <$> encrypt k) $ toWgt (iconLetterOrEmail False) <> text2widget "-link"
+          | otherwise
+            -> mempty
+      , sortable Nothing (i18nCell MsgCommSubject) $ \row ->
+          let tsubject = row ^? resultPrint . _entityVal . _printJobFilename . packed
+              msubject = row ^? resultMail . _entityVal . _sentMailHeaders . _mailHeaders' . _mailHeader' "Subject"
+          in maybeCell (tsubject <|> msubject) textCell
+      ]
+    dbtSorting = mconcat
+      [ singletonMap "date"       $ SortColumn  $ \row -> E.coalesce [queryPrint row E.?. PrintJobCreated, queryMail row E.?. SentMailSentAt]
+      , singletonMap "recipient"  $ SortColumns $ \row ->
+          [ SomeExprValue $ E.coalesce [queryRecipientPrint row E.?. UserSurname    , queryRecipientMail row E.?. UserSurname    ]
+          , SomeExprValue $ E.coalesce [queryRecipientPrint row E.?. UserDisplayName, queryRecipientMail row E.?. UserDisplayName]
+          ]
+      ]
+    dbtFilter = mconcat
+      [ single ("sent"      , FilterColumn . E.mkDayFilterTo
+                                $ \row -> E.coalesceDefault [queryPrint row E.?. PrintJobCreated, queryMail row E.?. SentMailSentAt] E.now_) -- either one is guaranteed to be non-null, default never used
+      , single ("recipient" , FilterColumn . E.mkContainsFilterWithCommaPlus Just
+                                $ \row -> E.coalesce [queryRecipientPrint row E.?. UserDisplayName, queryRecipientMail row E.?. UserDisplayName])
+      , single ("subject"   , FilterColumn . E.mkContainsFilterWithCommaPlus Just
+                                $ \row -> E.coalesce [E.str2text' $ queryPrint row E.?. PrintJobFilename
+                                                     ,E.str2text' $ queryMail  row E.?. SentMailHeaders  ])
+      ]
+    dbtFilterUI mPrev = mconcat
+      [ prismAForm (singletonFilter "date"      . maybePrism _PathPiece) mPrev $ aopt (hoistField lift  dayField)  (fslI MsgPrintJobCreated)
+      , prismAForm (singletonFilter "recipient" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)  (fslI MsgPrintRecipient & setTooltip MsgTableFilterCommaPlus)
+      , prismAForm (singletonFilter "subject"   . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)  (fslI MsgCommSubject    & setTooltip MsgTableFilterCommaPlusShort)
+      ]
+    dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout}
+    dbtIdent :: Text
+    dbtIdent = "comms"
+    dbtCsvEncode = noCsvEncode
+    dbtCsvDecode = Nothing
+    dbtExtraReps = []
+    dbtParams = def
+    psValidator = def & defaultSorting [SortDescBy "date"]
+  dbTable psValidator DBTable{..}
+
+getCommCenterR :: Handler Html
+getCommCenterR = do
+  (_, ccTable) <- runDB mkCCTable
+  siteLayoutMsg MsgMenuCommCenter $ do
+    setTitleI MsgMenuCommCenter
+    $(widgetFile "comm-center")
+

src/Handler/Course/Edit.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@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
+-- SPDX-FileCopyrightText: 2022-24 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 <s.jost@fraport.de>,Winnie Ros <winnie.ros@campus.lmu.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -46,12 +46,13 @@ data CourseForm = CourseForm
         , cfRegTo        :: Maybe UTCTime
         , cfDeRegUntil   :: Maybe UTCTime
         , cfLecturers    :: [Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)]
+        , cfQualis       :: [(QualificationId, Int)]
         }
 
 makeLenses_ ''CourseForm
 
-courseToForm :: Entity Course -> [Lecturer] -> Map UserEmail (InvitationDBData Lecturer) -> CourseForm
-courseToForm (Entity cid Course{..}) lecs lecInvites = CourseForm
+courseToForm :: Entity Course -> [Lecturer] -> Map UserEmail (InvitationDBData Lecturer) -> [CourseQualification] -> CourseForm
+courseToForm (Entity cid Course{..}) lecs lecInvites qualis = CourseForm
     { cfCourseId            = Just cid
     , cfName                = courseName
     , cfDesc                = courseDescription
@@ -69,6 +70,9 @@ courseToForm (Entity cid Course{..}) lecs lecInvites = CourseForm
     , cfDeRegUntil          = courseDeregisterUntil
     , cfLecturers           = [Right (lecturerUser, lecturerType) | Lecturer{..} <- lecs]
                            ++ [Left (email, mType) | (email, InvDBDataLecturer mType) <- Map.toList lecInvites ]
+    -- TODO: Filterung nach aktueller Schule, da ansonsten ein Sicherheitleck droht! Siehe #150
+    , cfQualis              = [ (courseQualificationQualification, courseQualificationSortOrder)
+                              | CourseQualification{..} <- qualis, courseQualificationCourse == cid ]
     }
 
 
@@ -81,17 +85,19 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
     MsgRenderer mr <- getMsgRenderer
 
     uid <- liftHandler requireAuthId
-    (lecturerSchools, adminSchools, oldSchool) <- liftHandler . runDB $ do
-      lecturerSchools <- map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolLecturer]] []
-      protoAdminSchools  <- map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolAdmin]] []
-      adminSchools <- filterM (hasWriteAccessTo . flip SchoolR SchoolEditR) protoAdminSchools
+    (userSchools, elegibleQualifications) :: ([SchoolId], OptionList QualificationId) <- liftHandler . runDB $ do
+      lecturerSchools   <- map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolLecturer]] []
+      protoAdminSchools <- map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolAdmin]]    [] -- default rights
+      adminSchools <- filterM (hasWriteAccessTo . flip SchoolR SchoolEditR) protoAdminSchools -- and user as admin rights active right now
       oldSchool <- forM (cfCourseId =<< template) $ fmap courseSchool . getJust
-      return (lecturerSchools, adminSchools, oldSchool)
-    let userSchools = nubOrd . maybe id (:) oldSchool $ lecturerSchools ++ adminSchools
+      let elegibleSchools = Set.fromList $ lecturerSchools ++ adminSchools
+          userSchools = Set.toList $ maybe id Set.insert oldSchool elegibleSchools
+      elegibleQualifications <- selectList [QualificationSchool <-. Set.toList elegibleSchools] [Asc QualificationName, Asc QualificationSchool]
+      return (userSchools, qualificationsOptionList elegibleQualifications)
 
     (termsField, userTerms) <- liftHandler $ case template of
       -- Change of term is only allowed if user may delete the course (i.e. no participants) or admin
-      (Just cform)  | (Just cid) <- cfCourseId cform -> do -- edit existing course
+      (Just cform)  | (Just cid) <- cfCourseId cform -> do -- edit existing course& \c
           _courseOld@Course{..} <- runDB $ get404 cid
           mayEditTerm <- isAuthorized TermEditR True
           mayDelete   <- isAuthorized (CourseR courseTerm courseSchool courseShorthand CDeleteR) True
@@ -102,51 +108,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
               -> return (termsSetField [cfTerm cform], [cfTerm cform])
       _allOtherCases -> (termsAllowedField, ) . Set.toList <$> runDB getActiveTerms
 
-    let miAdd :: ListPosition -> Natural -> ListLength -> (Text -> Text) -> FieldView UniWorX -> Maybe (Form (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId))))
-        miAdd _ _ _ nudge btn = Just $ \csrf -> do
-          (addRes, addView) <- mpreq (multiUserInvitationField $ MUILookupAnyUser Nothing) (fslI MsgCourseLecturerEmail & addName (nudge "email") & addPlaceholder (mr MsgLdapIdentificationOrEmail)) Nothing
-          let addRes'' = addRes <&> \newDat oldDat -> if
-                | existing <- newDat `Set.intersection` Set.fromList (Map.elems oldDat)
-                , not $ Set.null existing
-                  -> FormFailure [mr MsgCourseLecturerAlreadyAdded]
-                | otherwise
-                  -> FormSuccess . Map.fromList . zip [maybe 0 (succ . fst) $ Map.lookupMax oldDat ..] $ Set.toList newDat
-              addView' = $(widgetFile "course/lecturerMassInput/add")
-          return (addRes'', addView')
-
-        miCell :: ListPosition -> Either UserEmail UserId -> Maybe (Maybe LecturerType) -> (Text -> Text) -> Form (Maybe LecturerType)
-        miCell _ (Right lid) defType nudge = \csrf -> do
-          (lrwRes,lrwView) <- mreq (selectField optionsFinite) (fslI MsgCourseLecturerType & addName (nudge "lecturer-type")) (join defType)
-          usr <- liftHandler . runDB $ get404 lid
-          let lrwView' = $(widgetFile "course/lecturerMassInput/cellKnown")
-          return (Just <$> lrwRes,lrwView')
-        miCell _ (Left lEmail) defType nudge = \csrf -> do
-          (lrwRes,lrwView) <- mopt (selectField optionsFinite) ("" & addName (nudge "lecturer-type")) defType
-          invWarnMsg <- messageIconI Info IconEmail MsgEmailInvitationWarning
-          let lrwView' = $(widgetFile "course/lecturerMassInput/cellInvitation")
-          return (lrwRes,lrwView')
-
-        miDelete :: Map ListPosition (Either UserEmail UserId) -- ^ Current shape
-                 -> ListPosition -- ^ Coordinate to delete
-                 -> MaybeT (MForm (HandlerFor UniWorX)) (Map ListPosition ListPosition)
-        miDelete = miDeleteList
-
-        miAddEmpty :: ListPosition -> Natural -> ListLength -> Set ListPosition
-        miAddEmpty _ _ _ = Set.empty
-
-        miLayout :: ListLength
-                 -> Map ListPosition (Either UserEmail UserId, FormResult (Maybe LecturerType)) -- ^ massInput state
-                 -> Map ListPosition Widget -- ^ Cell widgets
-                 -> Map ListPosition (FieldView UniWorX) -- ^ Deletion buttons
-                 -> Map (Natural, ListPosition) Widget -- ^ Addition widgets
-                 -> Widget
-        miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "course/lecturerMassInput/layout")
-
-        miIdent :: Text
-        miIdent = "lecturers"
-
-
-        lecturerForm :: AForm Handler [Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)]
+    let lecturerForm :: AForm Handler [Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)]
         lecturerForm = formToAForm . over (mapped._2) pure . over (mapped._1.mapped) (map liftEither . Map.elems) $ massInput
                 MassInput{..}
                 (fslI MsgCourseLecturers & setTooltip MsgCourseLecturerRightsIdentical)
@@ -163,6 +125,79 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
             unliftEither (Right (lid   , lType )) = (Right lid  , Just lType)
             unliftEither (Left  (lEmail, mLType)) = (Left lEmail, mLType    )
 
+            miAdd :: ListPosition -> Natural -> ListLength -> (Text -> Text) -> FieldView UniWorX -> Maybe (Form (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId))))
+            miAdd _ _ _ nudge btn = Just $ \csrf -> do
+              (addRes, addView) <- mpreq (multiUserInvitationField $ MUILookupAnyUser Nothing) (fslI MsgCourseLecturerEmail & addName (nudge "email") & addPlaceholder (mr MsgLdapIdentificationOrEmail)) Nothing
+              let addRes'' = addRes <&> \newDat oldDat -> if
+                    | existing <- newDat `Set.intersection` Set.fromList (Map.elems oldDat)
+                    , not $ Set.null existing
+                      -> FormFailure [mr MsgCourseLecturerAlreadyAdded]
+                    | otherwise
+                      -> FormSuccess . Map.fromList . zip [maybe 0 (succ . fst) $ Map.lookupMax oldDat ..] $ Set.toList newDat
+                  addView' = $(widgetFile "course/lecturerMassInput/add")
+              return (addRes'', addView')
+
+            miCell :: ListPosition -> Either UserEmail UserId -> Maybe (Maybe LecturerType) -> (Text -> Text) -> Form (Maybe LecturerType)
+            miCell _ (Right lid) defType nudge = \csrf -> do
+              (lrwRes,lrwView) <- mreq (selectField optionsFinite) (fslI MsgCourseLecturerType & addName (nudge "lecturer-type")) (join defType)
+              usr <- liftHandler . runDB $ get404 lid
+              let lrwView' = $(widgetFile "course/lecturerMassInput/cellKnown")
+              return (Just <$> lrwRes,lrwView')
+            miCell _ (Left lEmail) defType nudge = \csrf -> do
+              (lrwRes,lrwView) <- mopt (selectField optionsFinite) ("" & addName (nudge "lecturer-type")) defType
+              invWarnMsg <- messageIconI Info IconEmail MsgEmailInvitationWarning
+              let lrwView' = $(widgetFile "course/lecturerMassInput/cellInvitation")
+              return (lrwRes,lrwView')
+
+            miDelete :: Map ListPosition (Either UserEmail UserId) -- ^ Current shape
+                    -> ListPosition -- ^ Coordinate to delete
+                    -> MaybeT (MForm (HandlerFor UniWorX)) (Map ListPosition ListPosition)
+            miDelete = miDeleteList
+
+            miAddEmpty :: ListPosition -> Natural -> ListLength -> Set ListPosition
+            miAddEmpty _ _ _ = Set.empty
+
+            miLayout :: ListLength
+                    -> Map ListPosition (Either UserEmail UserId, FormResult (Maybe LecturerType)) -- ^ massInput state
+                    -> Map ListPosition Widget -- ^ Cell widgets
+                    -> Map ListPosition (FieldView UniWorX) -- ^ Deletion buttons
+                    -> Map (Natural, ListPosition) Widget -- ^ Addition widgets
+                    -> Widget
+            miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "course/lecturerMassInput/layout")
+
+            miIdent :: Text
+            miIdent = "lecturers"
+
+        qualificationsForm :: Maybe [(QualificationId, Int)] -> AForm Handler [(QualificationId, Int)] -- filter by admin school done later through upsertCourseQualifications
+        qualificationsForm = massInputAccumEditA miAdd miEdit miButtonAction miLayout miIdent (fslI $ MsgCourseQualifications 9) False
+          where
+            miIdent :: Text
+            miIdent = "qualifications"
+
+            miAdd :: (Text -> Text) -> FieldView UniWorX -> Form ([(QualificationId,Int)] -> FormResult [(QualificationId,Int)])
+            miAdd  nudge submitView csrf = do
+              (formRes, formView) <- aCourseQualiForm nudge Nothing csrf
+              let addRes = formRes <&> \newDat@(newQid,oldOrd) (unzip -> (oldQids,oldOrds)) ->
+                    let qidBad = guardMonoid (newQid `elem` oldQids) [mr MsgCourseEditQualificationFailExists]
+                        ordBad = guardMonoid (oldOrd `elem` oldOrds) [mr MsgCourseEditQualificationFailOrder ]
+                        problems = qidBad ++ ordBad
+                    in if null problems
+                        then FormSuccess $ pure newDat
+                        else FormFailure problems
+              return (addRes, $(widgetFile "widgets/massinput/courseQualifications/add"))
+
+            miEdit :: (Text -> Text) -> (QualificationId, Int) -> Form (QualificationId, Int)
+            miEdit nudge  = aCourseQualiForm nudge . Just
+
+            miLayout :: MassInputLayout ListLength (QualificationId,Int) (QualificationId, Int)
+            miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/courseQualifications/layout")
+
+            aCourseQualiForm :: (Text -> Text) -> Maybe (QualificationId, Int) -> Form (QualificationId, Int)
+            aCourseQualiForm nudge mTemplate csrf = do
+              (cquRes, cquView) <- mpreq (selectField $ pure elegibleQualifications) ("" & addName (nudge "cquali")) (view _1 <$> mTemplate)
+              (ordRes, ordView) <- mpreq     intField                                ("" & addName (nudge "cqordr")) (view _2 <$> mTemplate)
+              return ((,) <$> cquRes <*> ordRes, $(widgetFile "widgets/massinput/courseQualifications/form"))
+
     (newVisFrom,newRegFrom,newRegTo,newDeRegUntil) <- case template of
         (Just cform) | (Just _cid) <- cfCourseId cform -> return (Nothing,Nothing,Nothing,Nothing)
         _allIOtherCases -> do
@@ -208,6 +243,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
             & setTooltip MsgCourseDeregisterUntilTip)                   (deepAlt (cfDeRegUntil <$> template) newDeRegUntil)
       <*  aformSection MsgCourseFormSectionAdministration
       <*> lecturerForm
+      <*> qualificationsForm (cfQualis <$> template)
     return (result, widget)
 
 
@@ -227,6 +263,10 @@ validateCourse = do
   unless userAdmin $ do
     guardValidation MsgCourseUserMustBeLecturer
       $ anyOf (traverse . _Right . _1) (== uid) cfLecturers
+  guardValidation MsgCourseEditQualificationFailExists
+    $ not $ hasDuplicates $ fst <$> cfQualis
+  guardValidation MsgCourseEditQualificationFailOrder
+    $ not $ hasDuplicates $ snd <$> cfQualis
 
   warnValidation MsgCourseShorthandTooLong
     $ length (CI.original cfShort) <= 10
@@ -280,8 +320,11 @@ getCourseNewR = do
           E.limit 1
           return course
       template <- case oldCourses of
-        (oldTemplate:_) ->
-            let newTemplate = courseToForm oldTemplate mempty mempty in
+        (oldTemplate:_) -> runDB $ do
+            mbLecs       <- oldTemplate & \course -> map entityVal <$> selectList [LecturerCourse ==. entityKey course] [Asc LecturerType]
+            mbLecInvites <- oldTemplate & sourceInvitationsF . entityKey
+            mbQualis     <- oldTemplate & \course -> map entityVal <$> selectList [CourseQualificationCourse ==. entityKey course] [Asc CourseQualificationSortOrder]
+            let newTemplate = courseToForm oldTemplate mbLecs mbLecInvites mbQualis
             return $ Just $ newTemplate
                 { cfCourseId   = Nothing
                 , cfTerm       = TermKey $ termFromRational 0 -- invalid, will be ignored; undefined won't work due to strictness
@@ -314,10 +357,11 @@ pgCEditR tid ssh csh = do
       mbCourse     <- getBy (TermSchoolCourseShort tid ssh csh)
       mbLecs       <- for mbCourse $ \course -> map entityVal <$> selectList [LecturerCourse ==. entityKey course] [Asc LecturerType]
       mbLecInvites <- for mbCourse $ sourceInvitationsF . entityKey
-      return $ (,,) <$> mbCourse <*> mbLecs <*> mbLecInvites
+      mbQualis     <- for mbCourse $ \course -> map entityVal <$> selectList [CourseQualificationCourse ==. entityKey course] [Asc CourseQualificationSortOrder]
+      return $ (,,,) <$> mbCourse <*> mbLecs <*> mbLecInvites <*> mbQualis
   -- IMPORTANT: both GET and POST Handler must use the same template,
   --    since an Edit is identified via CourseID, which is not embedded in the received form data for security reasons.
-  courseEditHandler (\p -> Just . SomeRoute $ CourseR tid ssh csh CEditR :#: p) $ $(uncurryN 3) courseToForm <$> courseData
+  courseEditHandler (\p -> Just . SomeRoute $ CourseR tid ssh csh CEditR :#: p) $ $(uncurryN 4) courseToForm <$> courseData
 
 
 -- | Course Creation and Editing
@@ -357,6 +401,7 @@ courseEditHandler miButtonAction mbCourseForm = do
               let (invites, adds) = partitionEithers $ cfLecturers res
               insertMany_ $ map (\(lid, lty) -> Lecturer lid cid lty) adds
               sinkInvitationsF lecturerInvitationConfig $ map (\(lEmail, mLty) -> (lEmail, cid, (InvDBDataLecturer mLty, InvTokenDataLecturer))) invites
+              void $ upsertCourseQualifications aid cid $ cfQualis res
               insert_ $ CourseEdit aid now cid
               memcachedByInvalidate AuthCacheLecturerList $ Proxy @(Set UserId)
             return insertOkay
@@ -405,11 +450,9 @@ courseEditHandler miButtonAction mbCourseForm = do
                     let (invites, adds) = partitionEithers $ cfLecturers res
                     insertMany_ $ map (\(lid, lty) -> Lecturer lid cid lty) adds
                     sinkInvitationsF lecturerInvitationConfig $ map (\(lEmail, mLty) -> (lEmail, cid, (InvDBDataLecturer mLty, InvTokenDataLecturer))) invites
-
+                    void $ upsertCourseQualifications aid cid $ cfQualis res
                     insert_ $ CourseEdit aid now cid
-
                     memcachedByInvalidate AuthCacheLecturerList $ Proxy @(Set UserId)
-
                     addMessageI Success $ MsgCourseEditOk tid ssh csh
                     return True
           when success $ redirect $ CourseR tid ssh csh CShowR
@@ -420,3 +463,35 @@ courseEditHandler miButtonAction mbCourseForm = do
         { formAction = Just $ SomeRoute actionUrl
         , formEncoding = formEnctype
         }
+
+-- upsertCourseQualifications :: forall m backend . (MonadIO m, PersistStoreWrite backend, PersistQueryRead backend) => UserId -> CourseId -> [(QualificationId, Int)] -> ReaderT backend m Bool
+upsertCourseQualifications :: UserId -> CourseId -> [(QualificationId, Int)] -> YesodJobDB UniWorX Bool -- could be generalized
+upsertCourseQualifications uid cid qualis = do
+  let newQualis = Map.fromList qualis
+  oldQualis <- Map.fromList . fmap (\Entity{entityKey=k, entityVal=CourseQualification{..}} -> (courseQualificationQualification, (k, courseQualificationSortOrder)))
+                <$> selectList [CourseQualificationCourse ==. cid] [Asc CourseQualificationQualification]
+  -- NOTE: CourseQualification allow the immediate assignment of these qualifications to any enrolled user. Hence SchoolAdmins must not be allowed to assign school-foreign qualifications, see #150
+  okSchools <- Set.fromList . fmap (userFunctionSchool . entityVal)
+                <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolAdmin, SchoolLecturer]] [Asc UserFunctionSchool]
+  {- Some debugging due to an error caused by using fromDistinctAscList with violated precondition:
+  $logErrorS "CourseQuali" $ "OLD  Course Qualifications:" <> tshow oldQualis
+  $logErrorS "CourseQuali" $ "NEW  Course Qualifications:" <> tshow newQualis
+  $logErrorS "CourseQuali" $ "DIFF Course Qualifications:" <> tshow (newQualis Map.\\ oldQualis)
+  -}
+  foldWithKeyMapM oldQualis $ \qu (k, so_old) -> case Map.lookup qu newQualis of
+        Just so_new | so_new /= so_old
+                -> update k [CourseQualificationSortOrder =. so_new] -- existing CourseQualifications may be re-ordered, regardless of school association
+        Nothing -> delete k                                          -- existing CourseQualifications may be removed,    regardless of school association
+        _       -> return ()
+  res <- foldWithKeyMapM (newQualis Map.\\ oldQualis) $ \qu so -> get qu >>= \case
+        Just Qualification{qualificationSchool=ssh, qualificationShorthand=qsh}
+          | Set.member ssh okSchools ->
+              insert_ CourseQualification{courseQualificationQualification = qu, courseQualificationCourse = cid, courseQualificationSortOrder = so}
+              $> All True
+          | otherwise -> do
+              addMessageI Warning $ MsgCourseEditQualificationFailRights qsh ssh
+              pure $ All False
+        _ -> do
+              addMessageI Warning   MsgCourseEditQualificationFail
+              pure $ All False
+  pure $ getAll res

src/Handler/Course/Register.hs

@@ -68,7 +68,7 @@ courseRegisterForm (Entity cid Course{..}) = liftHandler $ do
       | otherwise
         -> return $ FormSuccess ()
 
-    mayViewCourseAfterDeregistration <- liftHandler . runDB $ E.selectExists . E.from $ \course -> do
+    mayViewCourseAfterDeregistration <- liftHandler . runDBRead $ E.selectExists . E.from $ \course -> do
       E.where_ $  course E.^. CourseId E.==. E.val cid
            E.&&. (       isSchoolAdminLike muid ata (course E.^. CourseSchool)
                    E.||. mayEditCourse muid ata course
@@ -92,7 +92,7 @@ courseMayReRegister :: Entity Course -> DB Bool
 courseMayReRegister (Entity cid Course{..}) = do
   registrations <- count [ CourseParticipantState ==. CourseParticipantActive, CourseParticipantCourse ==. cid ]
   let capacity = maybe True (>= registrations) courseCapacity
-  
+
   wouldHaveWriteAccessTo [(AuthCapacity, capacity), (AuthCourseRegistered, False)] $ CourseR courseTerm courseSchool courseShorthand CRegisterR
 
 

src/Handler/Course/Users.hs

@@ -129,11 +129,11 @@ _userSheets = _dbrOutput . _7
 
 -- _userQualifications :: Traversal' UserTableData [Entity Qualification]
 -- _userQualifications = _dbrOutput . _8 . (traverse _1)
--- last part: ([Entity Qualification] -> f [Entity Qualification]) -> UserTableQualfications -> f UserTableQualifications
+-- last part: ([Entity Qualification] -> f [Entity Qualification]) -> UserTableQualifications -> f UserTableQualifications
 
 _userQualifications :: Getter UserTableData [Entity Qualification]
 _userQualifications = _dbrOutput . _8 . to (fmap fst3)
--- _userQualifications = _dbrOutput . _8 . each . _1 -- TODO: how to make this work 
+-- _userQualifications = _dbrOutput . _8 . each . _1 -- TODO: how to make this work
 
 
 _userCourseQualifications :: Lens' UserTableData UserTableQualifications
@@ -194,7 +194,7 @@ colUserQualifications cutoff = sortable (Just "qualifications") (i18nCell MsgTab
 colUserQualificationBlocked :: forall m c. IsDBTable m c => Bool -> Day -> Colonnade Sortable UserTableData (DBCell m c)
 colUserQualificationBlocked isAdmin cutoff = sortable (Just "qualification-block") (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltipSimple) $
   let qualNamedReasonCell (q,qu,qb) = textCell ((q ^. hasQualification . _qualificationShorthand . _CI) <> ": ") <> qualificationValidReasonCell' Nothing isAdmin cutoff qb qu
-  in  \(view _userCourseQualifications -> qualis) ->  
+  in  \(view _userCourseQualifications -> qualis) ->
         (cellAttrs <>~ [("class", "list--inline list--comma-separated list--iconless")]) . listCell qualis $ qualNamedReasonCell
 
 data UserTableCsv = UserTableCsv
@@ -420,12 +420,12 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
                      )
                    )
           qualis <- E.select . E.from $ \(qualification `E.InnerJoin` qualificationUser `E.LeftOuterJoin` qualificationBlock) -> do
-            E.on $ qualificationUser E.^. QualificationUserId  E.=?. qualificationBlock E.?. QualificationUserBlockQualificationUser 
+            E.on $ qualificationUser E.^. QualificationUserId  E.=?. qualificationBlock E.?. QualificationUserBlockQualificationUser
                   E.&&. qualificationBlock `isLatestBlockBefore` E.now_
-            E.on $ qualificationUser E.^. QualificationUserQualification E.==. qualification E.^. QualificationId 
+            E.on $ qualificationUser E.^. QualificationUserQualification E.==. qualification E.^. QualificationId
             E.where_ $ qualificationUser E.^. QualificationUserUser E.==. E.val (entityKey user)
-                  E.&&. qualification E.^. QualificationId `E.in_` E.valList cqids                  
-            E.orderBy [E.asc $ qualification E.^. QualificationShorthand] -- we should sort by CourseQualificationSortOrder instead, but since we have not seen a course with multiple qualifications yet, we take a shortcut here 
+                  E.&&. qualification E.^. QualificationId `E.in_` E.valList cqids
+            E.orderBy [E.asc $ qualification E.^. QualificationShorthand] -- we should sort by CourseQualificationSortOrder instead, but since we have not seen a course with multiple qualifications yet, we take a shortcut here
             return (qualification, qualificationUser, qualificationBlock)
           let
             regGroups = setOf (folded . _entityVal . _tutorialRegGroup . _Just) tutorials
@@ -739,7 +739,7 @@ postCUsersR tid ssh csh = do
         redirect $ CourseR tid ssh csh CUsersR
     (CourseUserRegisterExamData{..}, selectedUsers) -> do
         Sum nrReg <- fmap mconcat . runDB . forM (Set.toList selectedUsers) $ \uid -> maybeT (return mempty) $ do
-          guardM . lift $ exists [ CourseParticipantUser ==. uid, CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive ]          
+          guardM . lift $ exists [ CourseParticipantUser ==. uid, CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive ]
           let (exam, mOccurrence) = registerExam
           mExamReg <- lift $ insertUnique ExamRegistration
             { examRegistrationExam       = exam
@@ -763,7 +763,7 @@ postCUsersR tid ssh csh = do
         Just _  -> addMessageI Success $ MsgCourseUsersSubmissionGroupSetNew nrSet
 
       redirect $ CourseR tid ssh csh CUsersR
-    (CourseUserReRegisterData, selectedUsers) -> do      
+    (CourseUserReRegisterData, selectedUsers) -> do
       Sum nrSet <- runDB . flip foldMapM selectedUsers $ \uid -> maybeT (return mempty) $ do
         didUpdate <- lift $ updateWhereCount
           [ CourseParticipantUser ==. uid

src/Handler/Firm.hs

@@ -19,6 +19,7 @@ import Import
 
 -- import Jobs
 import Handler.Utils
+import Handler.Utils.Company
 import Handler.Utils.Communication
 import Handler.Utils.Avs (guessAvsUser)
 
@@ -32,8 +33,8 @@ import qualified Data.CaseInsensitive as CI
 import Database.Persist.Postgresql
 import           Database.Esqueleto.Experimental ((:&)(..))
 import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
-import qualified Database.Esqueleto.Legacy as EL (on)
-import qualified Database.Esqueleto.PostgreSQL as E
+import qualified Database.Esqueleto.Legacy as EL (on) -- needed for legacy join expected by dbTable
+-- import qualified Database.Esqueleto.PostgreSQL as E
 import qualified Database.Esqueleto.Utils as E
 import Database.Esqueleto.Utils.TH
 
@@ -56,7 +57,7 @@ postalEmailField = boolFieldCustom (SomeMessage MsgUtilPostal) (SomeMessage MsgU
 
 data FirmAction = FirmActNotify
                 | FirmActResetSupervision
-                | FirmActAddSupersvisors
+                | FirmActAddSupervisors
                 | FirmActChangeContactFirm
                 | FirmActChangeContactUser
   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
@@ -70,10 +71,11 @@ data FirmActionData = FirmActNotifyData
                         { firmActResetKeepOldSupers       :: Maybe Bool
                         , firmActResetMutualSupervision   :: Maybe Bool
                         }
-                    | FirmActAddSupersvisorsData
+                    | FirmActAddSupervisorsData
                         { firmActAddSupervisorIds         :: Set Text
                         , firmActAddSupervisorReroute     :: Bool
                         , firmActAddSupervisorPostal      :: Maybe Bool
+                        , firmActAddSupervisorReason      :: Maybe Text
                         }
                     | FirmActChangeContactFirmData
                         { firmActCCFPostalAddr            :: Maybe StoredMarkup
@@ -82,6 +84,7 @@ data FirmActionData = FirmActNotifyData
                         }
                     | FirmActChangeContactUserData
                         { firmActCCUPostalAddr            :: Maybe StoredMarkup
+                        , firmActCCUUseCompanyPostal      :: Maybe Bool
                         , firmActCCUPostalPref            :: Maybe Bool
                         }
   deriving (Eq, Ord, Read, Show, Generic)
@@ -91,21 +94,31 @@ firmActionMap mr isAdmin acts = mconcat (mkAct isAdmin <$> acts)
   where
     mkAct True  FirmActNotify           = singletonMap FirmActNotify           $ pure FirmActNotifyData
     mkAct _     FirmActResetSupervision = singletonMap FirmActResetSupervision $      FirmActResetSupervisionData
-                  <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep)                     (Just $ Just False)
-                  <*> aopt checkBoxField                                      (fslI MsgFirmActResetMutualSupervision)             (Just $ Just True )
-    mkAct _     FirmActAddSupersvisors   = singletonMap FirmActAddSupersvisors   $ FirmActAddSupersvisorsData
-                  <$> areq (textField & cfAnySeparatedSet)  (fslI MsgTableIsDefaultSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip)  Nothing
+                  <$> aopt boolField'                       (fslI MsgFirmActResetSuperKeep)                     (Just $ Just False)
+                  <*> aopt checkBoxField                    (fslI MsgFirmActResetMutualSupervision)             (Just $ Just True )
+    mkAct _     FirmActAddSupervisors   = singletonMap FirmActAddSupervisors   $ FirmActAddSupervisorsData
+                  <$> areq (textField & cfAnySeparatedSet)  (fslI MsgFirmSuperDefault & setTooltip MsgCourseParticipantsRegisterUsersFieldTip)  Nothing
                   <*> areq checkBoxField                    (fslI MsgTableIsDefaultReroute)                                                             (Just True)
                   <*> aopt postalEmailField                 (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip)                                Nothing
+                  <*> aopt (textField & cfStrip & addDatalist ucdefSuperReasons)
+                                                            (fslI MsgUserCompanyReason & setTooltip MsgUserCompanyReasonTooltip)                        Nothing
     mkAct _     FirmActChangeContactFirm = singletonMap FirmActChangeContactFirm $ FirmActChangeContactFirmData
                   <$> aopt htmlField                        (fslI MsgPostAddress      & setTooltip (SomeMessages [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing
                   <*> aopt (emailField & cfStrip & cfCI)    (fslI MsgUserDisplayEmail & setTooltip MsgUtilEmptyNoChangeTip) Nothing
-                  <*> aopt postalEmailField                 (fslI MsgFormFieldPostal  & setTooltip MsgFormFieldPostalTip)   Nothing
+                  <*> aopt postalEmailField                 (fslI MsgFormFieldPostal  & setTooltip MsgFirmDefaultPreferenceInfo)   Nothing
                   <*  aformMessage (Message Info (toHtml $ mr MsgFirmActChangeContactFirmInfo) (Just IconNotificationNonactive))
     mkAct _     FirmActChangeContactUser = singletonMap FirmActChangeContactUser $ FirmActChangeContactUserData
                   <$> aopt htmlField                        (fslI MsgPostAddress      & setTooltip (SomeMessages [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing
+                  <*> aopt boolField'                       (fslI MsgCompanyUserUseCompanyAddress & setTooltip MsgCompanyUserUseCompanyAddressTip) Nothing
                   <*> aopt postalEmailField                 (fslI MsgFormFieldPostal  & setTooltip MsgFormFieldPostalTip) Nothing
     mkAct _  _ = mempty
+    ucdefSuperReasons :: HandlerFor UniWorX (OptionList Text)
+    ucdefSuperReasons = fmap (mkOptionList . map (\t -> Option t t t) . Set.toAscList) . runDB $
+      fmap (setOf $ folded . _Value . _Just) . E.select . E.distinct $ do
+        usrc <- E.from $ E.table @UserCompany
+        E.where_ $ E.isJust $ usrc E.^. UserCompanyReason
+        return $ usrc E.^. UserCompanyReason
+
 
 firmActionForm :: _ -> Bool -> [FirmAction] -> AForm Handler FirmActionData
 firmActionForm mr isAdmin acts = multiActionA (firmActionMap mr isAdmin acts) (fslI MsgTableAction) Nothing
@@ -119,7 +132,7 @@ firmActionHandler route isAdmin = flip formResult faHandler
     faHandler (_,fids) | null fids = addMessageI Error MsgNoCompanySelected
 
     faHandler (FirmActNotifyData, Set.toList -> fids) = do
-      usrs <- runDB $ E.select $ E.distinct $ do
+      usrs <- runDBRead $ E.select $ E.distinct $ do
         (usr :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser)
         E.where_ $ uc E.^. UserCompanyCompany `E.in_` E.valList fids
         return $ usr E.^. UserId
@@ -136,17 +149,19 @@ firmActionHandler route isAdmin = flip formResult faHandler
         delSupers <- if firmActResetKeepOldSupers == Just False
           then E.deleteCount $ do
                 spr <- E.from $ E.table @UserSupervisor
-                E.where_ $ suprFltr spr E.&&. E.exists (do
-                    usr <- E.from $ E.table @UserCompany
-                    E.where_ $ usr E.^. UserCompanyCompany `E.in_` E.vals fids
-                        E.&&.  usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser
-                  )
+                E.where_ $ suprFltr spr
+                    E.&&. spr E.^. UserSupervisorReason E.~=. E.val (tshow SupervisorReasonCompanyDefault)
+                    E.&&. E.exists (do
+                      usr <- E.from $ E.table @UserCompany
+                      E.where_ $ usr E.^. UserCompanyCompany `E.in_` E.vals fids
+                          E.&&.  usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser
+                    )
           else return 0
-        newSupers <- addDefaultSupervisorsFor madId (firmActResetMutualSupervision /= Just False) fids
+        newSupers <- addDefaultSupervisorsFor (Just $ tshow SupervisorReasonCompanyDefault) madId (firmActResetMutualSupervision /= Just False) fids
         addMessageI Success $ MsgFirmResetSupervision delSupers newSupers
       reloadKeepGetParams route -- reload to reflect changes
 
-    faHandler (FirmActAddSupersvisorsData{..}, Set.toList -> [cid]) = do
+    faHandler (FirmActAddSupervisorsData{..}, Set.toList -> [cid]) = do
       avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser firmActAddSupervisorIds
       let (usersFound', usersNotFound) = partition (is _Just . view _2) $ Map.toList avsUsers
           usersFound = mapMaybe snd usersFound'
@@ -164,7 +179,7 @@ firmActionHandler route isAdmin = flip formResult faHandler
       runDB $ do
         -- putMany [UserCompany uid cid True firmActAddSupervisorReroute 0 False | uid <- usersFound] -- putMany always overwrites existing records, which would destroy priority and useCompanyAddress here
         -- upsertManyWhere [UserCompany uid cid True firmActAddSupervisorReroute 0 False | uid <- usersFound] [copyField UserCompanySupervisor, copyField UserCompanySupervisorReroute] [] [] -- overwrite Supervisor and SupervisorReroute, keep priority and useCompanyAddress
-        upsertManyWhere [UserCompany uid cid True firmActAddSupervisorReroute 0 False | uid <- usersFound] [] [UserCompanySupervisor =. True, UserCompanySupervisorReroute =. firmActAddSupervisorReroute] [] -- identical to previous line, but perhaps more clear?
+        upsertManyWhere [UserCompany uid cid True firmActAddSupervisorReroute 0 False firmActAddSupervisorReason| uid <- usersFound] [] [UserCompanySupervisor =. True, UserCompanySupervisorReroute =. firmActAddSupervisorReroute, UserCompanyReason =. firmActAddSupervisorReason] [] -- identical to previous line, but perhaps more clear?
         whenIsJust firmActAddSupervisorPostal $ \prefPostal ->
           updateWhere [UserId <-. usersFound] [UserPrefersPostal =. prefPostal]
         addMessageI Success $ MsgFirmActAddSupersSet (fromIntegral $ length usersFound) firmActAddSupervisorPostal
@@ -181,21 +196,30 @@ firmActionHandler route isAdmin = flip formResult faHandler
         addMessageI Success MsgFirmActChangeContactFirmResult
         reloadKeepGetParams route
 
-    faHandler (FirmActChangeContactUserData{..}, Set.toList -> [cid]) =
-      let changes = catMaybes
-            [ (UserPostAddress   E.=.) . E.justVal <$> canonical firmActCCUPostalAddr  -- note that Nothing means no change and not delete address!
-            , (UserPrefersPostal E.=.) . E.val     <$>           firmActCCUPostalPref
-            ]
-      in unless (null changes) $ do
-        nrChanged <- runDB $ E.updateCount $ \usr -> do
-          E.set usr changes
-          E.where_ $ E.exists $ do
-            usrCmpy <- E.from $ E.table @UserCompany
-            E.where_ $ usrCmpy E.^. UserCompanyCompany E.==. E.val cid
-                E.&&.  usrCmpy E.^. UserCompanyUser    E.==. usr E.^. UserId
-        addMessageI Success $ MsgFirmUserChanges nrChanged
-        reloadKeepGetParams route  -- reload to reflect changes
-
+    faHandler (FirmActChangeContactUserData{..}, Set.toList -> [cid])
+      | firmActCCUUseCompanyPostal == Just True, isJust firmActCCUPostalAddr =
+          addMessageI Error MsgCompanyUserUseCompanyPostalError
+      | otherwise = do
+          let changes = catMaybes
+                [ toMaybe (firmActCCUUseCompanyPostal == Just True) (UserPostAddress   E.=. E.nothing)      -- precondition ensures that only one update applies for UserPostAddress
+                , (UserPostAddress   E.=.) . E.justVal <$> canonical firmActCCUPostalAddr  -- note that Nothing means no change and not delete address!
+                , (UserPrefersPostal E.=.) . E.val     <$>           firmActCCUPostalPref
+                ]
+          (total, nrChanged) <- runDB $ do
+            nrUsrChange <- E.updateCount $ \usr -> do
+              E.set usr changes
+              E.where_ $ E.exists $ do
+                usrCmpy <- E.from $ E.table @UserCompany
+                E.where_ $ usrCmpy E.^. UserCompanyCompany E.==. E.val cid
+                    E.&&.  usrCmpy E.^. UserCompanyUser    E.==. usr E.^. UserId
+            nrUseComp <- case firmActCCUUseCompanyPostal of
+              Just x  -> updateWhereCount [UserCompanyCompany ==. cid] [UserCompanyUseCompanyAddress =. x]
+              Nothing -> return 0
+            nrCid <- count [UserCompanyCompany ==. cid]
+            return (fromIntegral nrCid, max nrUsrChange nrUseComp)
+          let allok = bool Warning Success $ nrChanged == total
+          addMessageI allok $ MsgFirmUserActChangeResult nrChanged total
+          reloadKeepGetParams route  -- reload to reflect changes
     faHandler _ = addMessageI Error MsgErrorUnknownFormAction
 
 
@@ -230,109 +254,35 @@ runFirmActionFormPost cid route isAdmin acts = do
 -- Firm specific utilities
 -- for filters and counts also see before FirmAllR Handlers
 
-
-
--- | remove supervisors for given users; maybe restricted to those linked to a given companies
-deleteSupervisors :: NonEmpty UserId -> [CompanyId] -> DB Int64
-deleteSupervisors usrs cids = deleteWhereCount $ (UserSupervisorUser <-. toList usrs) : restrictByCompany
-  where
-    restrictByCompany = guardMonoid (notNull cids) [UserSupervisorCompany <-. (Just <$> cids)]      
-
--- reset supervisors given employees of a company to default company supervision, deleting all previous company-related supervisors
-resetSupervisors :: CompanyId -> NonEmpty UserId -> DB Int64
-resetSupervisors cid employees = do
-  nr_del <- deleteSupervisors employees [cid]
-  nr_add <- addDefaultSupervisors cid employees
-  return $ max nr_del nr_add
-
--- adds the default company supervisors as supervisor to a given set of users, which themselves may belong to any company
-addDefaultSupervisors :: CompanyId -> NonEmpty UserId -> DB Int64
-addDefaultSupervisors cid employees = do
-  E.insertSelectWithConflictCount UniqueUserSupervisor
-    (do
-      (spr :& usr) <- E.from $ E.table @UserCompany `E.crossJoin` E.toValues employees
-      E.where_ $ spr E.^. UserCompanyCompany E.==. E.val cid
-          E.&&.  spr E.^. UserCompanySupervisor
-      E.distinct $ return $ UserSupervisor
-        E.<#  (spr E.^. UserCompanyUser)
-        E.<&>  usr
-        E.<&> (spr E.^. UserCompanySupervisorReroute)
-        E.<&> E.justVal cid
-        E.<&> E.nothing
-    )
-    (\_old new -> 
-      [ UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications
-      , UserSupervisorCompany E.=. E.justVal cid      
-      -- , UserSupervisorReason  E.=. new E.^. UserSupervisorReason -- keep any existing reason
-      ])
-
--- like `addDefaultSupervisors`, but selects all employees of given companies from database, optionally filtered by being under supervision of a given individual
-addDefaultSupervisorsFor ::  (CompanyId ~ Element mono, MonoFoldable mono) => Maybe UserId -> Bool -> mono -> DB Int64
-addDefaultSupervisorsFor mbSuperId mutualSupervision cids = do
-  E.insertSelectWithConflictCount UniqueUserSupervisor
-    (do
-      (spr :& usr) <- E.from $ E.table @UserCompany `E.innerJoin` E.table @UserCompany `E.on` (\(spr :& usr) -> spr E.^. UserCompanyCompany E.==. usr E.^. UserCompanyCompany)
-      E.where_ $ E.and $ guardMonoid (not mutualSupervision)
-                            [ E.not_ $ usr E.^. UserCompanySupervisor ]
-                        <>  maybeEmpty mbSuperId (\sprId -> [E.exists $ do
-                              superv <- E.from $ E.table @UserSupervisor
-                              E.where_ $ superv E.^. UserSupervisorSupervisor E.==. E.val sprId
-                                  E.&&.  superv E.^. UserSupervisorUser       E.==. usr E.^. UserCompanyUser
-                            ])
-                        <>  [          spr E.^. UserCompanySupervisor
-                            , spr E.^. UserCompanyCompany `E.in_` E.vals cids
-                            , usr E.^. UserCompanyCompany `E.in_` E.vals cids
-                            ]
-      E.distinct $ return $ UserSupervisor
-        E.<#  (spr E.^. UserCompanyUser)
-        E.<&> (usr E.^. UserCompanyUser)
-        E.<&> (spr E.^. UserCompanySupervisorReroute)
-        E.<&> E.just (spr E.^. UserCompanyCompany)
-        E.<&> E.nothing
-    )
-    (\_old new -> 
-        [ UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications
-        , UserSupervisorCompany E.=. new E.^. UserSupervisorCompany
-        -- , UserSupervisorReason  E.=. new E.^. UserSupervisorReason   -- keep any existing reaon
-        ] )
-
--- like `addDefaultSupervisors`, but selects all employees of given companies from database
-addDefaultSupervisorsAll ::  (CompanyId ~ Element mono, MonoFoldable mono) => Bool -> mono -> DB Int64
-addDefaultSupervisorsAll mutualSupervision cids = do
-  E.insertSelectWithConflictCount UniqueUserSupervisor
-    (do
-      (spr :& usr) <- E.from $ E.table @UserCompany `E.innerJoin` E.table @UserCompany `E.on` (\(spr :& usr) -> spr E.^. UserCompanyCompany E.==. usr E.^. UserCompanyCompany)
-      E.where_ $ E.and $ guardMonoid (not mutualSupervision)
-                            [ E.not_ $ usr E.^. UserCompanySupervisor ]
-                        <>  [          spr E.^. UserCompanySupervisor
-                            , spr E.^. UserCompanyCompany `E.in_` E.vals cids
-                            , usr E.^. UserCompanyCompany `E.in_` E.vals cids
-                            ]
-      E.distinct $ return $ UserSupervisor
-        E.<#  (spr E.^. UserCompanyUser)
-        E.<&> (usr E.^. UserCompanyUser)
-        E.<&> (spr E.^. UserCompanySupervisorReroute)
-        E.<&> E.just (spr E.^. UserCompanyCompany)
-        E.<&> E.nothing
-    )
-    (\_old new -> 
-        [ UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications
-        , UserSupervisorCompany E.=. new E.^. UserSupervisorCompany
-        -- , UserSupervisorReason  E.=. new E.^. UserSupervisorReason   -- keep any existing reaon
-        ] )
-
-
-------------------------------
 -- repeatedly useful queries
 
+usrPrimaryCompanies :: E.SqlExpr (Entity Company) -> E.SqlExpr (Entity UserCompany) -> E.SqlQuery ()
+-- usrPrimaryCompanies :: E.SqlExpr (E.Value CompanyId) -> E.SqlExpr (Entity UserCompany) -> E.SqlQuery (Entity UserCompany) -- possible alternative
+usrPrimaryCompanies cmp usr = do
+  othr <- E.from $ E.table @UserCompany
+  E.where_ $ othr E.^. UserCompanyPriority E.>.  usr E.^. UserCompanyPriority
+      E.&&.  othr E.^. UserCompanyUser     E.==. usr E.^. UserCompanyUser
+      E.&&.  othr E.^. UserCompanyCompany  E.!=. cmp E.^. CompanyId                     -- redundant due to > above, but likely performance improving
+  -- return othr
+
 fromUserCompany :: Maybe (E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (Entity Company) -> E.SqlQuery ()
 fromUserCompany mbFltr cmpy = do
   usrCmpy <- E.from $ E.table @UserCompany
   let basecond = usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId
   E.where_ $ maybe basecond ((basecond E.&&.).($ usrCmpy)) mbFltr
 
-firmCountUsers        :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
-firmCountUsers        = E.subSelectCount . fromUserCompany Nothing
+firmCountUsers              :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
+firmCountUsers              = E.subSelectCount . fromUserCompany Nothing
+
+firmCountUsersPrimary       :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
+firmCountUsersPrimary cmp   = E.subSelectCount $ fromUserCompany (Just primFltr) cmp
+  where
+    primFltr = E.notExists . usrPrimaryCompanies cmp
+
+firmCountUsersSecondary     :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
+firmCountUsersSecondary cmp = E.subSelectCount $ fromUserCompany (Just primFltr) cmp
+  where
+    primFltr =    E.exists . usrPrimaryCompanies cmp
 
 firmCountSupervisors  :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
 firmCountSupervisors  = E.subSelectCount . fromUserCompany (Just (E.^. UserCompanySupervisor))
@@ -445,7 +395,7 @@ type AllCompanyTableExpr = E.SqlExpr (Entity Company)
 queryAllCompany :: AllCompanyTableExpr -> E.SqlExpr (Entity Company)
 queryAllCompany = id
 
-type AllCompanyTableData = DBRow (Entity Company, E.Value Word64, E.Value Bool, E.Value Bool)
+type AllCompanyTableData = DBRow (Entity Company, E.Value Word64, E.Value Bool, E.Value Bool, E.Value Word64)
 resultAllCompanyEntity          :: Lens' AllCompanyTableData (Entity Company)
 resultAllCompanyEntity          = _dbrOutput . _1
 
@@ -461,6 +411,8 @@ resultAllCompanySupervisors       = _dbrOutput . _3 . _unValue
 resultAllCompanyDefaultReroutes   :: Lens' AllCompanyTableData Bool
 resultAllCompanyDefaultReroutes   = _dbrOutput . _4 . _unValue
 
+resultAllCompanyUsersSecondary    :: Lens' AllCompanyTableData Word64
+resultAllCompanyUsersSecondary    = _dbrOutput . _5 . _unValue
 
 mkFirmAllTable :: Bool -> UserId -> DB (FormResult (FirmActionData, Set CompanyId), Widget)
 mkFirmAllTable isAdmin uid = do
@@ -483,12 +435,13 @@ mkFirmAllTable isAdmin uid = do
                   , cmpy & firmCountUsers                       --  2
                   , cmpy & firmHasSupervisors                   --  3
                   , cmpy & firmHasDefaultReroutes               --  4
-                  -- , cmpy & firmCountEmployeeSupervised          --  4
-                  -- , cmpy & firmCountEmployeeRerouted            --  5
-                  -- , cmpy & firmCountEmployeeRerPost             --  6
-                  -- , cmpy & firmCountForeignSupervisors          --  7
-                  -- , cmpy & firmCountActiveReroutes              --  9
-                  -- , cmpy & firmCountActiveReroutes'             -- 10
+                  , cmpy & firmCountUsersSecondary              --  5
+                  -- , cmpy & firmCountEmployeeSupervised
+                  -- , cmpy & firmCountEmployeeRerouted
+                  -- , cmpy & firmCountEmployeeRerPost
+                  -- , cmpy & firmCountForeignSupervisors
+                  -- , cmpy & firmCountActiveReroutes
+                  -- , cmpy & firmCountActiveReroutes'
                   )
         dbtRowKey = (E.^. CompanyId)
         dbtProj = dbtProjFilteredPostId
@@ -501,6 +454,7 @@ mkFirmAllTable isAdmin uid = do
               in  anchorCell (FirmSupersR fsh) $ toWgt fsh
           , sortable (Just "avsnr")         (i18nCell MsgTableCompanyNo)               $ \(view resultAllCompany -> firm) -> numCell $ companyAvsId firm
           , sortable (Just "users")         (i18nCell MsgTableCompanyNrUsers)          $ \(view resultAllCompanyUsers               -> nr) -> wgtCell $ word2widget nr
+          , sortable (Just "secondary")     (i18nCell MsgTableCompanyNrSecondaryUsers) $ \(view resultAllCompanyUsersSecondary      -> nr) -> wgtCell $ word2widget nr
           , sortable (Just "supervisors")   (i18nCell MsgTableCompanyNrSupersDefault)  $ \row ->
               anchorCell (FirmSupersR $ row ^. resultAllCompany . _companyShorthand) $ toWgt $ hasTickmark $ row ^. resultAllCompanySupervisors
           , sortable (Just "reroute-def")   (i18nCell MsgTableCompanyNrRerouteDefault) $ \(view resultAllCompanyDefaultReroutes     -> ok) -> tickmarkCell ok
@@ -518,6 +472,7 @@ mkFirmAllTable isAdmin uid = do
           , singletonMap "avsnr"          $ SortColumn (E.^. CompanyAvsId)
           , singletonMap "postal-pref"    $ SortColumn (E.^. CompanyPrefersPostal)
           , singletonMap "users"          $ SortColumn firmCountUsers
+          , singletonMap "secondary"      $ SortColumn firmCountUsersSecondary
           , singletonMap "supervisors"    $ SortColumn firmHasSupervisors
           -- , singletonMap "emp-supervised" $ SortColumn firmCountEmployeeSupervised
           -- , singletonMap "emp-rerouted"   $ SortColumn firmCountEmployeeRerouted
@@ -598,7 +553,7 @@ mkFirmAllTable isAdmin uid = do
           --               ))
           --       )
           --   )
-          -- , single ("is-supervisor", FilterColumn $ \row (getLast -> criterion) -> 
+          -- , single ("is-supervisor", FilterColumn $ \row (getLast -> criterion) ->
           --     case criterion of
           --       Nothing -> E.true
           --       (Just (crit::Text)) -> E.exists $ do
@@ -618,7 +573,7 @@ mkFirmAllTable isAdmin uid = do
           --                       ))
           --               )
           --   )
-          , single ("is-supervisor", mkFilterProjectedPost $ \(getLast -> criterion) dbr -> 
+          , single ("is-supervisor", mkFilterProjectedPost $ \(getLast -> criterion) dbr ->
               case criterion of
                 Nothing -> return True :: DB Bool
                 (Just (crit::Text)) -> do
@@ -711,6 +666,8 @@ mkFirmAllTable isAdmin uid = do
                 E.&&. qual E.^. QualificationShorthand E.==. E.val criterion
                 E.&&. validQualification now usrQual
             )
+          , single ("company-address", FilterColumn $ E.mkContainsFilterWithCommaPlus id $ views (to queryAllCompany) ((E.->>. "markup-input").(E.^. CompanyPostAddress))
+            )
           ]
         dbtFilterUI mPrev = mconcat
           [ fltrCompanyNameUI mPrev
@@ -720,7 +677,8 @@ mkFirmAllTable isAdmin uid = do
           , prismAForm (singletonFilter "is-supervisor")                              mPrev $ aopt textField (fslI MsgTableSupervisor)
           , prismAForm (singletonFilter "is-default-supervisor")                      mPrev $ aopt textField (fslI MsgFirmSuperDefault)
           , prismAForm (singletonFilter "foreign-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterForeignSupervisor)
-          , prismAForm (singletonFilter "company-postal"     . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterFirmExtern)
+          , prismAForm (singletonFilter "company-postal"     . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterFirmExtern & setTooltip MsgFilterFirmExternTooltip)
+          , prismAForm (singletonFilter "company-address")                            mPrev $ aopt textField (fslI MsgFirmAddress)
           , fltrQualificationHdrUI MsgFilterHasQualification mPrev
           ]
         dbtStyle =  def { dbsFilterLayout = defaultDBSFilterLayout }
@@ -773,7 +731,9 @@ data FirmUserAction = FirmUserActNotify
                     | FirmUserActResetSupervision
                     | FirmUserActSetSupervisor
                     | FirmUserActMkSuper
+                    | FirmUserActChangeDetails
                     | FirmUserActChangeContact
+                    | FirmUserActRemove
   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
   deriving anyclass (Universe, Finite)
 
@@ -782,20 +742,28 @@ embedRenderMessage ''UniWorX ''FirmUserAction id
 
 data FirmUserActionData = FirmUserActNotifyData
                         | FirmUserActResetSupervisionData
-                            { firmUserActResetKeepOldSupers     :: Maybe Bool
-                            -- , firmUserActResetMutualSupervision :: Maybe Bool
+                            { firmUserActResetSupers            :: Maybe Bool
                             }
                         | FirmUserActSetSupervisorData
-                            {  firmUserActSetSuperNames   :: Maybe (Set Text)
-                            ,  firmUserActSetSuperIds     :: Maybe [UserId]
-                            ,  firmUserActSetSuperReroute :: Bool
-                            ,  firmUserActSetSuperKeep    :: Bool
+                            { firmUserActSetSuperNames          :: Maybe (Set Text)
+                            , firmUserActSetSuperIds            :: Maybe [UserId]
+                            , firmUserActSetSuperReason         :: Maybe Text
+                            , firmUserActSetSuperReroute        :: Bool
+                            , firmUserActResetSupers            :: Maybe Bool
                             }
                         | FirmUserActMkSuperData
-                            { firmUserActMkSuperReroute   :: Maybe Bool }
+                            { firmUserActMkSuperReroute         :: Maybe Bool }
+                        | FirmUserActChangeDetailsData
+                            { firmUserActDetailPriority         :: Maybe Int
+                            , firmUserActDetailReason           :: Maybe Text
+                            }
                         | FirmUserActChangeContactData
-                            { firmUserActPostalAddr :: Maybe StoredMarkup
-                            , firmUserActPostalPref :: Maybe Bool
+                            { firmUserActPostalAddr             :: Maybe StoredMarkup
+                            , firmUserActUseCompanyPostal       :: Maybe Bool
+                            , firmUserActPostalPref             :: Maybe Bool
+                            }
+                        | FirmUserActRemoveData
+                            { firmUserActRemoveSupers           :: Bool
                             }
   deriving (Eq, Ord, Show, Generic)
 
@@ -807,7 +775,7 @@ queryUserUser = $(sqlIJproj 2 1)
 queryUserUserCompany :: UserCompanyTableExpr -> E.SqlExpr (Entity UserCompany)
 queryUserUserCompany = $(sqlIJproj 2 2)
 
-type UserCompanyTableData = DBRow (Entity User, Entity UserCompany, E.Value Word64, E.Value Word64) -- , E.Value Bool)
+type UserCompanyTableData = DBRow (Entity User, Entity UserCompany, E.Value Word64, E.Value Word64, E.Value Bool)
 
 resultUserUser :: Lens' UserCompanyTableData (Entity User)
 resultUserUser = _dbrOutput . _1
@@ -821,8 +789,8 @@ resultUserCompanySupervisors = _dbrOutput . _3 . _unValue
 resultUserCompanyReroutes :: Lens' UserCompanyTableData Word64
 resultUserCompanyReroutes = _dbrOutput . _4 . _unValue
 
--- resultUserCompanyPrimary :: Lens' UserCompanyTableData Bool
--- resultUserCompanyPrimary = _dbrOutput . _5 . _unValue
+resultUserCompanyPrimary :: Lens' UserCompanyTableData Bool
+resultUserCompanyPrimary = _dbrOutput . _5 . _unValue
 
 instance HasEntity UserCompanyTableData User where
   hasEntity = resultUserUser
@@ -835,24 +803,27 @@ mkFirmUserTable :: Bool -> CompanyId -> DB (FormResult (FirmUserActionData, Set
 mkFirmUserTable isAdmin cid = do
   mr <- getMessageRender
   let
-    mkSprOption (E.Value uid, E.Value udn, E.Value mbSpr) = do
+    reasonSuperior = Just $ tshow SupervisorReasonAvsSuperior
+    mkSprOption (E.Value uid, E.Value udn, E.Value mbSpr, E.Value mbmbReason) = do
       uuid <- toPathPiece <$> encryptUser uid
-      return (Option{ optionDisplay = udn, optionInternalValue = uid, optionExternalValue = uuid }, mbSpr)
+      return (Option{ optionDisplay = udn, optionInternalValue = uid, optionExternalValue = uuid }, mbSpr, mbmbReason == Just reasonSuperior)
 
     procOptions rawSupers = do
       procSupers <- traverse mkSprOption rawSupers
       return $ mkOptionListGrouped $ filter (notNull . snd)
-             [ (mr MsgFirmSuperDefault  , [opt | (opt, Just True ) <- procSupers])
-             , (mr MsgFirmSuperIrregular, [opt | (opt, Just False) <- procSupers])
-             , (mr MsgFirmSuperForeign  , [opt | (opt, Nothing   ) <- procSupers])
+             [ (mr MsgTableSuperior     , [opt | (opt, _         , True ) <- procSupers])
+             , (mr MsgFirmSuperDefault  , [opt | (opt, Just True , False) <- procSupers])
+             , (mr MsgFirmSuperIrregular, [opt | (opt, Just False, False) <- procSupers])
+             , (mr MsgFirmSuperForeign  , [opt | (opt, Nothing   , False) <- procSupers])
              ]
 
   rawSupers <- E.select $ do
     (usr :& usrCmp) <- E.from $ E.table @User `E.leftJoin` E.table @UserCompany
             `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.=?. usrCmp E.?. UserCompanyUser E.&&. usrCmp E.?. UserCompanyCompany E.==. E.justVal cid)
     E.where_ $ E.isTrue (usrCmp E.?. UserCompanySupervisor)
-        E.||.  E.exists (firmQuerySupervisedBy cid Nothing usr)    
-    return (usr E.^. UserId, usr E.^. UserDisplayName, usrCmp E.?. UserCompanySupervisor)
+        E.||.  (usrCmp E.?. UserCompanyReason E.?=. E.val reasonSuperior)
+        E.||.  E.exists (firmQuerySupervisedBy cid Nothing usr)
+    return (usr E.^. UserId, usr E.^. UserDisplayName, usrCmp E.?. UserCompanySupervisor, usrCmp E.?. UserCompanyReason)
   let
     -- supervisorField :: Field Handler UserId
     -- supervisorField  =      selectField' (Just $ SomeMessage MsgMultiNoSelection) $ procOptions rawSupers
@@ -864,12 +835,12 @@ mkFirmUserTable isAdmin cid = do
         dbtSQLQuery = \(usr `E.InnerJoin` usrCmp) -> do
           EL.on $ usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser
           E.where_ $ usrCmp E.^. UserCompanyCompany E.==. E.val cid
-          -- let isPrimary = E.notExists (do
-          --         other <- E.from $ E.table @UserCompany
-          --         E.where_ $ other E.^. UserCompanyUser     E.==. usrCmp E.^. UserCompanyUser
-          --             E.&&.  other E.^. UserCompanyPriority E.>.  usrCmp E.^. UserCompanyPriority
-          --         )
-          return (usr, usrCmp, firmCountUserSupervisors usrCmp, firmCountUserSupervisorsReroute usrCmp)
+          let isPrimary = E.notExists (do
+                  other <- E.from $ E.table @UserCompany
+                  E.where_ $ other E.^. UserCompanyUser     E.==. usrCmp E.^. UserCompanyUser
+                      E.&&.  other E.^. UserCompanyPriority E.>.  usrCmp E.^. UserCompanyPriority
+                  )
+          return (usr, usrCmp, firmCountUserSupervisors usrCmp, firmCountUserSupervisorsReroute usrCmp, isPrimary)
         dbtRowKey = queryUserUser >>> (E.^. UserId)
         dbtProj = dbtProjId
         dbtColonnade = formColonnade $ mconcat
@@ -880,7 +851,16 @@ mkFirmUserTable isAdmin cid = do
           , sortable (Just "supervisors")     (i18nCell MsgTableCompanyNrSupers       )  $ \(view resultUserCompanySupervisors  -> nr) -> wgtCell $ word2widget nr
           , sortable (Just "reroutes")        (i18nCell MsgTableCompanyNrRerouteActive)  $ \(view resultUserCompanyReroutes     -> nr) -> wgtCell $ word2widget nr
           , sortable (Just "postal-pref")     (i18nCell MsgPrefersPostal)                $ \(view $ resultUserUser . _userPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b
+          , sortable Nothing                  (i18nCell MsgCompanyUserUseCompanyAddress) $ \row ->
+              let noUsrAddr = isNothing $ row ^. resultUserUser . _userPostAddress
+                  useCompA  = row ^. resultUserUserCompany . _entityVal . _userCompanyUseCompanyAddress
+              in tickmarkCell $ noUsrAddr && useCompA
           , colUserEmail
+          , sortable (Just "usr-reason")      (i18nCell MsgTableCompanyReason)           $ \(view $ resultUserUserCompany . _entityVal . _userCompanyReason -> r) -> cellMaybe textCell r
+          , sortable (Just "priority")        (i18nCell MsgCompanyUserPriority)          $ \row ->
+              let prio :: Int = row ^. resultUserUserCompany . _entityVal . _userCompanyPriority
+                  isPrime     = row ^. resultUserCompanyPrimary
+              in numCell prio <> spacerCell <> ifIconCell isPrime IconTop
           , sortable Nothing (i18nCell MsgTableUserEdit) $ \(view resultUserUser -> entUsr) -> cellEditUserModal entUsr
           ]
         dbtSorting = mconcat
@@ -891,6 +871,8 @@ mkFirmUserTable isAdmin cid = do
           , singletonMap "personal-number"  $ SortColumn $ queryUserUser        >>> (E.^. UserCompanyPersonalNumber)
           , singletonMap "supervisors"      $ SortColumn $ queryUserUserCompany >>> firmCountUserSupervisors
           , singletonMap "reroutes"         $ SortColumn $ queryUserUserCompany >>> firmCountUserSupervisorsReroute
+          , singletonMap "usr-reason"       $ SortColumn $ queryUserUserCompany >>> (E.^. UserCompanyReason)
+          , singletonMap "priority"         $ SortColumn $ queryUserUserCompany >>> (E.^. UserCompanyPriority)
           ]
         dbtFilter = mconcat
           [ single $ fltrUserNameEmail queryUserUser
@@ -950,7 +932,7 @@ mkFirmUserTable isAdmin cid = do
               let checkPrimary = do
                     other <- E.from $ E.table @UserCompany
                     E.where_ $ other E.^. UserCompanyUser     E.==. queryUserUserCompany row E.^. UserCompanyUser
-                        E.&&.  other E.^. UserCompanyPriority E.>.  queryUserUserCompany row E.^. UserCompanyPriority                  
+                        E.&&.  other E.^. UserCompanyPriority E.>.  queryUserUserCompany row E.^. UserCompanyPriority
               in case criterion of
                   Nothing     -> E.true
                   Just False  -> E.exists    checkPrimary
@@ -967,22 +949,42 @@ mkFirmUserTable isAdmin cid = do
           , prismAForm (singletonFilter "is-primary-company"     . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI   MsgFilterFirmPrimary)
           ]
         dbtStyle =  def { dbsFilterLayout = defaultDBSFilterLayout }
+        userReasons :: HandlerFor UniWorX (OptionList Text)
+        userReasons = fmap (mkOptionList . map (\t -> Option t t t) . Set.toAscList) . runDB $
+          fmap (setOf $ folded . _Value . _Just) . E.select . E.distinct $ do
+            usrc <- E.from $ E.table @UserCompany
+            E.where_ $ E.isJust (usrc E.^. UserCompanyReason)
+                  E.&&. usrc E.^. UserCompanyCompany E.==. E.val cid
+            return $ usrc E.^. UserCompanyReason
+        superReasons :: HandlerFor UniWorX (OptionList Text)
+        superReasons = fmap (mkOptionList . map (\t -> Option t t t) . Set.toAscList) . runDB $
+          fmap (setOf $ folded . _Value . _Just) . E.select . E.distinct $ do
+            usrc <- E.from $ E.table @UserSupervisor
+            E.where_ $ E.isJust (usrc E.^. UserSupervisorReason)
+                  E.&&. usrc E.^. UserSupervisorCompany E.~=. E.val cid
+            return $ usrc E.^. UserSupervisorReason
         acts :: Map FirmUserAction (AForm Handler FirmUserActionData)
         acts = mconcat
           [ guardMonoid isAdmin $ singletonMap FirmUserActNotify $ pure FirmUserActNotifyData
           , singletonMap FirmUserActResetSupervision $ FirmUserActResetSupervisionData
-              <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep)         (Just $ Just False)
-              -- <*> aopt checkBoxField                                      (fslI MsgFirmActResetMutualSupervision) (Just $ Just True )
+              <$> aopt (boolFieldCustom (SomeMessage MsgFirmActResetSupersRemoveAll) (SomeMessage MsgFirmActResetSupersRemoveAps) $ Just $ SomeMessage MsgFirmActResetSupersKeepAll) (fslI MsgFirmActResetSuperKeep) (Just $ Just False)
           , singletonMap FirmUserActSetSupervisor $ FirmUserActSetSupervisorData
               <$> aopt (textField & cfAnySeparatedSet)                    (fslI MsgFirmNewSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing
               <*> aopt supervisorsField                                   (fslI MsgFirmSetSupervisor & setTooltip MsgMultiSelectTip)                          Nothing
-              <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip)        (Just False)
-              <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep)                                                     (Just False)
+              <*> aopt (textField & cfStrip & addDatalist superReasons)   (fslI MsgUserSupervisorReason  & setTooltip MsgUserSupervisorReasonTooltip)         Nothing
+              <*> areq  boolField'                                        (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip)        (Just False)
+              <*> aopt (boolFieldCustom (SomeMessage MsgFirmActResetSupersRemoveAll) (SomeMessage MsgFirmActResetSupersRemoveAps) $ Just $ SomeMessage MsgFirmActResetSupersKeepAll) (fslI MsgFirmActResetSuperKeep) (Just $ Just False)
           , singletonMap FirmUserActMkSuper $ FirmUserActMkSuperData
               <$> aopt checkBoxField (fslI MsgTableIsDefaultReroute) (Just $ Just True)
           , singletonMap FirmUserActChangeContact $ FirmUserActChangeContactData
-              <$> aopt htmlField                        (fslI MsgPostAddress      & setTooltip (SomeMessages [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing
-              <*> aopt postalEmailField                 (fslI MsgFormFieldPostal  & setTooltip MsgFormFieldPostalTip) Nothing
+              <$> aopt htmlField        (fslI MsgPostAddress      & setTooltip (SomeMessages [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing
+              <*> aopt boolField'       (fslI MsgCompanyUserUseCompanyAddress & setTooltip MsgCompanyUserUseCompanyAddressTip) Nothing
+              <*> aopt postalEmailField (fslI MsgFormFieldPostal  & setTooltip MsgFormFieldPostalTip) Nothing
+          , singletonMap FirmUserActChangeDetails $ FirmUserActChangeDetailsData
+              <$> aopt intField                                           (fslI MsgCompanyUserPriority & setTooltip MsgCompanyUserPriorityTip) Nothing
+              <*> aopt (textField & cfStrip & addDatalist userReasons)    (fslI MsgUserCompanyReason & setTooltip (SomeMessages [SomeMessage MsgUserCompanyReasonTooltip, SomeMessage MsgNullDeletes])) Nothing
+          , singletonMap FirmUserActRemove $ FirmUserActRemoveData
+              <$> areq boolField'       (fslI MsgFirmActRemoveSupers) (Just True)
           ]
         dbtParams = DBParamsForm
           { dbParamsFormMethod = POST
@@ -1049,6 +1051,10 @@ postFirmUsersR fsh = do
       --     return usr
       <*> mkFirmUserTable isAdmin cid
 
+  let resetSupers :: Maybe Bool -> NonEmpty UserId -> DB Int64
+      resetSupers Nothing      _    = return 0
+      resetSupers (Just False) uids = deleteDefaultSupervisorsForUsers [] [] uids
+      resetSupers (Just True ) uids = deleteWhereCount [UserSupervisorUser <-. toList uids]
   formResult fusrRes $ \case
     (_, uids) | null uids -> addMessageI Error MsgUtilEmptyChoice
     (FirmUserActNotifyData , uids) -> do
@@ -1056,10 +1062,8 @@ postFirmUsersR fsh = do
       redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids])
     (FirmUserActResetSupervisionData{..}, set2NonEmpty (error "Unexpected empty user list in getFirmUserR action handler.") -> uids) -> do  -- set guaranteed to be non-empty due to first case clause
       runDB $ do
-        delSupers <- if firmUserActResetKeepOldSupers == Just False
-          then deleteSupervisors uids []
-          else return 0
-        newSupers <- addDefaultSupervisors cid uids
+        delSupers <- resetSupers firmUserActResetSupers uids
+        newSupers <- addDefaultSupervisors Nothing cid uids
         addMessageI Info $ MsgFirmResetSupervision delSupers newSupers
       reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
     (FirmUserActSetSupervisorData{..}, set2NonEmpty (error "Unexpected empty user list in getFirmUserR action handler.") -> uids) -> do
@@ -1077,27 +1081,55 @@ postFirmUsersR fsh = do
                   <li>#{usr}
               |]
         in addMessageModal Error (i18n . MsgCourseParticipantsRegisterNotFoundInAvs $ length usersNotFound) (Right msgContent)
-      delSupers <- runDB
-         $ bool (deleteSupervisors uids [cid]) (return 0) firmUserActSetSuperKeep
-        <* putMany [UserSupervisor s u firmUserActSetSuperReroute (Just cid) Nothing | u <- toList uids, s <- newSupers]
+      delSupers <- runDB $ resetSupers firmUserActResetSupers uids
+        <* putMany [UserSupervisor s u firmUserActSetSuperReroute (Just cid) firmUserActSetSuperReason | u <- toList uids, s <- newSupers]
       addMessageI Success $ MsgFirmSetSupersReport nrUsers nrSupers delSupers
       reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
-
     (FirmUserActMkSuperData{..}, Set.toList -> uids) -> do
-      nrMkSuper <- runDB $ updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. True, UserCompanySupervisorReroute =. (firmUserActMkSuperReroute == Just True)]
-      addMessageI Info $ MsgFirmActAddSupersSet nrMkSuper Nothing
+      nrUpd <- runDB $ updateWhereCount [UserCompanyCompany ==. cid, UserCompanyUser <-. uids] [UserCompanySupervisor =. True, UserCompanySupervisorReroute =. (firmUserActMkSuperReroute == Just True)]
+      addMessageI Success $ MsgFirmActAddSupersSet nrUpd Nothing
       reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
-    (FirmUserActChangeContactData{..}, Set.toList -> uids) ->
-      let changes = catMaybes
-            [ (UserPostAddress   =.) . Just <$> canonical firmUserActPostalAddr  -- note that Nothing means no change and not delete address!
-            , (UserPrefersPostal =.)        <$>           firmUserActPostalPref
-            ]
-      in unless (null changes) $ do
-        nrChanged <- runDB $ updateWhereCount [UserId <-. uids] changes
-        addMessageI Success $ MsgFirmUserChanges nrChanged
+    (FirmUserActChangeDetailsData{..}, Set.toList -> uids) -> do
+      let upReason = case canonical firmUserActDetailReason of
+                      Nothing     -> Nothing
+                      Just "NULL" -> Just $ UserCompanyReason =. Nothing
+                      other       -> Just $ UserCompanyReason =. other
+      nrUpd <- runDB $ updateWhereCount [UserCompanyCompany ==. cid, UserCompanyUser <-. uids] $ catMaybes [upReason, (UserCompanyPriority =.) <$> firmUserActDetailPriority]
+      let total = fromIntegral $ length uids
+          allok = bool Warning Success $ nrUpd == total
+      addMessageI allok $ MsgFirmUserActChangeDetailsResult nrUpd total
+      reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
+    (FirmUserActChangeContactData{..}, Set.toList -> uids)
+      | firmUserActUseCompanyPostal == Just True, isJust firmUserActPostalAddr ->
+          addMessageI Error MsgCompanyUserUseCompanyPostalError
+      | otherwise -> do
+        let changes = catMaybes
+              [ toMaybe (firmUserActUseCompanyPostal == Just True) (UserPostAddress =. Nothing) -- precondition ensures that only one update applies for UserPostAddress
+              , (UserPostAddress   =.) . Just <$> canonical firmUserActPostalAddr               -- note that Nothing means no change and not delete address!
+              , (UserPrefersPostal =.)        <$>           firmUserActPostalPref
+              ]
+        nrChanged <- runDB $ do
+          nrUsrChange <- updateWhereCount [UserId <-. uids] changes
+          nrUseComp   <- case firmUserActUseCompanyPostal of
+            Just x  -> updateWhereCount [UserCompanyCompany ==. cid, UserCompanyUser <-. uids] [UserCompanyUseCompanyAddress =. x]
+            Nothing -> return 0
+          return $ max nrUsrChange nrUseComp
+        let total = fromIntegral $ length uids
+            allok = bool Warning Success $ nrChanged == total
+        addMessageI allok $ MsgFirmUserActChangeResult nrChanged total
         reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
+    (FirmUserActRemoveData{..}, Set.toList -> uids) -> do
+      let optRemove = if firmUserActRemoveSupers then id else const $ return 0
+      (nrUc, nrSuper, nrSubs) <- runDB $ (,,)
+        <$> deleteWhereCount [UserCompanyCompany ==. cid, UserCompanyUser <-. uids]
+        <*> optRemove (deleteWhereCount [UserSupervisorCompany ==. Just cid, UserSupervisorSupervisor <-. uids])
+        <*> optRemove (deleteWhereCount [UserSupervisorCompany ==. Just cid, UserSupervisorUser       <-. uids])
+      let total = fromIntegral $ length uids
+          allok = bool Warning Success $ total == nrUc
+      addMessageI allok $ someMessages [MsgFirmUserActRemoveResult nrUc, MsgFirmRemoveSupervision nrSuper nrSubs]
+      reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
 
-  formFirmAction <- runFirmActionFormPost cid (FirmUsersR fsh) isAdmin [FirmActNotify, FirmActResetSupervision, FirmActAddSupersvisors, FirmActChangeContactFirm, FirmActChangeContactUser]
+  formFirmAction <- runFirmActionFormPost cid (FirmUsersR fsh) isAdmin [FirmActNotify, FirmActResetSupervision, FirmActAddSupervisors, FirmActChangeContactFirm, FirmActChangeContactUser]
 
   siteLayout (citext2widget companyName) $ do
     setTitle $ toHtml $ CI.original companyShorthand <> "-" <> tshow companyAvsId
@@ -1124,7 +1156,7 @@ data FirmSuperActionData = FirmSuperActNotifyData
                             , firmSuperActSwitchReroute :: Maybe Bool
                             }
                          | FirmSuperActRMSuperDefData
-                            { firmSuperActRMSuperActive :: Maybe Bool }
+                            { firmSuperActRMSuperActive ::       Bool }
 
   deriving (Eq, Ord, Show, Generic)
 
@@ -1140,6 +1172,7 @@ querySuperUserCompany = $(sqlLOJproj 2 2)
 type SuperCompanyTableData = DBRow (Entity User, E.Value Word64, E.Value Word64
                                     , [(E.Value CompanyName, E.Value CompanyShorthand, E.Value Bool)]
                                     , E.Value (Maybe Bool), E.Value (Maybe Bool)   -- Maybe (Entity UserCompany)
+                                    , E.Value Bool
                                     )
 
 resultSuperUser :: Lens' SuperCompanyTableData (Entity User)
@@ -1160,6 +1193,9 @@ resultSuperCompanyDefaultSuper = _dbrOutput . _5 . _unValue
 resultSuperCompanyDefaultReroute :: Lens' SuperCompanyTableData (Maybe Bool)
 resultSuperCompanyDefaultReroute = _dbrOutput . _6 . _unValue
 
+resultSuperCompanySuperior :: Lens' SuperCompanyTableData Bool
+resultSuperCompanySuperior = _dbrOutput . _7 . _unValue
+
 instance HasEntity SuperCompanyTableData User where
   hasEntity = resultSuperUser
 
@@ -1171,27 +1207,31 @@ mkFirmSuperTable :: Bool -> CompanyId -> DB (FormResult (FirmSuperActionData, Se
 mkFirmSuperTable isAdmin cid = do
   msgSupervisorUnchanged <- messageI Info MsgFirmSuperActSwitchSuperInfo
   let
+    reasonSuperior = tshow SupervisorReasonAvsSuperior
     -- fsh = unCompanyKey cid
     resultDBTable = DBTable{..}
       where
         dbtSQLQuery = \(usr `E.LeftOuterJoin` usrCmp) -> do
           EL.on $ usr E.^. UserId E.=?. usrCmp E.?. UserCompanyUser E.&&. usrCmp E.?. UserCompanyCompany E.?=. E.val cid
-          E.where_ $ E.isTrue (usrCmp E.?. UserCompanySupervisor)
-              E.||.  E.exists (firmQuerySupervisedBy cid Nothing usr)
+          E.where_ $  E.isTrue (usrCmp E.?. UserCompanySupervisor) E.||. E.exists (firmQuerySupervisedBy cid Nothing usr)
+          -- let uc_reason = E.joinV (usrCmp E.?. UserCompanyReason)
           return ( usr
                  , usr & firmCountForSupervisor cid Nothing
                  , usr & firmCountForSupervisor cid (Just (E.^. UserSupervisorRerouteNotifications))
                  , usrCmp E.?. UserCompanySupervisor
                  , usrCmp E.?. UserCompanySupervisorReroute
+                 -- , (E.isJust uc_reason E.&&. uc_reason E.==. E.justVal reasonSuperior) -- NOTE: this is problematic, as obvious approaches caused errors such as: Failed to parse Haskell type bool, received PersistNull, since the SQL comparison with NULL returns NULL
+                 , (E.coalesceDefault [E.joinV (usrCmp E.?. UserCompanyReason)] (E.val mempty) E.==. E.val reasonSuperior) -- works as well
+                    E.||. E.exists (firmQuerySupervisedBy cid (Just (\usrSpr -> usrSpr E.^. UserSupervisorReason E.==. E.justVal reasonSuperior)) usr)
                  )
         dbtRowKey = querySuperUser >>> (E.^. UserId)
-        dbtProj = dbtProjSimple $ \(usr, supervised, rerouted, supervisor, reroute) -> do
+        dbtProj = dbtProjSimple $ \(usr, supervised, rerouted, supervisor, reroute, isSuperior) -> do
             cmps <- E.select $ do
               (cmp :& usrCmp) <- E.from $ E.table @Company `E.innerJoin` E.table @UserCompany `E.on` (\(cmp :& usrCmp) -> cmp E.^. CompanyId E.==. usrCmp E.^. UserCompanyCompany)
               E.where_ $ usrCmp E.^. UserCompanyUser E.==. E.val (entityKey usr)
               E.orderBy [E.asc $ cmp E.^. CompanyName]
               return (cmp E.^. CompanyName, cmp E.^. CompanyShorthand, usrCmp E.^. UserCompanySupervisor)
-            return (usr, supervised, rerouted, cmps, supervisor, reroute)
+            return (usr, supervised, rerouted, cmps, supervisor, reroute, isSuperior)
         dbtColonnade = formColonnade $ mconcat
           [ dbSelect (applying _2) id (return . view (resultSuperUser . _entityKey))
           , colUserNameModalHdr MsgTableSupervisor ForProfileDataR
@@ -1203,7 +1243,11 @@ mkFirmSuperTable isAdmin cid = do
           , colUserEmail
           , sortable (Just "supervised")  (i18nCell MsgTableCompanyNrEmpSupervised)  $ \(view resultSuperCompanySupervised -> nr) -> wgtCell $ word2widget nr
           , sortable (Just "rerouted")    (i18nCell MsgTableCompanyNrEmpRerouted  )  $ \(view resultSuperCompanyReroutes   -> nr) -> wgtCell $ word2widget nr
-          , sortable (Just "def-super")   (i18nCell MsgTableIsDefaultSupervisor) $ \(view resultSuperCompanyDefaultSuper   -> mb) -> case mb of { Nothing -> iconCell IconSupervisorForeign; Just True -> iconCell IconSupervisor; Just False -> iconSpacerCell }
+          , sortable (Just "def-super")   (i18nCell MsgTableIsDefaultSupervisor) $ view resultSuperCompanyDefaultSuper >>> \case
+              Nothing      -> iconCell IconSupervisorForeign
+              (Just True ) -> iconCell IconSupervisor
+              (Just False) -> iconSpacerCell
+          , sortable Nothing  (i18nCell MsgTableSuperior) $ view resultSuperCompanySuperior >>> flip ifIconCell IconSuperior
           , sortable (Just "def-reroute") (i18nCell MsgTableIsDefaultReroute)    $ \(view resultSuperCompanyDefaultReroute -> mb) -> tickmarkCell (mb == Just True)
           , sortable Nothing (i18nCell MsgTableUserEdit) $ \(view resultSuperUser -> entUsr) -> cellEditUserModal entUsr
           ]
@@ -1226,20 +1270,40 @@ mkFirmSuperTable isAdmin cid = do
           ]
         dbtFilter = mconcat
           [ single $ fltrUserNameEmail querySuperUser
+          , singletonMap "is-foreign-supervisor" $ FilterColumn $ \(querySuperUserCompany -> suc) (getLast -> criterion) ->
+              case criterion of
+                  Nothing     -> E.true
+                  Just True   -> E.isNothing $ suc E.?. UserCompanyUser
+                  Just False  -> E.isJust    $ suc E.?. UserCompanyUser
+          , singletonMap "super-relation-foreign" $ FilterColumn $ \row (getLast -> criterion) ->
+              let checkSuper = do
+                    usrSpr <- E.from $ E.table @UserSupervisor
+                    E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. querySuperUser row E.^. UserId
+                        E.&&.  E.exists (do
+                                  usr <- E.from $  E.table @UserCompany
+                                  E.where_ $ usr E.^. UserCompanyCompany E.!=. E.val cid
+                                    E.&&.    usr E.^. UserCompanyUser    E.==. usrSpr E.^. UserSupervisorUser
+                                )
+              in case criterion of
+                  Nothing     -> E.true
+                  Just True   -> E.exists    checkSuper
+                  Just False  -> E.notExists checkSuper
           ]
         dbtFilterUI mPrev = mconcat
           [ fltrUserNameEmailHdrUI MsgTableSupervisor mPrev
+          , prismAForm (singletonFilter "is-foreign-supervisor"   . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmSuperForeign)
+          , prismAForm (singletonFilter "super-relation-foreign"  . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterIsForeignSupervisee)
           ]
         dbtStyle =  def { dbsFilterLayout = defaultDBSFilterLayout }
         acts :: Map FirmSuperAction (AForm Handler FirmSuperActionData)
         acts = mconcat
           [ guardMonoid isAdmin $ singletonMap FirmSuperActNotify $ pure FirmSuperActNotifyData
           , singletonMap FirmSuperActSwitchSuper $ FirmSuperActSwitchSuperData
-              <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableIsDefaultSupervisor)  (Just $ Just True)
-              <*> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableIsDefaultReroute)      Nothing
+              <$> aopt boolField' (fslI MsgFirmSuperDefault)  (Just $ Just True)
+              <*> aopt boolField' (fslI MsgTableIsDefaultReroute)      Nothing
               <*  aformMessage msgSupervisorUnchanged
           , singletonMap FirmSuperActRMSuperDef $ FirmSuperActRMSuperDefData
-              <$> aopt checkBoxField (fslI MsgFirmSuperActRMSuperActive) (Just $ Just True)
+              <$> areq boolField' (fslI MsgFirmSuperActRMSuperActive) (Just True)
           ]
         dbtParams = DBParamsForm
           { dbParamsFormMethod = POST
@@ -1283,19 +1347,14 @@ postFirmSupersR fsh = do
   formResult fsprRes $ \case
     (_, uids) | null uids -> addMessageI Error MsgUtilEmptyChoice
     (FirmSuperActRMSuperDefData{..}, Set.toList -> uids) -> do
-      (nrRmSuper,nrRmActual) <- runDB $ (,)
+      let optRemove = if firmSuperActRMSuperActive then id else const $ return 0
+      (nrRmSuper,nrRmSupers,nrRmSubs) <- runDB $ (,,)
         <$> updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False]
-        <*> if firmSuperActRMSuperActive /= Just True
-              then return 0
-              else E.deleteCount $ do
-                spr <- E.from $ E.table @UserSupervisor
-                E.where_ $ spr E.^. UserSupervisorSupervisor `E.in_` E.vals uids
-                    E.&&. E.exists (do
-                      usr <- E.from $ E.table @UserCompany
-                      E.where_ $ usr E.^. UserCompanyCompany E.==. E.val cid
-                          E.&&.  usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser
-                    )
-      addMessageI Info $ MsgRemoveSupervisors nrRmSuper nrRmActual
+        <*> optRemove (deleteWhereCount [UserSupervisorCompany ==. Just cid, UserSupervisorSupervisor <-. uids])
+        <*> optRemove (deleteWhereCount [UserSupervisorCompany ==. Just cid, UserSupervisorUser       <-. uids])
+      let total = fromIntegral $ length uids
+          allok = bool Warning Success $ total == nrRmSuper
+      addMessageI allok $ someMessages [MsgRemoveSupervisors nrRmSuper, MsgFirmRemoveSupervision nrRmSupers nrRmSubs]
       reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
     (FirmSuperActSwitchSuperData{..}, Set.toList -> uids) -> do
       let (fltrSpr, changes) = case (firmSuperActSwitchSuper, firmSuperActSwitchReroute) of
@@ -1313,9 +1372,9 @@ postFirmSupersR fsh = do
       cuids <- traverse encrypt $ Set.toList uids :: Handler [CryptoUUIDUser]
       redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids])
 
-  formFirmAction <- runFirmActionFormPost cid (FirmSupersR fsh) isAdmin [FirmActAddSupersvisors, FirmActResetSupervision, FirmActChangeContactFirm]
+  formFirmAction <- runFirmActionFormPost cid (FirmSupersR fsh) isAdmin [FirmActAddSupervisors, FirmActResetSupervision, FirmActChangeContactFirm]
 
-  siteLayout (citext2widget fsh) $ do
+  siteLayout (citext2widget companyName) $ do
     setTitle $ citext2Html $ fsh <> " Supers"
     let firmContactInfo = $(widgetFile "firm-contact-info")
     $(i18nWidgetFile "firm-supervisors")
@@ -1350,14 +1409,14 @@ handleFirmCommR ultDest cs = do
     csKeys = CompanyKey <$> cs
   mbUser <- maybeAuthId
   -- get employees of chosen companies
-  empys <- mkCompanyUsrList <$> runDB (E.select $ do
+  empys <- mkCompanyUsrList <$> runDBRead (E.select $ do
       (emp :& cmp) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& cmp) -> emp E.^. UserId E.==. cmp E.^. UserCompanyUser)
       E.where_ $ cmp E.^. UserCompanyCompany `E.in_` E.valList csKeys
       E.orderBy [E.ascNullsFirst $ cmp E.^. UserCompanyCompany]
       return (E.just $ cmp E.^. UserCompanyCompany, emp E.^. UserId)
     )
   -- get supervisors of employees
-  sprs <- mkCompanyUsrList <$> runDB (E.select $ do
+  sprs <- mkCompanyUsrList <$> runDBRead (E.select $ do
       (spr :& cmp) <- E.from $ E.table @User `E.leftJoin` E.table @UserCompany `E.on` (\(spr :& cmp) -> spr E.^. UserId E.=?. cmp E.?. UserCompanyUser)
       E.where_ $ (E.isTrue (cmp E.?. UserCompanySupervisor) E.&&. cmp E.?. UserCompanyCompany `E.in_` E.justValList csKeys)
         E.||. (spr E.^. UserId E.=?. E.val mbUser)

src/Handler/Health.hs

@@ -6,6 +6,7 @@ module Handler.Health where
 
 import Import
 
+import Data.Time.Format.ISO8601 (iso8601Show)
 import Handler.Utils.DateTime (formatTimeW)
 
 import qualified Data.Aeson.Encode.Pretty as Aeson
@@ -19,6 +20,9 @@ import Control.Concurrent.STM.Delay
 
 import System.Environment (lookupEnv) -- while git version number is not working
 
+import qualified Database.Esqueleto.Experimental as E
+import qualified Database.Esqueleto.PostgreSQL as E  (now_)
+
 -- import Data.FileEmbed (embedStringFile)
 
 getHealthR :: Handler TypedContent
@@ -77,12 +81,12 @@ getHealthR = do
                       #{boolSymbol (healthOk hcstatus)} #
                       $case report
                         $of HealthLDAPAdmins (Just found)
-                          #{textPercent found 1}  
+                          #{textPercent found 1}
                         $of HealthActiveJobExecutors (Just active)
                           #{textPercent active 1}
                         $of _
                       <div>
-                        ^{formatTimeW SelFormatDateTime lUp}                      
+                        ^{formatTimeW SelFormatDateTime lUp}
           |]
         provideJson healthReports
         provideRep . return . Builder.toLazyText $ Aeson.encodePrettyToTextBuilder healthReports
@@ -113,34 +117,44 @@ getInstanceR = do
 getStatusR :: Handler Html
 getStatusR = do
   starttime <- getsYesod appStartTime
-  (currtime, env_version) <- liftIO $ (,) <$> getCurrentTime <*> lookupEnv "VERSION_NR"
+  dbTime <- runDBRead $ E.selectOne $ return E.now_
+  (currtime,env_version) <- liftIO $ (,) <$> getCurrentTime <*> lookupEnv "VERSION_NR"
   -- ft <- formatTime'  "%Y-%m-%d %H:%M:%S" currtime
-  withUrlRenderer 
+  let diffTime :: UTCTime -> Text
+      diffTime t =
+        let tdiff = diffUTCTime currtime t
+        in if 64 > abs tdiff
+            then tshow tdiff
+            else pack . iso8601Show . calendarTimeTime . fromIntegral $ truncate tdiff
+
+  withUrlRenderer
     [hamlet|
       $doctype 5
       <html lang=en>
-        <head>        
+        <head>
           <title>Status
         <body>
           $maybe env_ver <- env_version
             <p>
               Environment version #{env_ver}
-          <p> 
-            Current Time <br> 
-            #{show currtime} <br>     
           <p>
-            Instance Start <br> 
+            Current Application Time <br>
+            #{show currtime} <br>
+          $maybe dbtval <- dbTime
+            $with dbt <- E.unValue dbtval
+              Current Database Time <br>
+              #{show dbt} #
+              Difference: #{diffTime dbt} <br>
+          <p>
+            Instance Start <br>
             #{show starttime} #
-            Uptime: #{show $ ddays starttime currtime} days.
+            Uptime: #{diffTime starttime}
           <p>
             Compile Time <br>
             #{show cTime} #
-            Build age: #{show $ ddays cTime currtime} days.
+            Build age: #{diffTime cTime}
     |]
-  where 
-    -- vnr_full :: Text = $(embedStringFile "nix/docker/version.json") -- nix/ files not accessible during container construction  
+  where
+    -- vnr_full :: Text = $(embedStringFile "nix/docker/version.json") -- nix/ files not accessible during container construction
     cTime :: UTCTime
-    cTime = $compileTime
-
-    ddays :: UTCTime -> UTCTime -> Double
-    ddays tstart tstop = (/100) $ fromIntegral $ round $ diffUTCTime tstop tstart / (36 * 24)
+    cTime = $compileTime

src/Handler/Health/Interface.hs

@@ -8,12 +8,14 @@ module Handler.Health.Interface
     getHealthInterfaceR
   , mkInterfaceLogTable
   , runInterfaceChecks
+  , getConfigInterfacesR, postConfigInterfacesR
   )
  where
 
 import Import
 
--- import qualified Data.Set as Set
+import qualified Data.Set as Set
+import qualified Data.Map as Map
 import qualified Data.Text as Text
 import Handler.Utils
 import Handler.Utils.Concurrent
@@ -24,6 +26,8 @@ import qualified Database.Esqueleto.Utils as E
 import qualified Database.Esqueleto.Legacy as EL (on)
 import qualified Database.Persist.Sql as E (deleteWhereCount)
 
+defaultInterfaceWarnHours :: Int
+defaultInterfaceWarnHours = 3 * 24      -- if no warn time can be found, use 3 days instead
 
 -- | identify a wildcard argument
 wc2null :: Text -> Maybe Text
@@ -33,6 +37,12 @@ wc2null "_" = Nothing
 wc2null "*" = Nothing
 wc2null  o  = Just o
 
+warnIntervalCell :: (IsDBTable m b, Integral a) => a -> DBCell m b
+warnIntervalCell x
+  | x >= 0      = textCell $ formatDiffHours x
+  | x <= (-100) = i18nCell MsgInterfaceWarningDisabledEntirely
+  | otherwise   = i18nCell MsgInterfaceWarningDisabledInterval
+
 -- | sloppily parse a boolean, also see Model.Types.Avs.SloppyBool
 pbool :: Text -> Maybe Bool
 pbool (Text.toLower . Text.strip -> w)
@@ -88,12 +98,7 @@ getHealthInterfaceR (dropWhile (=="force") -> ris) = do               -- for bac
 
 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
+  (res, twgt) <- runDB $ mkInterfaceLogTable interfs
   let missing = notNull [ifce | (UniqueInterfaceHealth ifce _subt _writ) <- reqIfs, ifce `notElem` (fst <$> res) ]
       allok   = all snd res
   return (missing, allok, res, twgt)
@@ -101,12 +106,14 @@ runInterfaceLogTable interfs@(reqIfs,_) = do
 -- 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
+mkInterfaceLogTable :: ReqBanInterfaceHealth -> DB ([(Text,Bool)], Widget)
+mkInterfaceLogTable interfs@(reqIfs, banIfs) = do
     --   $logWarnS "DEBUG" $ tshow ([ihDebugShow x | x<- reqIfs], [ihDebugShow x | x<- banIfs])
-    void $ liftHandler $ timeoutHandler 42000001 $ runDB $ runInterfaceChecks interfs
+    flagError <- liftHandler $ do
+      void $ timeoutHandler 42000001 $ runDB $ runInterfaceChecks interfs -- ensure interface checkc are up to date
+      mkErrorFlag
     now <- liftIO getCurrentTime
-    dbTableDB ilvalidator DBTable{dbtColonnade=colonnade now, ..}
+    dbTableDB ilvalidator DBTable{dbtColonnade=colonnade now flagError, ..}
   where
     sanitize      = text2AlphaNumPlus ['+','-','_','Ä','Ö','Ü','ß','ä','ö','ü']
     dbtIdent      = "interface-log" :: Text
@@ -115,7 +122,16 @@ mkInterfaceLogTable flagError interfs@(reqIfs, banIfs) = 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  )
-            )
+              E.&&. E.notExists (do -- a more specific match does not exist
+                  otherh <- E.from $ E.table @InterfaceHealth
+                  E.where_ $ ilog    E.^. InterfaceLogInterface E.==.         otherh E.^. InterfaceHealthInterface
+                      E.&&.  ilog    E.^. InterfaceLogSubtype   E.=~.         otherh E.^. InterfaceHealthSubtype
+                      E.&&.  ilog    E.^. InterfaceLogWrite     E.=~.         otherh E.^. InterfaceHealthWrite
+                      E.&&.  ihealth E.?. InterfaceHealthHours  E.!=. E.just (otherh E.^. InterfaceHealthHours)
+                      E.&&.  (E.isNothing (E.joinV $ ihealth E.?. InterfaceHealthSubtype)
+                        E.||. E.isNothing (E.joinV $ ihealth E.?. InterfaceHealthWrite  ))
+                    )
+                )
       let matchUIH crits = E.or
            [ E.and $ catMaybes
              [  ilog E.^. InterfaceLogInterface E.==.    E.val  (sanitize     ifce) & Just
@@ -139,32 +155,34 @@ mkInterfaceLogTable flagError interfs@(reqIfs, banIfs) = do
       -- 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
+      let ihour = E.coalesceDefault [ihealth E.?. InterfaceHealthHours] (E.val defaultInterfaceWarnHours)  -- if no default time is set, use a default 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)
+    queryHealth   :: (E.SqlExpr (Entity InterfaceLog) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity InterfaceHealth))) -> E.SqlExpr (Maybe (Entity InterfaceHealth))
+    queryHealth   = $(E.sqlLOJproj 2 2)
     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
+    colonnade now flagError = 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
+                status  = (success || hours <= -100) && (hours < 0 || now <= addHours hours logtime)
+            in tellCell [(iface,status)] $ wgtCell $ flagError $ toMaybe (success || not status) 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 "hours")     (i18nCell MsgInterfaceFreshness & cellTooltips [SomeMessage MsgInterfaceFreshnessTooltip, SomeMessage MsgTableDiffDaysTooltip]
+                                                                      ) $ warnIntervalCell . 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
@@ -180,6 +198,7 @@ mkInterfaceLogTable flagError interfs@(reqIfs, banIfs) = do
         , singletonMap "time"      $ SortColumn $ queryILog >>> (E.^. InterfaceLogTime)
         , singletonMap "rows"      $ SortColumn $ queryILog >>> (E.^. InterfaceLogRows)
         , singletonMap "success"   $ SortColumn $ queryILog >>> (E.^. InterfaceLogSuccess)
+        , singletonMap "hours"     $ SortColumn $ \r -> E.coalesceDefault [queryHealth r E.?. InterfaceHealthHours] (E.val defaultInterfaceWarnHours)
         ]
     ilvalidator   = def & defaultSorting [SortAscBy "interface", SortAscBy "subtype", SortAscBy "write"]
     dbtFilter     = mempty
@@ -249,3 +268,135 @@ avsInterfaceCheck interfs = maybeRunCheck interfs (UniqueInterfaceHealth "AVS" (
       -- lastOk <- userAvsLastSynch . entityVal <<$>> selectFirst [UserAvsLastSynchError ==. Nothing] [Desc UserAvsLastSynch]
       writeAvsSynchStats Nothing =<< mkBadInfo badRows badTime
     _ -> return ()
+
+
+
+data IWTableAction
+    = IWTActAdd
+    | IWTActDelete
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
+
+instance Universe IWTableAction
+instance Finite   IWTableAction
+nullaryPathPiece ''IWTableAction $ camelToPathPiece' 2
+embedRenderMessage ''UniWorX ''IWTableAction id
+
+data IWTableActionData
+    = IWTActAddData
+        { iwtActInterface :: Text
+        , iwtActSubtype   :: Maybe Text
+        , iwtActWrite     :: Maybe Bool
+        , iwtActHours     :: Int
+        }
+    | IWTActDeleteData
+  deriving (Eq, Ord, Read, Show, Generic)
+
+type IWTableExpr = E.SqlExpr (Entity InterfaceHealth)
+
+queryInterfaceHealth :: IWTableExpr -> E.SqlExpr (Entity InterfaceHealth)
+queryInterfaceHealth = id
+
+type IWTableData = DBRow (Entity InterfaceHealth)
+
+resultInterfaceHealth :: Lens' IWTableData (Entity InterfaceHealth)
+resultInterfaceHealth = _dbrOutput
+
+wildcardCell :: IsDBTable m b => (a -> DBCell m b) -> Maybe a -> DBCell m b
+wildcardCell _ Nothing  = iconFixedCell $ icon IconWildcard
+wildcardCell c (Just x) = c x
+
+mkInterfaceWarnTable :: DB (FormResult (IWTableActionData, Set InterfaceHealthId), Widget)
+mkInterfaceWarnTable = do
+  let
+    mkOption :: E.Value Text -> Option Text
+    mkOption (E.unValue -> t) = Option{ optionDisplay = t, optionInternalValue = t, optionExternalValue = toPathPiece t }
+    getSuggestion pj = E.select $ E.distinct $ do
+      il <- E.from $ E.table @InterfaceLog
+      let res = il E.^. pj
+      E.orderBy [E.asc res]
+      pure res
+    suggestionInterface :: HandlerFor UniWorX (OptionList Text)
+    suggestionInterface = mkOptionList . fmap mkOption <$> runDB (getSuggestion InterfaceLogInterface)
+    suggestionSubtype   :: HandlerFor UniWorX (OptionList Text)
+    suggestionSubtype   = mkOptionList . fmap mkOption <$> runDB (getSuggestion InterfaceLogSubtype)
+    dbtIdent = "interface-warnings" :: Text
+    dbtSQLQuery :: IWTableExpr -> E.SqlQuery IWTableExpr
+    dbtSQLQuery = return
+    dbtRowKey = queryInterfaceHealth >>> (E.^. InterfaceHealthId)
+    dbtProj = dbtProjId
+    dbtColonnade = formColonnade $ mconcat
+      [ dbSelect (applying _2) id (return . view (resultInterfaceHealth . _entityKey))
+      , sortable (Just "interface") (i18nCell MsgInterfaceName      ) $ \(view (resultInterfaceHealth . _entityVal . _interfaceHealthInterface) -> n) -> textCell n
+      , sortable (Just "subtype")   (i18nCell MsgInterfaceSubtype   ) $ wildcardCell textCell . view (resultInterfaceHealth . _entityVal . _interfaceHealthSubtype )
+      , sortable (Just "write")     (i18nCell MsgInterfaceWrite     ) $ wildcardCell (iconFixedCell . iconWriteReadOnly) . view (resultInterfaceHealth . _entityVal . _interfaceHealthWrite   )
+      -- , sortable (Just "hours")     (i18nCell MsgInterfaceFreshness ) $ numCell                               . view (resultInterfaceHealth . _entityVal . _interfaceHealthHours   )
+      , sortable (Just "hours")     (i18nCell MsgInterfaceFreshness
+                              & cellTooltip MsgTableDiffDaysTooltip ) $ warnIntervalCell . view (resultInterfaceHealth . _entityVal . _interfaceHealthHours   )
+      ]
+    dbtSorting = mconcat
+      [ singletonMap "interface" $ SortColumn $ queryInterfaceHealth >>> (E.^. InterfaceHealthInterface)
+      , singletonMap "subtype"   $ SortColumn $ queryInterfaceHealth >>> (E.^. InterfaceHealthSubtype)
+      , singletonMap "write"     $ SortColumn $ queryInterfaceHealth >>> (E.^. InterfaceHealthWrite)
+      , singletonMap "hours"     $ SortColumn $ queryInterfaceHealth >>> (E.^. InterfaceHealthHours)
+      ]
+    dbtFilter     = mempty
+    dbtFilterUI   = mempty
+    dbtStyle      = def { dbsFilterLayout = defaultDBSFilterLayout }
+    dbtParams     = DBParamsForm
+      { dbParamsFormMethod = POST
+      , dbParamsFormAction = Nothing -- Just $ SomeRoute currentRoute
+      , dbParamsFormAttrs  = []
+      , dbParamsFormSubmit = FormSubmit
+      , dbParamsFormAdditional
+          = let acts :: Map IWTableAction (AForm Handler IWTableActionData)
+                acts = mconcat
+                  [ singletonMap IWTActAdd    $      IWTActAddData
+                      <$> apreq (textField & cfStrip & addDatalist suggestionInterface) (fslI MsgInterfaceName)       Nothing
+                      <*> aopt  (textField & cfStrip & addDatalist suggestionSubtype)   (fslI MsgInterfaceSubtype)    Nothing
+                      <*> aopt   boolField'                                             (fslI MsgInterfaceWrite)      Nothing
+                      <*> apreq  intField                                               (fslI MsgInterfaceFreshness & setTooltip MsgHours)  Nothing
+                  , singletonMap IWTActDelete $ pure IWTActDeleteData
+                  ]
+             in renderAForm FormStandard
+               $  (, mempty) . First . Just
+              <$> multiActionA acts (fslI MsgTableAction) Nothing
+      , dbParamsFormEvaluate = liftHandler . runFormPost
+      , dbParamsFormResult   = id
+      , dbParamsFormIdent    = def
+      }
+    dbtCsvEncode  = noCsvEncode
+    dbtCsvDecode  = Nothing
+    dbtExtraReps  = []
+    postprocess :: FormResult (First IWTableActionData, DBFormResult InterfaceHealthId Bool IWTableData)
+                -> FormResult (      IWTableActionData,          Set InterfaceHealthId)
+    postprocess inp = do
+        (First (Just act), jobMap) <- inp
+        let jobSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) jobMap
+        return (act, jobSet)
+    psValidator   = def & defaultSorting [SortAscBy "interface", SortAscBy "subtype", SortAscBy "write"]
+  over _1 postprocess <$> dbTable psValidator DBTable{..}
+
+getConfigInterfacesR,  postConfigInterfacesR :: Handler Html
+getConfigInterfacesR = postConfigInterfacesR
+postConfigInterfacesR = do
+  ((interfaceOks, interfaceTable), (warnRes, configTable)) <- runDB $ (,)
+    <$> mkInterfaceLogTable mempty
+    <*> mkInterfaceWarnTable
+  let interfacesBadNr = length $ filter (not . snd) interfaceOks
+  formResult warnRes $ \case
+    (IWTActAddData{..}, _) -> do
+      void $ runDB $ upsertBy
+        (UniqueInterfaceHealth iwtActInterface iwtActSubtype iwtActWrite)
+        (      InterfaceHealth iwtActInterface iwtActSubtype iwtActWrite iwtActHours)
+        [InterfaceHealthHours =. iwtActHours]
+      addMessageI Success MsgInterfaceWarningAdded
+      reloadKeepGetParams ConfigInterfacesR
+    (IWTActDeleteData, ihids) -> do
+      runDB $ mapM_ delete ihids
+      addMessageI Success $ MsgInterfaceWarningDeleted $ Set.size ihids
+      reloadKeepGetParams ConfigInterfacesR
+
+  siteLayoutMsg MsgConfigInterfacesHeading $ do
+    setTitleI MsgConfigInterfacesHeading
+    let defWarnTime = formatDiffHours defaultInterfaceWarnHours
+    $(i18nWidgetFile "config-interfaces")

src/Handler/LMS.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022-23 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
+-- SPDX-FileCopyrightText: 2022-24 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -19,7 +19,7 @@ module Handler.LMS
   , getLmsFakeR           , postLmsFakeR
   , getLmsUserR
   , getLmsUserSchoolR
-  , getLmsUserAllR     
+  , getLmsUserAllR
   )
   where
 
@@ -81,11 +81,11 @@ postLmsAllR = do
   mbBtnForm <- if not isAdmin then return Nothing else do
     ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm ("buttons" :: Text) (buttonForm :: Form ButtonManualLms)
     case btnResult of
-      (FormSuccess BtnLmsEnqueue) -> 
-        queueJob' JobLmsQualificationsEnqueue 
+      (FormSuccess BtnLmsEnqueue) ->
+        queueJob' JobLmsQualificationsEnqueue
         >> addMessage Info "Einreihung ablaufender Qualifikationen zum LMS wird nun im Hintergund durchgeführt."
-      (FormSuccess BtnLmsDequeue) -> 
-        queueJob' JobLmsQualificationsDequeue 
+      (FormSuccess BtnLmsDequeue) ->
+        queueJob' JobLmsQualificationsDequeue
         >> addMessage Info "Benachrichtigung abgelaufener Qualifikationen und Aufräumen beendeter LMS Nutzer wird im Hintergund ausgeführt."
       FormMissing -> return ()
       _other -> addMessage Warning "Kein korrekter LMS Knopf erkannt"
@@ -112,20 +112,20 @@ resultAllQualificationActive = _dbrOutput . _2 . _unValue
 resultAllQualificationTotal  :: Lens' AllQualificationTableData Word64
 resultAllQualificationTotal  = _dbrOutput . _3 . _unValue
 
-  
+
 mkLmsAllTable :: Bool -> Int -> DB (Any, Widget)
 mkLmsAllTable isAdmin lmsDeletionDays = do
-  svs <- getSupervisees   
+  svs <- getSupervisees
   let
     resultDBTable = DBTable{..}
       where
         dbtSQLQuery quali = do
-          let filterSvs luser = luser Ex.^. LmsUserQualification Ex.==. quali Ex.^. QualificationId                  
+          let filterSvs luser = luser Ex.^. LmsUserQualification Ex.==. quali Ex.^. QualificationId
                          Ex.&&. (E.val isAdmin E.||. luser Ex.^. LmsUserUser `Ex.in_` E.vals svs)
-              cusers = Ex.subSelectCount $ do 
+              cusers = Ex.subSelectCount $ do
                 luser <- Ex.from $ Ex.table @LmsUser
-                Ex.where_ $ filterSvs luser 
-              cactive = Ex.subSelectCount $ do 
+                Ex.where_ $ filterSvs luser
+              cactive = Ex.subSelectCount $ do
                 luser <- Ex.from $ Ex.table @LmsUser
                 Ex.where_ $ filterSvs luser Ex.&&. E.isNothing (luser E.^. LmsUserStatus)
           -- Failed attempt using Join/GroupBy instead of subselect: see branch csv-osis-demo-groupby-problem
@@ -149,21 +149,29 @@ mkLmsAllTable isAdmin lmsDeletionDays = do
           , sortable Nothing (i18nCell MsgQualificationRefreshWithin    & cellTooltips [SomeMessage MsgQualificationRefreshWithinTooltip  , SomeMessage MsgTableDiffDaysTooltip]) $
               foldMap (textCell . formatCalendarDiffDays             ) . view (resultAllQualification . _qualificationRefreshWithin)
           -- , sortable Nothing (i18nCell MsgQualificationRefreshWithin)   $ foldMap textCell . view (resultAllQualification . _qualificationRefreshWithin . to formatCalendarDiffDays) -- does not work, since there is a maybe in between
+          , sortable (Just "qelearning") (i18nCell MsgTableLmsElearning & cellTooltip MsgQualificationElearningStart) $ \row ->
+              let elearnstart = row ^. resultAllQualification . _qualificationElearningStart
+                  reminder    = row ^. resultAllQualification . _qualificationRefreshReminder
+              in tickmarkCell $ elearnstart && isJust reminder
           , sortable Nothing (i18nCell MsgQualificationRefreshReminder  & cellTooltips [SomeMessage MsgQualificationRefreshReminderTooltip, SomeMessage MsgTableDiffDaysTooltip]) $
               foldMap (textCell . formatCalendarDiffDays             ) . view (resultAllQualification . _qualificationRefreshReminder)
           , sortable Nothing (i18nCell MsgQualificationAuditDuration    & cellTooltips [SomeMessage (MsgQualificationAuditDurationTooltip lmsDeletionDays), SomeMessage MsgTableDiffDaysTooltip]) $
               foldMap (textCell . formatCalendarDiffDays . fromMonths) . view (resultAllQualification . _qualificationAuditDuration)
-          , sortable (Just "qelearning") (i18nCell MsgTableLmsElearning & cellTooltip MsgQualificationElearningStart)
-                                                                        $ tickmarkCell . view (resultAllQualification . _qualificationElearningStart)
-          , sortable Nothing (i18nCell MsgTableQualificationIsAvsLicence & cellTooltip MsgTableQualificationIsAvsLicenceTooltip) 
+          , sortable (Just "qel-renew")  (i18nCell MsgTableLmsElearningRenews & cellTooltip MsgQualificationElearningRenew)
+                                                                        $ tickmarkCell . view (resultAllQualification . _qualificationElearningRenews)
+          , sortable (Just "qel-limit")  (i18nCell MsgTableLmsElearningLimit & cellTooltip MsgQualificationElearningLimit)
+                                                                        $ cellMaybe numCell . view (resultAllQualification . _qualificationElearningLimit)
+          , sortable (Just "qel-reuse")  (i18nCell MsgTableQualificationLmsReuses & cellTooltip MsgTableQualificationLmsReusesTooltip)
+                  $ \(view (resultAllQualification . _qualificationLmsReuses) -> reuseQid) -> maybeCell reuseQid qualificationIdShortCell
+          , sortable Nothing (i18nCell MsgTableQualificationIsAvsLicence & cellTooltip MsgTableQualificationIsAvsLicenceTooltip)
                   $ \(view (resultAllQualification . _qualificationAvsLicence) -> licence) -> maybeCell licence $ textCell . T.singleton . licence2char
-          , sortable Nothing (i18nCell MsgTableQualificationSapExport & cellTooltip MsgTableQualificationSapExportTooltip)  
+          , sortable Nothing (i18nCell MsgTableQualificationSapExport & cellTooltip MsgTableQualificationSapExportTooltip)
                   $ \(view (resultAllQualification . _qualificationSapId) -> mbSapId) ->
                       let icn = IconOK -- change icon here, if desired
-                      in case mbSapId of 
+                      in case mbSapId of
                         Nothing               -> mempty
                         Just sapId | isAdmin  -> cellTooltipIcon (Just icn) (text2message sapId) mempty
-                        Just _                -> iconCell icn 
+                        Just _                -> iconCell icn
           , adminable Nothing (i18nCell MsgTableQualificationCountActive & cellTooltip MsgTableQualificationCountActiveTooltip)
                   $ \(view resultAllQualificationActive -> n) -> wgtCell $ word2widget n
           , adminable Nothing (i18nCell MsgTableQualificationCountTotal) $ wgtCell . word2widget . view resultAllQualificationTotal
@@ -175,6 +183,9 @@ mkLmsAllTable isAdmin lmsDeletionDays = do
           , singletonMap "qshort"       $ SortColumn (E.^. QualificationShorthand)
           , singletonMap "qname"        $ SortColumn (E.^. QualificationName)
           , singletonMap "qelearning"   $ SortColumn (E.^. QualificationElearningStart)
+          , singletonMap "qel-renew"    $ SortColumn (E.^. QualificationElearningRenews)
+          , singletonMap "qel-limit"    $ SortColumn (E.^. QualificationElearningLimit)
+          , singletonMap "qel-reuse"    $ SortColumn (E.^. QualificationLmsReuses)
           ]
         dbtFilter = mconcat
           [
@@ -209,7 +220,6 @@ data LmsTableCsv = LmsTableCsv   -- L..T..C.. -> ltc..
   { ltcDisplayName    :: UserDisplayName
   , ltcEmail          :: UserEmail
   , ltcCompany        :: Maybe Text
-  , ltcCompanyNumbers :: CsvSemicolonList Int
   , ltcValidUntil     :: Day
   , ltcLastRefresh    :: Day
   , ltcFirstHeld      :: Day
@@ -231,8 +241,7 @@ ltcExample :: LmsTableCsv
 ltcExample = LmsTableCsv
     { ltcDisplayName    = "Max Mustermann"
     , ltcEmail          = "m.mustermann@example.com"
-    , ltcCompany        = Just "Example Brothers LLC, SecondaryJobs Inc"
-    , ltcCompanyNumbers = CsvSemicolonList [27,69]
+    , ltcCompany        = Just "Example Brothers LLC"
     , ltcValidUntil     = succ compDay
     , ltcLastRefresh    = compDay
     , ltcFirstHeld      = pred $ pred compDay
@@ -274,8 +283,7 @@ instance CsvColumnsExplained LmsTableCsv where
   csvColumnsExplanations = genericCsvColumnsExplanations ltcOptions $ Map.fromList
     [ ('ltcDisplayName    , SomeMessage MsgLmsUser)
     , ('ltcEmail          , SomeMessage MsgTableLmsEmail)
-    , ('ltcCompany        , SomeMessage MsgTableCompanies)
-    , ('ltcCompanyNumbers , SomeMessage MsgTableCompanyNos)
+    , ('ltcCompany        , SomeMessage MsgTablePrimeCompany)
     , ('ltcValidUntil     , SomeMessage MsgLmsQualificationValidUntil)
     , ('ltcLastRefresh    , SomeMessage MsgTableQualificationLastRefresh)
     , ('ltcFirstHeld      , SomeMessage MsgTableQualificationFirstHeld)
@@ -309,7 +317,7 @@ queryQualBlock :: LmsTableExpr -> E.SqlExpr (Maybe (Entity QualificationUserBloc
 queryQualBlock = $(sqlLOJproj 2 2)
 
 
-type LmsTableData = DBRow (Entity QualificationUser, Entity User, Entity LmsUser, Maybe (Entity QualificationUserBlock), E.Value (Maybe [Maybe UTCTime]), [Entity UserCompany], E.Value Bool)
+type LmsTableData = DBRow (Entity QualificationUser, Entity User, Entity LmsUser, Maybe (Entity QualificationUserBlock), E.Value (Maybe [Maybe UTCTime]), E.Value (Maybe CompanyId), E.Value Bool)
 
 resultQualUser :: Lens' LmsTableData (Entity QualificationUser)
 resultQualUser = _dbrOutput . _1
@@ -326,8 +334,8 @@ resultQualBlock = _dbrOutput . _4 . _Just
 resultPrintAck :: Traversal' LmsTableData [Maybe UTCTime]
 resultPrintAck = _dbrOutput . _5 . _unValue . _Just
 
-resultCompanyUser :: Lens' LmsTableData [Entity UserCompany]
-resultCompanyUser = _dbrOutput . _6
+resultCompanyId :: Traversal' LmsTableData CompanyId
+resultCompanyId = _dbrOutput . _6 . _unValue . _Just
 
 resultValidQualification :: Lens' LmsTableData Bool
 resultValidQualification = _dbrOutput . _7 . _unValue
@@ -342,7 +350,7 @@ instance HasEntity LmsTableData QualificationUser where
   hasEntity = resultQualUser
 
 instance HasQualificationUser LmsTableData where
-  hasQualificationUser = resultQualUser . _entityVal  
+  hasQualificationUser = resultQualUser . _entityVal
 
 data LmsTableAction = LmsActNotify
                     | LmsActRenewNotify
@@ -351,7 +359,7 @@ data LmsTableAction = LmsActNotify
                     | LmsActRestart
   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
   deriving anyclass (Universe, Finite)
-  
+
 nullaryPathPiece ''LmsTableAction $ camelToPathPiece' 2
 embedRenderMessage ''UniWorX ''LmsTableAction id
 
@@ -360,12 +368,12 @@ data LmsTableActionData = LmsActNotifyData
                         | LmsActRenewPinData            -- no longer used
                         | LmsActResetData
                             { lmsActRestartExtend  :: Maybe Integer
-                            , lmsActRestartUnblock :: Maybe Bool 
+                            , lmsActRestartUnblock :: Maybe Bool
                             , lmsActRestartNotify  :: Maybe Bool
                             }
-                        | LmsActRestartData  
+                        | LmsActRestartData
                             { lmsActRestartExtend  :: Maybe Integer
-                            , lmsActRestartUnblock :: Maybe Bool 
+                            , lmsActRestartUnblock :: Maybe Bool
                             , lmsActRestartNotify  :: Maybe Bool
                             }
   deriving (Eq, Ord, Read, Show, Generic)
@@ -395,6 +403,7 @@ lmsTableQuery :: UTCTime -> QualificationId -> LmsTableExpr
                 , E.SqlExpr (Entity LmsUser)
                 , E.SqlExpr (Maybe (Entity QualificationUserBlock))
                 , E.SqlExpr (E.Value (Maybe [Maybe UTCTime])) -- outer maybe indicates, whether a printJob exists, inner maybe indicates all acknowledged printJobs
+                , E.SqlExpr (E.Value (Maybe CompanyId))
                 , E.SqlExpr (E.Value Bool)
                 )
 lmsTableQuery now qid (qualUser `E.InnerJoin` user `E.InnerJoin` lmsUser `E.LeftOuterJoin` qualBlock) = do
@@ -407,15 +416,19 @@ lmsTableQuery now qid (qualUser `E.InnerJoin` user `E.InnerJoin` lmsUser `E.Left
     E.on $ user E.^. UserId E.==. lmsUser  E.^. LmsUserUser
             E.&&. E.val qid E.==. lmsUser  E.^. LmsUserQualification            -- NOTE: condition was once erroneously placed in where-clause, which does not work
     E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser
-    E.where_ $    E.val qid E.==. qualUser E.^. QualificationUserQualification        
+    E.where_ $    E.val qid E.==. qualUser E.^. QualificationUserQualification
     -- Letztes Datum anzeigen, wenn mehrere, dann diese in klickbaren Tooltip verstecken!
     let printAcknowledged = E.subSelectMaybe . E.from $ \pj -> do
-                    E.where_ $ E.isJust (pj E.^. PrintJobLmsUser)
-                        E.&&. ((lmsUser E.^. LmsUserIdent) E.=?. (pj E.^. PrintJobLmsUser))
-                    let pjOrder = [E.desc $ pj E.^. PrintJobCreated, E.desc $ pj E.^. PrintJobAcknowledged] -- latest created comes first! This is assumed to be the case later on!
-                    pure $ --(E.arrayAggWith E.AggModeAll (pj E.^. PrintJobCreated     ) pjOrder, -- return two aggregates only works with select, the restricted type of subSelect does not seem to support this!
-                           E.arrayAggWith E.AggModeAll (pj E.^. PrintJobAcknowledged) pjOrder                                                        
-    return (qualUser, user, lmsUser, qualBlock, printAcknowledged, validQualification now qualUser)
+          E.where_ $ E.isJust (pj E.^. PrintJobLmsUser)
+              E.&&. ((lmsUser E.^. LmsUserIdent) E.=?. (pj E.^. PrintJobLmsUser))
+          let pjOrder = [E.desc $ pj E.^. PrintJobCreated, E.desc $ pj E.^. PrintJobAcknowledged] -- latest created comes first! This is assumed to be the case later on!
+          pure $ --(E.arrayAggWith E.AggModeAll (pj E.^. PrintJobCreated     ) pjOrder, -- return two aggregates only works with select, the restricted type of subSelect does not seem to support this!
+                  E.arrayAggWith E.AggModeAll (pj E.^. PrintJobAcknowledged) pjOrder
+        primeComp = E.subSelect . E.from $ \uc -> do
+          E.where_ $ user E.^. UserId E.==. uc E.^. UserCompanyUser
+          E.orderBy [E.desc $ uc E.^. UserCompanyPriority, E.asc $ uc E.^. UserCompanyCompany]
+          return (uc E.^. UserCompanyCompany)
+    return (qualUser, user, lmsUser, qualBlock, printAcknowledged, primeComp, validQualification now qualUser)
 
 
 mkLmsTable :: ( Functor h, ToSortable h
@@ -423,26 +436,27 @@ mkLmsTable :: ( Functor h, ToSortable h
               )
            => Bool
            -> Entity Qualification
-           -> Map LmsTableAction (AForm Handler LmsTableActionData)           
-           -> (Map CompanyId Company -> cols)
+           -> Map LmsTableAction (AForm Handler LmsTableActionData)
+           -> ((CompanyId -> CompanyName) -> cols)
            -> PSValidator (MForm Handler) (FormResult (First LmsTableActionData, DBFormResult UserId Bool LmsTableData))
            -> DB (FormResult (LmsTableActionData, Set UserId), Widget)
 mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
   now <- liftIO getCurrentTime
-  -- lookup all companies 
-  cmpMap <- memcachedBy (Just . Right $ 5 * diffMinute) ("CompanyDictionary"::Text) $ do 
+  -- lookup all companies
+  cmpMap <- memcachedBy (Just . Right $ 15 * diffMinute) ("CompanyDictionary"::Text) $ do
     cmps <- selectList [] [] -- [Asc CompanyShorthand]
     return $ Map.fromList $ fmap (\Entity{..} -> (entityKey, entityVal)) cmps
-  let            
+  let
+    getCompanyName :: CompanyId -> CompanyName
+    getCompanyName cid = maybe (unCompanyKey cid) companyName $ Map.lookup cid cmpMap -- use shorthand in case of impossible failure
+
     csvName = T.replace " " "-" $ ciOriginal (quali ^. _qualificationName)
     dbtIdent :: Text
     dbtIdent = "lms"
     dbtSQLQuery = lmsTableQuery now qid
     dbtRowKey = queryUser >>> (E.^. UserId)
-    dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr, qUsrBlock, printAcks, validQ) -> do
-      cmpUsr <- selectList [UserCompanyUser ==. entityKey usr] [Desc UserCompanyPriority, Asc UserCompanyCompany, LimitTo 1]
-      return (qualUsr, usr, lmsUsr, qUsrBlock, printAcks, cmpUsr, validQ)
-    dbtColonnade = cols cmpMap
+    dbtProj = dbtProjId
+    dbtColonnade = cols getCompanyName
     dbtSorting = mconcat
       [ single $ sortUserNameLink   queryUser
       , single $ sortUserEmail      queryUser
@@ -486,19 +500,19 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
       --   )
       , single ("notified", FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) (E.isJust . (E.^. LmsUserNotified)))
       , single ("avs-number"  , FilterColumn . E.mkExistsFilter $ \row criterion ->
-              E.from $ \usrAvs -> -- do 
+              E.from $ \usrAvs -> -- do
                 E.where_ $ usrAvs E.^. UserAvsUser      E.==. queryUser row E.^. UserId
                     E.&&.  ((E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.==.
                           (E.explicitUnsafeCoerceSqlExprValue "citext" (usrAvs E.^. UserAvsNoPerson) :: E.SqlExpr (E.Value (CI Text))) ))
       , single ("user-company", FilterColumn . E.mkExistsFilter $ \row criterion ->
-              E.from $ \(usrComp `E.InnerJoin` comp) -> do 
+              E.from $ \(usrComp `E.InnerJoin` comp) -> do
                 let testname = (E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf`
                                 (E.explicitUnsafeCoerceSqlExprValue "citext" (comp E.^. CompanyName) :: E.SqlExpr (E.Value (CI Text)))
                     testnumber nr = E.val nr E.==. comp E.^. CompanyAvsId
                     testcrit = maybe testname testnumber $ readMay $ ciOriginal criterion
                 E.on $     usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
                 E.where_ $ usrComp E.^. UserCompanyUser    E.==. queryUser row E.^. UserId E.&&. testcrit
-        )        
+        )
       , fltrAVSCardNos queryUser
       , single ("personal-number", FilterColumn $ \(queryUser -> user) (criteria :: Set.Set Text) -> if
           | Set.null criteria -> E.true
@@ -506,7 +520,7 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
         )
       ]
     dbtFilterUI mPrev = mconcat
-      [ fltrUserNameEmailHdrUI MsgLmsUser mPrev    
+      [ fltrUserNameEmailHdrUI MsgLmsUser mPrev
       , prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany)
       , prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumber)
       , fltrAVSCardNosUI mPrev
@@ -516,7 +530,7 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
       , prismAForm (singletonFilter "notified" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsNotified)
       , prismAForm (singletonFilter "status"  . maybePrism _PathPiece) mPrev $ aopt (hoistField liftHandler (selectField optionsFinite) :: (Field _ (Maybe LmsStatus))) (fslI MsgTableLmsStatus)
       -- , if isNothing mbRenewal then mempty
-      --   else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal)      
+      --   else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal)
       ]
     dbtStyle =  def { dbsFilterLayout = defaultDBSFilterLayout }
     dbtCsvEncode = Just DBTCsvEncode
@@ -533,29 +547,24 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
         doEncode' = LmsTableCsv
           <$>  view    (resultUser     . _entityVal . _userDisplayName)
           <*>  view    (resultUser     . _entityVal . _userDisplayEmail)
-          <*> (view     resultCompanyUser >>= getCompanies)
-          <*> (view     resultCompanyUser >>= getCompanyNos)
-          <*>  view    (resultQualUser . _entityVal . _qualificationUserValidUntil)
-          <*>  view    (resultQualUser . _entityVal . _qualificationUserLastRefresh)
-          <*>  view    (resultQualUser . _entityVal . _qualificationUserFirstHeld)
+          <*>  preview (resultCompanyId . to getCompanyName . _CI)
+          <*>  view    (resultQualUser  . _entityVal . _qualificationUserValidUntil)
+          <*>  view    (resultQualUser  . _entityVal . _qualificationUserLastRefresh)
+          <*>  view    (resultQualUser  . _entityVal . _qualificationUserFirstHeld)
           <*>  preview (resultQualBlock . _entityVal . _qualificationUserBlockUnblock . _not)
           <*>  preview (resultQualBlock . _entityVal . _qualificationUserBlockFrom)
-          <*>  view    (resultLmsUser  . _entityVal . _lmsUserIdent)
-          <*>  view    (resultLmsUser  . _entityVal . _lmsUserStatus)
-          <*>  view    (resultLmsUser  . _entityVal . _lmsUserStatusDay)
-          <*>  view    (resultLmsUser  . _entityVal . _lmsUserStarted)
-          <*>  view    (resultLmsUser  . _entityVal . _lmsUserDatePin)
-          <*>  view    (resultLmsUser  . _entityVal . _lmsUserReceived)
-          <*>  view    (resultLmsUser  . _entityVal . _lmsUserNotified) -- TODO: only exports last email date / print job sending date, not print acknowledge
-          <*>  view    (resultLmsUser  . _entityVal . _lmsUserEnded)
-        getCompanies cmps = case mapMaybe (flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) cmps of 
-          []        -> pure   Nothing
-          somecmps  -> pure $ Just $ intercalate ", " $ fmap (view (_companyName . _CI)) somecmps
-        getCompanyNos = pure . CsvSemicolonList . mapMaybe (preview (_Just . _companyAvsId) . flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany))
-        
+          <*>  view    (resultLmsUser   . _entityVal . _lmsUserIdent)
+          <*>  view    (resultLmsUser   . _entityVal . _lmsUserStatus)
+          <*>  view    (resultLmsUser   . _entityVal . _lmsUserStatusDay)
+          <*>  view    (resultLmsUser   . _entityVal . _lmsUserStarted)
+          <*>  view    (resultLmsUser   . _entityVal . _lmsUserDatePin)
+          <*>  view    (resultLmsUser   . _entityVal . _lmsUserReceived)
+          <*>  view    (resultLmsUser   . _entityVal . _lmsUserNotified) -- TODO: only exports last email date / print job sending date, not print acknowledge
+          <*>  view    (resultLmsUser   . _entityVal . _lmsUserEnded)
+
     dbtCsvDecode = Nothing
     dbtExtraReps = []
-    dbtParams = if not isAdmin then def {dbParamsFormAction = Nothing, dbParamsFormSubmit = FormNoSubmit} else 
+    dbtParams = if not isAdmin then def {dbParamsFormAction = Nothing, dbParamsFormSubmit = FormNoSubmit} else
       DBParamsForm
       { dbParamsFormMethod = POST
       , dbParamsFormAction = Nothing -- Just $ SomeRoute currentRoute
@@ -596,37 +605,34 @@ postLmsR sid qsh = do
   msgResetInfo      <- messageIconI Info    IconNotificationNonactive MsgLmsActResetInfo
   msgRestartWarning <- messageIconI Warning IconWarning               MsgLmsActRestartWarning
 
-  ((lmsRes, lmsTable), Entity qid quali) <- runDB $ do
-    qent <- getBy404 $ SchoolQualificationShort sid qsh
+  ((lmsRes, lmsTable), Entity qid quali, lmsQualiReused) <- runDB $ do
+    qent@Entity{entityVal=Qualification{qualificationLmsReuses = reuseQuali}} <- getBy404 $ SchoolQualificationShort sid qsh
+    lmsQualiReused <- traverseJoin get reuseQuali
     let acts :: Map LmsTableAction (AForm Handler LmsTableActionData)
         acts = mconcat
           [ singletonMap LmsActNotify       $ pure LmsActNotifyData
           , singletonMap LmsActRenewNotify  $ pure LmsActRenewNotifyData
           -- , singletonMap LmsActRenewPin     $ pure LmsActRenewPinData
-          , singletonMap LmsActReset $ LmsActResetData 
-              <$> aopt      intField (fslI MsgLmsActRestartExtend)  Nothing  
+          , singletonMap LmsActReset $ LmsActResetData
+              <$> aopt      intField (fslI MsgLmsActRestartExtend)  Nothing
               <*> aopt checkBoxField (fslI MsgLmsActRestartUnblock) Nothing
-              <*> aopt checkBoxField (fslI MsgLmsActNotify)         Nothing              
+              <*> aopt checkBoxField (fslI MsgLmsActNotify)         Nothing
               <*  aformMessage msgResetInfo
-          , singletonMap LmsActRestart $ LmsActRestartData 
-              <$> aopt      intField (fslI MsgLmsActRestartExtend)  Nothing  
+          , singletonMap LmsActRestart $ LmsActRestartData
+              <$> aopt      intField (fslI MsgLmsActRestartExtend)  Nothing
               <*> aopt checkBoxField (fslI MsgLmsActRestartUnblock) Nothing
               <*> aopt checkBoxField (fslI MsgLmsActNotify)         Nothing
               -- <*> aopt (commentField MsgQualificationActBlockSupervisor) (fslI MsgMessageWarning) Nothing
-              <*  aformMessage msgRestartWarning              
-          ]        
-        colChoices cmpMap = mconcat
+              <*  aformMessage msgRestartWarning
+          ]
+        colChoices getCompanyName = mconcat
           [ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultUser . _entityKey))
           , colUserNameModalHdrAdmin MsgLmsUser AdminUserR
           , colUserEmail
-          , sortable (Just "user-company") (i18nCell MsgTableCompany) $ \( view resultCompanyUser -> cmps) ->
-              let cs =  [ companyCell (unCompanyKey cmpId) cmpName cmpSpr
-                        | Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps
-                        , let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap                        
-                        ]
-              in intercalate spacerCell cs
+          , sortable (Just "user-company") (i18nCell MsgTablePrimeCompany) $ \(preview resultCompanyId -> mcid) ->
+              maybeEmpty mcid $ \cid -> companyCell (unCompanyKey cid) (getCompanyName cid) False
           , colUserMatriclenr isAdmin
-          -- , sortable (Just "validity")      (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser)          
+          -- , sortable (Just "validity")      (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser)
           , sortable (Just "first-held")    (i18nCell MsgTableQualificationFirstHeld)  $ \(   view $ resultQualUser . _entityVal . _qualificationUserFirstHeld   -> d)  -> dayCell d
           , sortable (Just "last-refresh")  (i18nCell MsgTableQualificationLastRefresh)$ \(   view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d)  -> dayCell d
           , sortable (Just "valid-until")   (i18nCell MsgLmsQualificationValidUntil)   $ \(   view $ resultQualUser . _entityVal . _qualificationUserValidUntil  -> d)  -> dayCell d
@@ -653,8 +659,8 @@ postLmsR sid qsh = do
               --   - Letter printed : LmsUserNotified == Just _  && PrintJobId == Just _
               --   - Letter sent    : LmsUserNotified == Just _  && PrintJobId == Just _ && PrintJobAcknowledged == Just _
               let notifyDate      = row ^. resultLmsUser . _entityVal . _lmsUserNotified
-                  lmsident        = row ^. resultLmsUser . _entityVal . _lmsUserIdent                  
-                  recipient       = row ^. hasUser                  
+                  lmsident        = row ^. resultLmsUser . _entityVal . _lmsUserIdent
+                  recipient       = row ^. hasUser
                   letterDates     = row ^? resultPrintAck
                   lastLetterDate  = headDef Nothing =<< letterDates
                   letterSent      = isJust letterDates  && (isNothing lastLetterDate || lastLetterDate >= notifyDate) -- was a letter attempted to send last (not 100% safe, if an email is sent after an unacknowledged letter)
@@ -675,7 +681,7 @@ postLmsR sid qsh = do
                                   $maybe ackdate <- mbackdate
                                     ^{formatTimeW SelFormatDateTime ackdate}
                                   $nothing
-                                    _{MsgPrintJobUnacknowledged}                          
+                                    _{MsgPrintJobUnacknowledged}
                           <p>
                             <a href=@{lprLink}>
                               _{MsgPrintJobs}
@@ -694,31 +700,31 @@ postLmsR sid qsh = do
             i18nLms msg = cell [whamlet|LMS #|] <> i18nCell msg
         psValidator = def & defaultSorting [SortDescBy "started", SortDescBy "status"]
     tbl <- mkLmsTable isAdmin qent acts colChoices psValidator
-    return (tbl, qent)
+    return (tbl, qent, lmsQualiReused)
 
   formResult lmsRes $ \case
     _ | not isAdmin -> addMessageI Error MsgUnauthorized -- only admins can use the form on this page
 
     (action, selectedUsers) | isResetRestartAct action -> do
-      let usersList = Set.toList selectedUsers      
+      let usersList = Set.toList selectedUsers
           numUsers  = Set.size   selectedUsers
           isReset   = isResetAct action
-          actRestartExtend  = action & lmsActRestartExtend  
-          actRestartUnblock = action & lmsActRestartUnblock 
-          actRestartNotify  = action & lmsActRestartNotify  
+          actRestartExtend  = action & lmsActRestartExtend
+          actRestartUnblock = action & lmsActRestartUnblock
+          actRestartNotify  = action & lmsActRestartNotify
 
-      chgUsers <- runDB $ do 
+      chgUsers <- runDB $ do
         when (actRestartUnblock == Just True) $ do
           oks <- qualificationUserBlocking qid usersList True Nothing (Left $ bool "Manueller LMS Neustart" "Manuelle LMS Zurücksetzung" isReset) (fromMaybe True actRestartNotify)
           addMessageI Success $ MsgQualificationStatusUnblock qsh oks numUsers
 
         whenIsJust actRestartExtend $ \extDays -> do
           let cutoff    = addDays extDays nowaday
-          shortUsers <- view (_entityVal . _qualificationUserUser) <<$>> selectList 
+          shortUsers <- view (_entityVal . _qualificationUserUser) <<$>> selectList
             [ QualificationUserQualification ==. qid
-            , QualificationUserUser <-. usersList            
+            , QualificationUserUser <-. usersList
             , QualificationUserValidUntil <. cutoff
-            ] []          
+            ] []
           forM_ shortUsers $ upsertQualificationUser qid now cutoff Nothing "E-Learning Reset"
 
         fromIntegral <$> (if isReset
@@ -727,25 +733,25 @@ postLmsR sid qsh = do
             else deleteWhereCount  [LmsUserQualification ==. qid, LmsUserUser <-. usersList]
           )
 
-      unless isReset $ 
+      unless isReset $
         forM_ selectedUsers $ \uid ->
           queueJob' $ JobLmsEnqueueUser { jQualification = qid, jUser = uid }
 
-      runDB $ forM_ selectedUsers $ \uid -> 
-        audit $ TransactionLmsReset   
-          { transactionQualification   = qid          
+      runDB $ forM_ selectedUsers $ \uid ->
+        audit $ TransactionLmsReset
+          { transactionQualification   = qid
           , transactionLmsUser         = uid
           , transactionLmsReset        = isReset
-          , transactionLmsResetExtend  = actRestartExtend 
+          , transactionLmsResetExtend  = actRestartExtend
           , transactionLmsResetUnblock = actRestartUnblock
-          , transactionLmsResetNotify  = actRestartNotify 
+          , transactionLmsResetNotify  = actRestartNotify
           }
 
       let mStatus  = bool Success Warning $ chgUsers < numUsers
       addMessageI mStatus $ bool MsgLmsActRestartFeedback MsgLmsActResetFeedback isReset chgUsers numUsers
       reloadKeepGetParams $ LmsR sid qsh
 
-    (action, selectedUsers) | isRenewPinAct action || isNotifyAct action -> do      
+    (action, selectedUsers) | isRenewPinAct action || isNotifyAct action -> do
       numExaminees <- runDB $ do
         okUsers <- selectList [ LmsUserQualification  ==. qid                       -- matching qualification
                               , LmsUserEnded          ==. Nothing                   -- not yet deleted
@@ -761,7 +767,7 @@ postLmsR sid qsh = do
         return $ length okUsers
       let numSelected  = length selectedUsers
           diffSelected = numSelected - numExaminees
-          mstat        = bool Success Warning $ diffSelected /= 0 
+          mstat        = bool Success Warning $ diffSelected /= 0
       when (isRenewPinAct action) $ addMessageI mstat   $ MsgLmsPinRenewal       numExaminees
       when (isNotifyAct action)   $ addMessageI mstat   $ MsgLmsNotificationSend numExaminees
       when (diffSelected /= 0)    $ addMessageI Warning $ MsgLmsActionFailed     diffSelected
@@ -791,22 +797,22 @@ getLmsUserR sid qsh = viewLmsUserR (Just sid) (Just qsh)
 viewLmsUserR :: Maybe SchoolId -> Maybe QualificationShorthand -> CryptoUUIDUser -> Handler Html
 viewLmsUserR msid mqsh uuid = do
   uid <- decrypt uuid
-  now <- liftIO getCurrentTime   
-  (user@User{userDisplayName}, quals, qblocks) <- runDB $ do 
+  now <- liftIO getCurrentTime
+  (user@User{userDisplayName}, quals, qblocks) <- runDBRead $ do
     usr <- get404 uid
-    qs  <- Ex.select $ do 
-          (qual :& qualUsr :& lmsUsr) <- 
+    qs  <- Ex.select $ do
+          (qual :& qualUsr :& lmsUsr) <-
             Ex.from $ Ex.table @Qualification
             `Ex.leftJoin` Ex.table @QualificationUser
             `Ex.on` (\(qual :& qualUsr)     -> qualUsr  E.?. QualificationUserUser          E.?=. Ex.val uid
                                         E.&&.  qualUsr  E.?. QualificationUserQualification E.?=. qual Ex.^. QualificationId
-                    ) 
+                    )
             `Ex.leftJoin` Ex.table @LmsUser
             `Ex.on` (\(qual :& _ :& lmsUsr) -> lmsUsr   E.?. LmsUserUser                    E.?=. Ex.val uid
-                                        E.&&.  lmsUsr   E.?. LmsUserQualification           E.?=. qual Ex.^. QualificationId 
+                                        E.&&.  lmsUsr   E.?. LmsUserQualification           E.?=. qual Ex.^. QualificationId
                     )
           Ex.where_ $ E.and $
-            (E.isJust (qualUsr E.?. QualificationUserUser) E.||. E.isJust ( lmsUsr E.?. LmsUserUser)) : catMaybes 
+            (E.isJust (qualUsr E.?. QualificationUserUser) E.||. E.isJust ( lmsUsr E.?. LmsUserUser)) : catMaybes
               [ (qual E.^. QualificationSchool     E.==.) . E.val <$> msid
               , (qual E.^. QualificationShorthand  E.==.) . E.val <$> mqsh
               ]
@@ -816,7 +822,7 @@ viewLmsUserR msid mqsh uuid = do
         <- foldMapM (\(_, mbqu, _, _) -> case mbqu of
               Nothing -> pure mempty
               Just (Entity quid _) -> do
-                blocks <- Ex.select $ do 
+                blocks <- Ex.select $ do
                   (qBlock :& qbUsr) <- Ex.from $ Ex.table @QualificationUserBlock
                     `Ex.leftJoin` Ex.table @User
                     `Ex.on` (\(qBlock :& qbUsr) -> qBlock Ex.^. QualificationUserBlockBlocker Ex.==. qbUsr Ex.?. UserId)
@@ -826,7 +832,7 @@ viewLmsUserR msid mqsh uuid = do
                 return $ Map.singleton quid blocks
             ) qs
     return (usr, qs, Map.filter notNull bs)
-  let heading = [whamlet|_{MsgMenuLmsUser} ^{userWidget user}|]  
+  let heading = [whamlet|_{MsgMenuLmsUser} ^{userWidget user}|]
   siteLayout heading $ do
     setTitle $ toHtml userDisplayName
-    $(widgetFile "lms-user")    
+    $(widgetFile "lms-user")

src/Handler/LMS/Learners.hs

@@ -19,6 +19,7 @@ import Handler.Utils.LMS
 
 import qualified Data.Map as Map
 import qualified Data.Csv as Csv
+import qualified Data.Text as Text
 import qualified Data.Conduit.List as C
 -- import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma
 import qualified Database.Esqueleto.Legacy as E
@@ -38,7 +39,7 @@ lmsUser2csv :: UTCTime -> LmsUser -> LmsUserTableCsv
 lmsUser2csv cutoff lu@LmsUser{..} = LmsUserTableCsv
   { csvLUTident     = lmsUserIdent
   , csvLUTpin       = lmsUserPin
-  , csvLUTresetPin  = LmsBool  lmsUserResetPin          
+  , csvLUTresetPin  = LmsBool  lmsUserResetPin
   , csvLUTdelete    = LmsBool (lmsUserToDelete cutoff lu)
   , csvLUTstaff     = LmsBool (lmsUserStaff lu)
   , csvLUTresetTries= LmsBool (lmsUserToResetTries lu) -- TODO: verify this works as intended!
@@ -92,7 +93,7 @@ instance CsvColumnsExplained LmsUserTableCsv where
 
 mkUserTable :: SchoolId -> QualificationShorthand -> QualificationId -> UTCTime -> DB (Any, Widget)
 mkUserTable _sid qsh qid cutoff = do
-  dbtCsvName <- csvFilenameLmsUser qsh  
+  dbtCsvName <- csvFilenameLmsUser qsh
   let dbtCsvSheetName = dbtCsvName
   let
     userDBTable = DBTable{..}
@@ -166,7 +167,7 @@ getQidCutoff sid qsh = do
 getLmsLearnersR :: SchoolId -> QualificationShorthand -> Handler Html
 getLmsLearnersR sid qsh = do
   lmsTable <- runDB $ do
-    (qid, cutoff) <- getQidCutoff sid qsh    
+    (qid, cutoff) <- getQidCutoff sid qsh
     view _2 <$> mkUserTable sid qsh qid cutoff
   siteLayoutMsg MsgMenuLmsLearners $ do
     setTitleI MsgMenuLmsLearners
@@ -174,14 +175,17 @@ getLmsLearnersR sid qsh = do
 
 getLmsLearnersDirectR :: SchoolId -> QualificationShorthand -> Handler TypedContent
 getLmsLearnersDirectR sid qsh = do
-  $logInfoS "LMS" $ "Direct Download Users for " <> tshow qsh <> " at " <> tshow sid  
-  (lms_users,cutoff) <- runDB $ do
-    (qid, cutoff) <- getQidCutoff sid qsh    
-    lms_users <- selectList [ LmsUserQualification ==. qid
+  $logInfoS "LMS" $ "Direct Download Users for " <> tshow qsh <> " at " <> tshow sid
+  (lms_users,cutoff,qshs) <- runDB $ do
+    (qid, cutoff) <- getQidCutoff sid qsh
+    qidsReuse <- selectList [QualificationLmsReuses ==. Just qid] []
+    let qids = qid : (entityKey <$> qidsReuse)
+        qshs = qsh : (qualificationShorthand . entityVal <$> qidsReuse)
+    lms_users <- selectList [ LmsUserQualification <-. qids
                             , LmsUserEnded ==. Nothing
                             -- , LmsUserReceived ==. Nothing ||. LmsUserResetPin ==. True ||. LmsUserStatus !=. Nothing -- send delta only NOTE: know-how no longer expects delta
-                            ] [Asc LmsUserStarted, Asc LmsUserIdent]    
-    return (lms_users, cutoff)
+                            ] [Asc LmsUserStarted, Asc LmsUserIdent]
+    return (lms_users, cutoff, qshs)
 
     {- To avoid exporting unneeded columns, we would need an SqlSelect instance for LmsUserTableCsv; probably not worth it
       Ex.select $ do
@@ -196,7 +200,7 @@ getLmsLearnersDirectR sid qsh = do
           , csvLUTstaff    = LmsBool False
           }
       -}
-  LmsConf{..} <- getsYesod $ view _appLmsConf  
+  LmsConf{..} <- getsYesod $ view _appLmsConf
   let --csvRenderedData = toNamedRecord . lmsUser2csv . entityVal <$> lms_users
       --csvRenderedHeader = lmsUserTableCsvHeader
       --cvsRendered = CsvRendered {..}
@@ -209,7 +213,7 @@ getLmsLearnersDirectR sid qsh = do
       csvOpts = def { csvFormat = fmtOpts }
   csvSheetName <- csvFilenameLmsUser qsh
   let nr  = length lms_users
-      msg = "Success. LMS user learners download file " <> csvSheetName <> " containing " <> tshow nr <> " rows"
+      msg = "Success. LMS user learners download file " <> csvSheetName <> " containing " <> tshow nr <> " rows for Qualifications " <> Text.intercalate ", " (ciOriginal <$> qshs)
   $logInfoS "LMS" msg
   addHeader "Content-Disposition" $ "attachment; filename=\"" <> csvSheetName <> "\""
   csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered

src/Handler/LMS/Report.hs

@@ -3,6 +3,7 @@
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
 {-# OPTIONS_GHC -fno-warn-orphans #-}      -- needed for HasEntity instances
+{-# LANGUAGE TypeApplications #-}
 
 module Handler.LMS.Report
   ( getLmsReportR, postLmsReportR
@@ -17,10 +18,13 @@ import Handler.Utils
 import Handler.Utils.Csv
 import Handler.Utils.LMS
 
+import qualified Data.Text as Text
 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           Database.Esqueleto.Experimental ((:&)(..))
+import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
+import qualified Database.Esqueleto.PostgreSQL as E
 import qualified Database.Esqueleto.Utils as E
 
 import Jobs.Queue
@@ -121,7 +125,7 @@ mkReportTable sid qsh qid = do
           ]
         dbtFilter = Map.fromList
           [ (csvLmsIdent    , FilterColumn $ E.mkContainsFilterWithCommaPlus LmsIdent (E.^. LmsReportIdent))
-          , (csvLmsDate     , FilterColumn $ E.mkExactFilter                          (E.^. LmsReportDate))          
+          , (csvLmsDate     , FilterColumn $ E.mkExactFilter                          (E.^. LmsReportDate))
           ]
         dbtFilterUI = \mPrev -> mconcat
           [ prismAForm (singletonFilter csvLmsIdent   . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent & setTooltip MsgTableFilterCommaPlus)
@@ -199,7 +203,7 @@ mkReportTable sid qsh qid = do
                   , LmsReportResult           =. lmsReportCsvResult actionData
                   , LmsReportLock             =. lmsReportCsvLock   actionData
                   , LmsReportTimestamp        =. eanow
-                  ]                
+                  ]
             lift . queueDBJob $ JobLmsReports qid
             return $ LmsReportR sid qsh
           , dbtCsvRenderKey           = const $ \case
@@ -246,8 +250,8 @@ postLmsReportR sid qsh = do
 
 -- Direct File Upload/Download
 
-saveReportCsv :: UTCTime -> QualificationId -> Int -> LmsReportTableCsv -> JobDB Int
-saveReportCsv now qid i LmsReportTableCsv{..} = do    
+saveReportCsv :: UTCTime -> NonEmpty QualificationId -> Int -> LmsReportTableCsv -> JobDB Int
+saveReportCsv now (qid :| []) i LmsReportTableCsv{..} = do
     void $ upsert
       LmsReport
         { lmsReportQualification  =  qid
@@ -263,6 +267,30 @@ saveReportCsv now qid i LmsReportTableCsv{..} = do
       , LmsReportTimestamp        =. now
       ]
     return $ succ i
+saveReportCsv now qids@(qid :| _) i lrtc@LmsReportTableCsv{..} = do
+    ok <- E.insertSelectWithConflictCount UniqueLmsReport
+      (do
+        lusr <- E.from $ E.table @LmsUser
+        E.where_ $ lusr E.^. LmsUserIdent         E.==. E.val csvLRident
+            E.&&.  lusr E.^. LmsUserQualification `E.in_` E.vals qids
+        return $ LmsReport
+          E.<#  (lusr E.^. LmsUserQualification)
+          E.<&> E.val  csvLRident
+          E.<&> E.val (csvLRdate <&> lms2timestamp)
+          E.<&> E.val  csvLRresult
+          E.<&> E.val (csvLRlock  & lms2bool)
+          E.<&> E.val  now
+      )
+      (\_old _new ->
+          [ LmsReportDate       E.=. E.val (csvLRdate <&> lms2timestamp)
+          , LmsReportResult     E.=. E.val  csvLRresult
+          , LmsReportLock       E.=. E.val (csvLRlock  & lms2bool)
+          , LmsReportTimestamp  E.=. E.val  now
+          ]
+      )
+    if ok > 0
+      then return $ succ i
+      else saveReportCsv now (qid :| []) i lrtc -- save unknown LmsIdent to primary qid regardless, so that the error can be tracked
 
 makeReportUploadForm :: Form FileInfo
 makeReportUploadForm = renderAForm FormStandard $ fileAFormReq "Report CSV"
@@ -276,15 +304,18 @@ postLmsReportUploadR sid qsh = do
     FormSuccess file -> do
       -- content <- fileSourceByteString file
       -- return $ Just (fileName file, content)
-      (nr, qid) <- runDBJobs $ do
+      (nr, qids, qshs) <- runDBJobs $ do
         qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
+        qidsReuse <- selectList [QualificationLmsReuses ==. Just qid] []
+        let qids = qid :| (entityKey <$> qidsReuse)
+            qshs = qsh :  (qualificationShorthand . entityVal <$> qidsReuse)
         nr <- runConduit $ fileSource file
                 .| decodeCsv
-                .| foldMC (saveReportCsv now qid) 0        
-        return (nr, qid)
-      addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file <> pack (" mit " <> show nr <> " Zeilen")
+                .| foldMC (saveReportCsv now qids) 0
+        return (nr, qids, qshs)
+      addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file <> pack (" mit " <> show nr <> " Zeilen") <> " für Qualifikationen: " <> Text.intercalate ", " (ciOriginal <$> qshs)
       -- redirect $ LmsReportR sid qsh
-      getLmsReportR sid qsh <* queueJob' (JobLmsReports qid) -- show uploaded data before processing
+      getLmsReportR sid qsh <* forM_ qids (queueJob' . JobLmsReports) -- show uploaded data before processing
 
     FormFailure errs -> do
       forM_ errs $ addMessage Error . toHtml
@@ -294,7 +325,7 @@ postLmsReportUploadR sid qsh = do
         setTitleI MsgMenuLmsUpload
         [whamlet|$newline never
           <form method=post enctype=#{enctype}>
-            ^{widget}            
+            ^{widget}
             <input type=submit>
         |]
 
@@ -308,18 +339,21 @@ postLmsReportDirectR sid qsh = do
       lmsDecoder <- getLmsCsvDecoder
       runDBJobs $ do
         qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
+        qidsReuse <- selectList [QualificationLmsReuses ==. Just qid] []
+        let qids = qid :| (entityKey <$> qidsReuse)
+            qshs = qsh :  (qualificationShorthand . entityVal <$> qidsReuse)
         enr <- try $ runConduit $ fileSource file
                 .| lmsDecoder
-                .| foldMC (saveReportCsv now qid) 0
+                .| foldMC (saveReportCsv now qids) 0
         case enr of
           Left (e :: SomeException) -> do -- catch all to avoid ok220 in case of any error
-            $logWarnS "LMS" $ "Report upload failed parsing: " <> tshow e
+            $logWarnS "LMS" $ "Report upload failed parsing: " <> tshow e <> " for Qualification: " <> Text.intercalate ", " (ciOriginal <$> qshs)
             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 <> ".  "
+            let msg = "Success. LMS Report upload file " <> fileName file <> " containing " <> tshow nr <> " rows for " <> fhead <> " and Qualifications: " <> Text.intercalate ", " (ciOriginal <$> qshs)
             $logInfoS "LMS" msg
-            when (nr > 0) $ queueDBJob $ JobLmsReports qid
+            when (nr > 0) $ forM_ qids (queueDBJob . JobLmsReports)
             logInterface "LMS" (ciOriginal qsh) True (Just nr) ""
             return (ok200, msg)
     []     -> do

src/Handler/MailCenter.hs

@@ -0,0 +1,375 @@
+-- SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
+--
+-- SPDX-License-Identifier: AGPL-3.0-or-later
+
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Handler.MailCenter
+  ( getMailCenterR, postMailCenterR
+  , getMailHtmlR
+  , getMailPlainR
+  , getMailAttachmentR
+  ) where
+
+import Import
+
+import qualified Data.Set as Set
+import qualified Data.Map as Map
+-- import qualified Data.Aeson  as Aeson
+-- import qualified Data.Text as Text
+
+-- import Database.Persist.Sql (updateWhereCount)
+-- import           Database.Esqueleto.Experimental ((:&)(..))
+import qualified Database.Esqueleto.Legacy as EL (on) -- only `on` and `from` are different, needed for dbTable using Esqueleto.Legacy
+import qualified Database.Esqueleto.Experimental as E
+import qualified Database.Esqueleto.Utils as E
+import Database.Esqueleto.Utils.TH
+
+import qualified Data.Aeson as Aeson
+
+import Text.Blaze.Html (preEscapedToHtml)
+-- import Text.Blaze.Html5 as H (html, body, pre, p, h1)
+-- import Text.Blaze.Html.Renderer.String (renderHtml)
+
+import Numeric (readHex)
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
+import qualified Data.ByteString as S
+import qualified Data.ByteString.Lazy as LB
+
+
+import Handler.Utils
+
+
+
+-- avoids repetition of local definitions
+single :: (k,a) -> Map k a
+single = uncurry Map.singleton
+
+
+data MCTableAction = MCActDummy -- just a dummy, since we don't now yet which actions we will be needing
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
+
+instance Universe MCTableAction
+instance Finite MCTableAction
+nullaryPathPiece ''MCTableAction $ camelToPathPiece' 2
+embedRenderMessage ''UniWorX ''MCTableAction id
+
+data MCTableActionData  = MCActDummyData
+  deriving (Eq, Ord, Read, Show, Generic)
+
+
+type MCTableExpr =
+  (                   E.SqlExpr (Entity SentMail)
+    `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
+  )
+
+queryMail :: MCTableExpr -> E.SqlExpr (Entity SentMail)
+queryMail = $(sqlLOJproj 2 1)
+
+
+queryRecipient :: MCTableExpr -> E.SqlExpr (Maybe (Entity User))
+queryRecipient = $(sqlLOJproj 2 2)
+
+
+type MCTableData = DBRow (Entity SentMail, Maybe (Entity User))
+
+resultMail :: Lens' MCTableData (Entity SentMail)
+resultMail = _dbrOutput . _1
+
+resultRecipient :: Traversal' MCTableData (Entity User)
+resultRecipient = _dbrOutput . _2 . _Just
+
+
+mkMCTable :: DB (FormResult (MCTableActionData, Set SentMailId), Widget)
+mkMCTable = do
+  let
+    dbtSQLQuery :: MCTableExpr -> E.SqlQuery (E.SqlExpr (Entity SentMail), E.SqlExpr (Maybe (Entity User)))
+    dbtSQLQuery  (mail `E.LeftOuterJoin` recipient) = do
+      EL.on $ mail E.^. SentMailRecipient E.==. recipient E.?. UserId
+      return (mail, recipient)
+    dbtRowKey = queryMail >>> (E.^. SentMailId)
+    dbtProj = dbtProjId
+    dbtColonnade = mconcat
+      [ -- dbSelect (applying _2) id (return . view (resultMail . _entityKey))
+        sortable (Just "sent")      (i18nCell MsgPrintJobCreated)       $ \(   view $ resultMail . _entityVal . _sentMailSentAt -> t) -> dateTimeCell t
+      , sortable (Just "recipient") (i18nCell MsgPrintRecipient)        $ \(preview resultRecipient -> u) -> maybeCell u $ cellHasUserLink AdminUserR
+      , sortable Nothing (i18nCell MsgCommSubject) $ \(view resultMail -> Entity k v) ->
+          let subject = v ^? _sentMailHeaders . _mailHeaders' . _mailHeader' "Subject"
+              linkWgt = maybe (msg2widget MsgUtilEMail) text2widget subject
+          in anchorCellM (MailHtmlR <$> encrypt k) linkWgt
+      -- , sortable Nothing (i18nCell MsgCommContent)    $ \(view $ resultMail . _entityKey -> k) -> anchorCellM (MailHtmlR <$> encrypt k) (text2widget "html")
+      -- , sortable Nothing (i18nCell MsgCommSubject) $ \(preview $ resultMail . _entityVal . _sentMailHeaders . _mailHeaders' . _mailHeader' "Subject" -> h) -> cellMaybe textCell h
+      ]
+    dbtSorting = mconcat
+      [ single ("sent"      , SortColumn $ queryMail >>> (E.^. SentMailSentAt))
+      , single ("recipient" , sortUserNameBareM queryRecipient)
+      ]
+    dbtFilter = mconcat
+      [ single ("sent"      , FilterColumn . E.mkDayFilterTo                        $ views (to queryMail)        (E.^. SentMailSentAt))
+      , single ("recipient" , FilterColumn . E.mkContainsFilterWithCommaPlus Just   $ views (to queryRecipient)   (E.?. UserDisplayName))
+      , single ("subject"   , FilterColumn . E.mkContainsFilterWithCommaPlus id     $ views (to queryMail)        (E.str2text . (E.^. SentMailHeaders)))
+      -- , single ("regex"     , FilterColumn . E.mkRegExFilterWith id                 $ views (to queryMail)        (E.str2text . (E.^. SentMailHeaders)))
+      ]
+    dbtFilterUI mPrev = mconcat
+      [ prismAForm (singletonFilter "sent"      . maybePrism _PathPiece) mPrev $ aopt (hoistField lift  dayField)  (fslI MsgPrintJobCreated)
+      , prismAForm (singletonFilter "recipient" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)  (fslI MsgPrintRecipient & setTooltip MsgTableFilterCommaPlus)
+      , prismAForm (singletonFilter "subject"   . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)  (fslI MsgCommSubject    & setTooltip MsgTableFilterCommaPlusShort)
+      -- , prismAForm (singletonFilter "regex"     . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)  (fslI MsgCommSubject    )
+      ]
+    dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout}
+    dbtIdent :: Text
+    dbtIdent = "sent-mail"
+    dbtCsvEncode = noCsvEncode
+    dbtCsvDecode = Nothing
+    dbtExtraReps = []
+    dbtParams = DBParamsForm
+      { dbParamsFormMethod = POST
+      , dbParamsFormAction = Nothing -- Just $ SomeRoute currentRoute
+      , dbParamsFormAttrs  = []
+      , dbParamsFormSubmit = FormNoSubmit
+      , dbParamsFormAdditional = \_csrf -> return (FormMissing, mempty)
+      -- , dbParamsFormSubmit = FormSubmit
+      -- , dbParamsFormAdditional
+      --     = let acts :: Map MCTableAction (AForm Handler MCTableActionData)
+      --           acts = mconcat
+      --             [ singletonMap MCActDummy $ pure MCActDummyData
+      --             ]
+      --        in renderAForm FormStandard
+      --          $  (, mempty) . First . Just
+      --         <$> multiActionA acts (fslI MsgTableAction) Nothing
+      , dbParamsFormEvaluate = liftHandler . runFormPost
+      , dbParamsFormResult   = id
+      , dbParamsFormIdent    = def
+      }
+    postprocess :: FormResult (First MCTableActionData, DBFormResult SentMailId Bool MCTableData)
+                -> FormResult (      MCTableActionData, Set SentMailId)
+    postprocess inp = do
+        (First (Just act), jobMap) <- inp
+        let jobSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) jobMap
+        return (act, jobSet)
+    psValidator = def & defaultSorting [SortDescBy "sent"]
+  over _1 postprocess <$> dbTable psValidator DBTable{..}
+
+getMailCenterR,  postMailCenterR :: Handler Html
+getMailCenterR = postMailCenterR
+postMailCenterR = do
+  (mcRes, mcTable) <- runDB mkMCTable
+  formResult mcRes $ \case
+    (MCActDummyData, Set.toList -> _smIds) -> do
+      addMessageI Success MsgBoolIrrelevant
+      reloadKeepGetParams MailCenterR
+  siteLayoutMsg MsgMenuMailCenter $ do
+    setTitleI MsgMenuMailCenter
+    $(widgetFile "mail-center")
+
+
+typePDF :: ContentType
+typePDF = "application/pdf"
+
+getMailAttachmentR :: CryptoUUIDSentMail -> Text -> Handler TypedContent
+getMailAttachmentR cusm attdisp = do
+  smid <- decrypt cusm
+  (sm,cn) <- runDBRead $ do
+    sm <- get404 smid
+    cn <- get404 $ sm ^. _sentMailContentRef
+    return (sm,cn)
+  let mcontent = getMailContent (sentMailContentContent cn)
+      getAttm alts = case selectAlternative [typePDF] alts of
+        (Just Part{partContent=PartContent (LB.toStrict -> pc), partDisposition=AttachmentDisposition t}) -- partType=pt,
+          | t == attdisp
+            -> Just pc
+        _ -> Nothing
+      attm = firstJust getAttm mcontent
+  case attm of
+    (Just pc) -> sendByteStringAsFile (T.unpack attdisp) pc $ sm ^. _sentMailSentAt
+    _              -> notFound
+
+getMailHtmlR  :: CryptoUUIDSentMail -> Handler Html
+getMailHtmlR  = handleMailShow (SomeMessages [SomeMessage MsgUtilEMail, SomeMessage MsgMenuMailHtml])  [typeHtml,typePlain]
+
+getMailPlainR :: CryptoUUIDSentMail -> Handler Html
+getMailPlainR = handleMailShow (SomeMessages [SomeMessage MsgUtilEMail, SomeMessage MsgMenuMailPlain]) [typePlain,typeHtml]
+
+handleMailShow :: _ -> [ContentType] -> CryptoUUIDSentMail -> Handler Html
+handleMailShow hdr prefTypes cusm = do
+  smid <- decrypt cusm
+  (sm,cn) <- runDBRead $ do
+    sm <- get404 smid
+    cn <- get404 $ sm ^. _sentMailContentRef
+    return (sm,cn)
+  siteLayout' Nothing $ do
+    setTitleI hdr
+    let mcontent = getMailContent (sentMailContentContent cn)
+        getHeader h = preview (_mailHeader' h) (sm ^. _sentMailHeaders . _mailHeaders')
+        mparts = reorderParts $ mapMaybe (selectAlternative prefTypes) mcontent
+    [whamlet|
+      <section>
+        <dl .deflist>
+          <dt .deflist__dt>
+            _{MsgPrintJobCreated}
+          <dd .deflist__dd>
+            ^{formatTimeW SelFormatDateTime (sm ^. _sentMailSentAt)}
+          $maybe usr <- sm ^. _sentMailRecipient
+            <dt .deflist__dt>
+              _{MsgPrintRecipient}
+            <dd .deflist__dd>
+              ^{userIdWidget usr}
+          $maybe r <- getHeader "To"
+            <dt .deflist__dt>
+              To
+            <dd .deflist__dd>
+              #{decodeEncodedWord r}
+          $maybe r <- getHeader "Cc"
+            <dt .deflist__dt>
+              Cc
+            <dd .deflist__dd>
+              #{decodeEncodedWord r}
+          $maybe r <- getHeader "From"
+            <dt .deflist__dt>
+              From
+            <dd .deflist__dd>
+              #{decodeEncodedWord r}
+          $maybe r <- getHeader "Subject"
+            <dt .deflist__dt>
+              _{MsgCommSubject}
+            <dd .deflist__dd>
+              #{decodeEncodedWord r}
+
+      <section>
+        $forall pt <- mparts
+          ^{part2widget cusm pt}
+    |]
+      -- Include for Debugging:
+      -- <section>
+      --   <h2>Debugging
+      --   <p>
+      --     ^{jsonWidget (sm ^. _sentMailHeaders)}
+      --   <p>
+      --     ^{jsonWidget (sentMailContentContent cn)} -- content fields needs decoding of base64 to make sense here
+
+selectAlternative :: [ContentType] -> Alternatives -> Maybe Part
+selectAlternative (fmap decodeUtf8 -> prefTypes) allAlts = aux prefTypes allAlts
+  where
+    aux ts@(ct:_) (pt:ps)
+      | ct == partType pt = Just pt
+      | otherwise         = aux ts ps
+    aux (_:ts) []         = aux ts allAlts
+    aux []     (pt:_)     = Just pt
+    aux _      []         = Nothing
+
+reorderParts :: [Part] -> [Part]
+reorderParts = sortBy pOrder
+  where
+    pOrder Part{partDisposition=d1} Part{partDisposition=d2} = dispoOrder d1 d2
+
+    dispoOrder DefaultDisposition DefaultDisposition                 = EQ
+    dispoOrder DefaultDisposition _                                  = LT
+    dispoOrder _ DefaultDisposition                                  = GT
+    dispoOrder (InlineDisposition t1) (InlineDisposition t2)         = compare t1 t2
+    dispoOrder (InlineDisposition _) _                               = LT
+    dispoOrder _ (InlineDisposition _)                               = GT
+    dispoOrder (AttachmentDisposition t1) (AttachmentDisposition t2) = compare t1 t2
+
+disposition2widget :: Disposition -> Widget
+disposition2widget (AttachmentDisposition _) = [whamlet|<h3>_{MsgMailFileAttachment}|]
+disposition2widget (InlineDisposition     n) = [whamlet|<h3>_{MsgMenuMailAttachment} #{n}|]
+disposition2widget  DefaultDisposition       = mempty
+
+part2widget :: CryptoUUIDSentMail -> Part -> Widget
+part2widget cusm Part{partContent=NestedParts ps} =
+  [whamlet|
+      $forall p <- ps
+        ^{part2widget cusm p}
+  |]
+part2widget cusm Part{partContent=PartContent (LB.toStrict -> pc), partType=pt, partDisposition=dispo} =
+    [whamlet|
+      <section>
+        ^{disposition2widget dispo}
+        ^{showBody}
+      ^{showPass}
+    |]
+  where
+    showBody
+      | pt == decodeUtf8 typePlain = toWidget $ preEscapedToHtml $ plainTextToHtml $ decodeUtf8 pc
+      | pt == decodeUtf8 typeHtml  = toWidget $ preEscapedToHtml $ plainHtmlToHtml $ decodeUtf8 pc -- preEscapedToHtml :: ToMarkup a => a -> Html
+      | pt == decodeUtf8 typeJson  =
+          let jw :: Aeson.Value -> Widget = jsonWidget
+          in  either str2widget jw $ Aeson.eitherDecodeStrict' pc
+      | pt == decodeUtf8 typePDF
+      , AttachmentDisposition t <- dispo
+        = [whamlet|<a href=@{MailAttachmentR cusm t}>#{t}|]
+      | otherwise = [whamlet|FRADrive cannot decode email parts of type #{pt} yet.|]
+    showPass
+      | pt == decodeUtf8 typePlain
+      , let cw = T.words $ decodeUtf8 pc
+      , Just name <- listBracket ("Inhaber","Gültig") cw                               -- heursitic for dirving licence renewal letters only; improve
+                <|>  listBracket ("Licensee","Valid") cw
+      = let sdn = T.filter (/= '*') (T.unwords $ dropWhile (":"==) name) in
+        liftHandler (runDBRead $ getByFilter [UserDisplayName ==. sdn]) >>= \case
+          Nothing -> mempty -- DEBUG: [whamlet|<h2>Not found: #{sdn}|]
+          Just Entity{entityVal = u@User{userPinPassword=mbpw}} ->
+            [whamlet|
+              <section>
+                $maybe pw <- mbpw
+                  <details>
+                    <summary>
+                      _{MsgAdminUserPinPassword}
+                    <p>
+                      <dl .deflist>
+                        <dt .deflist__dt>
+                          ^{userWidget u}
+                        <dd .deflist__dd>
+                          <b>
+                            #{pw}
+                    <p>
+                      _{MsgAdminUserPinPassNotIncluded}
+                $nothing
+                  _{MsgAdminUserNoPassword}
+            |]
+      | otherwise = mempty
+
+------------------------------
+-- Decode MIME Encoded Word
+
+-- | decode the MIME encoded-word format, which is used in email headers to encode non-ASCII text. This format is specified in RFC 2047.
+decodeEncodedWord :: Text -> Text
+decodeEncodedWord tinp
+  | (pl, T.drop 2 -> cf) <- T.breakOn "=?" tinp
+  , (cw, T.drop 2 -> rm) <- T.breakOn "?=" cf
+  , notNull cw
+    = pl <> decodeEncodedWordHeader cw <> decodeEncodedWord rm
+  | otherwise
+    = tinp
+
+decodeEncodedWordHeader :: Text -> Text
+decodeEncodedWordHeader tinp
+  | [enc, bin, cw] <- T.splitOn "?" tinp
+  , "utf-8" == T.toLower enc
+  , "Q"     == T.toUpper bin      -- Quoted Printable Text
+    = decEncWrdUtf8Q cw
+  -- TODO: add more decoders for other possible encodings here, but "=?utf-8?Q?..?=" is the only one used by Network.Mail.Mime at the moment
+  | otherwise
+    = tinp
+
+decEncWrdUtf8Q :: Text -> Text
+decEncWrdUtf8Q tinp
+  | Right ok <- TE.decodeUtf8' $ decWds tinp
+    = ok
+  | otherwise
+    = tinp
+  where
+    decWds :: Text -> S.ByteString
+    decWds t
+      | (h:tl) <- T.splitOn "=" t
+        = mconcat $ TE.encodeUtf8 h : map deco tl
+      | otherwise
+        = TE.encodeUtf8 t
+
+    deco :: Text -> S.ByteString
+    deco w
+      | (c,r) <- T.splitAt 2 w
+      , [(v,"")] <- readHex $ T.unpack c
+        = S.cons v $ TE.encodeUtf8 r
+      | otherwise
+        = TE.encodeUtf8 w

src/Handler/News.hs

@@ -13,7 +13,7 @@ import Handler.SystemMessage
 
 import qualified Data.Map.Strict as Map
 import qualified Data.Set as Set
-  
+
 import Database.Esqueleto.Utils.TH
 import qualified Database.Esqueleto.Legacy as E
 import qualified Database.Esqueleto.Utils as E
@@ -315,16 +315,16 @@ newsUpcomingExams uid = do
                     | otherwise -> mempty
             ]
           dbtSorting = Map.fromList
-            [ ("demo-both",     SortColumn $ queryCourse &&& queryExam >>> (\(_course,exam)-> exam E.^. ExamName))
-            , ("term",          SortColumn $ queryCourse >>> (E.^. CourseTerm      ))
-            , ("school",        SortColumn $ queryCourse >>> (E.^. CourseSchool    ))
-            , ("course",        SortColumn $ queryCourse >>> (E.^. CourseShorthand ))
-            , ("name",          SortColumn $ queryExam >>> (E.^. ExamName ))
-            , ("time",          SortColumn $ queryExam >>> (E.^. ExamStart ))
-            , ("register-from", SortColumn $ queryExam >>> (E.^. ExamRegisterFrom ))
-            , ("register-to",   SortColumn $ queryExam >>> (E.^. ExamRegisterTo ))
-            , ("visible",       SortColumn $ queryExam >>> (E.^. ExamVisibleFrom ))
-            , ("registered",    SortColumn $ queryExam >>> (\exam ->
+            [ ("demo-both",     SortColumns $ queryCourse &&& queryExam >>> (\(course,exam)-> [SomeExprValue $ course E.^. CourseShorthand, SomeExprValue $ exam E.^. ExamName]))
+            , ("term",          SortColumn  $ queryCourse >>> (E.^. CourseTerm      ))
+            , ("school",        SortColumn  $ queryCourse >>> (E.^. CourseSchool    ))
+            , ("course",        SortColumn  $ queryCourse >>> (E.^. CourseShorthand ))
+            , ("name",          SortColumn  $ queryExam >>> (E.^. ExamName ))
+            , ("time",          SortColumn  $ queryExam >>> (E.^. ExamStart ))
+            , ("register-from", SortColumn  $ queryExam >>> (E.^. ExamRegisterFrom ))
+            , ("register-to",   SortColumn  $ queryExam >>> (E.^. ExamRegisterTo ))
+            , ("visible",       SortColumn  $ queryExam >>> (E.^. ExamVisibleFrom ))
+            , ("registered",    SortColumn  $ queryExam >>> (\exam ->
                 E.exists $ E.from $ \registration -> do
                   E.where_ $ registration E.^. ExamRegistrationUser E.==. E.val uid
                   E.where_ $ registration E.^. ExamRegistrationExam E.==. exam E.^. ExamId

src/Handler/PrintCenter.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
+-- SPDX-FileCopyrightText: 2022-24 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -20,13 +20,12 @@ import qualified Data.Set as Set
 import qualified Data.Map as Map
 
 import Database.Persist.Sql (updateWhereCount)
-import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma
-import qualified Database.Esqueleto.Legacy as E
-import qualified Database.Esqueleto.Utils as E
+import qualified Database.Esqueleto.Experimental  as Ex     -- needs TypeApplications Lang-Pragma
+import qualified Database.Esqueleto.Legacy        as E      -- needed for dbTable using Esqueleto.Legacy
+import qualified Database.Esqueleto.Utils         as E
 import Database.Esqueleto.Utils.TH
 
-import Utils.Print hiding (LetterRenewQualificationF)
-import Utils.Print.RenewQualification
+import Utils.Print
 
 import qualified Data.Aeson  as Aeson
 -- import qualified Data.Text as Text
@@ -57,7 +56,7 @@ data LRQF = LRQF
     } deriving (Eq, Generic)
 
 makeRenewalForm :: Maybe LRQF -> Form LRQF
-makeRenewalForm tmpl = identifyForm FIDLmsLetter . validateForm validateLetterRenewQualificationF $ \html -> do
+makeRenewalForm tmpl = identifyForm FIDLmsLetter . validateForm validateLetterRenewQualification $ \html -> do
   -- now_day <- utctDay <$> liftIO getCurrentTime
   flip (renderAForm FormStandard) html $ LRQF
     <$> areq textField                  (fslI MsgPrintLetterType)              (lrqfLetter    <$> tmpl)
@@ -72,8 +71,8 @@ makeRenewalForm tmpl = identifyForm FIDLmsLetter . validateForm validateLetterRe
   where
     lmsField = convertField LmsIdent getLmsIdent textField
 
-validateLetterRenewQualificationF :: FormValidator LRQF Handler ()
-validateLetterRenewQualificationF = -- do
+validateLetterRenewQualification :: FormValidator LRQF Handler ()
+validateLetterRenewQualification = -- do
   -- LRQF{..} <- State.get
   return ()
 
@@ -95,6 +94,8 @@ lrqf2letter LRQF{..}
           , qualShort     = lrqfQuali ^. _qualificationShorthand . _CI
           , qualSchool    = lrqfQuali ^. _qualificationSchool
           , qualDuration  = lrqfQuali ^. _qualificationValidDuration
+          , qualRenewAuto = lrqfQuali ^. _qualificationElearningRenews
+          , qualELimit    = lrqfQuali ^. _qualificationElearningLimit
           , isReminder    = lrqfReminder
           }
     return (fromMaybe usr rcvr, SomeLetter letter)
@@ -132,11 +133,12 @@ instance Finite PJTableAction
 nullaryPathPiece ''PJTableAction $ camelToPathPiece' 2
 embedRenderMessage ''UniWorX ''PJTableAction id
 
--- Not yet needed, since there is no additional data for now:
 data PJTableActionData  = PJActAcknowledgeData | PJActReprintData { ignoreReroute :: Maybe Bool }
   deriving (Eq, Ord, Read, Show, Generic)
 
+
 type PJTableExpr = (                  E.SqlExpr (Entity PrintJob)
+                    `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
                     `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
                     `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
                     `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity Course))
@@ -144,21 +146,24 @@ type PJTableExpr = (                  E.SqlExpr (Entity PrintJob)
                   )
 
 queryPrintJob :: PJTableExpr -> E.SqlExpr (Entity PrintJob)
-queryPrintJob = $(sqlLOJproj 5 1)
+queryPrintJob = $(sqlLOJproj 6 1)
 
 queryRecipient :: PJTableExpr -> E.SqlExpr (Maybe (Entity User))
-queryRecipient = $(sqlLOJproj 5 2)
+queryRecipient = $(sqlLOJproj 6 2)
+
+queryAffected :: PJTableExpr -> E.SqlExpr (Maybe (Entity User))
+queryAffected = $(sqlLOJproj 6 3)
 
 querySender :: PJTableExpr -> E.SqlExpr (Maybe (Entity User))
-querySender = $(sqlLOJproj 5 3)
+querySender = $(sqlLOJproj 6 4)
 
 queryCourse :: PJTableExpr -> E.SqlExpr (Maybe (Entity Course))
-queryCourse = $(sqlLOJproj 5 4)
+queryCourse = $(sqlLOJproj 6 5)
 
 queryQualification :: PJTableExpr -> E.SqlExpr (Maybe (Entity Qualification))
-queryQualification = $(sqlLOJproj 5 5)
+queryQualification = $(sqlLOJproj 6 6)
 
-type PJTableData = DBRow (Entity PrintJob, Maybe (Entity User), Maybe (Entity User), Maybe (Entity Course), Maybe (Entity Qualification))
+type PJTableData = DBRow (Entity PrintJob, Maybe (Entity User), Maybe (Entity User), Maybe (Entity User), Maybe (Entity Course), Maybe (Entity Qualification))
 
 resultPrintJob :: Lens' PJTableData (Entity PrintJob)
 resultPrintJob = _dbrOutput . _1
@@ -166,30 +171,36 @@ resultPrintJob = _dbrOutput . _1
 resultRecipient :: Traversal' PJTableData (Entity User)
 resultRecipient = _dbrOutput . _2 . _Just
 
+resultAffected :: Traversal' PJTableData (Entity User)
+resultAffected = _dbrOutput . _3 . _Just
+
 resultSender :: Traversal' PJTableData (Entity User)
-resultSender = _dbrOutput . _3 . _Just
+resultSender = _dbrOutput . _4 . _Just
 
 resultCourse :: Traversal' PJTableData (Entity Course)
-resultCourse = _dbrOutput . _4 . _Just
+resultCourse = _dbrOutput . _5 . _Just
 
 resultQualification :: Traversal' PJTableData (Entity Qualification)
-resultQualification = _dbrOutput . _5 . _Just
+resultQualification = _dbrOutput . _6 . _Just
 
 pjTableQuery :: PJTableExpr -> E.SqlQuery
   ( E.SqlExpr (Entity PrintJob)
   , E.SqlExpr (Maybe (Entity User))
   , E.SqlExpr (Maybe (Entity User))
+  , E.SqlExpr (Maybe (Entity User))
   , E.SqlExpr (Maybe (Entity Course))
   , E.SqlExpr (Maybe (Entity Qualification)))
 pjTableQuery (printJob `E.LeftOuterJoin` recipient
+                       `E.LeftOuterJoin` affected
                        `E.LeftOuterJoin` sender
                        `E.LeftOuterJoin` course
                        `E.LeftOuterJoin` quali    ) = do
   E.on $ printJob E.^. PrintJobRecipient      E.==. recipient E.?. UserId
+  E.on $ printJob E.^. PrintJobAffected       E.==. affected  E.?. UserId
   E.on $ printJob E.^. PrintJobSender         E.==. sender    E.?. UserId
   E.on $ printJob E.^. PrintJobCourse         E.==. course    E.?. CourseId
   E.on $ printJob E.^. PrintJobQualification  E.==. quali     E.?. QualificationId
-  return (printJob, recipient, sender, course, quali)
+  return (printJob, recipient, affected, sender, course, quali)
 
 mkPJTable :: DB (FormResult (PJTableActionData, Set PrintJobId), Widget)
 mkPJTable = do
@@ -207,6 +218,7 @@ mkPJTable = do
       , sortable (Just "apcid")        (i18nCell MsgPrintJobApcAcknowledge)$ \(   view $ resultPrintJob . _entityVal . _printJobApcIdent  -> t) -> textCell t
       , sortable (Just "name")         (i18nCell MsgPrintJobName)          $ \(   view $ resultPrintJob . _entityVal . _printJobName      -> n) -> textCell n
       , sortable (Just "recipient")    (i18nCell MsgPrintRecipient)        $ \(preview resultRecipient -> u) -> maybeCell u $ cellHasUserLink AdminUserR
+      , sortable (Just "affected")     (i18nCell MsgPrintAffected)         $ \(preview resultAffected  -> u) -> maybeCell u $ cellHasUserLink AdminUserR
       , sortable (Just "sender")       (i18nCell MsgPrintSender)           $ \(preview resultSender    -> u) -> maybeCell u $ cellHasUserLink AdminUserR
       , sortable (Just "course")       (i18nCell MsgPrintCourse)           $ \(preview $ resultCourse        . _entityVal -> c) -> maybeCell c courseCell
       , sortable (Just "qualification")(i18nCell MsgPrintQualification)    $ \(preview $ resultQualification . _entityVal -> q) -> maybeCell q qualificationCell
@@ -219,6 +231,7 @@ mkPJTable = do
       , single ("acknowledged" , SortColumn $ queryPrintJob      >>> (E.^. PrintJobAcknowledged))
       , single ("apcid"        , SortColumn $ queryPrintJob      >>> (E.^. PrintJobApcIdent))
       , single ("recipient"    , sortUserNameBareM queryRecipient)
+      , single ("affected"     , sortUserNameBareM queryAffected)
       , single ("sender"       , sortUserNameBareM querySender   )
       , single ("course"       , SortColumn $ queryCourse        >>> (E.?. CourseName))
       , single ("qualification", SortColumn $ queryQualification >>> (E.?. QualificationName))
@@ -231,6 +244,7 @@ mkPJTable = do
       , single ("created"      , FilterColumn . E.mkDayFilter                                     $ views (to queryPrintJob)      (E.^. PrintJobCreated))
       --, single ("created"      , FilterColumn . E.mkDayBetweenFilter                            $ views (to queryPrintJob)      (E.^. PrintJobCreated))
       , single ("recipient"    , FilterColumn . E.mkContainsFilterWithCommaPlus Just              $ views (to queryRecipient)     (E.?. UserDisplayName))
+      , single ("affected"     , FilterColumn . E.mkContainsFilterWithCommaPlus Just              $ views (to queryAffected)      (E.?. UserDisplayName))
       , single ("sender"       , FilterColumn . E.mkContainsFilterWithCommaPlus Just              $ views (to querySender)        (E.?. UserDisplayName))
       , single ("course"       , FilterColumn . E.mkContainsFilterWith          (Just . CI.mk)    $ views (to queryCourse)        (E.?. CourseName))
       , single ("qualification", FilterColumn . E.mkContainsFilterWith          (Just . CI.mk)    $ views (to queryQualification) (E.?. QualificationName))
@@ -245,11 +259,12 @@ mkPJTable = do
       --, prismAForm (singletonFilter "created"      . maybePrism _PathPiece) mPrev ((,) <$> aopt (hoistField lift  dayField)                        (fslI MsgPrintJobCreated)
       --                                                                                  <*> aopt (hoistField lift  dayField)                        (fslI MsgPrintJobCreated)
       --                                                                          )
-      , prismAForm (singletonFilter "recipient"    . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)                        (fslI MsgPrintRecipient & setTooltip MsgTableFilterCommaPlus)
-      , prismAForm (singletonFilter "sender"       . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)                        (fslI MsgPrintSender    & setTooltip MsgTableFilterCommaPlus)
+      , prismAForm (singletonFilter "recipient"    . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)                        (fslI MsgPrintRecipient & setTooltip MsgTableFilterCommaPlusShort)
+      , prismAForm (singletonFilter "affected"     . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)                        (fslI MsgPrintAffected  & setTooltip MsgTableFilterCommaPlusShort)
+      , prismAForm (singletonFilter "sender"       . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)                        (fslI MsgPrintSender    & setTooltip MsgTableFilterCommaPlusShort)
       , prismAForm (singletonFilter "course"       . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)                        (fslI MsgPrintCourse)
       , prismAForm (singletonFilter "qualification". maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)                        (fslI MsgPrintQualification)
-      , prismAForm (singletonFilter "lmsid"        . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)                        (fslI MsgPrintLmsUser & setTooltip MsgTableFilterCommaPlus)
+      , prismAForm (singletonFilter "lmsid"        . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)                        (fslI MsgPrintLmsUser & setTooltip MsgTableFilterCommaPlusShort)
       , prismAForm (singletonFilter "apcid"        . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)                        (fslI MsgPrintJobApcAcknowledge & setTooltip MsgTableFilterComma)
       , prismAForm (singletonFilter "acknowledged" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgPrintJobAcknowledged)
       ]

src/Handler/Profile.hs

@@ -7,22 +7,19 @@
 module Handler.Profile
   ( getProfileR, postProfileR
   , getForProfileR, postForProfileR
-  , getProfileDataR, makeProfileData  
+  , getProfileDataR, makeProfileData
   , getForProfileDataR
   , getAuthPredsR, postAuthPredsR
   , getUserNotificationR, postUserNotificationR
   , getSetDisplayEmailR, postSetDisplayEmailR
   , getCsvOptionsR, postCsvOptionsR
   , postLangR
-  , getAdminUserSyncAvsR
-  , getAdminUserSyncLdapR
   ) where
 
 import Import
 
 import Handler.Utils
 import Handler.Utils.AvsUpdate
-import Handler.Utils.Avs
 import Handler.Utils.Profile
 import Handler.Utils.Users
 import Handler.Utils.Company
@@ -34,9 +31,12 @@ import Utils.Print (validCmdArgument)
 import Data.Map ((!))
 import qualified Data.Map as Map
 import qualified Data.Set as Set
-import qualified Database.Esqueleto.Legacy as E
+import           Database.Esqueleto.Experimental ((:&)(..))
+import qualified Database.Esqueleto.Experimental as E
+import qualified Database.Esqueleto.Legacy as EL (on,from)
 import qualified Database.Esqueleto.Utils as E
--- import           Database.Esqueleto      ((^.))
+import qualified Database.Esqueleto.PostgreSQL as E
+
 import qualified Data.Text as Text
 import Data.List (inits)
 
@@ -47,6 +47,9 @@ import Jobs
 import Foundation.Yesod.Auth (updateUserLanguage)
 
 
+{-# ANN module ("HLint: ignore Functor law" :: String) #-}
+
+
 data ExamOfficeSettings
   = ExamOfficeSettings
     { eosettingsGetSynced :: Bool
@@ -73,11 +76,11 @@ data SettingsForm = SettingsForm
       , stgDownloadFiles        :: Bool
       , stgWarningDays          :: NominalDiffTime
       , stgShowSex              :: Bool
-      
+
       , stgPinPassword          :: Maybe Text
       , stgPrefersPostal        :: Bool
       , stgPostAddress          :: Maybe StoredMarkup
-      
+
       , stgTelephone            :: Maybe Text
       , stgMobile               :: Maybe Text
 
@@ -116,10 +119,11 @@ instance RenderMessage UniWorX NotificationTriggerKind where
 makeSettingForm :: Maybe SettingsForm -> Form SettingsForm
 makeSettingForm template html = do
     MsgRenderer mr <- getMsgRenderer
+    -- isAdmin <- checkAdmin
     (result, widget) <- flip (renderAForm FormStandard) html $ SettingsForm
         <$  aformSection MsgFormPersonalAppearance
-        <*> areq (textField & cfStrip) (fslI MsgUserDisplayName & setTooltip MsgUserDisplayNameRulesBelow) (stgDisplayName <$> template)
-        <*> areq (emailField & cfStrip & cfCI) (fslI MsgUserDisplayEmail & setTooltip MsgUserDisplayEmailTip) (stgDisplayEmail <$> template)
+        <*> areq (textField & cfStrip) (fslI MsgUserDisplayName & setTooltip MsgUserDisplayNameRulesBelow)   (stgDisplayName  <$> template)
+        <*> areq (textField & cfStrip & cfCI) (fslI MsgUserDisplayEmail & setTooltip MsgUserDisplayEmailTip) (stgDisplayEmail <$> template)
         <*  aformSection MsgFormCosmetics
         <*> areq (natFieldI MsgFavouritesNotNatural)
             (fslpI MsgFavourites (mr MsgFavouritesPlaceholder) & setTooltip MsgFavouritesTip) (stgMaxFavourites <$> template)
@@ -145,9 +149,9 @@ makeSettingForm template html = do
         <*> aopt  htmlField             (fslI MsgPostAddress      & setTooltip MsgPostAddressTip) (stgPostAddress   <$> template)
 
         <*> aopt  (textField & cfStrip) (fslI MsgUserTelephone) (stgTelephone <$> template)
-        <*> aopt  (textField & cfStrip) (fslI MsgUserMobile   ) (stgMobile    <$> template)      
+        <*> aopt  (textField & cfStrip) (fslI MsgUserMobile   ) (stgMobile    <$> template)
 
-        <*> examOfficeForm (stgExamOfficeSettings <$> template)        
+        <*> examOfficeForm (stgExamOfficeSettings <$> template)
         <*> schoolsForm (stgSchools <$> template)
         <*> notificationForm (stgNotificationSettings <$> template)
     return (result, widget) -- no validation here, done later by validateSettings
@@ -159,7 +163,7 @@ schoolsForm template = formToAForm $ schoolsFormView =<< renderWForm FormStandar
   where
     schoolsForm' :: WForm Handler (FormResult (Set SchoolId))
     schoolsForm' = do
-      allSchools <- liftHandler . runDB $ selectList [] [Asc SchoolName]
+      allSchools <- liftHandler . runDBRead $ selectList [] [Asc SchoolName]
 
       let
         schoolForm (Entity ssh School{schoolName})
@@ -194,28 +198,28 @@ notificationForm template = wFormToAForm $ do
         -> return False
       NTKCourseParticipant
         | Just uid <- mbUid
-          -> fmap not . E.selectExists . E.from $ \courseParticipant ->
+          -> fmap not . E.selectExists . EL.from $ \courseParticipant ->
                E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val uid
                     E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
       NTKSubmissionUser
         | Just uid <- mbUid
-          -> fmap not . E.selectExists . E.from $ \submissionUser ->
+          -> fmap not . E.selectExists . EL.from $ \submissionUser ->
                E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val uid
       NTKExamParticipant
         | Just uid <- mbUid
-          -> fmap not . E.selectExists . E.from $ \examRegistration ->
+          -> fmap not . E.selectExists . EL.from $ \examRegistration ->
                E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val uid
       NTKCorrector
         | Just uid <- mbUid
-          -> fmap not . E.selectExists . E.from $ \sheetCorrector ->
+          -> fmap not . E.selectExists . EL.from $ \sheetCorrector ->
                E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val uid
       NTKCourseLecturer
         | Just uid <- mbUid
-          -> fmap not . E.selectExists . E.from $ \lecturer ->
+          -> fmap not . E.selectExists . EL.from $ \lecturer ->
                E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid
       NTKFunctionary f
         | Just uid <- mbUid
-          -> fmap not . E.selectExists . E.from $ \userFunction ->
+          -> fmap not . E.selectExists . EL.from $ \userFunction ->
                E.where_ $ userFunction E.^. UserFunctionUser E.==. E.val uid
                     E.&&. userFunction E.^. UserFunctionFunction E.==. E.val f
       _ | Nothing <- mbUid -> return False -- Show everything for not-logged-in users (e.g. if they presented a token)
@@ -229,7 +233,7 @@ notificationForm template = wFormToAForm $ do
   let
     ntfs nt = fslI nt & case nt of
       _other -> id
-    
+
     nsForm nt
       | maybe False ntHidden $ ntSection nt
       = pure $ notificationAllowed def nt
@@ -300,7 +304,7 @@ examOfficeForm template = wFormToAForm $ do
               | otherwise
               -> FormSuccess $ Map.singleton kStart (Left nLabel)
           return (addRes', $(widgetFile "profile/exam-office-labels/add"))
-        
+
         miCell :: ListPosition
                -> Either ExamOfficeLabelName ExamOfficeLabelId
                -> Maybe EOLabelData
@@ -369,11 +373,13 @@ validateSettings User{..} = do
   userDisplayName' <- use _stgDisplayName
   guardValidation MsgUserDisplayNameInvalid $
     userDisplayName == userDisplayName' ||  -- unchanged or valid (invalid displayNames delivered by LDAP are preserved)
-    validDisplayName userTitle userFirstName userSurname userDisplayName'    
+    validDisplayName userTitle userFirstName userSurname userDisplayName'
 
   userDisplayEmail' <- use _stgDisplayEmail
   guardValidation (MsgInvalidEmailAddressWith $ CI.original userDisplayEmail') $
-    validEmail' userDisplayEmail'
+    validEmail' userDisplayEmail'         || -- valid
+    userDisplayEmail' == userDisplayEmail || -- unchanged
+    userDisplayEmail' == userEmail           -- euqal to default, which is then ignored
 
   userPostAddress'  <- use _stgPostAddress
   let postalNotSet  = isNothing userPostAddress' -- TODO $ canonical userPostAddress'
@@ -415,7 +421,7 @@ nullaryPathPiece ''ProfileAnchor $ camelToPathPiece' 1
 
 getForProfileR , postForProfileR :: CryptoUUIDUser -> Handler Html
 getForProfileR = postForProfileR
-postForProfileR cID = do 
+postForProfileR cID = do
   uid <- decrypt cID
   user <- runDB $ get404 uid
   serveProfileR (uid, user)
@@ -428,8 +434,8 @@ serveProfileR :: (UserId, User) -> Handler Html
 serveProfileR (uid, user@User{..}) = do
   currentRoute <- fromMaybe ProfileR <$> getCurrentRoute
   (userSchools, userExamOfficeLabels) <- runDB $ do
-    userSchools <- fmap (setOf $ folded . _Value) . E.select . E.from $ \school -> do
-      E.where_ . E.exists . E.from $ \userSchool ->
+    userSchools <- fmap (setOf $ folded . _Value) . E.select . EL.from $ \school -> do
+      E.where_ . E.exists . EL.from $ \userSchool ->
         E.where_ $ E.not_ (userSchool E.^. UserSchoolIsOptOut)
              E.&&. userSchool E.^. UserSchoolUser E.==. E.val uid
              E.&&. userSchool E.^. UserSchoolSchool E.==. school E.^. SchoolId
@@ -438,7 +444,7 @@ serveProfileR (uid, user@User{..}) = do
     return (userSchools, userExamOfficeLabels)
   let settingsTemplate = Just SettingsForm
         { stgDisplayName          = userDisplayName
-        , stgDisplayEmail         = userDisplayEmail
+        , stgDisplayEmail         = if userDisplayEmail == "" then userEmail else userDisplayEmail
         , stgMaxFavourites        = userMaxFavourites
         , stgMaxFavouriteTerms    = userMaxFavouriteTerms
         , stgTheme                = userTheme
@@ -452,7 +458,7 @@ serveProfileR (uid, user@User{..}) = do
         , stgShowSex              = userShowSex
         , stgPinPassword          = userPinPassword
         , stgPostAddress          = userPostAddress
-        , stgPrefersPostal        = userPrefersPostal  
+        , stgPrefersPostal        = userPrefersPostal
         , stgTelephone            = userTelephone
         , stgMobile               = userMobile
         , stgExamOfficeSettings   = ExamOfficeSettings
@@ -467,11 +473,12 @@ serveProfileR (uid, user@User{..}) = do
     now <- liftIO getCurrentTime
     isAdmin <- checkAdmin
     thisUser <- fromMaybe uid <$> maybeAuthId
-    let changeEmailByUser = userDisplayEmail /= stgDisplayEmail && (not isAdmin || thisUser == uid)
+    let changeEmailByUser = not isAdmin || thisUser == uid
+        changeEmailProper = userDisplayEmail /= stgDisplayEmail && userEmail /= stgDisplayEmail
     runDBJobs $ do
       update uid $
-        [ UserDisplayEmail         =. stgDisplayEmail   | not changeEmailByUser                 ] ++ -- DisplayEmail changes by Users must be confirmed, see 480 below
-        [ UserPostLastUpdate       =. Just now          | userPostAddress   /= stgPostAddress   ] ++
+        [ UserDisplayEmail         =. stgDisplayEmail   | not changeEmailByUser, changeEmailProper ] ++ -- DisplayEmail changes by Users must be confirmed, see 480 below
+        [ UserPostLastUpdate       =. Just now          | userPostAddress /= stgPostAddress ] ++
         [ UserDisplayName          =. stgDisplayName
         , UserMaxFavourites        =. stgMaxFavourites
         , UserMaxFavouriteTerms    =. stgMaxFavouriteTerms
@@ -492,7 +499,7 @@ serveProfileR (uid, user@User{..}) = do
         , UserExamOfficeGetLabels  =. (stgExamOfficeSettings & eosettingsGetLabels)
         ]
       updateFavourites Nothing
-      when changeEmailByUser $ do
+      when (changeEmailByUser && changeEmailProper) $ do
         queueDBJob $ JobChangeUserDisplayEmail uid stgDisplayEmail
         addMessageI Info $ MsgUserDisplayEmailChangeSent stgDisplayEmail
       let
@@ -518,8 +525,8 @@ serveProfileR (uid, user@User{..}) = do
         oldExamLabels = userExamOfficeLabels
         newExamLabels = stgExamOfficeSettings & eosettingsLabels
       forM_ oldExamLabels $ \(Entity eolid ExamOfficeLabel{..}) -> unless (Right eolid `Map.member` newExamLabels || Left examOfficeLabelName `Map.member` newExamLabels) $ do
-        E.delete . E.from $ \examOfficeExternalExamLabel -> E.where_ $ examOfficeExternalExamLabel E.^. ExamOfficeExternalExamLabelLabel E.==. E.val eolid
-        E.delete . E.from $ \examOfficeExamLabel         -> E.where_ $ examOfficeExamLabel         E.^. ExamOfficeExamLabelLabel         E.==. E.val eolid
+        E.delete . EL.from $ \examOfficeExternalExamLabel -> E.where_ $ examOfficeExternalExamLabel E.^. ExamOfficeExternalExamLabelLabel E.==. E.val eolid
+        E.delete . EL.from $ \examOfficeExamLabel         -> E.where_ $ examOfficeExamLabel         E.^. ExamOfficeExamLabelLabel         E.==. E.val eolid
         when (csvExportLabel userCsvOptions == Just examOfficeLabelName) $
           update uid [ UserCsvOptions =. userCsvOptions { csvExportLabel = Nothing } ]
         delete eolid
@@ -583,67 +590,122 @@ getProfileDataR = do
 getForProfileDataR :: CryptoUUIDUser -> Handler Html
 getForProfileDataR cID = do
   uid <- decrypt cID
-  (user,dataWidget) <- runDB $ bind2 (get404 uid) $ makeProfileData . Entity uid    
+  (user,dataWidget) <- runDB $ bind2 (get404 uid) $ makeProfileData . Entity uid
   defaultLayout $ do
     setTitleI $ MsgHeadingForProfileData $ userDisplayName user
     dataWidget
 
+-- data TableHasData = TableHasData{tableHasRows :: Bool, tableWidget :: Widget}
+-- a poor man's record subsitute
+
+{-
+type TableHasData = (Bool, Widget)
+tableHasRows :: TableHasData -> Bool
+tableHasRows = fst
+tableWidget :: TableHasData -> Widget
+tableWidget  = snd
+-}
+
+-- | Given a header message, a bool and widget; display widget and header only if the boolean is true
+maybeTable :: (RenderMessage UniWorX a)
+           => a -> (Bool, Widget) -> Widget
+maybeTable m = maybeTable' m Nothing Nothing
+
+maybeTable' :: (RenderMessage UniWorX a)
+           => a -> Maybe a -> Maybe Widget -> (Bool, Widget) -> Widget
+maybeTable' _   Nothing       _ (False, _ ) = mempty
+maybeTable' _   (Just nodata) _ (False, _ ) =
+  [whamlet|
+    <div .container>
+      _{nodata}
+  |]
+maybeTable' hdr _ mbRemark      (True ,tbl) =
+  [whamlet|
+    <div .container>
+      <h2> _{hdr}
+      <div .container>
+        ^{tbl}
+        $maybe remark <- mbRemark
+          <em>_{MsgProfileRemark}
+          \ ^{remark}
+  |]
+
+
 makeProfileData :: Entity User -> DB Widget
 makeProfileData usrEnt@(Entity uid usrVal@User{..}) = do
-  now <- liftIO getCurrentTime 
+  now <- liftIO getCurrentTime
   avsId <- entityVal <<$>> getBy (UniqueUserAvsUser uid)
   let usrAutomatic :: CU_UserAvs_User -> Widget
       usrAutomatic = updateAutomatic . mayUpdate usrVal avsId . mkCheckUpdate
-
+  addressLinkdIcon <- messageTooltip <$> messageIconI Info IconLink MsgAddressIsLinkedTip
   (actualPrefersPostal, (actualPostAddress, postalAutomatic), (actualDisplayEmail, emailAutomatic)) <- getPostalPreferenceAndAddress' usrEnt
   functions <- Map.fromListWith Set.union . map (\(Entity _ UserFunction{..}) -> (userFunctionFunction, Set.singleton userFunctionSchool)) <$> selectList [UserFunctionUser ==. uid] []
-  lecture_corrector <- E.select $ E.distinct $ E.from $ \(sheet `E.InnerJoin` corrector `E.InnerJoin` course) -> do
-      E.on $ sheet E.^. SheetCourse E.==. course    E.^. CourseId
-      E.on $ sheet E.^. SheetId     E.==. corrector E.^. SheetCorrectorSheet
+  lecture_corrector <- E.select $ E.distinct $ EL.from $ \(sheet `E.InnerJoin` corrector `E.InnerJoin` course) -> do
+      EL.on $ sheet E.^. SheetCourse E.==. course    E.^. CourseId
+      EL.on $ sheet E.^. SheetId     E.==. corrector E.^. SheetCorrectorSheet
       E.where_ $ corrector E.^. SheetCorrectorUser E.==. E.val uid
       return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand)
-  studies <- E.select $ E.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do      
-      E.on $ studyfeat E.^. StudyFeaturesField    E.==. studyterms  E.^. StudyTermsId
-      E.on $ studyfeat E.^. StudyFeaturesDegree   E.==. studydegree E.^. StudyDegreeId
+  studies <- E.select $ EL.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do
+      EL.on $ studyfeat E.^. StudyFeaturesField    E.==. studyterms  E.^. StudyTermsId
+      EL.on $ studyfeat E.^. StudyFeaturesDegree   E.==. studydegree E.^. StudyDegreeId
       E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid
       return  (studyfeat, studydegree, studyterms)
   companies <- wgtCompanies uid
-  supervisors' <- E.select $ E.from $ \(spvr `E.InnerJoin` usrSpvr) -> do
-      E.on $ spvr E.^. UserSupervisorSupervisor E.==. usrSpvr E.^. UserId
-      E.where_ $ spvr E.^. UserSupervisorUser E.==. E.val uid      
-      E.orderBy [E.asc (usrSpvr E.^. UserDisplayName)]
-      return (usrSpvr, spvr E.^. UserSupervisorRerouteNotifications)
-  let numSupervisors = length supervisors'
-      supervisors = intersperse (text2widget ", ") $ 
-        (\(usr, E.Value reroutCom) -> linkUserWidget ForProfileDataR usr <> bool mempty icnReroute reroutCom) <$> supervisors'
-      icnReroute = text2widget " " <> toWgt (icon IconLetter)
-  supervisees' <- E.select $ E.from $ \(spvr `E.InnerJoin` usrSpvr) -> do
-      E.on $ spvr E.^. UserSupervisorUser E.==. usrSpvr E.^. UserId
-      E.where_ $ spvr E.^. UserSupervisorSupervisor E.==. E.val uid      
-      return (usrSpvr, spvr E.^. UserSupervisorRerouteNotifications)
-  let numSupervisees = length supervisees'
-      supervisees = intersperse (text2widget ", ") $ 
-        (\(usr, E.Value reroutCom) -> linkUserWidget ForProfileDataR usr <> bool mempty icnReroute reroutCom) <$> supervisees'
-      -- icnReroute = text2widget " " <> toWgt (icon IconLetter)
+  -- supervisors' <- E.select $ EL.from $ \(spvr `E.InnerJoin` usrSpvr) -> do
+  --     EL.on $ spvr E.^. UserSupervisorSupervisor E.==. usrSpvr E.^. UserId
+  --     E.where_ $ spvr E.^. UserSupervisorUser E.==. E.val uid
+  --     E.orderBy [E.asc (usrSpvr E.^. UserDisplayName)]
+  --     return (usrSpvr, spvr E.^. UserSupervisorRerouteNotifications)
+  -- let numSupervisors = length supervisors'
+  --     supervisors = intersperse (text2widget ", ") $
+  --       (\(usr, E.Value reroutCom) -> linkUserWidget ForProfileDataR usr <> bool mempty icnReroute reroutCom) <$> supervisors'
+  --     icnReroute = text2widget " " <> toWgt (icon IconReroute)
+  -- supervisees' <- E.select $ EL.from $ \(spvr `E.InnerJoin` usrSpvr) -> do
+  --     EL.on $ spvr E.^. UserSupervisorUser E.==. usrSpvr E.^. UserId
+  --     E.where_ $ spvr E.^. UserSupervisorSupervisor E.==. E.val uid
+  --     return (usrSpvr, spvr E.^. UserSupervisorRerouteNotifications)
+  -- let numSupervisees = length supervisees'
+  --     supervisees = intersperse (text2widget ", ") $
+  --       (\(usr, E.Value reroutCom) -> linkUserWidget ForProfileDataR usr <> bool mempty icnReroute reroutCom) <$> supervisees'
+  --     -- icnReroute = text2widget " " <> toWgt (icon IconReroute)
   --Tables
-  (hasRowsOwnedCourses, ownedCoursesTable) <- mkOwnedCoursesTable uid -- Tabelle mit eigenen Kursen
+  ownedCoursesTable    <- mkOwnedCoursesTable         uid -- Tabelle mit eigenen Kursen
   enrolledCoursesTable <- mkEnrolledCoursesTable      uid -- Tabelle mit allen Teilnehmer: Kurs (link), Datum
   submissionTable      <- mkSubmissionTable           uid -- Tabelle mit allen Abgaben und Abgabe-Gruppen
   submissionGroupTable <- mkSubmissionGroupTable      uid -- Tabelle mit allen Abgabegruppen
   correctionsTable     <- mkCorrectionsTable          uid -- Tabelle mit allen Korrektor-Aufgaben
   qualificationsTable  <- mkQualificationsTable  now  uid -- Tabelle mit allen Qualifikationen
   supervisorsTable     <- mkSupervisorsTable          uid -- Tabelle mit allen Supervisors
-  superviseesTable     <- mkSuperviseesTable          uid -- Tabelle mit allen Supervisees
-  let examTable, ownTutorialTable, tutorialTable :: Widget
-      examTable        = i18n MsgPersonalInfoExamAchievementsWip
-      ownTutorialTable = i18n MsgPersonalInfoOwnTutorialsWip
-      tutorialTable    = i18n MsgPersonalInfoTutorialsWip
+  superviseesTable     <- mkSuperviseesTable actualPrefersPostal uid -- Tabelle mit allen Supervisees
+  countUnderlings <- E.select $ do
+    spr <- E.from $ E.table @UserSupervisor
+    E.where_ $ spr E.^. UserSupervisorSupervisor E.==. E.val uid
+    return (E.countRows, E.count (spr E.^. UserSupervisorId) `E.filterWhere` (spr E.^. UserSupervisorRerouteNotifications))
+  countSupervisors <- E.select $ do
+    spr <- E.from $ E.table @UserSupervisor
+    E.where_ $ spr E.^. UserSupervisorUser E.==. E.val uid
+    return (E.countRows, E.count (spr E.^. UserSupervisorId) `E.filterWhere` (spr E.^. UserSupervisorRerouteNotifications))
+  let errorCount ((E.Value x, E.Value y):_) = (x,y)
+      errorCount _ = (-1,-1)
+      supervisorsWgt :: Widget =
+        let (nrSupers, nrSupersReroute) = errorCount countSupervisors
+        in  maybeTable' (MsgProfileSupervisor nrSupers nrSupersReroute) (Just MsgProfileNoSupervisor)
+                        (toMaybe (nrSupersReroute > 0) $ msg2widget $ MsgProfileSupervisorRemark nrSupers nrSupersReroute 0) (nrSupers > 0, supervisorsTable)
+      superviseesWgt :: Widget =
+        let (nrUnderlings, nrUndersReroute) = errorCount countUnderlings
+        in maybeTable' (MsgProfileSupervisee nrUnderlings nrUndersReroute) (Just MsgProfileNoSupervisee)
+                       (toMaybe (nrUndersReroute > 0) $ msg2widget $ MsgProfileSuperviseeRemark nrUnderlings nrUndersReroute) (nrUnderlings > 0, superviseesTable)
+  -- let examTable, ownTutorialTable, tutorialTable :: Widget
+  --     examTable        = i18n MsgPersonalInfoExamAchievementsWip
+  --     ownTutorialTable = i18n MsgPersonalInfoOwnTutorialsWip
+  --     tutorialTable    = i18n MsgPersonalInfoTutorialsWip -- note that tutorials are linked in enrolledCoursesTable
 
   cID <- encrypt uid
   mCRoute <- getCurrentRoute
-  showAdminInfo <- pure (mCRoute == Just (AdminUserR cID)) `or2M` hasReadAccessTo (AdminUserR cID)  
-  tooltipAvsPersNo <- messageI Info MsgAvsPersonNoNotId
-  tooltipInvalidEmail <- messageI Error MsgInvalidEmailAddress  
+  showAdminInfo <- pure (mCRoute == Just (AdminUserR cID)) `or2M` hasReadAccessTo (AdminUserR cID)
+  tooltipAvsPersNo        <- messageI Info  MsgAvsPersonNoNotId
+  tooltipAvsPersNoDiffers <- messageI Error MsgAvsPersonNoDiffers
+  tooltipInvalidEmail     <- messageI Error MsgInvalidEmailAddress
   let profileRemarks = $(i18nWidgetFile "profile-remarks")
   return $(widgetFile "profileData")
 
@@ -660,7 +722,7 @@ mkOwnedCoursesTable =
       withType = id
 
       dbtSQLQuery' uid (course `E.InnerJoin` lecturer) = do
-          E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
+          EL.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
           E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid
           return ( course E.^. CourseTerm
                  , course E.^. CourseSchool
@@ -701,26 +763,36 @@ mkOwnedCoursesTable =
 
 
 -- | Table listing all courses that the given user is enrolled in
-mkEnrolledCoursesTable :: UserId -> DB Widget
-mkEnrolledCoursesTable =
-  let withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a)
+mkEnrolledCoursesTable :: UserId -> DB (Bool, Widget)
+mkEnrolledCoursesTable uid = do
+  usrTuts <- E.select $ do
+    (tpar :& tut) <- E.from $ E.table @TutorialParticipant `E.innerJoin` E.table @Tutorial
+                      `E.on` (\(tpar :& tut) -> tut E.^. TutorialId E.==. tpar E.^. TutorialParticipantTutorial)
+    E.where_ $ tpar E.^. TutorialParticipantUser E.==. E.val uid
+    E.orderBy [E.asc $ tut E.^. TutorialCourse, E.desc $ tut E.^. TutorialName] -- Data.Map.fromAscListWith reverses tutorials, hence E.desc
+    return (tut E.^. TutorialCourse, tut E.^. TutorialName)
+
+  let usrTutMap :: Map CourseId [TutorialName]
+      usrTutMap = Map.fromAscListWith (++) [(tcid, [tnm]) | (E.Value tcid, E.Value tnm) <- usrTuts]
+
+      withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a)
                -> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a)
       withType = id
 
       validator = def & defaultSorting [SortDescBy "time"]
 
-  in \uid -> dbTableWidget' validator
+  (_1 %~ getAny) <$> dbTableWidget validator
     DBTable
       { dbtIdent     = "courseMembership" :: Text
       , dbtSQLQuery  = \(course `E.InnerJoin` participant) -> do
-          E.on $ course E.^. CourseId E.==. participant E.^. CourseParticipantCourse
+          EL.on $ course E.^. CourseId E.==. participant E.^. CourseParticipantCourse
           E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid
                E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
           return (course, participant E.^. CourseParticipantRegistration)
       , dbtRowKey = \(course `E.InnerJoin` _) -> course E.^. CourseId
       , dbtProj      = dbtProjId <&> _dbrOutput . _2 %~ E.unValue
       , dbtColonnade = mconcat
-          [ sortable (Just "term") (i18nCell MsgTableTerm) $
+          [ sortable (Just "term") (i18nCell MsgTableTerm) $ fmap addIndicatorCell
               termCell   <$> view (_dbrOutput . _1 . _entityVal . _courseTerm)
           , sortable (Just "school") (i18nCell MsgTableCourseSchool) . magnify (_dbrOutput . _1 . _entityVal) $
               schoolCell <$> view _courseTerm
@@ -730,7 +802,14 @@ mkEnrolledCoursesTable =
           , sortable (Just "time") (i18nCell MsgProfileRegistered) $ do
               regTime <- view $ _dbrOutput . _2
               return $ dateTimeCell regTime
-            ]
+          , sortable Nothing (i18nCell MsgCourseTutorials) $ \(view $ _dbrOutput . _1 -> Entity{entityKey=cid, entityVal=Course{..}}) ->
+              cell [whamlet|
+                <ul .list--iconless>
+                  $forall tutName <- maybeMonoid (Map.lookup cid usrTutMap)
+                    <li>
+                      ^{simpleLink (citext2widget tutName) (CTutorialR courseTerm courseSchool courseShorthand tutName TUsersR)}
+              |]
+          ]
       , dbtSorting   = Map.fromList
           [ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseName  )
           , ( "term"  , SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseTerm  )
@@ -753,7 +832,7 @@ mkEnrolledCoursesTable =
 
 
 -- | Table listing all submissions for the given user
-mkSubmissionTable :: UserId -> DB Widget
+mkSubmissionTable :: UserId -> DB (Bool, Widget)
 mkSubmissionTable =
   let dbtIdent = "submissions" :: Text
       dbtStyle = def
@@ -763,9 +842,9 @@ mkSubmissionTable =
       withType = id
 
       dbtSQLQuery' uid (course `E.InnerJoin` sheet `E.InnerJoin` submission `E.InnerJoin` subUser) = do
-        E.on $ submission E.^. SubmissionId E.==. subUser E.^. SubmissionUserSubmission
-        E.on $ sheet  E.^. SheetId  E.==. submission E.^. SubmissionSheet
-        E.on $ course E.^. CourseId E.==. sheet      E.^. SheetCourse
+        EL.on $ submission E.^. SubmissionId E.==. subUser E.^. SubmissionUserSubmission
+        EL.on $ sheet  E.^. SheetId  E.==. submission E.^. SubmissionSheet
+        EL.on $ course E.^. CourseId E.==. sheet      E.^. SheetCourse
         E.where_ $ subUser E.^. SubmissionUserUser E.==. E.val uid
         let crse = ( course E.^. CourseTerm
                    , course E.^. CourseSchool
@@ -776,7 +855,7 @@ mkSubmissionTable =
       dbtRowKey (_ `E.InnerJoin` _ `E.InnerJoin` submission `E.InnerJoin` _) = submission E.^. SubmissionId
 
       lastSubEdit uid submission = -- latest Edit-Time of this user for submission
-        E.subSelectMaybe . E.from $ \subEdit -> do
+        E.subSelectMaybe . EL.from $ \subEdit -> do
           E.where_ $ subEdit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId
               E.&&.  subEdit E.^. SubmissionEditUser E.==. E.val (Just uid)
           return . E.max_ $ subEdit E.^. SubmissionEditTime
@@ -787,7 +866,7 @@ mkSubmissionTable =
         <&> _dbrOutput . _4 %~ E.unValue
 
       dbtColonnade = mconcat
-        [ sortable (Just "term") (i18nCell MsgTableTerm) $
+        [ sortable (Just "term") (i18nCell MsgTableTerm) $ fmap addIndicatorCell
             termCell    <$> view (_dbrOutput . _1 . _1)
         , sortable (Just "school") (i18nCell MsgTableCourseSchool) . magnify (_dbrOutput . _1 ) $
             schoolCell  <$> view  _1
@@ -831,14 +910,10 @@ mkSubmissionTable =
       dbtExtraReps = []
   in \uid ->  let dbtSQLQuery = dbtSQLQuery' uid
                   dbtSorting  = dbtSorting'  uid
-              in  dbTableWidget' validator DBTable{..}
---   in do dbtSQLQuery <- dbtSQLQuery'
---         dbtSorting  <- dbtSorting'
---         return $ dbTableWidget' validator $ DBTable {..}
-
+              in   (_1 %~ getAny) <$> dbTableWidget validator DBTable{..}
 
 -- | Table listing all submissions for the given user
-mkSubmissionGroupTable :: UserId -> DB Widget
+mkSubmissionGroupTable :: UserId -> DB (Bool, Widget)
 mkSubmissionGroupTable =
   let dbtIdent = "subGroups" :: Text
       dbtStyle = def
@@ -847,8 +922,8 @@ mkSubmissionGroupTable =
       withType = id
 
       dbtSQLQuery' uid (course `E.InnerJoin` sgroup `E.InnerJoin` sguser) = do
-        E.on $ sguser E.^. SubmissionGroupUserSubmissionGroup E.==. sgroup E.^. SubmissionGroupId
-        E.on $ sgroup E.^. SubmissionGroupCourse              E.==. course E.^. CourseId
+        EL.on $ sguser E.^. SubmissionGroupUserSubmissionGroup E.==. sgroup E.^. SubmissionGroupId
+        EL.on $ sgroup E.^. SubmissionGroupCourse              E.==. course E.^. CourseId
         E.where_ $ sguser E.^. SubmissionGroupUserUser E.==. E.val uid
         let crse =  ( course E.^. CourseTerm
                     , course E.^. CourseSchool
@@ -861,7 +936,7 @@ mkSubmissionGroupTable =
         <&> _dbrOutput . _1 %~ $(E.unValueN 3)
 
       dbtColonnade = mconcat
-        [ sortable (Just "term") (i18nCell MsgTableTerm) $
+        [ sortable (Just "term") (i18nCell MsgTableTerm) $ fmap addIndicatorCell
             termCell    <$> view (_dbrOutput . _1 . _1)
         , sortable (Just "school") (i18nCell MsgTableCourseSchool) . magnify (_dbrOutput . _1 ) $
             schoolCell  <$> view _1
@@ -890,10 +965,10 @@ mkSubmissionGroupTable =
       dbtCsvDecode = Nothing
       dbtExtraReps = []
   in \uid ->  let dbtSQLQuery = dbtSQLQuery' uid
-              in  dbTableWidget' validator DBTable{..}
+              in  (_1 %~ getAny) <$> dbTableWidget validator DBTable{..}
 
 
-mkCorrectionsTable :: UserId -> DB Widget
+mkCorrectionsTable :: UserId -> DB (Bool, Widget)
 mkCorrectionsTable =
   let dbtIdent = "corrections" :: Text
       dbtStyle = def
@@ -901,18 +976,18 @@ mkCorrectionsTable =
               ->  ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity SheetCorrector))->a)
       withType = id
 
-      corrsAssigned uid sheet = E.subSelectCount . E.from $ \submission ->
+      corrsAssigned uid sheet = E.subSelectCount . EL.from $ \submission ->
           E.where_ $ submission E.^. SubmissionSheet    E.==. sheet E.^. SheetId
               E.&&.  submission E.^. SubmissionRatingBy E.==. E.just (E.val uid)
 
-      corrsCorrected uid sheet = E.subSelectCount . E.from $ \submission ->
+      corrsCorrected uid sheet = E.subSelectCount . EL.from $ \submission ->
           E.where_ $ submission E.^. SubmissionSheet    E.==. sheet E.^. SheetId
                E.&&. submission E.^. SubmissionRatingBy E.==. E.just (E.val uid)
                E.&&. E.not_ (E.isNothing $ submission E.^. SubmissionRatingTime)
 
       dbtSQLQuery' uid (course `E.InnerJoin` sheet `E.InnerJoin` corrector) = do
-        E.on $ sheet E.^. SheetId     E.==. corrector E.^. SheetCorrectorSheet
-        E.on $ sheet E.^. SheetCourse E.==. course    E.^. CourseId
+        EL.on $ sheet E.^. SheetId     E.==. corrector E.^. SheetCorrectorSheet
+        EL.on $ sheet E.^. SheetCourse E.==. course    E.^. CourseId
         E.where_ $ corrector E.^. SheetCorrectorUser E.==. E.val uid
         let crse =  ( course E.^. CourseTerm
                     , course E.^. CourseSchool
@@ -926,7 +1001,7 @@ mkCorrectionsTable =
         <&> _dbrOutput . _2 %~ E.unValue
 
       dbtColonnade = mconcat
-        [ sortable (Just "term") (i18nCell MsgTableTerm) $
+        [ sortable (Just "term") (i18nCell MsgTableTerm) $ fmap addIndicatorCell
             termCellCL   <$> view (_dbrOutput . _1)
         , sortable (Just "school") (i18nCell MsgTableCourseSchool) $
             schoolCellCL <$> view (_dbrOutput . _1)
@@ -963,7 +1038,7 @@ mkCorrectionsTable =
       dbtCsvDecode = Nothing
       dbtExtraReps = []
   in \uid ->  let dbtSQLQuery = dbtSQLQuery' uid
-              in  dbTableWidget' validator DBTable{..}
+              in  (_1 %~ getAny) <$> dbTableWidget validator DBTable{..}
 
 
 -- | Table listing all qualifications that the given user is enrolled in
@@ -977,29 +1052,29 @@ mkQualificationsTable =
     DBTable
       { dbtIdent     = "userQualifications" :: Text
       , dbtSQLQuery  = \(quali `E.InnerJoin` quser `E.LeftOuterJoin` qblock) -> do
-          E.on $ quser E.^. QualificationUserId             E.=?. qblock E.?. QualificationUserBlockQualificationUser
+          EL.on $ quser E.^. QualificationUserId             E.=?. qblock E.?. QualificationUserBlockQualificationUser
             E.&&.  qblock `isLatestBlockBefore` E.val now
-          E.on $ quser E.^. QualificationUserQualification  E.==. quali  E.^. QualificationId
-          E.where_ $ quser E.^. QualificationUserUser E.==. E.val uid  
+          EL.on $ quser E.^. QualificationUserQualification  E.==. quali  E.^. QualificationId
+          E.where_ $ quser E.^. QualificationUserUser E.==. E.val uid
           return (quali, quser, qblock)
       , dbtRowKey = \(_quali `E.InnerJoin` quser `E.LeftOuterJoin` _qblock) -> quser E.^. QualificationUserId
-      , dbtProj      = dbtProjId 
+      , dbtProj      = dbtProjId
       , dbtColonnade = mconcat
           [ colSchool (_dbrOutput . _1 . _entityVal . _qualificationSchool)
-          , sortable (Just "quali")         (i18nCell MsgQualificationName)             $ qualificationDescrCell         <$> view (_dbrOutput . _1 . _entityVal)
-          , sortable (Just "first-held")    (i18nCell MsgTableQualificationFirstHeld)   $ dayCell                   <$> view (_dbrOutput . _2 . _entityVal . _qualificationUserFirstHeld  )          
+          , sortable (Just "quali")         (i18nCell MsgQualificationName)             $ qualificationDescrCell    <$> view (_dbrOutput . _1 . _entityVal)
+          , sortable (Just "first-held")    (i18nCell MsgTableQualificationFirstHeld)   $ dayCell                   <$> view (_dbrOutput . _2 . _entityVal . _qualificationUserFirstHeld  )
           , sortable (Just "last-refresh")  (i18nCell MsgTableQualificationLastRefresh) $ dayCell                   <$> view (_dbrOutput . _2 . _entityVal . _qualificationUserLastRefresh)
           , sortable (Just "valid-until")   (i18nCell MsgLmsQualificationValidUntil)    $ dayCell                   <$> view (_dbrOutput . _2 . _entityVal . _qualificationUserValidUntil )
           , sortable (Just "blocked")       (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltipSimple) $ \row ->
-              qualificationValidReasonCell False (utctDay now) (row ^? _dbrOutput . _3 . _Just . _entityVal) (row ^. _dbrOutput . _2 . _entityVal)                                                                                             
+              qualificationValidReasonCell False (utctDay now) (row ^? _dbrOutput . _3 . _Just . _entityVal) (row ^. _dbrOutput . _2 . _entityVal)
           ]
       , dbtSorting   = mconcat
           [ sortSchool $ to (\(quali `E.InnerJoin` _ `E.LeftOuterJoin` _) -> quali E.^. QualificationSchool)
-          , singletonMap "quali"        $ SortColumn $ withType $ \(quali `E.InnerJoin` _ `E.LeftOuterJoin`  _) -> quali  E.^. QualificationName  
+          , singletonMap "quali"        $ SortColumn $ withType $ \(quali `E.InnerJoin` _ `E.LeftOuterJoin`  _) -> quali  E.^. QualificationName
           , singletonMap "blocked"      $ SortColumn $ withType $ \(_ `E.InnerJoin` _ `E.LeftOuterJoin` qblock) -> qblock E.?. QualificationUserBlockFrom
           , singletonMap "valid-until"  $ SortColumn $ withType $ \(_ `E.InnerJoin` quser `E.LeftOuterJoin`  _) -> quser  E.^. QualificationUserValidUntil
           , singletonMap "last-refresh" $ SortColumn $ withType $ \(_ `E.InnerJoin` quser `E.LeftOuterJoin`  _) -> quser  E.^. QualificationUserLastRefresh
-          , singletonMap "first-held"   $ SortColumn $ withType $ \(_ `E.InnerJoin` quser `E.LeftOuterJoin`  _) -> quser  E.^. QualificationUserFirstHeld          
+          , singletonMap "first-held"   $ SortColumn $ withType $ \(_ `E.InnerJoin` quser `E.LeftOuterJoin`  _) -> quser  E.^. QualificationUserFirstHeld
           ]
       , dbtFilter    = mempty
       , dbtFilterUI  = mempty
@@ -1032,12 +1107,12 @@ instance HasUser TblSupervisorData where
 -- | Table listing all supervisor of the given user
 mkSupervisorsTable :: UserId -> DB Widget
 mkSupervisorsTable uid = dbTableWidget' validator DBTable{..}
-  where 
-    dbtIdent = "userSupervisedBy" :: Text
+  where
+    dbtIdent = "supervisors" :: Text
     dbtStyle = def
 
     dbtSQLQuery (usr `E.InnerJoin` spr) = do
-        E.on $ spr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId
+        EL.on $ spr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId
         E.where_ $ spr E.^. UserSupervisorUser E.==. E.val uid
         return (usr, spr)
     dbtRowKey (_ `E.InnerJoin` spr) = spr E.^. UserSupervisorId
@@ -1046,10 +1121,16 @@ mkSupervisorsTable uid = dbTableWidget' validator DBTable{..}
     dbtColonnade = mconcat
         [ colUserNameModalHdr MsgTableSupervisor ForProfileDataR
         , colUserEmail
-        , sortable (Just "postal-pref") (i18nCell MsgPrefersPostal)       $ \(view $ resultUser . _userPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b          
-        , sortable (Just "rerouted")    (i18nCell MsgTableRerouteActive)  $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorRerouteNotifications -> b) -> tickmarkCell b
-        , sortable (Just "cshort")      (i18nCell MsgTableCompany)        $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorCompany -> mc) -> maybeCell mc (\(unCompanyKey -> c) -> anchorCell (FirmUsersR c) $ citext2widget c)
-        , sortable (Just "reason")      (i18nCell MsgSupervisorReason)    $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorReason  -> mr) -> maybeCell mr textCell          
+        -- , sortable (Just "rerouted")    (i18nCell MsgTableRerouteActive)  $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorRerouteNotifications -> b) -> indicatorCell <> ifIconCell b IconReroute
+        -- , sortable (Just "postal-pref") (i18nCell MsgPrefersPostal)       $ \(view $ resultUser . _userPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b
+        , sortable (Just "reroute") (i18nCell MsgTableRerouteActive) $ \row ->
+            let isReroute = row ^. resultUserSupervisor . _entityVal ._userSupervisorRerouteNotifications
+                isLetter  = row ^. resultUser . _userPrefersPostal
+            in  if isReroute
+                  then iconCell IconReroute <> spacerCell <> iconFixedCell (iconLetterOrEmail isLetter)
+                  else mempty
+        , sortable (Just "cshort")      (i18nCell MsgTableCompany) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorCompany -> mc) -> maybeCell mc (\(unCompanyKey -> c) -> anchorCell (FirmUsersR c) $ citext2widget c)
+        , sortable (Just "reason")      (i18nCell MsgTableReason)  $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorReason  -> mr) -> maybeCell mr textCell
         ]
     validator = def & defaultSorting [ SortAscBy "cshort", SortAscBy "user-name" ]
     dbtSorting = mconcat
@@ -1057,8 +1138,13 @@ mkSupervisorsTable uid = dbTableWidget' validator DBTable{..}
         , singletonMap & uncurry $ sortUserEmail    queryUser
         , singletonMap "postal-pref"  $ SortColumn $ queryUser            >>> (E.^. UserPrefersPostal)
         , singletonMap "rerouted"     $ SortColumn $ queryUserSupervisor  >>> (E.^. UserSupervisorRerouteNotifications)
+        -- , singletonMap "reroute"      $ SortColumn $ queryUserSupervisor &&& queryUser >>> (\(spr,usr) ->  mTuple (spr E.^. UserSupervisorRerouteNotifications) (usr E.^. UserPrefersPostal))
+        , singletonMap "reroute"      $ SortColumns  $ \row ->
+            [ SomeExprValue $ queryUserSupervisor row E.^. UserSupervisorRerouteNotifications
+            , SomeExprValue $ queryUser           row E.^. UserPrefersPostal
+            ]
         , singletonMap "cshort"       $ SortColumn $ queryUserSupervisor  >>> (E.^. UserSupervisorCompany)
-        , singletonMap "reason"       $ SortColumn $ queryUserSupervisor  >>> (E.^. UserSupervisorReason)          
+        , singletonMap "reason"       $ SortColumn $ queryUserSupervisor  >>> (E.^. UserSupervisorReason)
         ]
     dbtFilter  = mconcat
         [ singletonMap & uncurry $ fltrUserNameEmail queryUser
@@ -1071,35 +1157,43 @@ mkSupervisorsTable uid = dbTableWidget' validator DBTable{..}
 
 
 -- | Table listing all persons supervised by the given user
-mkSuperviseesTable :: UserId -> DB Widget
-mkSuperviseesTable uid = dbTableWidget' validator DBTable{..}
-  where 
-    dbtIdent = "userSupervisedBy" :: Text
+mkSuperviseesTable ::Bool -> UserId -> DB Widget
+mkSuperviseesTable userPrefersPostal uid = dbTableWidget' validator DBTable{..}
+  where
+    dbtIdent = "supervisees" :: Text
     dbtStyle = def
 
     dbtSQLQuery (usr `E.InnerJoin` spr) = do
-        E.on $ spr E.^. UserSupervisorUser E.==. usr E.^. UserId
+        EL.on $ spr E.^. UserSupervisorUser E.==. usr E.^. UserId
         E.where_ $ spr E.^. UserSupervisorSupervisor E.==. E.val uid
         return (usr, spr)
     dbtRowKey (_ `E.InnerJoin` spr) = spr E.^. UserSupervisorId
     dbtProj = dbtProjId
 
+    iconCellLetterOrEmail = spacerCell <> iconFixedCell (iconLetterOrEmail userPrefersPostal) -- only notification type of supervisor matters here
     dbtColonnade = mconcat
         [ colUserNameModalHdr MsgTableSupervisee ForProfileDataR
-        -- , colUserEmail
-        -- , sortable (Just "postal-pref") (i18nCell MsgPrefersPostal)       $ \(view $ resultUser . _userPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b          
-        , sortable (Just "rerouted")    (i18nCell MsgTableRerouteActive)  $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorRerouteNotifications -> b) -> tickmarkCell b
-        , sortable (Just "cshort")      (i18nCell MsgTableCompany)        $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorCompany -> mc) -> maybeCell mc (\(unCompanyKey -> c) -> anchorCell (FirmUsersR c) $ citext2widget c)
-        , sortable (Just "reason")      (i18nCell MsgSupervisorReason)    $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorReason  -> mr) -> maybeCell mr textCell          
+        , colUserEmail
+        -- , sortable (Just "rerouted")    (i18nCell MsgTableRerouteActive)  $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorRerouteNotifications -> b) -> ifIconCell b IconReroute
+        -- , sortable (Just "postal-pref") (i18nCell MsgPrefersPostal)       $ \(view $ resultUser . _userPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b
+        , sortable (Just "reroute") (i18nCell MsgTableRerouteActive) $ \row ->
+            let isReroute = row ^. resultUserSupervisor . _entityVal ._userSupervisorRerouteNotifications
+            in  boolCell isReroute $ iconCell IconReroute <> iconCellLetterOrEmail
+        , sortable (Just "cshort")      (i18nCell MsgTableCompany)  $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorCompany -> mc) -> maybeCell mc (\(unCompanyKey -> c) -> anchorCell (FirmUsersR c) $ citext2widget c)
+        , sortable (Just "reason")      (i18nCell MsgTableReason)   $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorReason  -> mr) -> maybeCell mr textCell
         ]
     validator = def & defaultSorting [ SortAscBy "cshort", SortAscBy "user-name" ]
     dbtSorting = mconcat
         [ singletonMap & uncurry $ sortUserNameLink queryUser
         , singletonMap & uncurry $ sortUserEmail    queryUser
-        , singletonMap "postal-pref"  $ SortColumn $ queryUser            >>> (E.^. UserPrefersPostal)
-        , singletonMap "rerouted"     $ SortColumn $ queryUserSupervisor  >>> (E.^. UserSupervisorRerouteNotifications)
+        -- , singletonMap "postal-pref"  $ SortColumn $ queryUser            >>> (E.^. UserPrefersPostal)
+        -- , singletonMap "rerouted"     $ SortColumn $ queryUserSupervisor  >>> (E.^. UserSupervisorRerouteNotifications)
+        , singletonMap "reroute"      $ SortColumns  $ \row ->
+            [ SomeExprValue $ queryUserSupervisor row E.^. UserSupervisorRerouteNotifications
+            , SomeExprValue $ queryUser           row E.^. UserPrefersPostal
+            ]
         , singletonMap "cshort"       $ SortColumn $ queryUserSupervisor  >>> (E.^. UserSupervisorCompany)
-        , singletonMap "reason"       $ SortColumn $ queryUserSupervisor  >>> (E.^. UserSupervisorReason)          
+        , singletonMap "reason"       $ SortColumn $ queryUserSupervisor  >>> (E.^. UserSupervisorReason)
         ]
     dbtFilter  = mconcat
         [ singletonMap & uncurry $ fltrUserNameEmail queryUser
@@ -1229,7 +1323,7 @@ postCsvOptionsR = do
   Entity uid User{userCsvOptions} <- requireAuth
 
   userIsExamOffice <- hasReadAccessTo $ ExamOfficeR EOExamsR
-  examOfficeLabels <- if not userIsExamOffice then return mempty else runDB . E.select . E.from $ \examOfficeLabel -> do
+  examOfficeLabels <- if not userIsExamOffice then return mempty else runDB . E.select . EL.from $ \examOfficeLabel -> do
     E.where_ $ examOfficeLabel E.^. ExamOfficeLabelUser E.==. E.val uid
     E.orderBy [ E.asc (examOfficeLabel E.^. ExamOfficeLabelName) ]
     return $ examOfficeLabel E.^. ExamOfficeLabelName
@@ -1262,18 +1356,3 @@ postLangR = do
   addMessage Success . toHtml $ mr MsgLanguageChanged
 
   redirect . fromMaybe NewsR =<< lookupGlobalGetParam GetReferer
-
-
-getAdminUserSyncLdapR :: CryptoUUIDUser -> Handler Html
-getAdminUserSyncLdapR uuid = do
-  uid <- decrypt uuid
-  queueJob' $ JobSynchroniseLdapUser uid
-  addMessageI Success $ MsgSynchroniseLdapUserQueued 1
-  redirectUltDest $ AdminUserR uuid
-
-getAdminUserSyncAvsR :: CryptoUUIDUser -> Handler Html
-getAdminUserSyncAvsR uuid = do
-  uid <- decrypt uuid
-  n <- runDB $ queueAvsUpdateByUID (Set.singleton uid) Nothing
-  addMessageI Success $ MsgSynchroniseAvsUserQueued $ fromIntegral n
-  redirectUltDest $ AdminUserR uuid

src/Handler/Qualification.hs

@@ -14,7 +14,7 @@ module Handler.Qualification
 
 import Import
 
--- import Jobs
+import Jobs
 import Handler.Utils
 import Handler.Utils.Users
 import Handler.Utils.LMS
@@ -55,7 +55,7 @@ getQualificationAllR = do
 
 type AllQualificationTableData = DBRow (Entity Qualification, Ex.Value Word64, Ex.Value Word64)
 resultAllQualification :: Lens' AllQualificationTableData Qualification
-resultAllQualification = _dbrOutput . _1 . _entityVal 
+resultAllQualification = _dbrOutput . _1 . _entityVal
 
 resultAllQualificationActive :: Lens' AllQualificationTableData Word64
 resultAllQualificationActive = _dbrOutput . _2 . _unValue
@@ -65,53 +65,59 @@ resultAllQualificationTotal  = _dbrOutput . _3 . _unValue
 
 
 mkQualificationAllTable :: Bool -> DB (Any, Widget)
-mkQualificationAllTable isAdmin = do 
-  svs <- getSupervisees 
+mkQualificationAllTable isAdmin = do
+  svs <- getSupervisees
   now <- liftIO getCurrentTime
-  let    
+  let
     resultDBTable = DBTable{..}
       where
-        dbtSQLQuery quali = do         
-          let filterSvs quser = quser Ex.^. QualificationUserQualification Ex.==. quali Ex.^. QualificationId                  
+        dbtSQLQuery quali = do
+          let filterSvs quser = quser Ex.^. QualificationUserQualification Ex.==. quali Ex.^. QualificationId
                          Ex.&&. (E.val isAdmin E.||. quser Ex.^. QualificationUserUser `Ex.in_` E.vals svs)
-              cusers = Ex.subSelectCount $ do 
+              cusers = Ex.subSelectCount $ do
                 quser <- Ex.from $ Ex.table @QualificationUser
-                Ex.where_ $ filterSvs quser 
-              cactive = Ex.subSelectCount $ do 
+                Ex.where_ $ filterSvs quser
+              cactive = Ex.subSelectCount $ do
                 quser <- Ex.from $ Ex.table @QualificationUser
                 Ex.where_ $ filterSvs quser Ex.&&. validQualification now quser
-          return (quali, cactive, cusers)                          
+          return (quali, cactive, cusers)
         dbtRowKey = (Ex.^. QualificationId)
         dbtProj = dbtProjId
         dbtColonnade = dbColonnade $ mconcat
           [ colSchool $ resultAllQualification . _qualificationSchool
-          , sortable (Just "qshort")        (i18nCell MsgQualificationShort) $ \(view resultAllQualification -> quali) -> 
-              let qsh = qualificationShorthand quali in 
+          , sortable (Just "qshort")        (i18nCell MsgQualificationShort) $ \(view resultAllQualification -> quali) ->
+              let qsh = qualificationShorthand quali in
               anchorCell (QualificationR (qualificationSchool quali) qsh) $ toWgt qsh
-          , sortable (Just "qname")         (i18nCell MsgQualificationName)  $ \(view resultAllQualification -> quali) -> 
+          , sortable (Just "qname")         (i18nCell MsgQualificationName)  $ \(view resultAllQualification -> quali) ->
               let qsh = qualificationShorthand quali
-                  qnm = qualificationName quali 
+                  qnm = qualificationName quali
               in anchorCell (QualificationR (qualificationSchool quali) qsh) $ toWgt qnm
           , sortable Nothing (i18nCell MsgQualificationDescription) $ \(view resultAllQualification -> quali) ->
               maybeCell (qualificationDescription quali) markupCellLargeModal
-          , sortable Nothing (i18nCell MsgQualificationValidDuration & cellTooltip MsgTableDiffDaysTooltip) $ 
+          , sortable Nothing (i18nCell MsgQualificationValidDuration & cellTooltip MsgTableDiffDaysTooltip) $
               foldMap (textCell . formatCalendarDiffDays . fromMonths) . view (resultAllQualification . _qualificationValidDuration)
           , sortable Nothing (i18nCell MsgQualificationRefreshWithin    & cellTooltips [SomeMessage MsgQualificationRefreshWithinTooltip  , SomeMessage MsgTableDiffDaysTooltip]) $
               foldMap (textCell . formatCalendarDiffDays             ) . view (resultAllQualification . _qualificationRefreshWithin)
+          , sortable (Just "qelearning") (i18nCell MsgTableLmsElearning & cellTooltip MsgQualificationElearningStart) $ \row ->
+              let elearnstart = row ^. resultAllQualification . _qualificationElearningStart
+                  reminder    = row ^. resultAllQualification . _qualificationRefreshReminder
+              in tickmarkCell $ elearnstart && isJust reminder
           , sortable Nothing (i18nCell MsgQualificationRefreshReminder  & cellTooltips [SomeMessage MsgQualificationRefreshReminderTooltip, SomeMessage MsgTableDiffDaysTooltip]) $
-              foldMap (textCell . formatCalendarDiffDays             ) . view (resultAllQualification . _qualificationRefreshReminder)                   
-          , sortable (Just "qelearning") (i18nCell MsgTableLmsElearning & cellTooltip MsgQualificationElearningStart)
-                                                                        $ tickmarkCell . view (resultAllQualification . _qualificationElearningStart)
-          , sortable (Just "noteexpiry") (i18nCell MsgQualificationExpiryNotification & cellTooltip MsgQualificationExpiryNotificationTooltip) 
+              foldMap (textCell . formatCalendarDiffDays             ) . view (resultAllQualification . _qualificationRefreshReminder)
+          , sortable (Just "noteexpiry") (i18nCell MsgQualificationExpiryNotification & cellTooltip MsgQualificationExpiryNotificationTooltip)
                                                                         $ tickmarkCell . view (resultAllQualification . _qualificationExpiryNotification)
-          , sortable Nothing (i18nCell MsgTableQualificationIsAvsLicence & cellTooltip MsgTableQualificationIsAvsLicenceTooltip) 
+          -- , sortable (Just "qelearrenew") (i18nCell MsgTableLmsElearningRenews & cellTooltip MsgQualificationElearningRenew)
+          --                                                               $ tickmarkCell . view (resultAllQualification . _qualificationElearningRenews)
+          -- , sortable Nothing (i18nCell MsgTableQualificationLmsReuses & cellTooltip MsgTableQualificationLmsReusesTooltip)
+          --         $ \(view (resultAllQualification . _qualificationLmsReuses) -> reuseQid) -> maybeCell reuseQid qualificationIdShortCell
+          , sortable Nothing (i18nCell MsgTableQualificationIsAvsLicence & cellTooltip MsgTableQualificationIsAvsLicenceTooltip)
                   $ \(view (resultAllQualification . _qualificationAvsLicence) -> licence) -> maybeCell licence $ textCell . T.singleton . licence2char
-          , sortable Nothing (i18nCell MsgTableQualificationSapExport & cellTooltip MsgTableQualificationSapExportTooltip)  
+          , sortable Nothing (i18nCell MsgTableQualificationSapExport & cellTooltip MsgTableQualificationSapExportTooltip)
                   $ \(view (resultAllQualification . _qualificationSapId) -> mbSapId) -> tickmarkCell $ isJust mbSapId
           , sortable Nothing (i18nCell MsgTableQualificationCountActive & cellTooltip MsgTableQualificationCountActiveTooltip)
-                  $ \(view resultAllQualificationActive -> n) -> wgtCell $ word2widget n                
-          , sortable Nothing (i18nCell MsgTableQualificationCountTotal) $ wgtCell . word2widget . view resultAllQualificationTotal                     
-          ] 
+                  $ \(view resultAllQualificationActive -> n) -> wgtCell $ word2widget n
+          , sortable Nothing (i18nCell MsgTableQualificationCountTotal) $ wgtCell . word2widget . view resultAllQualificationTotal
+          ]
         dbtSorting = mconcat
           [
             sortSchool $ to (E.^. QualificationSchool)
@@ -133,7 +139,7 @@ mkQualificationAllTable isAdmin = do
         dbtStyle =  def { dbsFilterLayout = defaultDBSFilterLayout }
         dbtParams = def
         dbtIdent :: Text
-        dbtIdent = "qualification-overview"        
+        dbtIdent = "qualification-overview"
         dbtCsvEncode = noCsvEncode
         dbtCsvDecode = Nothing
         dbtExtraReps = []
@@ -145,18 +151,17 @@ mkQualificationAllTable isAdmin = do
 
 
 -- getQualificationEditR,  postQualificationEditR :: SchoolId -> QualificationShorthand -> Handler Html
--- getQualificationEditR = postQualificationEditR 
+-- getQualificationEditR = postQualificationEditR
 -- postQualificationEditR = error "TODO"
 
 data QualificationTableCsv = QualificationTableCsv   -- Q..T..C.. -> qtc..
   { qtcDisplayName    :: UserDisplayName
   , qtcEmail          :: UserEmail
   , qtcCompany        :: Maybe Text
-  , qtcCompanyNumbers :: CsvSemicolonList Int
   , qtcValidUntil     :: Day
   , qtcLastRefresh    :: Day
   , qtcBlockStatus    :: Maybe Bool
-  , qtcBlockFrom      :: Maybe UTCTime  
+  , qtcBlockFrom      :: Maybe UTCTime
   , qtcScheduleRenewal:: Bool
   , qtcLmsStatusTxt   :: Maybe Text
   , qtcLmsStatusDay   :: Maybe UTCTime
@@ -168,12 +173,11 @@ qtcExample :: QualificationTableCsv
 qtcExample = QualificationTableCsv
     { qtcDisplayName    = "Max Mustermann"
     , qtcEmail          = "m.mustermann@example.com"
-    , qtcCompany        = Just "Example Brothers LLC, SecondaryJobs Inc"
-    , qtcCompanyNumbers = CsvSemicolonList [27,69]
+    , qtcCompany        = Just "Example Brothers LLC"
     , qtcValidUntil     = compDay
     , qtcLastRefresh    = compDay
     , qtcBlockStatus    = Nothing
-    , qtcBlockFrom      = Nothing    
+    , qtcBlockFrom      = Nothing
     , qtcScheduleRenewal= True
     , qtcLmsStatusTxt   = Just "Success"
     , qtcLmsStatusDay   = Just compTime
@@ -203,15 +207,14 @@ instance CsvColumnsExplained QualificationTableCsv where
   csvColumnsExplanations = genericCsvColumnsExplanations qtcOptions $ Map.fromList
     [ ('qtcDisplayName    , SomeMessage MsgLmsUser)
     , ('qtcEmail          , SomeMessage MsgTableLmsEmail)
-    , ('qtcCompany        , SomeMessage MsgTableCompanies)
-    , ('qtcCompanyNumbers , SomeMessage MsgTableCompanyNos)
+    , ('qtcCompany        , SomeMessage MsgTablePrimeCompany)
     , ('qtcValidUntil     , SomeMessage MsgLmsQualificationValidUntil)
     , ('qtcLastRefresh    , SomeMessage MsgTableQualificationLastRefresh)
     , ('qtcBlockStatus    , SomeMessage MsgInfoQualificationBlockStatus)
     , ('qtcBlockFrom      , SomeMessage MsgInfoQualificationBlockFrom)
     , ('qtcScheduleRenewal, SomeMessage MsgQualificationScheduleRenewalTooltip)
     , ('qtcLmsStatusTxt   , SomeMessage MsgTableLmsStatus)
-    , ('qtcLmsStatusDay   , SomeMessage MsgTableLmsStatusDay)    
+    , ('qtcLmsStatusDay   , SomeMessage MsgTableLmsStatusDay)
     ]
 
 
@@ -232,7 +235,7 @@ queryLmsUser = $(sqlLOJproj 3 2)
 queryQualBlock :: QualificationTableExpr -> E.SqlExpr (Maybe (Entity QualificationUserBlock))
 queryQualBlock = $(sqlLOJproj 3 3)
 
-type QualificationTableData = DBRow (Entity QualificationUser, Entity User, Maybe (Entity LmsUser), Maybe (Entity QualificationUserBlock), [Entity UserCompany])
+type QualificationTableData = DBRow (Entity QualificationUser, Entity User, Maybe (Entity LmsUser), Maybe (Entity QualificationUserBlock), E.Value (Maybe CompanyId))
 
 resultQualUser :: Lens' QualificationTableData (Entity QualificationUser)
 resultQualUser = _dbrOutput . _1
@@ -246,8 +249,8 @@ resultLmsUser = _dbrOutput . _3 . _Just
 resultQualBlock :: Traversal' QualificationTableData (Entity QualificationUserBlock)
 resultQualBlock = _dbrOutput . _4 . _Just
 
-resultCompanyUser :: Lens' QualificationTableData [Entity UserCompany]
-resultCompanyUser = _dbrOutput . _5
+resultCompanyId :: Traversal' QualificationTableData CompanyId
+resultCompanyId = _dbrOutput . _5 . _unValue . _Just
 
 
 instance HasEntity QualificationTableData User where
@@ -266,15 +269,16 @@ instance HasQualificationUser QualificationTableData where
 --   hasQualificationUserBlock = resultQualBlock
 
 
-data QualificationTableAction 
-  = QualificationActExpire 
+data QualificationTableAction
+  = QualificationActExpire
   | QualificationActUnexpire
   | QualificationActBlockSupervisor
   | QualificationActBlock
   | QualificationActUnblock
   | QualificationActRenew
   | QualificationActGrant
-  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)  
+  | QualificationActStartELearning
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
 
 instance Universe QualificationTableAction
 instance Finite QualificationTableAction
@@ -289,15 +293,16 @@ isAdminAct QualificationActBlockSupervisor  = False
 isAdminAct _ = True
 -}
 
-data QualificationTableActionData 
-  = QualificationActExpireData 
-  | QualificationActUnexpireData  
+data QualificationTableActionData
+  = QualificationActExpireData
+  | QualificationActUnexpireData
   | QualificationActBlockSupervisorData
-  | QualificationActBlockData           { qualTableActBlockReason :: Text, qualTableActNotify :: Bool, qualTableActRemoveSupervisors :: Bool }
-  | QualificationActUnblockData         { qualTableActBlockReason :: Text, qualTableActNotify :: Bool}
-  | QualificationActRenewData           { qualTableActChangeReason :: Text}
-  | QualificationActGrantData           { qualTableActGrantUntil  :: Day }   
-  deriving (Eq, Ord, Show, Generic)  
+  | QualificationActBlockData           { qualTableActBlockReason  :: Text, qualTableActNotify :: Bool, qualTableActRemoveSupervisors :: Bool }
+  | QualificationActUnblockData         { qualTableActBlockReason  :: Text, qualTableActNotify :: Bool }
+  | QualificationActRenewData           { qualTableActChangeReason :: Text }
+  | QualificationActGrantData           { qualTableActGrantUntil   :: Day  }
+  | QualificationActStartELearningData  --  { qualTableActELearnUntil  :: Maybe Day }
+  deriving (Eq, Ord, Show, Generic)
 
 isExpiryAct :: QualificationTableActionData -> Bool
 isExpiryAct QualificationActExpireData    = True
@@ -332,18 +337,23 @@ qualificationTableQuery :: UTCTime -> QualificationId -> (_ -> E.SqlExpr (E.Valu
                 , E.SqlExpr (Entity User)
                 , E.SqlExpr (Maybe (Entity LmsUser))
                 , E.SqlExpr (Maybe (Entity QualificationUserBlock))
+                , E.SqlExpr (E.Value (Maybe CompanyId))
                 )
 qualificationTableQuery now qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser `E.LeftOuterJoin` qualBlock) = do
   -- E.distinctOnOrderBy will not work: sorting with dbTable should work, except that columns contained in distinctOnOrderBy cannot be sorted inversely by user; but PostgreSQL leftJoin with distinct filters too many results, see SQL Example lead/lag under jost/misc DevOps
-  -- 
+  --
     E.on $  qualBlock E.?. QualificationUserBlockQualificationUser E.?=. qualUser E.^. QualificationUserId
       E.&&. qualBlock `isLatestBlockBefore` E.val now
     E.on $ user E.^. UserId E.=?. lmsUser  E.?. LmsUserUser
             E.&&. E.val qid E.=?. lmsUser  E.?. LmsUserQualification            -- NOTE: condition was once erroneously placed in where-clause, which does not work
     E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser
-    E.where_ $    fltr qualUser 
-            E.&&. (E.val qid E.==. qualUser E.^. QualificationUserQualification)            
-    return (qualUser, user, lmsUser, qualBlock)
+    E.where_ $    fltr qualUser
+            E.&&. (E.val qid E.==. qualUser E.^. QualificationUserQualification)
+    let primeComp = E.subSelect . E.from $ \uc -> do
+          E.where_ $ user E.^. UserId E.==. uc E.^. UserCompanyUser
+          E.orderBy [E.desc $ uc E.^. UserCompanyPriority, E.asc $ uc E.^. UserCompanyCompany]
+          return (uc E.^. UserCompanyCompany)
+    return (qualUser, user, lmsUser, qualBlock, primeComp)
 
 
 mkQualificationTable ::
@@ -352,18 +362,20 @@ mkQualificationTable ::
               )
            => Bool
            -> Entity Qualification
-           -> Map QualificationTableAction (AForm Handler QualificationTableActionData)           
-           -> (Map CompanyId Company -> cols)
+           -> Map QualificationTableAction (AForm Handler QualificationTableActionData)
+           -> ((CompanyId -> CompanyName) -> cols)
            -> PSValidator (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableData))
            -> DB (FormResult (QualificationTableActionData, Set UserId), Widget)
 mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
   svs <- getSupervisees
-  now <- liftIO getCurrentTime  
-  -- lookup all companies   
-  cmpMap <- memcachedBy (Just . Right $ 5 * diffMinute) ("CompanyDictionary"::Text) $ do 
+  now <- liftIO getCurrentTime
+  -- lookup all companies
+  cmpMap <- memcachedBy (Just . Right $ 15 * diffMinute) ("CompanyDictionary"::Text) $ do
     cmps <- selectList [] [] -- [Asc CompanyShorthand]
     return $ Map.fromList $ fmap (\Entity{..} -> (entityKey, entityVal)) cmps
   let
+    getCompanyName :: CompanyId -> CompanyName
+    getCompanyName cid = maybe (unCompanyKey cid) companyName $ Map.lookup cid cmpMap -- use shorthand in case of impossible failure
     nowaday = utctDay now
     mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday
     csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName)
@@ -372,15 +384,8 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
     fltrSvs = if isAdmin then const E.true else \quser -> quser E.^. QualificationUserUser `Ex.in_` E.vals svs
     dbtSQLQuery = qualificationTableQuery now qid fltrSvs
     dbtRowKey = queryUser >>> (E.^. UserId)
-    dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr, qUsrBlock) -> do
-      -- cmps <- E.select . E.from $ \(usrComp `E.InnerJoin` comp) -> do
-      --   E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
-      --   E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val (entityKey usr)
-      --   E.orderBy [E.asc (comp E.^. CompanyName)]
-      --   return (comp E.^. CompanyName, comp E.^. CompanyAvsId, usrComp E.^. UserCompanySupervisor)
-      cmpUsr <- selectList [UserCompanyUser ==. entityKey usr] [Desc UserCompanyPriority, Asc UserCompanyCompany, LimitTo 1]
-      return (qualUsr, usr, lmsUsr, qUsrBlock, cmpUsr)
-    dbtColonnade = cols cmpMap
+    dbtProj = dbtProjId
+    dbtColonnade = cols getCompanyName
     dbtSorting = mconcat
       [ single $ sortUserNameLink   queryUser
       , single $ sortUserEmail      queryUser
@@ -390,7 +395,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
       , single ("last-notified" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastNotified))
       , single ("valid-until"   , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil))
       , single ("blocked"       , SortColumnNeverNull $ queryQualBlock >>> (E.?. QualificationUserBlockFrom))
-      , single ("lms-status-plus",SortColumnNeverNull $ \row -> E.coalesce [ E.joinV (queryLmsUser row E.?. LmsUserStatusDay)
+      , single ("lms-status-plus",SortColumnNullsInv  $ \row -> E.coalesce [ E.joinV (queryLmsUser row E.?. LmsUserStatusDay)
                                                                            , E.joinV (queryLmsUser row E.?. LmsUserNotified)
                                                                            ,          queryLmsUser row E.?. LmsUserStarted])
       , single ("schedule-renew", SortColumnNullsInv  $ queryQualUser  >>> (E.^. QualificationUserScheduleRenewal))
@@ -405,7 +410,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
     dbtFilter = mconcat
       [ single $ fltrUserNameEmail queryUser
       , single ("avs-number"  , FilterColumn . E.mkExistsFilter $ \row criterion ->
-              E.from $ \usrAvs -> -- do 
+              E.from $ \usrAvs -> -- do
                 E.where_ $ usrAvs E.^. UserAvsUser      E.==. queryUser row E.^. UserId
                     E.&&.  ((E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.==.
                           (E.explicitUnsafeCoerceSqlExprValue "citext" (usrAvs E.^. UserAvsNoPerson) :: E.SqlExpr (E.Value (CI Text))) ))
@@ -415,14 +420,14 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
           | otherwise         -> E.any (\c -> user E.^. UserCompanyPersonalNumber `E.hasInfix` E.val c) criteria
         )
       , single ("user-company", FilterColumn . E.mkExistsFilter $ \row criterion ->
-              E.from $ \(usrComp `E.InnerJoin` comp) -> do 
+              E.from $ \(usrComp `E.InnerJoin` comp) -> do
                 let testname = (E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf`
                                 (E.explicitUnsafeCoerceSqlExprValue "citext" (comp E.^. CompanyName) :: E.SqlExpr (E.Value (CI Text)))
                     testnumber nr = E.val nr E.==. comp E.^. CompanyAvsId
                     testcrit = maybe testname testnumber $ readMay $ CI.original criterion
                 E.on $     usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
                 E.where_ $ usrComp E.^. UserCompanyUser    E.==. queryUser row E.^. UserId E.&&. testcrit
-        )                                  
+        )
       , single ("validity"    , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification now))
       , single ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion ->
           if | Just renewal <- mbRenewal
@@ -441,7 +446,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
       , prismAForm (singletonFilter "user-company")                             mPrev $ aopt textField (fslI MsgTableCompany)
       , prismAForm (singletonFilter "personal-number" )                         mPrev $ aopt textField (fslI MsgCompanyPersonalNumber)
       , fltrAVSCardNosUI mPrev
-      , prismAForm (singletonFilter "avs-number" )                              mPrev $ aopt textField (fslI MsgAvsPersonNo)            
+      , prismAForm (singletonFilter "avs-number" )                              mPrev $ aopt textField (fslI MsgAvsPersonNo)
       , prismAForm (singletonFilter "validity"         . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid)
       , if isNothing mbRenewal then mempty
         else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal)
@@ -463,34 +468,29 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
         doEncode' = QualificationTableCsv
           <$>  view    (resultUser     . _entityVal . _userDisplayName)
           <*>  view    (resultUser     . _entityVal . _userDisplayEmail)
-          <*> (view     resultCompanyUser >>= getCompanies)
-          <*> (view     resultCompanyUser >>= getCompanyNos)
+          <*>  preview (resultCompanyId . to getCompanyName . _CI)
           <*>  view    (resultQualUser . _entityVal . _qualificationUserValidUntil)
-          <*>  view    (resultQualUser . _entityVal . _qualificationUserLastRefresh)                  
+          <*>  view    (resultQualUser . _entityVal . _qualificationUserLastRefresh)
           <*>  preview (resultQualBlock. _entityVal . _qualificationUserBlockUnblock . _not)
-          <*>  preview (resultQualBlock. _entityVal . _qualificationUserBlockFrom)          
+          <*>  preview (resultQualBlock. _entityVal . _qualificationUserBlockFrom)
           <*>  view    (resultQualUser . _entityVal . _qualificationUserScheduleRenewal)
           <*>  getStatusPlusTxt
           <*>  getStatusPlusDay
-        getCompanies cmps = case mapMaybe (flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) cmps of 
-          []        -> pure   Nothing
-          somecmps  -> pure $ Just $ intercalate ", " $ fmap (view (_companyName . _CI)) somecmps
-        getCompanyNos = pure . CsvSemicolonList . mapMaybe (preview (_Just . _companyAvsId) . flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany))
 
-        getStatusPlusTxt = 
-          (join . preview (resultLmsUser  . _entityVal . _lmsUserStatus)) >>= \case 
+        getStatusPlusTxt =
+          (join . preview (resultLmsUser  . _entityVal . _lmsUserStatus)) >>= \case
             Just LmsBlocked{} -> return $ Just "Failed"
             Just LmsExpired{} -> return $ Just "Expired"
             Just LmsSuccess{} -> return $ Just "Success"
             Nothing -> maybeM (return Nothing) (const $ return $ Just "Open") $
               preview (resultLmsUser  . _entityVal . _lmsUserStarted)
-        getStatusPlusDay = 
-          (join . preview (resultLmsUser  . _entityVal . _lmsUserStatusDay)) >>= \case 
+        getStatusPlusDay =
+          (join . preview (resultLmsUser  . _entityVal . _lmsUserStatusDay)) >>= \case
             lsd@(Just _) -> return lsd
             Nothing -> preview (resultLmsUser  . _entityVal . _lmsUserStarted)
-          
+
     dbtCsvDecode = Nothing
-    dbtExtraReps = []    
+    dbtExtraReps = []
     dbtParams = DBParamsForm
       { dbParamsFormMethod = POST
       , dbParamsFormAction = Nothing
@@ -518,31 +518,32 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
 
 getQualificationR,  postQualificationR :: SchoolId -> QualificationShorthand -> Handler Html
 getQualificationR = postQualificationR
-postQualificationR sid qsh = do  
+postQualificationR sid qsh = do
   isAdmin <- hasReadAccessTo AdminR
   msgGrantWarning <- messageIconI Warning IconWarning MsgQualificationActGrantWarning
   msgUnexpire     <- messageIconI Info    IconWarning MsgQualificationActUnexpireWarning
   now <- liftIO getCurrentTime
   let nowaday = utctDay now
-  ((lmsRes, qualificationTable), Entity qid quali) <- runDB $ do
+  ((lmsRes, qualificationTable), Entity qid quali, lmsQualiReused) <- runDB $ do
     qent@Entity{
         entityKey=qid
       , entityVal=Qualification{
           qualificationAuditDuration=auditMonths
         , qualificationValidDuration=validMonths
+        , qualificationLmsReuses    =reuseQuali
       }} <- getBy404 $ SchoolQualificationShort sid qsh
-
+    lmsQualiReused <- traverseJoin get reuseQuali
     -- Block copied to Handler/Qualifications TODO: refactor
-    let getBlockReasons unblk = Ex.select $ do 
-          (quser :& qblock) <- Ex.from $ Ex.table @QualificationUser 
+    let getBlockReasons unblk = Ex.select $ do
+          (quser :& qblock) <- Ex.from $ Ex.table @QualificationUser
             `Ex.innerJoin` Ex.table @QualificationUserBlock
             `Ex.on` (\(quser :& qblock) -> quser Ex.^. QualificationUserId Ex.==. qblock Ex.^. QualificationUserBlockQualificationUser)
           Ex.where_ $     quser  Ex.^. QualificationUserQualification Ex.==. Ex.val qid
             Ex.&&. unblk (qblock Ex.^. QualificationUserBlockUnblock)
-          Ex.groupBy     (qblock Ex.^. QualificationUserBlockReason)        
+          Ex.groupBy     (qblock Ex.^. QualificationUserBlockReason)
           let countRows' :: Ex.SqlExpr (Ex.Value Int64) = Ex.countRows
           Ex.orderBy [Ex.desc countRows']
-          Ex.limit 7
+          Ex.limit 9
           pure (qblock Ex.^. QualificationUserBlockReason)
         mkOption :: Ex.Value Text -> Option Text
         mkOption (Ex.unValue -> t) = Option{ optionDisplay = t, optionInternalValue = t, optionExternalValue = toPathPiece t }
@@ -553,67 +554,78 @@ postQualificationR sid qsh = do
         acts :: Map QualificationTableAction (AForm Handler QualificationTableActionData)
         acts = mconcat $
           [ singletonMap QualificationActExpire   $ pure QualificationActExpireData
-          , singletonMap QualificationActUnexpire $      QualificationActUnexpireData 
-              <$ aformMessage msgUnexpire        
-          ] ++ bool 
+          , singletonMap QualificationActUnexpire $      QualificationActUnexpireData
+              <$ aformMessage msgUnexpire
+          ] ++ bool
           -- nonAdmin actions, ie. Supervisor
-          [ singletonMap QualificationActBlockSupervisor $ pure QualificationActBlockSupervisorData ] 
+          [ singletonMap QualificationActBlockSupervisor $ pure QualificationActBlockSupervisorData ]
           -- Admin-only actions
           [ singletonMap QualificationActUnblock         $      QualificationActUnblockData
               <$> apreq (textField & cfStrip & addDatalist suggestionsUnblock)  (fslI MsgQualificationGrantReason)             Nothing
               <*> areq  (boolField . Just $ SomeMessage MsgBoolIrrelevant)      (fslI MsgQualificationBlockNotify)            (Just False)
-          , singletonMap QualificationActBlock           $      QualificationActBlockData 
+          , singletonMap QualificationActBlock           $      QualificationActBlockData
               <$> 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           $      QualificationActRenewData
               <$> apreq (textField & cfStrip & addDatalist suggestionsBlock)    (fslI MsgQualificationRenewReason)             Nothing
-          , singletonMap QualificationActGrant           $      QualificationActGrantData 
+          , singletonMap QualificationActGrant           $      QualificationActGrantData
                 <$> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry
                 <*  aformMessage msgGrantWarning
+          , singletonMap QualificationActStartELearning  $ pure QualificationActStartELearningData
+                -- <$> aopt dayField (fslI MsgQualificationReduceValidUntil) Nothing
           ] isAdmin
         linkLmsUser     = toMaybe isAdmin (LmsUserR sid qsh)
-        linkUserName    = bool ForProfileR ForProfileDataR isAdmin        
-        colChoices cmpMap = mconcat
+        linkUserName    = bool ForProfileR ForProfileDataR isAdmin
+        colChoices getCompanyName = mconcat
           [ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
           , colUserNameModalHdr MsgLmsUser linkUserName
-          , colUserEmail          
-          , sortable (Just "user-company") (i18nCell MsgTableCompany) $ \( view resultCompanyUser -> cmps) ->
-              let cs =  [ companyCell (unCompanyKey cmpId) cmpName cmpSpr
-                        | Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps
-                        , let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap                        
-                        ]
-              in intercalate spacerCell cs
+          , colUserEmail
+          , sortable (Just "user-company") (i18nCell MsgTablePrimeCompany) $ \(preview resultCompanyId -> mcid) ->
+              maybeEmpty mcid $ \cid -> companyCell (unCompanyKey cid) (getCompanyName cid) False
           , guardMonoid isAdmin $ colUserMatriclenr isAdmin
           -- , sortable (Just "validity")      (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser)
           , sortable (Just "first-held")    (i18nCell MsgTableQualificationFirstHeld)  $    \(   view $ resultQualUser . _entityVal . _qualificationUserFirstHeld   -> d)  -> dayCell d
-          , sortable (Just "last-refresh")  (i18nCell MsgTableQualificationLastRefresh)$    \(   view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d)  -> dayCell d          
+          , sortable (Just "last-refresh")  (i18nCell MsgTableQualificationLastRefresh)$    \(   view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d)  -> dayCell d
           , sortable (Just "valid-until")   (i18nCell MsgLmsQualificationValidUntil)  (dayCell . view ( resultQualUser . _entityVal . _qualificationUserValidUntil))
-          , sortable (Just "blocked")       (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltipSimple) $ \row -> 
+          , sortable (Just "blocked")       (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltipSimple) $ \row ->
               qualificationValidReasonCell' (Just $ LmsUserR sid qsh) isAdmin nowaday (row ^? resultQualBlock) row
           , sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip
                                                                                     )     $ \(   view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification
           , sortable (Just "lms-status-plus")(i18nCell MsgTableLmsStatus & cellTooltipWgt Nothing (lmsStatusInfoCell isAdmin auditMonths))
                                                                                           $ \(preview $ resultLmsUser  . _entityVal -> lu) -> foldMap (lmsStatusCell isAdmin linkLmsUser) lu
-          -- QualificationUserLastNotified is about notification on actual validity changes. If a user's licence is about to expire and renewed before expiry via e-learning, this value does not change. 
+          -- QualificationUserLastNotified is about notification on actual validity changes. If a user's licence is about to expire and renewed before expiry via e-learning, this value does not change.
           -- NOTE: If this column is reinstatiated, header and tooltip were already updated to avoid any confusion!
-          -- , sortable (Just "last-notified") (i18nCell MsgTableQualificationLastNotified & cellTooltip MsgTableQualificationLastNotifiedTooltip)  
+          -- , sortable (Just "last-notified") (i18nCell MsgTableQualificationLastNotified & cellTooltip MsgTableQualificationLastNotifiedTooltip)
           --                                                                                 $ \(   view $ resultQualUser . _entityVal . _qualificationUserLastNotified -> d) -> dateTimeCell d
           ]
         psValidator = def & defaultSorting [SortDescBy "last-refresh"]
     tbl <- mkQualificationTable isAdmin qent acts colChoices psValidator
-    return (tbl, qent)
-  
+    return (tbl, qent, lmsQualiReused)
+
   formResult lmsRes $ \case
     (QualificationActRenewData renewReason, selectedUsers) | isAdmin -> do
-      noks <- runDB $ renewValidQualificationUsers qid (canonical $ Just $ Left renewReason) 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      
+    (QualificationActGrantData grantValidday, selectedUsers) | isAdmin -> do
       runDB . forM_ selectedUsers $ upsertQualificationUser qid now grantValidday Nothing "Admin"
       addMessageI  (if 0 < Set.size selectedUsers then Success else Warning) . MsgTutorialUserGrantedQualification $ Set.size selectedUsers
       reloadKeepGetParams $ QualificationR sid qsh
-    (action, selectedUsers) | isExpiryAct action -> do      
+    (QualificationActStartELearningData, Set.toList -> selectedUsers) | isAdmin -> do
+      -- whenIsJust mbExpDay $ \expDay ->
+      --   when expDay > nowaday $
+          -- -- updateWhere [QualificationUserQualification ==. qid, QualificationUserUser <-. selectedUsers, QualificationUserValidUntil >. expDay] [QualificationUserValidUntil =. expDay] -- DO NOT USE: no audit
+          -- NOTE: if needed, create function Handler.Utils.Qualification.updateQualificationUser qid QualificationChangeReason -> Day -> [UserId] -> DB Int
+      validQualHolderEnts <- runDB $ selectValidQualifications qid selectedUsers now
+      let validQualHolders = view (_entityVal . _qualificationUserUser) <$> validQualHolderEnts
+      jobs <- forM validQualHolders $ queueJob . JobLmsEnqueueUser qid
+      let nrTodo     = length selectedUsers
+          nrEnqueued = length $ catMaybes jobs
+      addMessageI (bool Warning Success $ nrEnqueued > 0 && nrEnqueued == nrTodo) $ MsgQualificationActStartELearningStatus qsh nrEnqueued nrTodo
+      -- transaction audit identical to automatic start, performed by JobLmsEnqueueUser
+      reloadKeepGetParams $ QualificationR sid qsh
+    (action, selectedUsers) | isExpiryAct action -> do
       let isUnexpire = action == QualificationActUnexpireData
       upd <- runDB $ do
         forM_ selectedUsers $ \uid -> audit TransactionQualificationUserScheduleRenewal
@@ -628,18 +640,18 @@ postQualificationR sid qsh = do
           msgVal  = upd & if isUnexpire then MsgQualificationSetUnexpire else MsgQualificationSetExpire
       addMessageI msgKind msgVal
       reloadKeepGetParams $ QualificationR sid qsh
-    (action, selectedUsers) | isBlockAct action && (isAdmin || action == QualificationActBlockSupervisorData)  -> do      
+    (action, selectedUsers) | isBlockAct action && (isAdmin || action == QualificationActBlockSupervisorData)  -> do
       let selUserIds = Set.toList selectedUsers
-          (unblock, reason) = case action of 
-              QualificationActBlockSupervisorData -> (False, Right QualificationBlockReturnedByCompany)              
+          (unblock, reason) = case action of
+              QualificationActBlockSupervisorData -> (False, Right QualificationBlockReturnedByCompany)
               QualificationActBlockData{..}       -> (False, Left qualTableActBlockReason)
               QualificationActUnblockData{..}     -> (True , Left qualTableActBlockReason)
               _ -> error "Handle.Qualification.isBlockAct returned non-block action" -- cannot occur due to earlier checks
-          notify = case action of 
+          notify = case action of
               QualificationActBlockData{qualTableActNotify} -> qualTableActNotify
               _ -> False
-          
-      oks <- runDB $ do 
+
+      oks <- runDB $ do
         when (blockActRemoveSupervisors action) $ deleteWhere [UserSupervisorUser <-. selUserIds]
         qualificationUserBlocking qid selUserIds unblock Nothing reason notify
       let nrq = length selectedUsers

src/Handler/SAP.hs

@@ -27,10 +27,10 @@ import qualified Database.Esqueleto.Utils as E
 
 
 data SapUserTableCsv = SapUserTableCsv -- for csv export only
-  { csvSUTpersonalNummer :: Text 
+  { csvSUTpersonalNummer :: Text
   , csvSUTqualifikation  :: Text
   , csvSUTgültigVon      :: Day
-  , csvSUTgültigBis      :: Day  
+  , csvSUTgültigBis      :: Day
   -- , csvSUTsupendiertBis  :: Maybe Day
   , csvSUTausprägung     :: Text
   }
@@ -38,7 +38,7 @@ data SapUserTableCsv = SapUserTableCsv -- for csv export only
 makeLenses_ ''SapUserTableCsv
 
 sapUserTableCsvHeader :: Csv.Header
-sapUserTableCsvHeader = Csv.header 
+sapUserTableCsvHeader = Csv.header
     [ "PersonalNummer"
     , "Qualifikation"
     , "GültigVon"
@@ -51,40 +51,40 @@ instance ToNamedRecord SapUserTableCsv where
   toNamedRecord SapUserTableCsv{..} = Csv.namedRecord
     [ "PersonalNummer"  Csv..= csvSUTpersonalNummer
     , "Qualifikation"   Csv..= csvSUTqualifikation
-    , "GültigVon"       Csv..= csvSUTgültigVon   
-    , "GültigBis"       Csv..= csvSUTgültigBis     
+    , "GültigVon"       Csv..= csvSUTgültigVon
+    , "GültigBis"       Csv..= csvSUTgültigBis
     -- , "SupendiertBis"   Csv..= csvSUTsupendiertBis
-    , "Ausprägung"      Csv..= csvSUTausprägung   
+    , "Ausprägung"      Csv..= csvSUTausprägung
     ]
 
--- | Removes all personalNummer which are not numbers between 10000 and 99999 (also excludes E-Accounts), which should not be returned by the query anyway (only qualfications with sap id and users with internal personnel number must be transmitted)
+-- | Removes all personalNummer which are not numbers between 10000 and 99999 (also excludes E-Accounts), which should not be returned by the query anyway (only qualifications with sap id and users with internal personnel number must be transmitted)
 --   temporary suspensions are transmitted to SAP in multiple rows: firstheld->suspension1, reinstate1->suspension2, reinstate2->validTo
 sapRes2csv :: [(E.Value (Maybe Text), E.Value (Maybe Text), E.Value Day, E.Value Day, E.Value (Maybe [Maybe Day]), E.Value (Maybe [Maybe Bool]))] -> [SapUserTableCsv]
 sapRes2csv = concatMap procRes
-  where 
+  where
     procRes (E.Value pn@(Just persNo), E.Value (Just sapId), E.Value firstHeld, E.Value validUntil, E.Value (fromMaybe [] -> qubFroms), E.Value (fromMaybe [] -> qubUnblocks))
       | validFraportPersonalNumber pn -- between 10000 and 99999 also see Handler.Utils.Profile.validFraportPersonalNumber
         = let mkSap (dfrom,duntil) = SapUserTableCsv
                               { csvSUTpersonalNummer = persNo
                               , csvSUTqualifikation  = sapId
                               , csvSUTgültigVon      = dfrom
-                              , csvSUTgültigBis      = duntil                            
+                              , csvSUTgültigBis      = duntil
                               , csvSUTausprägung     = "J"
                               }
           in fmap mkSap $ compileBlocks firstHeld validUntil $ zipMaybes qubFroms qubUnblocks
     procRes _ = []
 
 -- | compute a series of valid periods, assume that lists is already sorted by Day
---   the lists encodes qualification_user_blocks with block=False/unblock=True 
+--   the lists encodes qualification_user_blocks with block=False/unblock=True
 compileBlocks :: Day -> Day -> [(Day,Bool)] -> [(Day, Day)]
-compileBlocks dStart dEnd = go (dStart, True) 
-  where 
+compileBlocks dStart dEnd = go (dStart, True)
+  where
     go :: (Day,Bool) -> [(Day,Bool)] -> [(Day, Day)]
     go (d,s) (p1@(d1,s1):r1@((d2,s2):r2))
-      | s1 == s2 && d <= d1                            = go (d,s) (p1:r2)   -- ignore unnecessary 2nd change      
-      | d1 == d2 || succ d1 == d2 || s == s1 || d > d1 = go (d,s)     r1    -- ignore unnecessary 1st change      
+      | s1 == s2 && d <= d1                            = go (d,s) (p1:r2)   -- ignore unnecessary 2nd change
+      | d1 == d2 || succ d1 == d2 || s == s1 || d > d1 = go (d,s)     r1    -- ignore unnecessary 1st change
     go (d,s) ((d1,s1):r1)
-      | dEnd <= d1        =          go (d ,s ) []                          -- remaining dates extend validity        
+      | dEnd <= d1        =          go (d ,s ) []                          -- remaining dates extend validity
       | s, not s1, d < d1 = (d,d1) : go (d1,s1) r1                          -- valid interval found
       | s == s1           =          go (d ,s ) r1                          -- no change
       | otherwise         =          go (d1,s1) r1                          -- ignore invalid interval
@@ -95,18 +95,18 @@ compileBlocks dStart dEnd = go (dStart, True)
 -- | Deliver all employess with a successful LDAP synch within the last 3 months
 getQualificationSAPDirectR :: Handler TypedContent
 getQualificationSAPDirectR = do
-  now   <- liftIO getCurrentTime  
-  fdate <- formatTime' "%Y%m%d_%H-%M" now 
+  now   <- liftIO getCurrentTime
+  fdate <- formatTime' "%Y%m%d_%H-%M" now
   let ldap_cutoff = addDiffDaysRollOver (fromMonths $ -3) now
-  qualUsers <- runDB $ E.select $ do
-    (qual :& qualUser :& user :& qualBlock) <- 
-      E.from $ E.table @Qualification 
+  qualUsers <- runDBRead $ E.select $ do
+    (qual :& qualUser :& user :& qualBlock) <-
+      E.from $ E.table @Qualification
       `E.innerJoin` E.table @QualificationUser
       `E.on` (\(qual :& qualUser) -> qual E.^. QualificationId E.==. qualUser E.^. QualificationUserQualification)
       `E.innerJoin` E.table @User
       `E.on` (\(_ :& qualUser :& user) -> qualUser E.^. QualificationUserUser E.==. user E.^. UserId)
       `E.leftJoin` E.table @QualificationUserBlock
-      `E.on` (\(_ :& qualUser :& _ :& qualBlock) -> 
+      `E.on` (\(_ :& qualUser :& _ :& qualBlock) ->
                   qualUser E.^. QualificationUserId E.=?. qualBlock E.?. QualificationUserBlockQualificationUser
           E.&&.   E.val now                         E.>~. qualBlock E.?. QualificationUserBlockFrom
         )
@@ -116,19 +116,19 @@ getQualificationSAPDirectR = do
         E.&&.  (E.justVal ldap_cutoff E.<=. user E.^. UserLastLdapSynchronisation)
     E.groupBy ( user      E.^. UserCompanyPersonalNumber
               , qualUser  E.^. QualificationUserFirstHeld
-              , qualUser  E.^. QualificationUserValidUntil                
+              , qualUser  E.^. QualificationUserValidUntil
               , qual      E.^. QualificationSapId
               )
     let blockOrder = [E.asc $ qualBlock E.?. QualificationUserBlockFrom, E.asc $ qualBlock E.?. QualificationUserBlockId]
         -- blockAgg f = E.arrayAggWith E.AggModeAll (qualBlock E.^. f) blockOrder
-    return 
+    return
       ( user      E.^. UserCompanyPersonalNumber
       , qual      E.^. QualificationSapId
       , qualUser  E.^. QualificationUserFirstHeld
       , qualUser  E.^. QualificationUserValidUntil
       , E.arrayAggWith E.AggModeAll (E.dayMaybe $ qualBlock E.?. QualificationUserBlockFrom   ) blockOrder
       , E.arrayAggWith E.AggModeAll (             qualBlock E.?. QualificationUserBlockUnblock) blockOrder
-      )    
+      )
   let csvRendered = toCsvRendered sapUserTableCsvHeader $ sapRes2csv qualUsers
       fmtOpts = (review csvPreset CsvPresetRFC)
                     { csvIncludeHeader  = True
@@ -144,7 +144,7 @@ getQualificationSAPDirectR = do
   let logInt = runDB $ logInterface "SAP" quals True (Just nr) ""
   addHeader "Content-Disposition" $ "attachment; filename=\"" <> csvSheetName <> "\""
   csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered <* logInt
-  
+
 
 -- direct Download see:
 -- https://ersocon.net/blog/2017/2/22/creating-csv-files-in-yesod

src/Handler/Submission/List.hs

@@ -48,14 +48,14 @@ import Data.List (genericLength)
 
 import qualified Data.Csv as Csv
 
-
+{-# ANN module ("HLint: ignore Functor law" :: String) #-}
 
 data CorrectionTableFilterProj = CorrectionTableFilterProj
   { corrProjFilterSubmission :: Maybe (Set [CI Char])
   , corrProjFilterPseudonym  :: Maybe (Set [CI Char])
   , corrProjFilterAuthorshipStatementState :: Last AuthorshipStatementSubmissionState
   }
- 
+
 instance Default CorrectionTableFilterProj where
   def = CorrectionTableFilterProj
     { corrProjFilterSubmission = Nothing
@@ -64,7 +64,7 @@ instance Default CorrectionTableFilterProj where
     }
 
 makeLenses_ ''CorrectionTableFilterProj
-  
+
 
 type CorrectionTableExpr  = (               E.SqlExpr (Entity Course)
                               `E.InnerJoin` E.SqlExpr (Entity Sheet)
@@ -135,7 +135,7 @@ resultSubmittors = _dbrOutput . _6 . itraversed
 
 resultUserUser :: Lens' CorrectionTableUserData User
 resultUserUser = _1
-  
+
 resultUserPseudonym :: Traversal' CorrectionTableUserData Pseudonym
 resultUserPseudonym = _2 . _Just
 
@@ -207,7 +207,7 @@ instance Csv.ToNamedRecord CorrectionTableCsv where
       , "rating-points" Csv..= csvCorrectionRatingPoints
       , "rating-comment" Csv..= csvCorrectionRatingComment
       ]
-    where 
+    where
       mkEmpty = \case
         [Nothing] -> []
         x -> x
@@ -269,7 +269,7 @@ data CorrectionTableCsvQualification
   = CorrectionTableCsvNoQualification
   | CorrectionTableCsvQualifySheet
   | CorrectionTableCsvQualifyCourse
-  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)    
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)
   deriving anyclass (Universe, Finite)
 
 correctionTableCsvHeader :: Bool -- ^ @showCorrector@
@@ -402,7 +402,7 @@ colSubmissionLink = sortable (Just "submission") (i18nCell MsgTableSubmission) $
 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
 
-  
+
 colSubmittors :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
 colSubmittors = sortable (Just "submittors") (i18nCell MsgSubmissionUsers) $ \x ->
   let tid = x ^. resultCourseTerm
@@ -457,7 +457,7 @@ colRating' l = sortable (Just "rating") (i18nCell MsgTableRating) $ \x ->
         ]
 
 colAssigned :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
-colAssigned = sortable (Just "assignedtime") (i18nCell MsgAssignedTime) $ \x -> maybeCell (x ^? resultSubmission . _entityVal . _submissionRatingAssigned . _Just) dateTimeCell 
+colAssigned = sortable (Just "assignedtime") (i18nCell MsgAssignedTime) $ \x -> maybeCell (x ^? resultSubmission . _entityVal . _submissionRatingAssigned . _Just) dateTimeCell
 
 colRated :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
 colRated = sortable (Just "ratingtime") (i18nCell MsgTableRatingTime) $ \x -> maybeCell (x ^? resultSubmission . _entityVal . _submissionRatingTime . _Just) dateTimeCell
@@ -515,7 +515,7 @@ colAuthorshipStatementState = sortable (Just "as-state") (i18nCell MsgSubmission
       csh = x ^. resultCourseShorthand
       shn = x ^. resultSheet . _entityVal . _sheetName
       cID = x ^. resultCryptoID
-      
+
       asRoute = CSubmissionR tid ssh csh shn cID SubAuthorshipStatementsR
    in maybeCell (guardOnM (x ^. resultNonAnonymousAccess) $ x ^. resultASState) (\s -> heatC s $ anchorCell asRoute (i18n s :: Widget))
 
@@ -537,7 +537,7 @@ filterUIIsRated = flip (prismAForm $ singletonFilter "israted" . maybePrism _Pat
 
 filterUISubmission :: DBFilterUI
 filterUISubmission = flip (prismAForm $ singletonFilter "submission") $ aopt (lift `hoistField` textField) (fslI MsgTableSubmission)
-  
+
 filterUIPseudonym :: DBFilterUI
 filterUIPseudonym = flip (prismAForm $ singletonFilter "pseudonym") $ aopt (lift `hoistField` textField) (fslI MsgSubmissionPseudonym)
 
@@ -809,7 +809,7 @@ correctionsR whereClause displayColumns dbtFilterUI csvSettings psValidator acti
   fmap toTypedContent . defaultLayout $ do
     setTitleI MsgCourseCorrectionsTitle
     $(widgetFile "corrections")
-  
+
 correctionsR' :: CorrectionTableWhere -> _ -> _ -> Maybe CorrectionTableCsvSettings -> _ -> Map ActionCorrections (AForm (HandlerFor UniWorX) ActionCorrectionsData) -> Handler (Widget, SheetTypeSummary SqlBackendKey)
 correctionsR' whereClause displayColumns dbtFilterUI csvSettings psValidator actions = do
   currentRoute <- fromMaybe (error "correctionsR called from 404-handler") <$> getCurrentRoute -- This should never be called from a 404 handler

src/Handler/Tutorial/Form.hs

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

src/Handler/Tutorial/Users.hs

@@ -50,7 +50,7 @@ data TutorialUserActionData
   | TutorialUserGrantQualificationData
     { tuQualification :: QualificationId
     , tuValidUntil    :: Day
-    }    
+    }
   | TutorialUserSendMailData
   | TutorialUserDeregisterData{}
   deriving (Eq, Ord, Read, Show, Generic)
@@ -62,7 +62,7 @@ postTUsersR tid ssh csh tutn = do
   isAdmin <- hasReadAccessTo AdminR
   (Entity tutid tut@Tutorial{..}, (participantRes, participantTable), qualifications) <- runDB $ do
     cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
-    tutEnt@(Entity tutid _) <- fetchTutorial tid ssh csh tutn    
+    tutEnt@(Entity tutid _) <- fetchTutorial tid ssh csh tutn
     qualifications <- getCourseQualifications cid
     now <- liftIO getCurrentTime
     let nowaday = utctDay now
@@ -70,7 +70,7 @@ postTUsersR tid ssh csh tutn = do
         dayExpiry = flip addGregorianDurationClip nowaday . fromMonths <$> minDur
         colChoices  = mconcat $ catMaybes
           [ pure $ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
-          , pure $ colUserNameModalHdr MsgTableCourseMembers ForProfileDataR          
+          , pure $ colUserNameModalHdr MsgTableCourseMembers ForProfileDataR
           , pure   colUserEmail
           , pure $ colUserMatriclenr isAdmin
           , pure $ colUserQualifications nowaday
@@ -80,34 +80,27 @@ postTUsersR tid ssh csh tutn = do
           & defaultSortingByName
           & restrictSorting (\name _ -> none (== name) ["note", "registration", "tutorials", "exams", "submission-group", "state"]) -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information
           & restrictFilter  (\name _ -> none (== name) ["tutorial", "exam", "submission-group", "active", "has-personalised-sheet-files"])
-        isInTut q = E.exists $ do 
+        isInTut q = E.exists $ do
           tutorialParticipant <- E.from $ E.table @TutorialParticipant
           E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. queryUser q E.^. UserId
                E.&&. tutorialParticipant E.^. TutorialParticipantTutorial E.==. E.val tutid
         csvColChoices = flip elem ["name", "matriculation", "email", "qualifications"]
-    
-    let      
-      qualOpt :: Entity Qualification -> Handler (Option QualificationId)
-      qualOpt (Entity qualId qual) = do
-        cQualId :: CryptoUUIDQualification <- encrypt qualId
-        return $ Option
-          { optionDisplay       = CI.original $ qualificationName qual
-          , optionInternalValue = qualId
-          , optionExternalValue = tshow cQualId
-          }
+
+        qualOptions = qualificationsOptionList qualifications
+    let
       acts :: Map TutorialUserAction (AForm Handler TutorialUserActionData)
       acts = Map.fromList $
         (if null qualifications then mempty else
           [ ( TutorialUserRenewQualification
             , TutorialUserRenewQualificationData
-              <$> apopt (selectField . fmap mkOptionList $ mapM qualOpt qualifications) (fslI MsgQualificationName) Nothing            
+              <$> apopt (selectField $ pure qualOptions) (fslI MsgQualificationName) Nothing
             )
           , ( TutorialUserGrantQualification
             , TutorialUserGrantQualificationData
-              <$> apopt (selectField . fmap mkOptionList $ mapM qualOpt qualifications) (fslI MsgQualificationName) Nothing
+              <$> apopt (selectField $ pure qualOptions) (fslI MsgQualificationName) Nothing
               <*> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry
-            )                     
-          ] 
+            )
+          ]
         ) ++
         [ ( TutorialUserSendMail          , pure TutorialUserSendMailData           )
         , ( TutorialUserDeregister        , pure TutorialUserDeregisterData         )
@@ -122,20 +115,20 @@ postTUsersR tid ssh csh tutn = do
         rcvr <- requireAuth
         encRcvr <- encrypt $ entityKey rcvr
         letters <- runDB $ makeCourseCertificates tut Nothing $ toList selectedUsers
-        let mbAletter = anyone letters 
-        case mbAletter of 
+        let mbAletter = anyone letters
+        case mbAletter of
           Nothing -> addMessageI Error MsgErrorUnknownFormAction >> return Nothing -- TODO: better error message
-          Just aletter -> do             
+          Just aletter -> do
             now <- liftIO getCurrentTime
-            apcIdent <- letterApcIdent aletter encRcvr now        
+            apcIdent <- letterApcIdent aletter encRcvr now
             let fName = letterFileName aletter
             renderLetters rcvr letters apcIdent >>= \case
-              Left err  -> sendResponseStatus internalServerError500 $ "PDF generation failed: \n" <> err                      
+              Left err  -> sendResponseStatus internalServerError500 $ "PDF generation failed: \n" <> err
               Right pdf -> return $ Just (sendByteStringAsFile fName (LBS.toStrict pdf) now)
                 -- sendResponseByteStringFile "demoPDF.pdf" (LBS.toStrict pdf)
-                -- let typePDF :: ContentType 
+                -- let typePDF :: ContentType
                 --     typePDF = "application/pdf"
-                -- sendResponse (typePDF, toContent pdf)          
+                -- sendResponse (typePDF, toContent pdf)
     (TutorialUserGrantQualificationData{..}, selectedUsers)
       | tuQualification `Set.member` courseQids -> do
         -- today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime
@@ -146,7 +139,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 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
@@ -160,8 +153,8 @@ postTUsersR tid ssh csh tutn = do
         addMessageI Success $ MsgTutorialUsersDeregistered nrDel
         redirect $ CTutorialR tid ssh csh tutn TUsersR
     _other -> addMessageI Error MsgErrorUnknownFormAction >> return Nothing
-  
-  case tcontent of 
+
+  case tcontent of
     Just act -> act -- abort and return produced content
     Nothing -> do
       tutors <- runDB $ E.select $ do

src/Handler/Users.hs

@@ -44,7 +44,7 @@ import Data.Aeson hiding (Result(..))
 
 -- import Handler.Users.Add as Handler.Users
 
-import qualified Data.Conduit.List as C
+-- import qualified Data.Conduit.List as C
 
 import qualified Data.HashSet as HashSet
 
@@ -56,13 +56,12 @@ hijackUserForm = \csrf -> do
   (btnResult, btnView) <- mopt (buttonField BtnHijack) "" Nothing
   return (btnResult >>= guard . is _Just, mconcat [toWidget csrf, fvWidget btnView])
 
--- In case of refactoring, use this:
--- instance HasEntity (DBRow (Entity User)) User where
---    hasEntity = _dbrOutput
--- instance HasUser   (DBRow (Entity USer)) where
---    hasUser = _entityVal
+instance HasEntity (DBRow (Entity User)) User where
+   hasEntity = _dbrOutput
+instance HasUser   (DBRow (Entity User)) where
+   hasUser = _dbrOutput . _entityVal
 
-data UserAction = UserAvsSync | UserLdapSync | UserAddSupervisor | UserSetSupervisor | UserRemoveSupervisor 
+data UserAction = UserAvsSync | UserLdapSync | UserAddSupervisor | UserSetSupervisor | UserRemoveSupervisor | UserRemoveSubordinates
   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
   deriving anyclass (Universe, Finite)
 
@@ -70,14 +69,15 @@ nullaryPathPiece ''UserAction $ camelToPathPiece' 1
 embedRenderMessage ''UniWorX ''UserAction id
 
 data UserActionData = UserAvsSyncData
-                    | UserLdapSyncData 
+                    | UserLdapSyncData
                     | UserHijack
-                    | UserAddSupervisorData { getActionSupervisors :: Set Text, getActionRerouteNotifications :: Bool, getActionSupervisorReason :: Maybe Text } 
+                    | UserAddSupervisorData { getActionSupervisors :: Set Text, getActionRerouteNotifications :: Bool, getActionSupervisorReason :: Maybe Text }
                     | UserSetSupervisorData { getActionSupervisors :: Set Text, getActionRerouteNotifications :: Bool, getActionSupervisorReason :: Maybe Text }
                     | UserRemoveSupervisorData
-                    
+                    | UserRemoveSubordinatesData
+
   deriving (Eq, Ord, Read, Show, Generic)
-  
+
 isNotSetSupervisor :: UserActionData -> Bool
 isNotSetSupervisor UserSetSupervisorData{} = False
 isNotSetSupervisor _ = True
@@ -111,30 +111,31 @@ postUsersR = do
       , sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \DBRow{ dbrOutput = entUsr } -> cellHasMatrikelnummerLinkedAdmin entUsr
       , sortable (Just "user-company") (i18nCell MsgTableCompanies)   $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ liftHandler $ runDB $ -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX"
           maybeMonoid <$> wgtCompanies uid
-      , sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM
-          (AdminUserR <$> encrypt uid)
-          (toWgt userCompanyPersonalNumber)
+      -- , sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM -- redundant
+      --     (AdminUserR <$> encrypt uid)
+      --     (toWgt userCompanyPersonalNumber)
       , 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)
       , sortable (Just "user-supervisor") (i18nCell MsgTableSupervisor) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do
-            supervisors' <- liftHandler . runDB . E.select $ E.from $ \(spvr `E.InnerJoin` usrSpvr) -> do
+            supervisors' <- liftHandler . runDBRead . E.select $ E.from $ \(spvr `E.InnerJoin` usrSpvr) -> do
               E.on $ spvr E.^. UserSupervisorSupervisor E.==. usrSpvr E.^. UserId
               E.where_ $ spvr E.^. UserSupervisorUser E.==. E.val uid
               E.orderBy [E.asc (usrSpvr E.^. UserDisplayName)]
               return (usrSpvr, spvr E.^. UserSupervisorRerouteNotifications)
             let supervisors = intersperse (text2widget ", ") $
                   (\(usr, E.Value reroutCom) -> linkUserWidget ForProfileDataR usr <> bool mempty icnReroute reroutCom) <$> supervisors'
-                icnReroute = text2widget " " <> toWgt (icon IconLetter)
+                icnReroute = text2widget " " <> toWgt (icon IconReroute)
             pure $ mconcat supervisors
       , sortable (Just "last-login") (i18nCell MsgLastLogin)  $ \DBRow{ dbrOutput = Entity _ User{..} } -> maybe mempty dateTimeCell userLastAuthentication
-      , sortable (Just "auth-ldap")  (i18nCell MsgAuthMode)   $ \DBRow{ dbrOutput = Entity _ User{..} } -> i18nCell userAuthentication      
+      , sortable (Just "auth-ldap")  (i18nCell MsgAuthMode)   $ \DBRow{ dbrOutput = Entity _ User{..} } -> i18nCell userAuthentication
+      , colUserEmail
       , 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
+            schools <- liftHandler . runDBRead . E.select . E.from $ \(school `E.InnerJoin` userFunction) -> do
               E.on $ school E.^. SchoolId E.==. userFunction E.^. UserFunctionSchool
               E.where_ $ userFunction E.^. UserFunctionUser E.==. E.val uid
                    E.&&. userFunction E.^. UserFunctionFunction E.==. E.val function
@@ -147,7 +148,7 @@ postUsersR = do
                   <li>#{sh}
               |]
       , sortable (Just "system-function") (i18nCell MsgUserSystemFunctions) $ \DBRow{ dbrOutput = Entity uid _ } ->
-          let getFunctions = fmap (map $ userSystemFunctionFunction . entityVal) . liftHandler . runDB $ selectList [ UserSystemFunctionUser ==. uid, UserSystemFunctionIsOptOut ==. False ] [ Asc UserSystemFunctionFunction ]
+          let getFunctions = fmap (map $ userSystemFunctionFunction . entityVal) . liftHandler . runDBRead $ selectList [ UserSystemFunctionUser ==. uid, UserSystemFunctionIsOptOut ==. False ] [ Asc UserSystemFunctionFunction ]
            in listCell' getFunctions i18nCell
       , sortable Nothing (mempty & cellAttrs <>~ pure ("hide-columns--hider-label", mr MsgTableActionsHead)) $ \inp@DBRow{ dbrOutput = Entity uid _ } -> FormCell
           { formCellAttrs    = []
@@ -185,19 +186,27 @@ postUsersR = do
         let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap
         return (act, usrSet)
 
+      superReasons :: HandlerFor UniWorX (OptionList Text)
+      superReasons = fmap (mkOptionList . map (\t -> Option t t t) . Set.toAscList) . runDB $
+        fmap (setOf $ folded . _Value . _Just) . Ex.select . Ex.distinct $ do
+          usrc <- Ex.from $ Ex.table @UserSupervisor
+          E.where_ $ E.isJust (usrc E.^. UserSupervisorReason)
+          Ex.limit 9
+          return $ usrc E.^. UserSupervisorReason
       acts :: Map UserAction (AForm Handler UserActionData)
-      acts = mconcat 
+      acts = mconcat
         [ singletonMap UserLdapSync      $ pure UserLdapSyncData
         , singletonMap UserAvsSync       $ pure UserAvsSyncData
-        , singletonMap UserAddSupervisor $ UserAddSupervisorData 
-            <$> apopt (textField & cfAnySeparatedSet) (fslI MsgTableSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing
-            <*> apopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just True)
-            <*> aopt   textField (fslI MsgSupervisorReason) Nothing
-        , singletonMap UserSetSupervisor $ UserSetSupervisorData 
-            <$> apopt  (textField & cfAnySeparatedSet) (fslI MsgTableSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing
-            <*> apopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just True)
-            <*> aopt   textField (fslI MsgSupervisorReason) Nothing
+        , singletonMap UserAddSupervisor $ UserAddSupervisorData
+            <$> apopt (textField & cfAnySeparatedSet) (fslI MsgTableSupervisor       & setTooltip MsgCourseParticipantsRegisterUsersFieldTip)     Nothing
+            <*> apopt  boolField'                     (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip)                (Just False)
+            <*> aopt  (textField & cfStrip & addDatalist superReasons) (fslI MsgUserSupervisorReason & setTooltip MsgUserSupervisorReasonTooltip) Nothing
+        , singletonMap UserSetSupervisor $ UserSetSupervisorData
+            <$> apopt (textField & cfAnySeparatedSet) (fslI MsgTableSupervisor       & setTooltip MsgCourseParticipantsRegisterUsersFieldTip)     Nothing
+            <*> apopt  boolField'                     (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip)                (Just False)
+            <*> aopt  (textField & cfStrip & addDatalist superReasons) (fslI MsgUserSupervisorReason & setTooltip MsgUserSupervisorReasonTooltip) Nothing
         , singletonMap UserRemoveSupervisor $ pure UserRemoveSupervisorData
+        , singletonMap UserRemoveSubordinates $ pure UserRemoveSubordinatesData
         ]
 
     over _1 postprocess <$> dbTable psValidator DBTable
@@ -207,17 +216,18 @@ postUsersR = do
       , dbtProj      = dbtProjId
       , dbtSorting   = Map.fromList $
           [ ( SortingKey $ CI.mk $ toPathPiece function
-            , SortColumn $ \user -> E.subSelect $ E.from $ \uf -> do 
+            , SortColumn $ \user -> E.subSelect $ E.from $ \uf -> do
                 E.where_ $ uf E.^. UserFunctionUser     E.==. user E.^. UserId
                     E.&&.  uf E.^. UserFunctionFunction E.==. E.val function
                 return (uf E.^. UserFunctionSchool)
             ) | function <- universeF
           ] ++
-          [ ( "name"
-            , SortColumn $ \user -> user E.^. UserSurname
+          [ sortUserEmail id
+          , ( "name"
+            , SortColumn (E.^. UserSurname)
             )
           , ( "display-name"
-            , SortColumn $ \user -> user E.^. UserDisplayName
+            , SortColumn (E.^. UserDisplayName)
             )
            , ( "matriculation"
             , SortColumn $ \user -> user E.^. UserMatrikelnummer
@@ -252,26 +262,27 @@ postUsersR = do
                 return (usrSpvr E.^. UserDisplayName)
             )
           , ( "system-function"
-            , SortColumn $ \user -> E.subSelect $ E.from $ \usf -> do 
+            , SortColumn $ \user -> E.subSelect $ E.from $ \usf -> do
                 E.where_ $ usf E.^. UserSystemFunctionUser     E.==. user E.^. UserId
-                return   $ usf E.^. UserSystemFunctionFunction            
+                return   $ usf E.^. UserSystemFunctionFunction
             )
           ]
       , dbtFilter    = Map.fromList -- OverloadedLists does not work with the templates
-          [ ( "user-search", FilterColumn $ \user (criteria :: Set.Set Text) ->
-              if Set.null criteria then E.true else -- TODO: why is this condition not needed?
-                  -- Set.foldr (\needle acc -> acc E.||. (user E.^. UserDisplayName) `E.hasInfix` needle) eFalse (criterion :: Set.Set Text)
-                  E.any (\c -> user E.^. UserDisplayName `E.hasInfix` E.val c) criteria
-            )
-          , ( "user-ident", FilterColumn $ \user criterion -> case getLast (criterion :: Last Text) of
-              Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
-              Just needle -> E.castString (user E.^. UserIdent) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%)
-            )
-          , ( "user-email", FilterColumn $ \user criterion -> case getLast (criterion :: Last Text) of
-              Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
-              Just needle -> (E.castString (user E.^. UserEmail) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
-                      E.||. (E.castString (user E.^. UserDisplayEmail) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
-            )
+          [ fltrUserNameEmail id
+          -- , ( "user-search", FilterColumn $ \user (criteria :: Set.Set Text) ->
+          --     if Set.null criteria then E.true else -- TODO: why is this condition not needed?
+          --         -- Set.foldr (\needle acc -> acc E.||. (user E.^. UserDisplayName) `E.hasInfix` needle) eFalse (criterion :: Set.Set Text)
+          --         E.any (\c -> user E.^. UserDisplayName `E.hasInfix` E.val c) criteria
+          --   )
+          -- , ( "user-ident", FilterColumn $ \user criterion -> case getLast (criterion :: Last Text) of
+          --     Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
+          --     Just needle -> E.castString (user E.^. UserIdent) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%)
+          --   )
+          -- , ( "user-email", FilterColumn $ \user criterion -> case getLast (criterion :: Last Text) of
+          --     Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
+          --     Just needle -> (E.castString (user E.^. UserEmail) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
+          --             E.||. (E.castString (user E.^. UserDisplayEmail) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
+          --   )
           , ( "personal-number"   , FilterColumn . E.mkContainsFilterWithComma Just $ (E.^. UserCompanyPersonalNumber))
           , ( "matriculation"     , FilterColumn . E.mkContainsFilterWithComma Just $ (E.^. UserMatrikelnummer)) -- allows partial matches
           , ( "company-department", FilterColumn $ \user (criteria :: Set.Set Text) -> if                        -- exact filter on table UserAvs
@@ -296,8 +307,14 @@ postUsersR = do
                       in E.maybe E.true (E.<=. E.val minTime) $ user E.^. UserLastLdapSynchronisation
                 | otherwise -> E.val True :: E.SqlExpr (E.Value Bool)
             )
+          , ( "avs-sync", FilterColumn . E.mkExistsFilter $ \user criterion ->
+                E.from $ \usrAvs -> do
+                  let minTime = (E.val criterion :: E.SqlExpr (E.Value UTCTime))
+                  E.where_ $ usrAvs E.^. UserAvsUser E.==. user E.^. UserId
+                      E.&&.  usrAvs E.^. UserAvsLastSynch E.<=. minTime
+            )
           , ( "user-company", FilterColumn . E.mkExistsFilter $ \user criterion ->
-                E.from $ \(usrComp `E.InnerJoin` comp) -> do 
+                E.from $ \(usrComp `E.InnerJoin` comp) -> do
                   let testname = (E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf`
                                   (E.explicitUnsafeCoerceSqlExprValue "citext" (comp E.^. CompanyName) :: E.SqlExpr (E.Value (CI Text)))
                       testnumber nr = E.val nr E.==. comp E.^. CompanyAvsId
@@ -314,31 +331,33 @@ postUsersR = do
                         E.&&.  E.any (E.hasInfix (usrSpvr E.^. UserDisplayName)) (E.val <$> Set.toList criteria)
             )
           -- , ( "avs-number", FilterColumn $ E.mkExistsFilterWithComma CI.mk $ \user criterion -> -- note that this is an exact filter
-          --     E.from $ \usrAvs -> -- do 
+          --     E.from $ \usrAvs -> -- do
           --       E.where_ $ user E.^. UserId E.==. usrAvs E.^. UserAvsUser
           --           E.&&.  ((E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.==.
           --                 (E.explicitUnsafeCoerceSqlExprValue "citext" (usrAvs E.^. UserAvsNoPerson) :: E.SqlExpr (E.Value (CI Text))) )
           --   )
-          , ( "is-supervisor", FilterColumn $ \user criterion -> case criterion of                
+          , ( "is-supervisor", FilterColumn $ \user criterion -> case criterion of
                 Last (Just True)   -> E.exists    . E.from $ \usrSpr -> E.where_ $ user E.^. UserId E.==. usrSpr E.^. UserSupervisorSupervisor
                 Last (Just False)  -> E.notExists . E.from $ \usrSpr -> E.where_ $ user E.^. UserId E.==. usrSpr E.^. UserSupervisorSupervisor
                 _                  -> E.val True :: E.SqlExpr (E.Value Bool)
             )
           ]
       , dbtFilterUI  = \mPrev -> mconcat
-          [ prismAForm (singletonFilter "user-search")        mPrev $ aopt textField (fslI MsgName)
-          , prismAForm (singletonFilter "user-ident")         mPrev $ aopt textField (fslI MsgAdminUserIdent)
-          , prismAForm (singletonFilter "user-email")         mPrev $ aopt textField (fslI MsgAdminUserEmail)
-          , prismAForm (singletonFilter "personal-number" )   mPrev $ aopt textField (fslI MsgCompanyPersonalNumber     & setTooltip MsgTableFilterCommaPlus)
-          , prismAForm (singletonFilter "matriculation")      mPrev $ aopt matriculationField  (fslI MsgTableMatrikelNr & setTooltip MsgTableFilterCommaPlus)    -- contains filter on UserMatrikelnummer
-          -- , prismAForm (singletonFilter "avs-number" )        mPrev $ aopt textField (fslI MsgAvsPersonNo               & setTooltip MsgTableFilterCommaPlus) -- exact filter on table UserAvs
+          [ fltrUserNameEmailHdrUI MsgName mPrev
+          -- , prismAForm (singletonFilter "user-search")        mPrev $ aopt textField (fslI MsgName)
+          -- , prismAForm (singletonFilter "user-ident")         mPrev $ aopt textField (fslI MsgAdminUserIdent)
+          -- , prismAForm (singletonFilter "user-email")         mPrev $ aopt textField (fslI MsgAdminUserEmail)
+          , prismAForm (singletonFilter "personal-number" )   mPrev $ aopt textField (fslI MsgCompanyPersonalNumber     & setTooltip MsgTableFilterCommaPlusShort)
+          , prismAForm (singletonFilter "matriculation")      mPrev $ aopt matriculationField  (fslI MsgTableMatrikelNr & setTooltip MsgTableFilterCommaPlusShort)    -- contains filter on UserMatrikelnummer
+          -- , prismAForm (singletonFilter "avs-number" )        mPrev $ aopt textField (fslI MsgAvsPersonNo               & setTooltip MsgTableFilterCommaPlusShort) -- exact filter on table UserAvs
           , prismAForm (singletonFilter "company-department") mPrev $ aopt textField (fslI MsgCompanyDepartment)
           , prismAForm (singletonFilter "user-company")       mPrev $ aopt textField (fslI MsgTableCompany)
           , prismAForm (singletonFilter "user-supervisor")    mPrev $ aopt textField (fslI MsgTableSupervisor)
           , prismAForm (singletonFilter "school")             mPrev $ aopt (lift `hoistField` selectFieldList schoolOptions) (fslI MsgCourseSchool)
           , prismAForm (singletonFilter "is-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgUserIsSupervisor)
-          , prismAForm (singletonFilter "auth-ldap"     . maybePrism _PathPiece) mPrev $ aopt (lift `hoistField` selectFieldList [(MsgAuthPWHash "", False), (MsgAuthLDAP, True)]) (fslI MsgAuthMode)          
+          , prismAForm (singletonFilter "auth-ldap"     . maybePrism _PathPiece) mPrev $ aopt (lift `hoistField` selectFieldList [(MsgAuthPWHash "", False), (MsgAuthLDAP, True)]) (fslI MsgAuthMode)
           , prismAForm (singletonFilter "ldap-sync"     . maybePrism _PathPiece) mPrev $ aopt utcTimeField (fslI MsgLdapSyncedBefore)
+          , prismAForm (singletonFilter "avs-sync"      . maybePrism _PathPiece) mPrev $ aopt utcTimeField (fslI MsgLastAvsSyncedBefore)
           ]
       , dbtStyle     = def { dbsFilterLayout = defaultDBSFilterLayout }
       , dbtParams    = DBParamsForm
@@ -364,10 +383,10 @@ postUsersR = do
   formResult usersRes $ \case
     (act, usersSet)
       | Set.null usersSet && isNotSetSupervisor act ->
-          addMessageI Info MsgActionNoUsersSelected          
+          addMessageI Info MsgActionNoUsersSelected
     (UserLdapSyncData, userSet) -> do
-      forM_ userSet $ \uid -> queueJob' $ JobSynchroniseLdapUser uid
-      addMessageI Success . MsgSynchroniseLdapUserQueued $ Set.size userSet      
+      forM_ userSet $ \uid -> void . queueJob $ JobSynchroniseLdapUser uid
+      addMessageI Success . MsgSynchroniseLdapUserQueued $ Set.size userSet
       redirectKeepGetParams UsersR
     (UserAvsSyncData, userSet) -> do
       n <- runDB $ queueAvsUpdateByUID userSet Nothing
@@ -375,16 +394,20 @@ postUsersR = do
       redirectKeepGetParams UsersR
     (UserHijack, Set.lookupMin -> Just uid) ->
       hijackUser uid >>= sendResponse
-    (UserRemoveSupervisorData, userSet) -> do      
+    (UserRemoveSupervisorData, userSet) -> do
       runDB $ deleteWhere [UserSupervisorUser <-. Set.toList userSet]
       addMessageI Success $ MsgUsersRemoveSupervisors $ Set.size userSet
       redirectKeepGetParams UsersR
+    (UserRemoveSubordinatesData, userSet) -> do
+      runDB $ deleteWhere [UserSupervisorSupervisor <-. Set.toList userSet]
+      addMessageI Success $ MsgUsersRemoveSubordinates $ Set.size userSet
+      redirectKeepGetParams UsersR
     (act, usersSet)
-      | isActionSupervisor act -> do 
+      | isActionSupervisor act -> do
         avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser $ getActionSupervisors act
         let (supersFound, supersNotFound) = partition (is _Just . view _2) $ Map.toList avsUsers
             users = Set.toList usersSet
-            nrSuperNotFound = length supersNotFound            
+            nrSuperNotFound = length supersNotFound
         runDB $ do
           unless (isNotSetSupervisor act) $ deleteWhere [UserSupervisorUser <-. users]
           putMany [UserSupervisor s u r Nothing (getActionSupervisorReason act)
@@ -398,14 +421,15 @@ postUsersR = do
         redirectKeepGetParams UsersR
     _other -> addMessageI Error MsgInvalidFormAction
 
-  ((allUsersRes, allUsersWgt), allUsersEnctype) <- runFormPost . identifyForm FIDAllUsersAction $ buttonForm
+  ((allUsersRes, allUsersWgt'), allUsersEnctype) <- runFormPost . identifyForm FIDAllUsersAction $ buttonForm
 
   formResult allUsersRes $ \case
     AllUsersLdapSync -> do
-      runDBJobs . runConduit $ selectSource [] [] .| C.mapM_ (queueDBJob . JobSynchroniseLdapUser . entityKey)
+      -- runDBJobs . runConduit $ selectSource [] [] .| C.mapM_ (queueDBJob . JobSynchroniseLdapUser . entityKey) -- to slow to execute directly
+      queueJob' JobSynchroniseLdapAll
       addMessageI Success MsgSynchroniseLdapAllUsersQueued
       redirect UsersR
-    AllUsersAvsSync -> do      
+    AllUsersAvsSync -> do
       now <- liftIO getCurrentTime
       let nowaday = utctDay now
       n <- runDB $ E.insertSelectWithConflictCount UniqueAvsSyncUser
@@ -417,16 +441,16 @@ postUsersR = do
                 -- Ex.<&> Ex.just (E.day E.now_) -- don't use DB time here, since job handler compares with FRADrive clock
                 Ex.<&> E.justVal nowaday
               )
-        ) (\current excluded -> 
+        ) (\current excluded ->
             [ AvsSyncCreationTime E.=. E.least    (current E.^. AvsSyncCreationTime) (excluded E.^. AvsSyncCreationTime)
             , AvsSyncPause        E.=. E.greatest (current E.^. AvsSyncPause)        (excluded E.^. AvsSyncPause)
             ]
         )
-      queueJob' JobSynchroniseAvsQueue
+      void $ queueJob JobSynchroniseAvsQueue
       addMessageI Success $ MsgSynchroniseAvsAllUsersQueued n
       redirect UsersR
 
-  let allUsersWgt' = wrapForm allUsersWgt def
+  let allUsersWgt = wrapForm allUsersWgt' def
         { formSubmit = FormNoSubmit
         , formAction = Just $ SomeRoute UsersR
         , formEncoding = allUsersEnctype
@@ -442,7 +466,7 @@ hijackUser uid = do
   setCredsRedirect $ Creds apDummy (CI.original userIdent) []
 
 getAdminHijackUserR :: CryptoUUIDUser -> Handler Html
-getAdminHijackUserR cID = do    
+getAdminHijackUserR cID = do
   (hijackWgt, hijackEnctype) <- generateFormPost hijackUserForm
   let hjForm = wrapForm hijackWgt def{ formSubmit = FormNoSubmit, formEncoding = hijackEnctype, formAction = Just . SomeRoute $ AdminHijackUserR cID }
   uid :: UserId <- decrypt cID
@@ -455,7 +479,7 @@ getAdminHijackUserR cID = do
     |]
 
 postAdminHijackUserR :: CryptoUUIDUser -> Handler TypedContent
-postAdminHijackUserR cID = do  
+postAdminHijackUserR cID = do
   ((hijackRes, _), _) <- runFormPost hijackUserForm
   $logWarnS "HIJACK" $ "Form Result is: " <> tshow hijackRes
   uid <- decrypt cID
@@ -486,6 +510,15 @@ nullaryPathPiece ''UserAssimilateButton $ camelToPathPiece' 2
 embedRenderMessage ''UniWorX ''UserAssimilateButton id
 
 
+data ThisUserAction = ThisUserLdapSync | ThisUserAvsSync --  ThisUserHijack would make sense, but this 'btn' should not always be visible
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
+  deriving anyclass (Universe, Finite)
+
+nullaryPathPiece ''ThisUserAction $ camelToPathPiece' 1
+embedRenderMessage ''UniWorX ''ThisUserAction id
+
+instance Button UniWorX ThisUserAction where
+  btnClasses _ = [BCIsButton, BCPrimary]
 
 
 getAdminUserR, postAdminUserR :: CryptoUUIDUser -> Handler Html
@@ -493,6 +526,25 @@ getAdminUserR = postAdminUserR
 postAdminUserR uuid = do
     adminId <- requireAuthId
     uid <- decrypt uuid
+
+    ((thisUserActRes, thisUserActWgt'), thisUserActEnctype) <- runFormPost . identifyForm FIDThisUserAction $ buttonForm
+    formResult thisUserActRes $ \case
+      ThisUserLdapSync -> do
+        queueJob' $ JobSynchroniseLdapUser uid
+        addMessageI Success $ MsgSynchroniseLdapUserQueued 1
+        redirectKeepGetParams $ AdminUserR uuid
+      ThisUserAvsSync -> do
+        n <- runDB $ queueAvsUpdateByUID (Set.singleton uid) Nothing
+        addMessageI Success $ MsgSynchroniseAvsUserQueued $ fromIntegral n
+        redirectKeepGetParams $ AdminUserR uuid
+      -- ThisUserHijack -> do
+      --   redirect $ AdminHijackUserR uuid
+    let thisUserActWgt = wrapForm thisUserActWgt' def
+          { formSubmit    = FormNoSubmit
+          , formAction    = Just $ SomeRoute $ AdminUserR uuid
+          , formEncoding  = thisUserActEnctype
+          }
+
     (user@User{..}, adminSchools, functions, schools, systemFunctions) <- runDB $ do
       user <- get404 uid
 

src/Handler/Utils.hs

@@ -150,47 +150,95 @@ reload r = getCurrentRoute >>= redirect . fromMaybe r
 
 -- | 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 
+reloadKeepGetParams r = liftHandler $ do
   getps <- reqGetParams <$> getRequest
   route <- fromMaybe r  <$> getCurrentRoute
   -- addMessage Info $ toHtml (show getps) -- DEBUG ONLY
   -- RECALL: redirect GET parameters are used like so: -- redirect (UsersR, [("users-user-company","fraport")])
-  redirect (route, getps) 
+  redirect (route, getps)
 
 -- | 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  
-  redirect (route, getps)  
+redirectKeepGetParams route = liftHandler $ do
+  getps <- reqGetParams <$> getRequest
+  redirect (route, getps)
 
+previousSuperior :: (IsDBTable m a) => Maybe UserId -> DBCell m a
+previousSuperior Nothing    = mempty
+previousSuperior (Just uid) = spacerCell <> i18nCell MsgAdminProblemCompanySuperiorPrevious <> anchorCellM (AdminUserR <$> encrypt uid) (userIdWidget uid)
 
-adminProblemCell :: IsDBTable m a => AdminProblem -> DBCell m a
+adminProblemCell :: (IsDBTable m a) => AdminProblem -> DBCell m a
 -- note that adminProblemCompany/adminProblemCompanyOld and adminProblemUser are automatically displayed within their own columns
-adminProblemCell AdminProblemNewCompany{}                                 
+-- WARNING: this function should correspond with adminProblem2Text
+adminProblemCell AdminProblemNewCompany{}
   = i18nCell MsgAdminProblemNewCompany
-adminProblemCell AdminProblemSupervisorNewCompany{adminProblemCompanyNew, adminProblemSupervisorReroute} 
+adminProblemCell AdminProblemSupervisorNewCompany{adminProblemCompanyNew, adminProblemSupervisorReroute}
   = i18nCell (MsgAdminProblemSupervisorNewCompany adminProblemSupervisorReroute) <> companyIdCell adminProblemCompanyNew
 adminProblemCell AdminProblemSupervisorLeftCompany{adminProblemSupervisorReroute}
   = i18nCell (MsgAdminProblemSupervisorLeftCompany adminProblemSupervisorReroute)
-adminProblemCell AdminProblemNewlyUnsupervised{adminProblemCompanyNew}  
+adminProblemCell AdminProblemCompanySuperiorChange{adminProblemUserOld}
+  = i18nCell MsgAdminProblemCompanySuperiorChange <> previousSuperior adminProblemUserOld
+adminProblemCell AdminProblemCompanySuperiorNotFound{..}
+  = i18nCell (MsgAdminProblemCompanySuperiorNotFound (fromMaybe "???" adminProblemEmail)) <> previousSuperior adminProblemUserOld
+adminProblemCell AdminProblemNewlyUnsupervised{adminProblemCompanyNew}
   = i18nCell MsgAdminProblemNewlyUnsupervised <> companyIdCell adminProblemCompanyNew
-adminProblemCell AdminProblemUnknown{adminProblemText}  
+adminProblemCell AdminProblemUnknown{adminProblemText}
   = textCell $ "Problem: " <> adminProblemText
 
 company2msg :: CompanyId -> SomeMessage UniWorX
 company2msg = text2message . ciOriginal . unCompanyKey
 
-msgAdminProblem :: AdminProblem -> DB (SomeMessages UniWorX) 
-msgAdminProblem AdminProblemNewCompany{adminProblemCompany=comp} = return $ 
+-- used to enable filtering, must correspond to function adminProblemCell shown above
+adminProblem2Text :: AdminProblem -> DB Text
+adminProblem2Text adprob = do
+  MsgRenderer mr <- getMsgRenderer
+  case adprob of
+    AdminProblemNewCompany{}
+      -> return $ mr MsgAdminProblemNewCompany
+    AdminProblemSupervisorNewCompany{adminProblemSupervisorReroute, adminProblemCompanyNew}
+      -> return $ mr $ SomeMessages [SomeMessage $ MsgAdminProblemSupervisorNewCompany adminProblemSupervisorReroute, company2msg adminProblemCompanyNew]
+    AdminProblemSupervisorLeftCompany{adminProblemSupervisorReroute}
+      -> return $ mr (MsgAdminProblemSupervisorLeftCompany adminProblemSupervisorReroute)
+    AdminProblemCompanySuperiorChange{adminProblemUserOld=mbuid}
+      -> maybeT (return $ mr MsgAdminProblemCompanySuperiorChange) $ do
+          uid <- MaybeT $ pure mbuid
+          User{userDisplayName = udn, userSurname = usn} <- MaybeT $ get uid
+          pure $ mr $ SomeMessages [SomeMessage MsgAdminProblemCompanySuperiorChange, SomeMessage MsgAdminProblemCompanySuperiorPrevious, SomeMessage udn, SomeMessage usn]
+    -- AdminProblemCompanySuperiorChange{adminProblemUserOld=Nothing}
+    --   -> return $ mr MsgAdminProblemCompanySuperiorChange
+    -- AdminProblemCompanySuperiorChange{adminProblemUserOld=Just uid}
+    --   -> get uid >>= \case
+    --       Nothing ->
+    --         return $ mr MsgAdminProblemCompanySuperiorChange
+    --       Just User{userDisplayName = udn, userSurname = usn} ->
+    --         return $ mr $ SomeMessages [SomeMessage MsgAdminProblemCompanySuperiorChange, SomeMessage MsgAdminProblemCompanySuperiorPrevious, SomeMessage udn, SomeMessage usn]
+    AdminProblemCompanySuperiorNotFound{adminProblemUserOld=mbuid, adminProblemEmail=eml}
+      ->  let basemsg = MsgAdminProblemCompanySuperiorNotFound $ fromMaybe "???" eml
+          in  maybeT (return $ mr basemsg) $ do
+            uid <- MaybeT $ pure mbuid
+            User{userDisplayName = udn, userSurname = usn} <- MaybeT $ get uid
+            pure $ mr $ SomeMessages [SomeMessage basemsg, SomeMessage MsgAdminProblemCompanySuperiorPrevious, SomeMessage udn, SomeMessage usn]
+    AdminProblemNewlyUnsupervised{adminProblemCompanyNew}
+      -> return $ mr $ SomeMessages [SomeMessage MsgAdminProblemNewlyUnsupervised, company2msg adminProblemCompanyNew]
+    AdminProblemUnknown{adminProblemText}
+      -> return $ "Problem: " <> adminProblemText
+
+-- | Show AdminProblem as message, used in message pop-up after manually switching companies for a user
+msgAdminProblem :: AdminProblem -> DB (SomeMessages UniWorX)
+msgAdminProblem AdminProblemNewCompany{adminProblemCompany=comp} = return $
   SomeMessages [SomeMessage MsgAdminProblemNewCompany, text2message ": ", company2msg comp]
-msgAdminProblem AdminProblemSupervisorNewCompany{adminProblemCompany=comp, adminProblemCompanyNew=newComp, adminProblemSupervisorReroute=rer} = return $ 
+msgAdminProblem AdminProblemSupervisorNewCompany{adminProblemCompany=comp, adminProblemCompanyNew=newComp, adminProblemSupervisorReroute=rer} = return $
   SomeMessages [SomeMessage $ MsgAdminProblemSupervisorNewCompany rer, text2message ": ", company2msg comp, text2message " -> ", company2msg newComp]
-msgAdminProblem AdminProblemSupervisorLeftCompany{adminProblemCompany=comp, adminProblemSupervisorReroute=rer} = return $ 
+msgAdminProblem AdminProblemSupervisorLeftCompany{adminProblemCompany=comp, adminProblemSupervisorReroute=rer} = return $
   SomeMessages [SomeMessage $ MsgAdminProblemSupervisorLeftCompany rer, text2message ": ", company2msg comp]
-msgAdminProblem AdminProblemNewlyUnsupervised{adminProblemCompanyOld=comp, adminProblemCompanyNew=newComp} = return $ 
-  SomeMessages [SomeMessage MsgAdminProblemNewlyUnsupervised, text2message ": ", maybe (text2message "???") company2msg comp, text2message " -> ", company2msg newComp]
+msgAdminProblem AdminProblemCompanySuperiorChange{adminProblemCompany=comp} = return $
+  SomeMessages [SomeMessage   MsgAdminProblemCompanySuperiorChange, text2message ": ", company2msg comp]
+msgAdminProblem AdminProblemCompanySuperiorNotFound{adminProblemCompany=comp, adminProblemEmail=eml} = return $
+  SomeMessages [SomeMessage $ MsgAdminProblemCompanySuperiorNotFound $ fromMaybe "???" eml, text2message ": ", company2msg comp]
+msgAdminProblem AdminProblemNewlyUnsupervised{adminProblemCompanyOld=comp, adminProblemCompanyNew=newComp} = return $
+  SomeMessages [SomeMessage   MsgAdminProblemNewlyUnsupervised, text2message ": ", maybe (text2message "???") company2msg comp, text2message " -> ", company2msg newComp]
 msgAdminProblem AdminProblemUnknown{adminProblemText=err} = return $
-  someMessages ["Problem: ", err]  
+  someMessages ["Problem: ", err]
 
 updateAutomatic :: Bool -> Widget
 -- updateAutomatic = iconTooltip [whamlet|_{MsgNoAutomaticUpdateTip}|] (Just IconLocked)
@@ -198,4 +246,3 @@ updateAutomatic True  = mempty
 updateAutomatic False = do
   msg <- messageIconI Warning IconLocked MsgNoAutomaticUpdateTip
   messageTooltip msg
-  

src/Handler/Utils/Avs.hs

@@ -14,7 +14,7 @@ module Handler.Utils.Avs
   , upsertAvsUserById
   , updateAvsUserByIds
   , linktoAvsUserByUIDs
-  , queueAvsUpdateByUID, queueAvsUpdateByAID  
+  , queueAvsUpdateByUID, queueAvsUpdateByAID
   -- , getLicence, getLicenceDB, getLicenceByAvsId -- not supported by interface
   , AvsLicenceDifferences(..)
   , setLicence, setLicenceAvs, setLicencesAvs
@@ -22,13 +22,13 @@ module Handler.Utils.Avs
   , computeDifferingLicences
   -- , synchAvsLicences
   , queryAvsFullStatus
-  -- , lookupAvsUser, lookupAvsUsers
+  , lookupAvsUser, lookupAvsUsers
   , AvsException(..)
   , updateReceivers
   , AvsPersonIdMapPersonCard
-  -- CR3 
+  -- CR3
   , SomeAvsQuery(..)
-  , queryAvsCardNo, queryAvsCardNos  
+  , queryAvsCardNo, queryAvsCardNos
   ) where
 
 import Import
@@ -51,6 +51,7 @@ import Jobs.Queue
 
 import Utils.Avs
 import Utils.Users
+-- import Utils.Mail (validEmail)
 import Handler.Utils.Users
 import Handler.Utils.Company
 import Handler.Utils.Qualification
@@ -98,22 +99,22 @@ catchAVS2log :: (MonadHandler m, MonadCatch m, RenderMessage (HandlerSite m) Avs
 catchAVS2log = catchAVShandler False True False Nothing
 
 catchAll2log :: (MonadHandler m, MonadCatch m, RenderMessage (HandlerSite m) AvsException) => m a -> m ()
-catchAll2log  = voidMaybe $ catchAVShandler True True False Nothing
+catchAll2log  = voidMaybe catchAll2log'
 
--- catchAll2log' :: (MonadHandler m, MonadCatch m, RenderMessage (HandlerSite m) AvsException, Monoid a) => m a -> m ()
--- catchAll2log' = voidMaybe $ catchAVShandler True True False mempty
+catchAll2log' :: (MonadHandler m, MonadCatch m, RenderMessage (HandlerSite m) AvsException) => m (Maybe a) -> m (Maybe a)
+catchAll2log' = catchAVShandler True True False Nothing
 
 catchAVShandler :: (MonadHandler m, MonadCatch m, RenderMessage (HandlerSite m) AvsException) => Bool -> Bool -> Bool -> a -> m a -> m a
 catchAVShandler allEx toLog toMsg dft act = act `catches` (avsHandlers <> allHandlers)
   where
-    avsHandlers = 
-      [ Catch.Handler (\(exc::AvsException) -> liftHandler $ do             
+    avsHandlers =
+      [ Catch.Handler (\(exc::AvsException) -> liftHandler $ do
             let txt = "AVS exception ignored: " <> tshow exc
             when toLog $ $logErrorS "AVS" txt
             when toMsg $ addMessageI Warning exc
             return dft
           )
-        
+
       , Catch.Handler (\(exc::ClientError ) -> liftHandler $ do
             let txt = "AVS fatal communicaton failure: " <> tshow exc
             when toLog $ $logErrorS "AVS" txt
@@ -139,8 +140,8 @@ catchAVShandler allEx toLog toMsg dft act = act `catches` (avsHandlers <> allHan
 -- convenience wrapper for easy replacement with true status query
 queryAvsFullStatus :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) => AvsPersonId -> m AvsResponseStatus
 queryAvsFullStatus api =
-  lookupAvsUser api <&> \case     
-    Just AvsDataPerson{avsPersonPersonCards=cards} 
+  lookupAvsUser api <&> \case
+    Just AvsDataPerson{avsPersonPersonCards=cards}
       | notNull cards -> AvsResponseStatus $ Set.singleton $ AvsStatusPerson api cards
     _otherwise        -> AvsResponseStatus   mempty
 
@@ -158,7 +159,7 @@ lookupAvsUser api = Map.lookup api <$> lookupAvsUsers (Set.singleton api)
 --   Does not write to our own DB!
 lookupAvsUsers :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) =>
                    Set AvsPersonId -> m (Map AvsPersonId AvsDataPerson)
-lookupAvsUsers apis = do  
+lookupAvsUsers apis = do
   AvsResponseStatus statuses <- avsQuery $ AvsQueryStatus apis
   let forFoldlM = $(permuteFun [3,2,1]) foldlM
   forFoldlM statuses mempty $ \acc1 AvsStatusPerson{avsStatusPersonCardStatus=cards} ->
@@ -171,15 +172,15 @@ lookupAvsUsers apis = do
 updateReceivers :: UserId -> Handler  (Entity User, [Entity User], Bool)
 updateReceivers uid = do
   -- First perform AVS update for receiver
-  runDB (getBy (UniqueUserAvsUser uid)) >>= \case 
+  runDBRead (getBy (UniqueUserAvsUser uid)) >>= \case
       Just Entity{entityVal=UserAvs{userAvsPersonId = apid}} -> catchAll2log $ upsertAvsUserById apid
-      Nothing -> return ()    
+      Nothing -> return ()
   -- Retrieve updated user and supervisors now
-  (underling :: Entity User, avsSupers :: [(E.Value UserId, E.Value (Maybe AvsPersonId))]) <- runDB $ (,)
-    <$> getJustEntity uid    
+  (underling :: Entity User, avsSupers :: [(E.Value UserId, E.Value (Maybe AvsPersonId))]) <- runDBRead $ (,)
+    <$> getJustEntity uid
     <*> (E.select $ do
           (usrSuper :& usrAvs) <-
-            E.from $     E.table @UserSupervisor            
+            E.from $     E.table @UserSupervisor
             `E.leftJoin` E.table @UserAvs
             `E.on` (\(usrSuper :& userAvs) -> usrSuper E.^. UserSupervisorSupervisor E.=?. userAvs E.?. UserAvsUser)
           E.where_ $ (usrSuper E.^. UserSupervisorUser E.==. E.val uid)
@@ -187,14 +188,14 @@ updateReceivers uid = do
           pure (usrSuper E.^. UserSupervisorSupervisor, usrAvs E.?. UserAvsPersonId)
         )
   let (superVs, avsIds) = unzip avsSupers
-      receiverIDs :: [UserId] = E.unValue <$> superVs      
+      receiverIDs :: [UserId] = E.unValue <$> superVs
       toUpdate = Set.fromList $ mapMaybe E.unValue avsIds
       directResult = return (underling, pure underling, True)             -- already contains updated address
   forM_ toUpdate (catchAll2log . upsertAvsUserById)   -- attempt to update postaddress from AVS
-  if null receiverIDs 
+  if null receiverIDs
     then directResult
-    else do 
-      receivers <- runDB $ selectList [UserId <-. receiverIDs] [] -- due to possible address updates, we must runDB once more and cannot join above
+    else do
+      receivers <- runDBRead $ selectList [UserId <-. receiverIDs] [] -- due to possible address updates, we must runDB once more and cannot join above
       if null receivers
         then directResult
         else return (underling, receivers, uid `elem` (entityKey <$> receivers))
@@ -205,8 +206,8 @@ updateReceivers uid = do
 
 
 -- | `SomeAvsQuery` is an umbrella to unify usage of all AVS queries, since Servant required separate types to fit the existing AVS-VSM API
-class SomeAvsQuery q where 
-  type SomeAvsResponse q :: Type  
+class SomeAvsQuery q where
+  type SomeAvsResponse q :: Type
   pickQuery       :: (MonadIO m) => AvsQuery -> q -> m (Either ClientError (SomeAvsResponse q))
   -- | send query to AVS or maybe look it up within cache, depending on the type of the query
   avsQuery        :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m) => q -> m (SomeAvsResponse q)
@@ -217,13 +218,13 @@ class SomeAvsQuery q where
 
 avsQueryNoCacheDefault :: (SomeAvsQuery q
                   ,   MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m) => q -> m (SomeAvsResponse q)
-avsQueryNoCacheDefault qry = do 
+avsQueryNoCacheDefault qry = do
     qfun <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ preview (_appAvsQuery . _Just . to pickQuery)
     throwLeftM $ qfun qry
 
 avsQueryCached :: (SomeAvsQuery q, Binary q, Binary (SomeAvsResponse q), Typeable (SomeAvsResponse q), NFData (SomeAvsResponse q)
                   ,   MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m) => q -> m (SomeAvsResponse q)
-avsQueryCached qry = 
+avsQueryCached qry =
   getsYesod (preview $ _appAvsConf . _Just . _avsCacheExpiry) >>= \case
     Just t | t > 1  -> memcachedBy (Just $ Right t) qry $ avsQueryNoCache qry
     _               ->                                    avsQueryNoCache qry
@@ -232,7 +233,7 @@ instance SomeAvsQuery AvsQueryPerson where
   type SomeAvsResponse AvsQueryPerson = AvsResponsePerson
   pickQuery = avsQueryPerson
   avsQuery  = avsQueryCached
-            
+
 instance SomeAvsQuery AvsQueryStatus where
   type SomeAvsResponse AvsQueryStatus = AvsResponseStatus
   pickQuery = avsQueryStatus
@@ -246,24 +247,24 @@ instance SomeAvsQuery AvsQueryContact where
 instance SomeAvsQuery AvsQuerySetLicences where
   type SomeAvsResponse AvsQuerySetLicences = AvsResponseSetLicences
   pickQuery = avsQuerySetLicences
-  -- NOTE: avsQuery  = avsQueryCached -- should not and indeed does not compile  
-  avsQueryNoCache qry = avsQueryNoCacheDefault qry 
+  -- NOTE: avsQuery  = avsQueryCached -- should not and indeed does not compile
+  avsQueryNoCache qry = avsQueryNoCacheDefault qry
     <* memcachedInvalidate (Proxy @AvsResponseContact) -- invalidate all AvsResponseContact which may contain RampLicence info, since keys may comprise several ids
 
 instance SomeAvsQuery AvsQueryGetAllLicences where
   type SomeAvsResponse AvsQueryGetAllLicences = AvsResponseGetLicences
   pickQuery = const . avsQueryGetAllLicences
-  
+
 
 
 queryAvsCardNos :: Foldable t => t (Either AvsCardNo AvsFullCardNo) -> Handler (Set AvsPersonId)
 queryAvsCardNos = foldMapM queryAvsCardNo
 
 queryAvsCardNo :: Either AvsCardNo AvsFullCardNo -> Handler (Set AvsPersonId)
-queryAvsCardNo crd = do 
+queryAvsCardNo crd = do
     AvsResponsePerson adps <- avsQuery $ qry crd
     return $ Set.map avsPersonPersonID adps
-  where 
+  where
     qry (Left acno)               = def{ avsPersonQueryCardNo     = Just acno }
     qry (Right AvsFullCardNo{..}) = def{ avsPersonQueryCardNo     = Just avsFullCardNo
                                        , avsPersonQueryVersionNo  = Just avsFullCardVersion
@@ -271,7 +272,7 @@ queryAvsCardNo crd = do
 
 -- | Queries AVS Status to retrieve primary card (heursitic)
 queryAvsPrimaryCard :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m) => AvsPersonId -> m (Maybe AvsDataPersonCard)
-queryAvsPrimaryCard api = runMaybeT $ do 
+queryAvsPrimaryCard api = runMaybeT $ do
   AvsResponseStatus res <- MaybeT . catchAVS2log . fmap Just . avsQuery . AvsQueryStatus $ Set.singleton api
   pstatus <- hoistMaybe $ Set.lookupMax $ Set.filter ((api ==) . avsStatusPersonID) res
   hoistMaybe $ Set.lookupMax $ avsStatusPersonCardStatus pstatus
@@ -285,7 +286,7 @@ queryAvsFullCardNo = fmap (fmap getFullCardNo) . queryAvsPrimaryCard
 
 -- | Like `updateAvsUserByIds`, but exceptions are not caught here to allow rollbacks
 updateAvsUserById :: AvsPersonId -> DB (Maybe UserId)
-updateAvsUserById apid = do 
+updateAvsUserById apid = do
   AvsResponseContact adcs <- avsQuery $ AvsQueryContact $ Set.singleton $ AvsObjPersonId apid
   let res = Set.filter ((== apid) . avsContactPersonID) adcs
   snd <<$>> traverseJoin updateAvsUserByADC (Set.lookupMax res)
@@ -306,10 +307,10 @@ updateAvsUserByIds' apids = do
       now <- liftIO getCurrentTime
       runDB $ updateWhere [UserAvsPersonId <-. missing] [UserAvsLastSynch =. now, UserAvsLastSynchError =. Just "Avs contact info unknown for AvsPersonId"] -- all others were already marked as updated
     return oks
-  where 
+  where
     procResp :: (Set (AvsPersonId, UserId), Set AvsPersonId) -> AvsDataContact -> Handler (Set (AvsPersonId, UserId), Set AvsPersonId)
     procResp (accOk, accBad) adc = do
-      let errHandler e = runDB $ do 
+      let errHandler e = runDB $ do
             let apid = avsContactPersonID adc
             now <- liftIO getCurrentTime
             updateBy (UniqueUserAvsId apid) [UserAvsLastSynch =. now, UserAvsLastSynchError =. Just (tshow e)]
@@ -319,27 +320,32 @@ updateAvsUserByIds' apids = do
             res <- updateAvsUserByADC adc
             return (maybeInsert res accOk, accBad)
       catchAll (runDB updateAvsUserByADC') errHandler
-      
+
 
 
 updateAvsUserByADC :: AvsDataContact -> DB (Maybe (AvsPersonId, UserId))
-updateAvsUserByADC (AvsDataContact apid newAvsPersonInfo newAvsFirmInfo) = runMaybeT $ do
-      (Entity uaId usravs) <- MaybeT $ getBy $ UniqueUserAvsId apid      
+updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAvsFirmInfo) = runMaybeT $ do
+      (Entity uaId usravs) <- MaybeT $ getBy $ UniqueUserAvsId apid
       let usrId = userAvsUser usravs
       usr <- MaybeT $ get usrId
       lift $ do -- maybeT no longer needed from here onwards
-        let oldAvsPersonInfo = userAvsLastPersonInfo usravs   -- Nothing is ok here
-            oldAvsFirmInfo   = userAvsLastFirmInfo   usravs   -- Nothing is ok here
-            oldAvsCardNo     = userAvsLastCardNo     usravs & fmap Just
+        uuid :: CryptoUUIDUser <- encrypt usrId
+        $logInfoS "AVS" [st|updateAvsUserByADC: #{tshow uuid}|]
+        let oldAvsPersonInfo  = userAvsLastPersonInfo usravs   -- Nothing is ok here
+            oldAvsFirmInfo    = userAvsLastFirmInfo   usravs   -- Nothing is ok here
+            oldAvsCardNo      = userAvsLastCardNo     usravs & fmap Just
+            oldAvsDataContact = case (oldAvsPersonInfo, oldAvsFirmInfo) of
+                                  (Just oapi, Just oafi) -> Just $ AvsDataContact apid oapi oafi
+                                  _ -> Nothing
         newAvsCardNo <- queryAvsFullCardNo apid               -- Nothing os ok here, does not throw
         now <- liftIO getCurrentTime
         mbLdapExpire <- getsYesod $ views appSettings appSynchroniseLdapUsersExpire
         ldap_ups <- if  | Just ldapExpire   <- mbLdapExpire
                         , maybe True (\lastLdapSync -> now > addUTCTime ldapExpire lastLdapSync) (userLastLdapSynchronisation usr)
-                        , Just udep <- userCompanyDepartment usr              
+                        , Just udep <- userCompanyDepartment usr
                         , let aipn = newAvsPersonInfo ^? _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo
                               depKey = CompanyKey $ stripCI udep -- Shorthand is returned by LDAP
-                          -> do -- LDAP sync invalid/expired                          
+                          -> do -- LDAP sync invalid/expired
                             usrComp <- getBy $ UniqueUserCompany usrId depKey
                             whenIsJust usrComp $ \Entity{entityKey=ucKey, entityVal=UserCompany{userCompanySupervisor=isSuper, userCompanySupervisorReroute=rroute}} -> do
                               delete ucKey
@@ -354,21 +360,20 @@ updateAvsUserByADC (AvsDataContact apid newAvsPersonInfo newAvsFirmInfo) = runMa
                               (mkCheckUpdate CU_API_UserLdapPrimaryKey)
                               [mkCheckUpdate CU_API_UserCompanyPersonalNumber]
         let per_ups = mapMaybe (mkUpdate' usr newAvsPersonInfo oldAvsPersonInfo . mkCheckUpdate)
-                      [ CU_API_UserFirstName            
-                      , CU_API_UserSurname              
-                      , CU_API_UserDisplayName          
-                      , CU_API_UserBirthday             
-                      , CU_API_UserMobile               
-                      , CU_API_UserMatrikelnummer       
+                      [ CU_API_UserFirstName
+                      , CU_API_UserSurname
+                      , CU_API_UserDisplayName
+                      , CU_API_UserBirthday
+                      , CU_API_UserMobile
+                      , CU_API_UserMatrikelnummer
                       -- , CU_API_UserCompanyPersonalNumber -- needs special treatment, see ldap_ups above
                       ]
-            eml_up =  let em_p_up = mkUpdate usr newAvsPersonInfo oldAvsPersonInfo  $ mkCheckUpdate CU_API_UserDisplayEmail 
-                          em_f_up = mkUpdate usr newAvsFirmInfo   oldAvsFirmInfo    $ mkCheckUpdate CU_AFI_UserDisplayEmail
-                      in  em_f_up <|> em_p_up                                                                                             -- Email updates erfolgen nur, wenn identisch. Für Firmen-Email leer lassen.          
-            frm_up  = mkUpdate' usr newAvsFirmInfo   oldAvsFirmInfo    $ mkCheckUpdate CU_AFI_UserPostAddress                             -- Legacy, if company postal is stored in user; should no longer be true for new users, since company address should now be referenced with UserCompany instead
-            pin_up  = mkUpdate' usr newAvsCardNo     oldAvsCardNo      $                                                                  -- Maybe update PDF pin to latest card
+            eml_up  = mkUpdate  usr newAvsDataContact oldAvsDataContact $ mkCheckUpdate CU_ADC_UserDisplayEmail                            -- DisplayEmail updates erfolgen nur, wenn identisch. Für Firmen-Email leer lassen.
+            -- eml_up2 = mkUpdate  usr newAvsFirmInfo   oldAvsFirmInfo     $ mkCheckUpdate CU_AFI_UserEmail                                -- Email update erfolgt nur, wenn hier die SuperiorEmail als Fallback gespeichert wurde; UserEmail Uniqueness nicht gewährleistet
+            frm_up  = mkUpdate' usr newAvsFirmInfo   oldAvsFirmInfo     $ mkCheckUpdate CU_AFI_UserPostAddress                             -- Legacy, if company postal is stored in user; should no longer be true for new users, since company address should now be referenced with UserCompany instead
+            pin_up  = mkUpdate' usr newAvsCardNo     oldAvsCardNo       $                                                                  -- Maybe update PDF pin to latest card
                         CheckUpdate UserPinPassword $ to $ fmap avsFullCardNo2pin -- _Just . to avsFullCardNo2pin . re _Just
-            usr_up1 = eml_up `mcons` (frm_up `mcons` (pin_up `mcons` (ldap_ups <> per_ups)))
+            usr_up1 = mconss [eml_up, frm_up, pin_up] $ ldap_ups <> per_ups
             avs_ups = ((UserAvsNoPerson =.) <$> readMay (avsInfoPersonNo newAvsPersonInfo)) `mcons`
                       [ UserAvsLastSynch      =. now
                       , UserAvsLastSynchError =. Nothing
@@ -376,82 +381,83 @@ updateAvsUserByADC (AvsDataContact apid newAvsPersonInfo newAvsFirmInfo) = runMa
                       , UserAvsLastFirmInfo   =. Just newAvsFirmInfo
                       , UserAvsLastCardNo     =. newAvsCardNo
                       ]
-            
-        -- update company association & supervision
-        Entity{entityKey=newCompanyId} <- upsertAvsCompany newAvsFirmInfo oldAvsFirmInfo
-        oldCompanyEnt <- getAvsCompany `traverseJoin` oldAvsFirmInfo
-        primaryCompanyId <- userCompanyCompany <<$>> getUserPrimaryCompany usrId
-        let oldCompanyId = entityKey <$> oldCompanyEnt
-            -- oldCompanyMb = entityVal <$> oldCompanyEnt
-            -- pst_up  = if  
-            --           -- | isNothing oldCompanyMb || oldCompanyId == primaryCompanyId                                              -- refactor could replace next 4 lines
-            --           --   -> mkUpdate'      usr newCompany oldCompanyMb $ CheckUpdate UserPrefersPostal _companyPrefersPostal  -- always update if company association is fresh (case should not occur in practice though)
-            --           | isNothing oldCompanyMb 
-            --             -> mkUpdateDirect usr newCompany              $ CheckUpdate UserPrefersPostal _companyPrefersPostal  -- always update if company association is fresh (case should not occur in practice though)
-            --           | oldCompanyId == primaryCompanyId -- && isJust oldCompanyId -- is ensured by previous line
-            --             -> mkUpdate       usr newCompany oldCompanyMb $ CheckUpdate UserPrefersPostal _companyPrefersPostal  -- possibly change postal preference
-            --           | otherwise
-            --             -> Nothing
-            superReasonComDef = tshow SupervisorReasonCompanyDefault
-            newUserComp = UserCompany usrId newCompanyId False False 1 True -- default value for new company insertion, if no update can be done
-        
 
-        usr_up2 <- case oldAvsFirmInfo of 
-          _ | Just newCompanyId == oldCompanyId                                               -- company unchanged entirely
-              -> return mempty                                                                --  => do nothing
-          (Just oafi) |  isJust    (view _avsFirmPostAddressSimple  oafi) 
-                      && ((==) `on` view _avsFirmPostAddressSimple) oafi newAvsFirmInfo       -- non-empty company address unchanged OR
-                      || isJust    (view _avsFirmPrimaryEmail       oafi)
-                      && ((==) `on` view _avsFirmPrimaryEmail)      oafi newAvsFirmInfo       -- non-empty company primary email unchanged
-              -> do                                                                           --  => just update user company association, keeping supervision privileges                  
-                  case oldCompanyId of
-                    Nothing -> void $ insertUnique newUserComp -- it's ok if this already exists
-                    Just ocid -> do 
-                      void $ upsertBySafe (UniqueUserCompany usrId ocid) newUserComp (_userCompanyCompany .~ newCompanyId)  -- keep default supervisor settings
-                      void $ updateWhere [ UserSupervisorSupervisor ==. usrId                                               -- update company-related supervisions
-                                         , UserSupervisorCompany ==. Just ocid                                              -- to new company, regardless of 
-                                         , UserSupervisorReason ==. Just superReasonComDef]                                 -- user 
-                                         [ UserSupervisorCompany =. Just newCompanyId]
-                  return mempty
-          _ | Just newCompanyId == primaryCompanyId                                           -- old primaryCompany is now also AVS-company
-              -> do
-                  whenIsJust oldCompanyId $ \oldCid -> do 
-                    deleteBy $ UniqueUserCompany usrId oldCid
-                    deleteWhere $ (UserSupervisorUser ==. usrId):(UserSupervisorCompany ==. oldCompanyId):(UserSupervisorReason ~=. superReasonComDef)
-                  return mempty
-          _                                                                                   -- company changed completely 
-              -> do 
-                  (pst_up, problems) <- switchAvsUserCompany False False usrId newCompanyId
-                  mapM_ reportAdminProblem problems
-                  -- Following line does not type, hence additional parameter needed
-                  -- return [ u | u@Update{updateField=f} <- pst_up, f /= UserPostAddress ] -- already computed in frm_up above, duplicate update must be prevented (version above accounts for legacy updates) 
-                  return pst_up 
-                  -- SPECIALISED CODE, PROBABLY DEPRECATED
-                  -- switch user company, keeping old priority
-                  -- (getBy . UniqueUserCompany usrId) `traverseJoin` oldCompanyId >>= \case
-                  --   Nothing ->
-                  --     void $ insertUnique newUserComp
-                  --   Just Entity{entityKey=ucidOld, entityVal=UserCompany{userCompanyCompany, userCompanySupervisor, userCompanySupervisorReroute, userCompanyPriority}} -> do
-                  --     when userCompanySupervisor $ reportAdminProblem $ AdminProblemSupervisorNewCompany usrId userCompanyCompany newCompanyId userCompanySupervisorReroute
-                  --     delete ucidOld
-                  --     void $ insertUnique newUserComp{userCompanyPriority} -- keep priority, if insert succeeds
-                  -- -- adjust supervison
-                  -- let oldCompDefSuperFltr = mconcat [UserSupervisorCompany ~~. oldCompanyId, UserSupervisorReason ~=. superReasonComDef]
-                  -- deleteWhere $          (UserSupervisorSupervisor ==. usrId) : oldCompDefSuperFltr
-                  -- oldAPs <- deleteWhereCount $ (UserSupervisorUser ==. usrId) : oldCompDefSuperFltr
-                  -- addCompanySupervisors newCompanyId usrId
-                  -- newAPs <- count $ (UserSupervisorUser ==. usrId) : (UserSupervisorCompany ==. Just newCompanyId) : (UserSupervisorReason ~=. superReasonComDef)
-                  -- when (oldAPs > 0 && newAPs <= 0) $ reportAdminProblem $ AdminProblemNewlyUnsupervised usrId oldCompanyId newCompanyId
-                  -- return pst_up 
-        repsertSuperiorSupervisor (Just newCompanyId) newAvsFirmInfo usrId        -- ensure firmInfo superior is at least normal supervisor, must be executed after updating company default supervisors                
-        update usrId $ usr_up2 <> usr_up1                                         -- update user eventually
-        update uaId    avs_ups                                                    -- update stored avsinfo for future updates
+        usr_up2 <- guardMonoidM (oldAvsFirmInfo /= Just newAvsFirmInfo) $ do
+          -- update company association & supervision
+          newCompanyEnt@Entity{entityKey=newCompanyId} <- upsertAvsCompany newAvsFirmInfo oldAvsFirmInfo
+          upsertCompanySuperior newCompanyEnt newAvsFirmInfo oldAvsFirmInfo usrId   -- ensure firmInfo superior is supervisor for this user
+          oldCompanyEnt <- getAvsCompany `traverseJoin` oldAvsFirmInfo
+          primaryCompanyId <- userCompanyCompany <<$>> getUserPrimaryCompany usrId
+          let oldCompanyId = entityKey <$> oldCompanyEnt
+              -- oldCompanyMb = entityVal <$> oldCompanyEnt
+              -- pst_up  = if
+              --           -- | isNothing oldCompanyMb || oldCompanyId == primaryCompanyId                                              -- refactor could replace next 4 lines
+              --           --   -> mkUpdate'      usr newCompany oldCompanyMb $ CheckUpdate UserPrefersPostal _companyPrefersPostal  -- always update if company association is fresh (case should not occur in practice though)
+              --           | isNothing oldCompanyMb
+              --             -> mkUpdateDirect usr newCompany              $ CheckUpdate UserPrefersPostal _companyPrefersPostal  -- always update if company association is fresh (case should not occur in practice though)
+              --           | oldCompanyId == primaryCompanyId -- && isJust oldCompanyId -- is ensured by previous line
+              --             -> mkUpdate       usr newCompany oldCompanyMb $ CheckUpdate UserPrefersPostal _companyPrefersPostal  -- possibly change postal preference
+              --           | otherwise
+              --             -> Nothing
+              superReasonComDef = tshow SupervisorReasonCompanyDefault
+              newUserComp = UserCompany usrId newCompanyId False False 1 True Nothing -- default value for new company insertion, if no update can be done
+
+          case oldAvsFirmInfo of
+            _ | Just newCompanyId == oldCompanyId                                               -- company unchanged entirely
+                -> return mempty                                                                --  => do nothing
+            (Just oafi) |  isJust    (view _avsFirmPostAddressSimple  oafi)
+                        && ((==) `on` view _avsFirmPostAddressSimple) oafi newAvsFirmInfo       -- non-empty company address unchanged OR
+                        || isJust    (view _avsFirmPrimaryEmail       oafi)
+                        && ((==) `on` view _avsFirmPrimaryEmail)      oafi newAvsFirmInfo       -- non-empty company primary email unchanged
+                -> do                                                                           --  => just update user company association, keeping supervision privileges
+                    case oldCompanyId of
+                      Nothing -> void $ insertUnique newUserComp -- it's ok if this already exists
+                      Just ocid -> do
+                        void $ upsertBySafe (UniqueUserCompany usrId ocid) newUserComp (_userCompanyCompany .~ newCompanyId)  -- keep default supervisor settings
+                        void $ updateWhere [ UserSupervisorSupervisor ==. usrId                                               -- update company-related supervisions
+                                          , UserSupervisorCompany ==. Just ocid                                              -- to new company, regardless of
+                                          , UserSupervisorReason ==. Just superReasonComDef]                                 -- user
+                                          [ UserSupervisorCompany =. Just newCompanyId]
+                    return mempty
+            _ | Just newCompanyId == primaryCompanyId                                           -- old primaryCompany is now also AVS-company
+                -> do
+                    whenIsJust oldCompanyId $ \oldCid -> do
+                      deleteBy $ UniqueUserCompany usrId oldCid
+                      deleteWhere $ (UserSupervisorUser ==. usrId):(UserSupervisorCompany ==. oldCompanyId):(UserSupervisorReason ~=. superReasonComDef)
+                    return mempty
+            _                                                                                   -- company changed completely
+                -> do
+                    (pst_up, problems) <- switchAvsUserCompany False False usrId newCompanyId
+                    mapM_ reportAdminProblem problems
+                    -- Following line does not type, hence additional parameter needed
+                    -- return [ u | u@Update{updateField=f} <- pst_up, f /= UserPostAddress ] -- already computed in frm_up above, duplicate update must be prevented (version above accounts for legacy updates)
+                    return pst_up
+                    -- SPECIALISED CODE, PROBABLY DEPRECATED
+                    -- switch user company, keeping old priority
+                    -- (getBy . UniqueUserCompany usrId) `traverseJoin` oldCompanyId >>= \case
+                    --   Nothing ->
+                    --     void $ insertUnique newUserComp
+                    --   Just Entity{entityKey=ucidOld, entityVal=UserCompany{userCompanyCompany, userCompanySupervisor, userCompanySupervisorReroute, userCompanyPriority}} -> do
+                    --     when userCompanySupervisor $ reportAdminProblem $ AdminProblemSupervisorNewCompany usrId userCompanyCompany newCompanyId userCompanySupervisorReroute
+                    --     delete ucidOld
+                    --     void $ insertUnique newUserComp{userCompanyPriority} -- keep priority, if insert succeeds
+                    -- -- adjust supervison
+                    -- let oldCompDefSuperFltr = mconcat [UserSupervisorCompany ~~. oldCompanyId, UserSupervisorReason ~=. superReasonComDef]
+                    -- deleteWhere $          (UserSupervisorSupervisor ==. usrId) : oldCompDefSuperFltr
+                    -- oldAPs <- deleteWhereCount $ (UserSupervisorUser ==. usrId) : oldCompDefSuperFltr
+                    -- addDefaultSupervisors' newCompanyId $ singleton usrId
+                    -- newAPs <- count $ (UserSupervisorUser ==. usrId) : (UserSupervisorCompany ==. Just newCompanyId) : (UserSupervisorReason ~=. superReasonComDef)
+                    -- when (oldAPs > 0 && newAPs <= 0) $ reportAdminProblem $ AdminProblemNewlyUnsupervised usrId oldCompanyId newCompanyId
+                    -- return pst_up
+        update usrId usr_up2                                         -- update user by company switch first (due to possible conflicts with usr_up2)
+        update usrId usr_up1                                         -- update user eventually
+        update uaId  avs_ups                                         -- update stored avsinfo for future updates
       return (apid, usrId)
 
 
 linktoAvsUserByUIDs :: Set UserId -> Handler ()
 linktoAvsUserByUIDs uids = do
-    ips <- runDB $ E.select $ do 
+    ips <- runDBRead $ E.select $ do
       usr <- E.from $ E.table @User
       let uid = usr E.^. UserId
           ipn = usr E.^. UserCompanyPersonalNumber
@@ -462,8 +468,8 @@ linktoAvsUserByUIDs uids = do
               E.where_ $ uid E.==. usrAvs E.^. UserAvsUser
             )
       return (uid, ipn)
-    mapM_ procUsr ips 
-  where 
+    mapM_ procUsr ips
+  where
     procUsr (E.Value uid, E.Value (Just ipn)) = catchAll2log $ linktoAvsUserByUID uid $ mkAvsInternalPersonalNo ipn
     procUsr _ = return ()
 
@@ -480,102 +486,92 @@ linktoAvsUserByUID uid aipn = do
 -- createAvsUserById :: Set AvsPersonId -> Handler (Set (AvsPersonId, UserId)) ???
 -- | Create new user from AVS-Id. Will throw an AvsException if this is not possible, e.g. due to Uniqueness Constraints
 createAvsUserById :: Maybe UserId -> AvsPersonId -> Handler UserId
-createAvsUserById muid api = do 
+createAvsUserById muid api = do
   AvsResponseContact contactRes <- avsQuery $ AvsQueryContact $ Set.singleton $ AvsObjPersonId api
   case Set.toList contactRes of
     []      -> throwM $ AvsUserUnknownByAvs api
     (_:_:_) -> throwM $ AvsUserAmbiguous    api
-    [AvsDataContact{avsContactPersonInfo=cpi, avsContactFirmInfo=firmInfo, avsContactPersonID}]
+    [adc@AvsDataContact{avsContactPersonInfo=cpi, avsContactFirmInfo=firmInfo, avsContactPersonID}]
       | avsContactPersonID /= api -> throwM $ AvsIdMismatch api avsContactPersonID
       | otherwise -> do
         -- check for matching existing user
         let internalPersNo :: Maybe Text = cpi ^? _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo
-            persMail  :: Maybe UserEmail = cpi ^? _avsInfoPersonEMail . _Just . from _CI            
-        oldUsr <- runDB $ do 
-          mbUid <- if isJust muid
-              then return muid
-              else firstJustM $ catMaybes
-                [ internalPersNo <&> (\ipn -> getKeyByFilter [UserCompanyPersonalNumber ==. Just ipn]) -- must ensure filter isnt ==. Nothing
-                , persMail       <&> guessUserByEmail
-                ]          
+            -- persMail  :: Maybe UserEmail = cpi ^? _avsInfoPersonEMail . _Just . from _CI
+        oldUsr <- runDB $ do
+          mbUid <- firstJustM $ return muid : maybe [] (\ipn ->
+                [ getKeyByFilter [UserCompanyPersonalNumber ==. Just ipn] -- must ensure filter isnt ==. Nothing
+                , catchAll2log' (Just . entityKey <$> ldapLookupAndUpsert ipn) -- attempt to insert by LDAP first
+                ]
+                ) internalPersNo
           mbUAvs <- (getBy . UniqueUserAvsUser) `traverseJoin` mbUid
           return (mbUid, mbUAvs)
         usrCardNo <- queryAvsFullCardNo api
         now <- liftIO getCurrentTime
-        let usrAvs uid mbFirmInfo = UserAvs
+        let usrAvs uid  mbPersonInfo mbFirmInfo mbUsrCardNo = UserAvs
                   { userAvsPersonId       = api
                   , userAvsUser           = uid
                   , userAvsNoPerson       = fromMaybe (negate $ avsPersonId api) $ readMay $ cpi ^. _avsInfoPersonNo -- negative personId as fallback, but readMay should never fail
                   , userAvsLastSynch      = now
                   , userAvsLastSynchError = Nothing
-                  , userAvsLastPersonInfo = Just cpi
+                  , userAvsLastPersonInfo = mbPersonInfo
                   , userAvsLastFirmInfo   = mbFirmInfo
-                  , userAvsLastCardNo     = usrCardNo
-                  }  
-        case oldUsr of 
+                  , userAvsLastCardNo     = mbUsrCardNo
+                  }
+        case oldUsr of
           (Nothing , Just _) -> throwM $ AvsUserUnknownByAvs api -- this case should never occur
           (Just uid, Just Entity{entityVal=UserAvs{userAvsPersonId=api',userAvsUser=uid'}})
-            | api /= api' -> throwM $ AvsIdMismatch api api'          
+            | api /= api' -> throwM $ AvsIdMismatch api api'
             | uid /= uid' -> throwM $ AvsUserAmbiguous api
             | otherwise   -> return uid                         -- nothing to do
           (Just uid, Nothing) -> runDB $ do                     -- link with matching exisitng user
-            insert_ $ usrAvs uid Nothing                        -- company info should cause the user to be associated with the company during the update
+            insert_ $ usrAvs uid Nothing Nothing Nothing        -- all infos must be Nothing for subsequent update to work as intended
             updRes <- updateAvsUserById api                     -- no loop, since updateAvsUserById does not call createAvsUserById
             case updRes of
               Nothing         -> throwM $ AvsUserUnknownByAvs api
-              Just uid' 
+              Just uid'
                 | uid /= uid' -> throwM $ AvsUserAmbiguous api
                 | otherwise   -> return uid
           (Nothing, Nothing) -> do                              -- create fresh user
             Entity{entityKey=cid, entityVal=cmp} <- runDB $ upsertAvsCompany firmInfo Nothing -- individual runDB, since no need to rollback
             let pinPass = avsFullCardNo2pin <$> usrCardNo
+                -- superiorEmail = filterMaybe validEmail $ adc ^. _avsContactFirmInfo . _avsFirmEMailSuperior
                 newUserData = AddUserData
-                  { audTitle            = Nothing                
+                  { audTitle            = Nothing
                   , audFirstName        = cpi ^. _avsInfoFirstName    & Text.strip
                   , audSurname          = cpi ^. _avsInfoLastName     & Text.strip
-                  , audDisplayName      = cpi ^. _avsInfoDisplayName                
-                  , audDisplayEmail     = persMail & fromMaybe mempty
-                  , audEmail            = persMail & fromMaybe ("AVSNO:" <> cpi ^. _avsInfoPersonNo . from _CI)
-                  , audIdent            = persMail & fromMaybe ("AVSID:" <> ciShow api )
+                  , audDisplayName      = cpi ^. _avsInfoDisplayName
+                  , audDisplayEmail     = adc ^. _avsContactPrimaryEmail . to (fromMaybe mempty) . from _CI
+                  , audEmail            = "AVSNO:" <> cpi ^. _avsInfoPersonNo . from _CI
+                  , audIdent            = "AVSID:" <> ciShow api
                   , audAuth             = maybe AuthKindNoLogin (const AuthKindLDAP) internalPersNo
-                  , audMatriculation    = cpi ^. _avsInfoPersonNo     & Just . tshow
+                  , audMatriculation    = cpi ^. _avsInfoPersonNo     & Just
                   , audSex              = Nothing
                   , audBirthday         = cpi ^. _avsInfoDateOfBirth
-                  , audMobile           = cpi ^. _avsInfoPersonMobilePhoneNo 
+                  , audMobile           = cpi ^. _avsInfoPersonMobilePhoneNo
                   , audTelephone        = Nothing
                   , audFPersonalNumber  = internalPersNo
-                  , audFDepartment      = toMaybe (isJust internalPersNo) (cmp ^. _companyShorthand . _CI)                  
+                  , audFDepartment      = toMaybe (isJust internalPersNo) (cmp ^. _companyShorthand . _CI)
                   , audPostAddress      = Nothing -- always use company address indirectly
                   , audPrefersPostal    = cmp ^. _companyPrefersPostal
                   , audPinPassword      = pinPass
                   }
             runDB $ do        -- any failure must rollback all DB write transactions here
-              uid <- maybeThrowM (AvsUserCreationFailed api) $ addNewUserDB newUserData  
-              let userComp = UserCompany uid cid False False 1 True -- default value for new company insertion, if no update can be done
+              uid <- maybeThrowM (AvsUserCreationFailed api) $ addNewUserDB newUserData
+              let userComp = UserCompany uid cid False False 1 True Nothing -- default value for new company insertion, if no update can be done
               void $ insertUnique userComp -- Nothing indicates that the user is already linked to the company (which is unlikely here)
               -- Supervision
-              addCompanySupervisors cid uid
-              repsertSuperiorSupervisor (Just cid) firmInfo uid
+              void $ addDefaultSupervisors' cid $ singleton uid
               -- Save AVS data for future updates
-              insert_ $ usrAvs uid $ Just firmInfo -- unlikely that uid cannot be linked with avsid, but throw if it is not possible
+              insert_ $ usrAvs uid (Just cpi) (Just firmInfo) usrCardNo -- unlikely that uid cannot be linked with avsid, but throw if it is not possible
               return uid
-      
 
--- | upsert superior by eMail through LDAP only (currently no email search available in AVS)
-repsertSuperiorSupervisor :: Maybe CompanyId -> AvsFirmInfo -> UserId -> DB ()
-repsertSuperiorSupervisor cid afi uid = 
-  whenIsJust (afi ^. _avsFirmEMailSuperior) $ \supemail -> forMM_
-    (altM (guessUserByEmail $ stripCI supemail)
-          (catchAVShandler True True False Nothing $ Just . entityKey <$> ldapLookupAndUpsert supemail)            
-    ) $ \supid -> do
-      let reasonSuperior = Just $ tshow SupervisorReasonAvsSuperior
-      deleteWhere [UserSupervisorUser ==. uid, UserSupervisorSupervisor !=. supid, UserSupervisorReason ==. reasonSuperior]
-      void $ insertUnique $ UserSupervisor supid uid False cid reasonSuperior
 
+-- getAvsCompanyId :: AvsFirmInfo -> DB (Maybe CompanyId)
+-- getAvsCompanyId = fmap (fmap entityKey) . getAvsCompany
 
 -- | Query DB from given AvsFirmInfo. Guarantees that all Uniqueness-Constraints are checked. Highly unlikely that Nothing is returned, since all AvsResponseContact always contains an AvsFirmInfo
 getAvsCompany :: AvsFirmInfo -> DB (Maybe (Entity Company))
-getAvsCompany afi = 
+getAvsCompany afi =
   let compName      :: CompanyName
       compName       = afi ^. _avsFirmFirm . from _CI
       compShorthand :: CompanyShorthand
@@ -583,25 +579,27 @@ getAvsCompany afi =
       compAvsId      = afi ^. _avsFirmFirmNo
   in firstJustM $ -- legacy treatment, only use UniqueCompnayAvsId in the future
         guardMonoid (compAvsId > 0)
-        [ getBy     $ UniqueCompanyAvsId  compAvsId    
+        [ getBy     $ UniqueCompanyAvsId  compAvsId
         , getEntity $ CompanyKey        $ compShorthand <> "-" <> ciShow compAvsId
         ] <>
         [ getByFilter [CompanyName ==.    compName]
-        , getEntity $ CompanyKey          compShorthand        
+        , getEntity $ CompanyKey          compShorthand
         ]
 
 -- | insert a company from AVS firm info or update an existing one based on previous values
 upsertAvsCompany :: AvsFirmInfo -> Maybe AvsFirmInfo -> DB (Entity Company)
+-- upsertAvsCompany newAvsFirmInfo (Just oldAvsFirmInfo)
+--   | newAvsFirmInfo == oldAvsFirmInfo = maybeM (upsertAvsCompany newAvsFirmInfo Nothing) pure $ getAvsCompany newAvsFirmInfo  -- firmInfo unchanged, shortcircuit; SHORTCIRCUIT no longer needed, checked at call-site due to result not being wrapped in Maybe
 upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do
     mbFirmEnt <- getAvsCompany newAvsFirmInfo --  primarily by AvsId, then Shorthand, then name
-    $logInfoS "AVS" [st|upsertAvsCompany: old #{tshow mbFirmEnt} new #{tshow newAvsFirmInfo}|]
-    case (mbFirmEnt, mbOldAvsFirmInfo) of
-      (Nothing, _) -> do                                                                                  -- insert new company, neither AvsId nor Shorthand exist in DB
+    $logInfoS "AVS" [st|upsertAvsCompany: old #{tshow mbOldAvsFirmInfo} new #{tshow newAvsFirmInfo} ent-new #{tshow mbFirmEnt}|]
+    case mbFirmEnt of
+      Nothing -> do                                                                                  -- insert new company, neither AvsId nor Shorthand exist in DB
         afn <- if 0 < newAvsFirmInfo ^. _avsFirmFirmNo
                 then return $ newAvsFirmInfo ^. _avsFirmFirmNo
                 else maybe (-1) (pred . companyAvsId . entityVal) <$> selectMaybe [CompanyAvsId <. 0] [Asc CompanyAvsId]
         let upd  = flip updateRecord newAvsFirmInfo
-            dmy = Company                                                                                 -- mostly dummy, values are actually prodcued through firmInfo2company below for consistency
+            dmy = Company                                                                            -- mostly dummy, values are actually produced through firmInfo2company below for consistency
                   { companyName           = newAvsFirmInfo ^. _avsFirmFirm          . from _CI
                   , companyShorthand      = newAvsFirmInfo ^. _avsFirmAbbreviation  . from _CI
                   , companyAvsId          = afn
@@ -613,17 +611,18 @@ upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do
         $logInfoS "AVS" $ "Insert new company: " <> tshow cmp
         newCmp <- insertEntity cmp
         reportAdminProblem $ AdminProblemNewCompany $ entityKey newCmp
-        $logInfoS "AVS" "Insert new company completed."
         return newCmp
 
-      (Just Entity{entityKey=firmid, entityVal=firm}, oldAvsFirmInfo) -> do                               -- possibly update existing company, if isJust oldAvsFirmInfo and changed occurred
-        let cmp_ups = mapMaybe  (mkUpdate'            firm newAvsFirmInfo oldAvsFirmInfo) firmInfo2company            
+      (Just Entity{entityKey=firmid, entityVal=firm}) -> do                                          -- possibly update existing company, if isJust oldAvsFirmInfo and identical AvsFirmNo and changes occurred
+        let oldHasSameFirmNo = Just (newAvsFirmInfo ^. _avsFirmFirmNo) == (mbOldAvsFirmInfo ^? _Just . _avsFirmFirmNo)
+            oldAvsFirmInfo = guardOnM oldHasSameFirmNo mbOldAvsFirmInfo
+            cmp_ups = mapMaybe  (mkUpdate'            firm newAvsFirmInfo oldAvsFirmInfo) firmInfo2company
             key_ups =            mkUpdate'            firm newAvsFirmInfo oldAvsFirmInfo  firmInfo2key
         uniq_ups    <-           mkUpdateCheckUnique' firm newAvsFirmInfo oldAvsFirmInfo  firmInfo2companyNo
         $logInfoS "AVS" [st|Update company #{companyShorthand firm}: #{tshow (length cmp_ups)}, #{tshow (length key_ups)}, #{tshow (length uniq_ups)} for #{tshow oldAvsFirmInfo}|]
         res_cmp <- updateGetEntity firmid $ mcons uniq_ups cmp_ups
         let cmp_id  = res_cmp ^. _entityVal . _companyAvsId
-        res_cmp2 <- case key_ups of 
+        res_cmp2 <- case key_ups of
           Just key_up | cmp_id > 0 -> do
             $logInfoS "AVS" $ "Updating CompanyShorthand from " <> ciOriginal (companyShorthand firm) <> " to " <> avsFirmAbbreviation newAvsFirmInfo <> " for AvsNo " <> tshow cmp_id
             let uniq_cmp = UniqueCompanyAvsId cmp_id
@@ -634,23 +633,90 @@ upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do
             if | key_ok -> updateBy uniq_cmp [key_up]                                                      -- this is ok, since we have OnUpdateCascade on all CompanyId entries
                | alt_ok -> updateBy uniq_cmp [CompanyShorthand =. alt_key]
                | otherwise -> $logInfoS "AVS" $ "Update company shorthand failed for " <> ciOriginal cmp_key <> " and " <> ciOriginal alt_key
-            maybeM (return res_cmp) return $ getBy uniq_cmp            
+            maybeM (return res_cmp) return $ getBy uniq_cmp
           _otherwise -> return res_cmp
-        $logInfoS "AVS" "Update company completed."
+        $logInfoS "AVS" [st|Update company #{companyShorthand firm} completed.|]
         return res_cmp2
   where
-    firmInfo2key = 
+    firmInfo2key =
         CheckUpdate CompanyShorthand   $ _avsFirmAbbreviation  . from _CI  -- Updating primary key works in principle thanks to OnUpdateCascade, but fails due to update get
     firmInfo2companyNo =
         CheckUpdate CompanyAvsId         _avsFirmFirmNo                    -- Updating a unique needs special considerations; AVS does not update FirmNo, but for legacy reasons we might have companies without a number
-    firmInfo2company = 
-      [ CheckUpdate CompanyName        $ _avsFirmFirm          . from _CI  
+    firmInfo2company =
+      [ CheckUpdate CompanyName        $ _avsFirmFirm          . from _CI
       , CheckUpdate CompanyPostAddress   _avsFirmPostAddress
       , CheckUpdate CompanyEmail       $ _avsFirmPrimaryEmail . _Just . from _CI . re _Just
       -- , CheckUpdate CompanyPrefersPostal _avsFirmPrefersPostal          -- Guessing here is not useful, since postal preference is ignored anyway when there is only one option available
       ]
 
 
+-- | adjust superiors, assumes that CompanyUser exists for all usrs for given company; does not work otherwise
+upsertCompanySuperior :: Entity Company -> AvsFirmInfo -> Maybe AvsFirmInfo -> UserId -> DB () -- may return superior (Maybe UserId), but currently not needed
+upsertCompanySuperior Entity{entityKey=cid, entityVal=Company{}} newAfi oldAfi usrId =
+  let reasonSuperior = Just $ tshow SupervisorReasonAvsSuperior
+      getInsertUid eml = altM (guessUserByEmail $ stripCI eml) (catchAll2log' $ Just . entityKey <$> ldapLookupAndUpsert eml)
+      newAvsNo    = newAfi ^.         _avsFirmFirmNo
+      oldAvsNo    = oldAfi ^? _Just . _avsFirmFirmNo
+      mbSupEmail  = newAfi ^.         _avsFirmEMailSuperior
+      mbOldEmail  = oldAfi ^? _Just . _avsFirmEMailSuperior . _Just
+      getSupId    =  getInsertUid                `traverseJoin` mbSupEmail
+      getOldId    = (guessUserByEmail . stripCI) `traverseJoin` mbOldEmail
+      getSupervision :: Maybe UserId -> DB (Maybe (Entity UserSupervisor))
+      getSupervision = traverseJoin (getBy . flip UniqueUserSupervisor usrId)
+      unchangedCompany = oldAvsNo   == Just newAvsNo
+      changedSuperior  = mbSupEmail /= mbOldEmail     -- beware we only have AvsFirmInfo for one user; also both could be Nothing
+      --   1. not unchangedCompany: do not delete, but ensure that superior supervision is set, since it could be a just a single user company change
+      --   2. unchangedCompany && not changedSuperior: superior must already been set, short-circuit
+      --   3. unchangedCompany && changedSuperior: update superior for all users
+  in unless (unchangedCompany && not changedSuperior) $ do      -- do nothing if (unchangedCompany && not changedSuperior).
+    mbSupId  <- getSupId
+    mbUsrSup <- getSupervision mbSupId
+    -- delete old superiors, if any
+    when (unchangedCompany && changedSuperior) $
+      deleteWhere $ mcons ((UserSupervisorSupervisor !=.) <$> mbSupId)
+                          [ UserSupervisorCompany ==. Just cid, UserSupervisorReason ==. reasonSuperior ]
+    unless unchangedCompany $
+      deleteWhere [ UserSupervisorReason ==. reasonSuperior, UserSupervisorUser ==. usrId ]
+    -- ensure superior supervision
+    case (mbSupId, mbUsrSup) of
+      (_          , Just _) -> return () -- supId is already supervisor for uid for any reason
+      (Just supId, Nothing) -> do
+        -- ensure association between company and superior at equal-to-top priority
+        prio <- getCompanyUserMaxPrio supId
+        void $ insertUnique (UserCompany supId cid False False prio True reasonSuperior) -- superior is not a supervisor, do not change existing user company associations
+
+        -- ensure all company associates are irregularly supervised by the superior
+        E.insertSelectWithConflict UniqueUserSupervisor
+          (do
+            usr <- E.from $ E.table @UserCompany
+            E.where_ $ usr E.^. UserCompanyCompany E.==. E.val cid
+                -- E.&&. E.notExists (do                                                              -- restrict to primary company only
+                --     othr <- E.from $ E.table @UserCompany
+                --     E.where_ $ othr E.^. UserCompanyPriority E.>.  usr E.^. UserCompanyPriority
+                --         E.&&.  othr E.^. UserCompanyUser     E.==. usr E.^. UserCompanyUser
+                --         E.&&.  othr E.^. UserCompanyCompany  E.!=. E.val cid                       -- redundant due to > above, but likely performance improving
+                --   )
+            return $ UserSupervisor
+              E.<#  E.val supId
+              E.<&> (usr E.^. UserCompanyUser)
+              E.<&> E.false
+              E.<&> E.justVal cid
+              E.<&> E.val reasonSuperior
+          )
+          (\_old _new -> [] -- do not change exisitng supervision
+            -- [ UserSupervisorCompany               E.=. new E.^. UserSupervisorCompany
+            -- , UserSupervisorReason                E.=. new E.^. UserSupervisorReason
+            -- , UserSupervisorRerouteNotifications  E.=. new E.^. UserSupervisorRerouteNotifications
+            -- ]
+          )
+        when (unchangedCompany && changedSuperior) $ do
+          oldSupId <- getOldId
+          reportAdminProblem $ AdminProblemCompanySuperiorChange supId cid oldSupId
+      (Nothing, Nothing) ->
+        when (unchangedCompany && changedSuperior) $ do
+          oldSupId <- getOldId
+          reportAdminProblem $ AdminProblemCompanySuperiorNotFound mbSupEmail cid oldSupId
+
 queueAvsUpdateByUID :: (MonoFoldable mono, UserId ~ Element mono) => mono -> Maybe Day -> DB Int64
 queueAvsUpdateByUID uids = queueAvsUpdateAux (E.table @User)    (E.^. UserId)      (\usr    -> usr E.^. UserId             `E.in_` E.vals uids)
 
@@ -659,14 +725,14 @@ queueAvsUpdateByAID aids = queueAvsUpdateAux (E.table @UserAvs) (E.^. UserAvsUse
 
 -- queueAvsUpdateAux :: E.From (E.SqlExpr (Entity ent)) -> (E.SqlExpr (Entity ent) -> E.SqlExpr (E.Value UserId)) -> (E.SqlExpr (Entity ent) -> E.SqlExpr (E.Value Bool)) -> Maybe Day -> DB Int64
 queueAvsUpdateAux :: E.From t -> (t -> E.SqlExpr (E.Value UserId)) -> (t -> E.SqlExpr (E.Value Bool)) -> Maybe Day -> DB Int64
-queueAvsUpdateAux tbl prj fltr pause = do 
-  now <- liftIO getCurrentTime  
+queueAvsUpdateAux tbl prj fltr pause = do
+  now <- liftIO getCurrentTime
   n <- E.insertSelectWithConflictCount UniqueAvsSyncUser
         ( do
             usr <- E.from tbl
             E.where_ $ fltr usr
             return (AvsSync E.<# prj usr E.<&> E.val now E.<&> E.val pause)
-        ) (\current excluded -> 
+        ) (\current excluded ->
             [ AvsSyncCreationTime E.=. E.least    (current E.^. AvsSyncCreationTime) (excluded E.^. AvsSyncCreationTime)
             , AvsSyncPause        E.=. E.greatest (current E.^. AvsSyncPause)        (excluded E.^. AvsSyncPause)
             ]
@@ -675,24 +741,24 @@ queueAvsUpdateAux tbl prj fltr pause = do
   return n
 
 
--- | Find or upsert User by AvsCardId (with dot), Fraport PersonalNumber, Fraport Email-Address or by prefixed AvsId or prefixed AvsNo; 
+-- | Find or upsert User by AvsCardId (with dot), Fraport PersonalNumber, Fraport Email-Address or by prefixed AvsId or prefixed AvsNo;
 --   fail-safe, may or may not update existing users, may insert new users
 --   If an existing User with internal number is found, an AVS update query is executed
 guessAvsUser :: Text -> Handler (Maybe UserId)
 guessAvsUser (Text.splitAt 6 -> (Text.toUpper -> prefix, readMay -> Just nr))
-  | prefix=="AVSID:" = 
-      let avsid = AvsPersonId nr in 
-      runDB (getBy $ UniqueUserAvsId avsid)          >>= \case
+  | prefix=="AVSID:" =
+      let avsid = AvsPersonId nr in
+      runDBRead (getBy $ UniqueUserAvsId avsid)          >>= \case
         (Just Entity{entityVal=UserAvs{userAvsUser=uid}}) -> return $ Just uid
-        Nothing -> catchAVS2message $ Just <$> upsertAvsUserById avsid  
-  | prefix=="AVSNO:" = 
-      runDB (view (_entityVal . _userAvsUser) <<$>> getByFilter [UserAvsNoPerson ==. nr])
-guessAvsUser someid@(discernAvsCardPersonalNo -> Just someavsid) =  
+        Nothing -> catchAVS2message $ Just <$> upsertAvsUserById avsid
+  | prefix=="AVSNO:" =
+      runDBRead (view (_entityVal . _userAvsUser) <<$>> getByFilter [UserAvsNoPerson ==. nr])
+guessAvsUser someid@(discernAvsCardPersonalNo -> Just someavsid) =
     catchAVS2message $ upsertAvsUserByCard someavsid >>= \case
       Nothing | Left{} <- someavsid -> -- attempt to find PersonalNumber in DB
-        runDB (getKeyByFilter [UserCompanyPersonalNumber ==. Just someid])
+        runDBRead (getKeyByFilter [UserCompanyPersonalNumber ==. Just someid])
       other -> return other
-guessAvsUser someid = do 
+guessAvsUser someid = do
     try (runDB $ ldapLookupAndUpsert someid) >>= \case
       Right Entity{entityKey=uid, entityVal=User{userCompanyPersonalNumber=Just persNo}} -> do -- ensure internal user is linked to avs, if possible
         let ldapUid = Just uid
@@ -701,8 +767,8 @@ guessAvsUser someid = do
         return ldapUid
       Right Entity{entityKey=uid} -> return $ Just uid
       other -> do -- attempt to recover by trying other ids
-        whenIsLeft other (\(err::SomeException) -> $logInfoS "AVS" $ "upsertAvsUser LDAP error " <> tshow err) -- this line primarily forces exception type to catch-all      
-        runDB . runMaybeT $ 
+        whenIsLeft other (\(err::SomeException) -> $logInfoS "AVS" $ "upsertAvsUser LDAP error " <> tshow err) -- this line primarily forces exception type to catch-all
+        runDB . runMaybeT $
                 MaybeT (guessUserByEmail $ stripCI someid)              -- recall that monadic actions are only executed until first success here
             <|> MaybeT (getKeyByFilter [UserDisplayName  ==. someid])
 
@@ -714,8 +780,8 @@ upsertAvsUserByCard persNo = do
   let qry = case persNo of
         Left fpn
           -> def{ avsPersonQueryInternalPersonalNo = Just fpn } -- recall: default has all fields set to nothing
-        Right AvsFullCardNo{..} 
-          -> def{ avsPersonQueryCardNo = Just avsFullCardNo, avsPersonQueryVersionNo = Just avsFullCardVersion } 
+        Right AvsFullCardNo{..}
+          -> def{ avsPersonQueryCardNo = Just avsFullCardNo, avsPersonQueryVersionNo = Just avsFullCardVersion }
           -- NOTE: card validity might be outdated, so we must always check diretcly with avs and not within our DB!
   AvsResponsePerson adps <- avsQuery qry
   case Set.elems adps of
@@ -738,11 +804,11 @@ setLicence :: (PersistUniqueRead backend, MonadThrow m,
                      MonadHandler m, HandlerSite m ~ UniWorX,
                      BaseBackend backend ~ SqlBackend) =>
                     UserId -> AvsLicence -> ReaderT backend m Bool
-setLicence uid lic = 
+setLicence uid lic =
   getBy (UniqueUserAvsUser uid) >>= \case
     Just Entity{entityVal=UserAvs{userAvsPersonId=api}} -> setLicenceAvs api lic
     Nothing -> do
-      uname <- userDisplayName <<$>> get uid      
+      uname <- userDisplayName <<$>> get uid
       throwM $ AvsUserUnassociated $ fromMaybe "user id unknown" uname
 
 setLicenceAvs :: (MonadHandler m, MonadThrow m, HandlerSite m ~ UniWorX) =>
@@ -755,7 +821,7 @@ setLicenceAvs apid lic = do
 --setLicencesAvs :: Set AvsPersonLicence -> Handler Bool
 setLicencesAvs :: (MonadHandler m, MonadThrow m, HandlerSite m ~ UniWorX) =>
                   Set AvsPersonLicence -> m Int
-setLicencesAvs = aux 0    
+setLicencesAvs = aux 0
   where
     aux batch0_ok pls
       | Set.null pls = return batch0_ok
@@ -774,7 +840,7 @@ setLicencesAvs = aux 0
                 bad = Map.withoutKeys (setToMap avsResponsePersonID bad') ok_ids -- it is possible to receive an id multiple times, with only one success, but this is sufficient
                 batch1_ok = Set.size ok
             forM_ bad $ \AvsLicenceResponse { avsResponsePersonID=api, avsResponseMessage=msg} ->
-              $logErrorS "AVS" $ "Set AVS Licence failed for " <> tshow api <> " due to " <> cropText msg              
+              $logErrorS "AVS" $ "Set AVS Licence failed for " <> tshow api <> " due to " <> cropText msg
             aux (batch0_ok + batch1_ok) batch2 -- yay for tail recursion (TODO: maybe refactor?)
 
 {- NOT USED ANYWHERE:
@@ -804,13 +870,13 @@ data AvsLicenceDifferences = AvsLicenceDifferences
 #ifndef DEVELOPMENT
 -- avsLicenceDifferences2LicenceIds is not used in DEVELOPMENT build
 avsLicenceDifferences2LicenceIds :: AvsLicenceDifferences -> Set AvsPersonId
-avsLicenceDifferences2LicenceIds AvsLicenceDifferences{..} = Set.unions 
-  [ avsLicenceDiffRevokeAll     
-  , avsLicenceDiffGrantVorfeld  
+avsLicenceDifferences2LicenceIds AvsLicenceDifferences{..} = Set.unions
+  [ avsLicenceDiffRevokeAll
+  , avsLicenceDiffGrantVorfeld
   , avsLicenceDiffRevokeRollfeld
-  , avsLicenceDiffGrantRollfeld 
+  , avsLicenceDiffGrantRollfeld
   ]
-#endif 
+#endif
 
 avsLicenceDifferences2personLicences :: AvsLicenceDifferences -> Set AvsPersonLicence
 avsLicenceDifferences2personLicences AvsLicenceDifferences{..} =
@@ -820,69 +886,71 @@ avsLicenceDifferences2personLicences AvsLicenceDifferences{..} =
   <> Set.map (AvsPersonLicence AvsLicenceRollfeld) avsLicenceDiffGrantRollfeld
 
 computeDifferingLicences :: AvsResponseGetLicences -> Handler (Set AvsPersonLicence)
-computeDifferingLicences = fmap avsLicenceDifferences2personLicences . getDifferingLicences
+computeDifferingLicences = fmap (avsLicenceDifferences2personLicences . fst) . getDifferingLicences
 
 type AvsPersonIdMapPersonCard = Map AvsPersonId (Set AvsDataPersonCard)
 
 avsResponseStatusMap :: AvsResponseStatus -> AvsPersonIdMapPersonCard
 avsResponseStatusMap (AvsResponseStatus status) = Map.fromDistinctAscList [(avsStatusPersonID,avsStatusPersonCardStatus) | AvsStatusPerson{..}<- Set.toAscList status]
 
-retrieveDifferingLicences :: Handler AvsLicenceDifferences
+retrieveDifferingLicences :: Handler (AvsLicenceDifferences, Set AvsPersonId)
 retrieveDifferingLicences = fst <$> retrieveDifferingLicences' False
 
-retrieveDifferingLicencesStatus :: Handler (AvsLicenceDifferences, AvsPersonIdMapPersonCard)
+retrieveDifferingLicencesStatus :: Handler ((AvsLicenceDifferences, Set AvsPersonId), AvsPersonIdMapPersonCard)
 retrieveDifferingLicencesStatus = retrieveDifferingLicences' True
 
-retrieveDifferingLicences' :: Bool -> Handler (AvsLicenceDifferences, AvsPersonIdMapPersonCard)
-retrieveDifferingLicences' getStatus = do  
+retrieveDifferingLicences' :: Bool -> Handler ((AvsLicenceDifferences, Set AvsPersonId),  AvsPersonIdMapPersonCard)
+retrieveDifferingLicences' getStatus = do
 #ifdef DEVELOPMENT
-  avsUsrs <- runDB $ selectList [] [LimitTo 444]
+  avsUsrs <- runDBRead $ selectList [] [LimitTo 444]
   let allLicences = AvsResponseGetLicences $ Set.fromList $
         [ AvsPersonLicence AvsLicenceVorfeld  $ AvsPersonId 77         -- AVS:1 FD:2
         , AvsPersonLicence AvsLicenceRollfeld $ AvsPersonId 12345678   -- AVS:2 FD:1
         , AvsPersonLicence AvsLicenceVorfeld  $ AvsPersonId 5          -- AVS:1 FD:0 (nichts)
         , AvsPersonLicence AvsLicenceVorfeld  $ AvsPersonId 2          -- AVS:1 FD:0 (ungültig)
         -- , AvsPersonLicence AvsLicenceVorfeld  $ AvsPersonId 4          -- AVS:1 FD:1
-        ] ++ [AvsPersonLicence AvsLicenceVorfeld avsid | Entity _ UserAvs{userAvsPersonId = avsid} <- avsUsrs]
-#else  
-  allLicences  <- avsQuery AvsQueryGetAllLicences
+        ] ++ [AvsPersonLicence (bool AvsLicenceRollfeld AvsLicenceVorfeld $ even $ avsPersonId avsid) avsid
+             | Entity _ UserAvs{userAvsPersonId = avsid} <- avsUsrs
+             ]
+#else
+  allLicences  <- avsQueryNoCache AvsQueryGetAllLicences
 #endif
-  lDiff <- getDifferingLicences allLicences  
+  lDiff <- getDifferingLicences allLicences
 #ifdef DEVELOPMENT
   let mkAdpc valid color = AvsDataPersonCard valid Nothing Nothing color (Set.singleton 'F') Nothing Nothing Nothing Nothing (AvsCardNo "1234") "5"
       lStat = AvsResponseStatus $ bool mempty fakes getStatus -- not really needed, but avoids unused variable error
-      fakes = Set.fromList $ 
+      fakes = Set.fromList $
               [ AvsStatusPerson (AvsPersonId 77      ) $ Set.singleton $ mkAdpc True AvsCardColorGelb
               , AvsStatusPerson (AvsPersonId 12345678) $ Set.fromList [mkAdpc False AvsCardColorGrün, mkAdpc True  AvsCardColorGelb, mkAdpc False AvsCardColorBlau, mkAdpc True  AvsCardColorRot, mkAdpc True $ AvsCardColorMisc "Violett"]
               , AvsStatusPerson (AvsPersonId 5       ) $ Set.fromList [mkAdpc True  AvsCardColorGrün, mkAdpc False AvsCardColorGelb, mkAdpc True  AvsCardColorBlau, mkAdpc False AvsCardColorRot, mkAdpc True $ AvsCardColorMisc "Pink"]
               , AvsStatusPerson (AvsPersonId 2       ) $ Set.singleton $ mkAdpc True AvsCardColorGrün
-              ] <> 
+              ] <>
               [ AvsStatusPerson  avsid $ Set.singleton $ mkAdpc (even $ avsPersonId avsid) AvsCardColorGelb | Entity _ UserAvs{userAvsPersonId = avsid} <- avsUsrs ]
 #else
-  let statQry = avsLicenceDifferences2LicenceIds lDiff
-  lStat <- if getStatus && notNull statQry 
+  let statQry = avsLicenceDifferences2LicenceIds $ fst lDiff
+  lStat <- if getStatus && notNull statQry
             then avsQueryNoCache (AvsQueryStatus statQry)
               -- `catch` handler
               -- let handler _exception = do
               --       addMessage Error $ toHtml $ "avsQueryStatus failed for " <> tshow (length statQry) <> " requests with: \n" <> tshow err <> "\nREQUEST:\n" <> tshow statQry
-              --       return $ AvsResponseStatus mempty                 
+              --       return $ AvsResponseStatus mempty
             else return $ AvsResponseStatus mempty -- avoid unnecessary avs calls
 #endif
   return (lDiff, avsResponseStatusMap lStat)
 
-  
-getDifferingLicences :: AvsResponseGetLicences -> Handler AvsLicenceDifferences
+
+getDifferingLicences :: AvsResponseGetLicences -> Handler (AvsLicenceDifferences, Set AvsPersonId)
 getDifferingLicences (AvsResponseGetLicences licences) = do
   now <- liftIO getCurrentTime
   --let (vorfeld, nonvorfeld) = Set.partition (`avsPersonLicenceIs` AvsLicenceVorfeld)  licences
   --     rollfeld             = Set.filter    (`avsPersonLicenceIs` AvsLicenceRollfeld) nonvorfeld
   -- Note: FRADrive users with 'R' also own 'F' qualification, but AvsGetResponseGetLicences yields only either
-  let vorORrollfeld' = Set.dropWhileAntitone (`avsPersonLicenceIsLEQ` AvsNoLicence)      licences
+  let vorORrollfeld' = Set.dropWhileAntitone (`avsPersonLicenceIsLEQ` AvsNoLicence)      licences        -- antitone is ok, see test/Utils/TypesSpec -> "Ord AvsPersonLicence"
       rollfeld'      = Set.dropWhileAntitone (`avsPersonLicenceIsLEQ` AvsLicenceVorfeld) vorORrollfeld'
       vorORrollfeld  = Set.map avsLicencePersonID vorORrollfeld'
       rollfeld       = Set.map avsLicencePersonID rollfeld'
 
-      antijoinAvsLicences :: AvsLicence -> Set AvsPersonId -> DB (Set AvsPersonId,Set AvsPersonId)
+      antijoinAvsLicences :: AvsLicence -> Set AvsPersonId -> DBRead (Set AvsPersonId,Set AvsPersonId)
       antijoinAvsLicences lic avsLics = fmap unwrapIds $
        E.select $ do
         ((_qauli :& _qualUser :& usrAvs) :& excl) <-
@@ -892,7 +960,7 @@ getDifferingLicences (AvsResponseGetLicences licences) = do
                     (quali E.^. QualificationId         E.==. qualUser E.^. QualificationUserQualification)
                 -- NOTE: filters on the innerJoin must be part of ON-condition in order for anti-join to work!
               E.&&. (quali E.^. QualificationAvsLicence E.==. E.justVal lic)                  -- correct type of licence
-              E.&&. (now `validQualification` qualUser)                                       -- currently valid and not blocked              
+              E.&&. (now `validQualification` qualUser)                                       -- currently valid and not blocked
               )
             `E.innerJoin` E.table @UserAvs
             `E.on` (\(_ :& qualUser :& usrAvs) -> qualUser E.^. QualificationUserUser E.==. usrAvs E.^. UserAvsUser)
@@ -908,19 +976,21 @@ getDifferingLicences (AvsResponseGetLicences licences) = do
           aux (E.Value(Just api), _) (l,r) = (Set.insert api l, r)
           aux _ acc = acc -- should never occur
 
-  ((vorfGrant, vorfRevoke), (rollGrant, rollRevoke)) <- runDB $ (,)
+  ((vorfGrant, vorfRevoke), (rollGrant, rollRevoke)) <- runDBRead $ (,)
     <$> antijoinAvsLicences AvsLicenceVorfeld  vorORrollfeld
     <*> antijoinAvsLicences AvsLicenceRollfeld rollfeld
-  let setTo0      = vorfRevoke                    -- revoke driving licences 
-      setTo1up    = vorfGrant Set.\\ rollGrant    -- grant apron driving licence
-      setTo1down  = rollRevoke Set.\\ vorfRevoke  -- revoke maneuvering area licence, but retain apron driving licence 
+  let setTo0      = vorfRevoke                    -- revoke driving licences
+      setTo1up    = vorfGrant  Set.\\ rollGrant   -- grant apron driving licence
+      setTo1down  = rollRevoke Set.\\ vorfRevoke  -- revoke maneuvering area licence, but retain apron driving licence
       setTo2      = (rollGrant Set.\\ vorfRevoke) `Set.intersection` (vorfGrant `Set.union` vorORrollfeld) -- grant maneuvering driving licence
-  return AvsLicenceDifferences
-    { avsLicenceDiffRevokeAll      = setTo0
-    , avsLicenceDiffGrantVorfeld   = setTo1up
-    , avsLicenceDiffRevokeRollfeld = setTo1down
-    , avsLicenceDiffGrantRollfeld  = setTo2
-    } 
+      rsChanged   = rollfeld `Set.intersection` Set.unions [vorfRevoke, rollRevoke, setTo1up] -- maneuvering driving licences to downgrade in AVS
+      alds = AvsLicenceDifferences
+              { avsLicenceDiffRevokeAll      = setTo0
+              , avsLicenceDiffGrantVorfeld   = setTo1up
+              , avsLicenceDiffRevokeRollfeld = setTo1down
+              , avsLicenceDiffGrantRollfeld  = setTo2
+              }
+  return (alds, rsChanged)
     {- Cases to consider (AVS_Licence,has_valid_F, has_valid_R) -> (vorfeld@(toset,unset), rollfeld@(toset,unset)) :
         A (0,0,0)  -> ((_,_),(_,_)) : nop; avs_id not returned from queries, no problem
         B (0,0,1)  -> ((_,_),(x,_)) : nop; do nothing     -- CHECK since id is returned by roll-query

src/Handler/Utils/AvsUpdate.hs

@@ -20,7 +20,7 @@ import Import
 -- import Language.Haskell.TH.Syntax
 --
 -- deriving instance Lift (EntityField User typ) -- possible
--- 
+--
 -- Lift instances for lenses are not possible:
 -- type Getting r s a = (a -> Const r a) -> s -> Const r s
 -- deriving instance Lift (Getting        typ AvsPersonInfo typ)
@@ -50,15 +50,15 @@ class MkCheckUpdate a where
   mkCheckUpdate :: a -> CheckUpdate (MCU_Rec a) (MCU_Raw a)
 
 data CU_AvsPersonInfo_User
-  = CU_API_UserFirstName 
+  = CU_API_UserFirstName
   | CU_API_UserSurname
-  | CU_API_UserDisplayName          
-  | CU_API_UserBirthday             
-  | CU_API_UserMobile               
-  | CU_API_UserMatrikelnummer       
+  | CU_API_UserDisplayName
+  | CU_API_UserBirthday
+  | CU_API_UserMobile
+  | CU_API_UserMatrikelnummer
   | CU_API_UserCompanyPersonalNumber
-  | CU_API_UserLdapPrimaryKey       
-  | CU_API_UserDisplayEmail         
+  | CU_API_UserLdapPrimaryKey
+  -- CU_API_UserDisplayEmail        -- use _avsContactPrimaryEmailAddress instead
   deriving (Show, Eq)
 
 instance MkCheckUpdate CU_AvsPersonInfo_User where
@@ -67,46 +67,58 @@ instance MkCheckUpdate CU_AvsPersonInfo_User where
   mkCheckUpdate CU_API_UserFirstName             = CheckUpdate     UserFirstName               _avsInfoFirstName
   mkCheckUpdate CU_API_UserSurname               = CheckUpdate     UserSurname                 _avsInfoLastName
   mkCheckUpdate CU_API_UserDisplayName           = CheckUpdate     UserDisplayName             _avsInfoDisplayName
-  mkCheckUpdate CU_API_UserBirthday              = CheckUpdate     UserBirthday                _avsInfoDateOfBirth
-  mkCheckUpdate CU_API_UserMobile                = CheckUpdate     UserMobile                  _avsInfoPersonMobilePhoneNo
-  mkCheckUpdate CU_API_UserMatrikelnummer        = CheckUpdate     UserMatrikelnummer        $ _avsInfoPersonNo . re _Just                                              -- Maybe im User, aber nicht im AvsInfo; also: `re _Just` work like `to Just
-  mkCheckUpdate CU_API_UserCompanyPersonalNumber = CheckUpdate     UserCompanyPersonalNumber $ _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just   -- Maybe im User und im AvsInfo; needs special treatment, see ldap_ups abov
-  mkCheckUpdate CU_API_UserLdapPrimaryKey        = CheckUpdate     UserLdapPrimaryKey        $ _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just
-  mkCheckUpdate CU_API_UserDisplayEmail          = CheckUpdateOpt  UserDisplayEmail          $ _avsInfoPersonEMail  . _Just . from _CI                                  -- Maybe im AvsInfo, aber nicht im User, daher Opt
+  mkCheckUpdate CU_API_UserBirthday              = CheckUpdateMay  UserBirthday                _avsInfoDateOfBirth
+  mkCheckUpdate CU_API_UserMobile                = CheckUpdateMay  UserMobile                  _avsInfoPersonMobilePhoneNo
+  mkCheckUpdate CU_API_UserMatrikelnummer        = CheckUpdateMay  UserMatrikelnummer        $ _avsInfoPersonNo . re _Just                                              -- Maybe im User, aber nicht im AvsInfo; also: `re _Just` work like `to Just
+  mkCheckUpdate CU_API_UserCompanyPersonalNumber = CheckUpdateMay  UserCompanyPersonalNumber $ _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just   -- Maybe im User und im AvsInfo; needs special treatment, see ldap_ups abov
+  mkCheckUpdate CU_API_UserLdapPrimaryKey        = CheckUpdateMay  UserLdapPrimaryKey        $ _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just
+  -- mkCheckUpdate CU_API_UserDisplayEmail          = CheckUpdateOpt  UserDisplayEmail          $ _avsInfoPersonEMail  . _Just . from _CI                                  -- Maybe im AvsInfo, aber nicht im User, daher Opt
 
+data CU_AvsDataContcat_User
+  = CU_ADC_UserPostAddress
+  | CU_ADC_UserDisplayEmail
+  deriving (Show, Eq)
+
+instance MkCheckUpdate CU_AvsDataContcat_User where
+  type MCU_Rec CU_AvsDataContcat_User = User
+  type MCU_Raw CU_AvsDataContcat_User = AvsDataContact
+  mkCheckUpdate CU_ADC_UserPostAddress  = CheckUpdateMay UserPostAddress    _avsContactPrimaryPostAddress
+  mkCheckUpdate CU_ADC_UserDisplayEmail = CheckUpdateOpt UserDisplayEmail $ _avsContactPrimaryEmail . _Just . from _CI
 
 data CU_AvsFirmInfo_User
   = CU_AFI_UserPostAddress
-  | CU_AFI_UserDisplayEmail
+  -- CU_AFI_UserEmail               -- PROBLEM: UserEmail must be unique!
+  -- CU_AFI_UserDisplayEmail        -- use _avsContactPrimaryEmailAddress instead
   deriving (Show, Eq)
 
 instance MkCheckUpdate CU_AvsFirmInfo_User where
   type MCU_Rec CU_AvsFirmInfo_User = User
   type MCU_Raw CU_AvsFirmInfo_User = AvsFirmInfo
-  mkCheckUpdate CU_AFI_UserPostAddress           = CheckUpdate     UserPostAddress             _avsFirmPostAddress
-  mkCheckUpdate CU_AFI_UserDisplayEmail          = CheckUpdateOpt  UserDisplayEmail          $ _avsFirmPrimaryEmail . _Just . from _CI                                  -- Maybe im AvsInfo, aber nicht im User, daher Opt
+  mkCheckUpdate CU_AFI_UserPostAddress           = CheckUpdateMay  UserPostAddress             _avsFirmPostAddress
+  -- mkCheckUpdate CU_AFI_UserEmail              = CheckUpdateOpt  UserEmail                 $ _avsFirmEMailSuperior . _Just . from _CI   -- in rare cases, firm superior email is used as fallback here; but UserEmail must be unique!
+  -- mkCheckUpdate CU_AFI_UserDisplayEmail       = CheckUpdateOpt  UserDisplayEmail          $ _avsFirmPrimaryEmail  . _Just . from _CI   -- Maybe im AvsInfo, aber nicht im User, daher Opt
 
 
 -- NOTE: Ensure that the lenses between CU_UserAvs_User and CU_AvsPersonInfo_User/CU_AvsFirmInfo_User agree!
-data CU_UserAvs_User 
-  = CU_UA_UserPinPassword          
-  | CU_UA_UserPostAddress          
-  | CU_UA_UserFirstName            
-  | CU_UA_UserSurname              
-  | CU_UA_UserDisplayName          
-  | CU_UA_UserBirthday             
-  | CU_UA_UserMobile               
-  | CU_UA_UserMatrikelnummer       
+data CU_UserAvs_User
+  = CU_UA_UserPinPassword
+  -- CU_UA_UserPostAddress          -- use _avsContactPrimaryPostAddress instead
+  | CU_UA_UserFirstName
+  | CU_UA_UserSurname
+  | CU_UA_UserDisplayName
+  | CU_UA_UserBirthday
+  | CU_UA_UserMobile
+  | CU_UA_UserMatrikelnummer
   | CU_UA_UserCompanyPersonalNumber
-  | CU_UA_UserLdapPrimaryKey       
-  | CU_UA_UserDisplayEmail         
+  | CU_UA_UserLdapPrimaryKey
+  -- CU_UA_UserDisplayEmail         -- use _avsContactPrimaryEmail instead
   deriving (Show, Eq)
 
 instance MkCheckUpdate CU_UserAvs_User where
   type MCU_Rec CU_UserAvs_User = User
   type MCU_Raw CU_UserAvs_User = UserAvs
   mkCheckUpdate CU_UA_UserPinPassword           = CheckUpdateOpt  UserPinPassword           $ _userAvsLastCardNo     . _Just . to avsFullCardNo2pin . re _Just
-  mkCheckUpdate CU_UA_UserPostAddress           = CheckUpdateOpt  UserPostAddress           $ _userAvsLastFirmInfo   . _Just . _avsFirmPostAddress
+  -- mkCheckUpdate CU_UA_UserPostAddress           = CheckUpdateOpt  UserPostAddress           $ _userAvsLastFirmInfo   . _Just . _avsFirmPostAddress
   mkCheckUpdate CU_UA_UserFirstName             = CheckUpdateOpt  UserFirstName             $ _userAvsLastPersonInfo . _Just . _avsInfoFirstName
   mkCheckUpdate CU_UA_UserSurname               = CheckUpdateOpt  UserSurname               $ _userAvsLastPersonInfo . _Just . _avsInfoLastName
   mkCheckUpdate CU_UA_UserDisplayName           = CheckUpdateOpt  UserDisplayName           $ _userAvsLastPersonInfo . _Just . _avsInfoDisplayName
@@ -115,4 +127,4 @@ instance MkCheckUpdate CU_UserAvs_User where
   mkCheckUpdate CU_UA_UserMatrikelnummer        = CheckUpdateOpt  UserMatrikelnummer        $ _userAvsLastPersonInfo . _Just . _avsInfoPersonNo . re _Just                                              -- Maybe im User, aber nicht im AvsInfo; also: `re _Just` work like `to Just
   mkCheckUpdate CU_UA_UserCompanyPersonalNumber = CheckUpdateOpt  UserCompanyPersonalNumber $ _userAvsLastPersonInfo . _Just . _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just   -- Maybe im User und im AvsInfo; needs special treatment, see ldap_ups abov
   mkCheckUpdate CU_UA_UserLdapPrimaryKey        = CheckUpdateOpt  UserLdapPrimaryKey        $ _userAvsLastPersonInfo . _Just . _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just
-  mkCheckUpdate CU_UA_UserDisplayEmail          = CheckUpdateOpt  UserDisplayEmail          $ _userAvsLastPersonInfo . _Just . _avsInfoPersonEMail  . _Just . from _CI
+  -- mkCheckUpdate CU_UA_UserDisplayEmail          = CheckUpdateOpt  UserDisplayEmail          $ _userAvsLastPersonInfo . _Just . _avsInfoPersonEMail  . _Just . from _CI

src/Handler/Utils/Communication.hs

@@ -15,7 +15,7 @@ module Handler.Utils.Communication
 
 import Import
 import Handler.Utils
-import Handler.Utils.Users 
+import Handler.Utils.Users
 
 import Jobs.Queue
 
@@ -124,7 +124,7 @@ crJobsFirmCommunication jCompanies Communication{..} = do
       adrReceiverMails = Set.map (Address Nothing . CI.original) rawReceiverMails
   netReceiverAddresses <- lift $ do
     netReceiverIds <- getReceiversFor $ jSender : Set.toList rawReceiverIds -- ensure supervisors get only one email
-    maybeMapM getEmailAddressFor netReceiverIds    
+    maybeMapM getEmailAddressFor netReceiverIds
   -- let jAllRecipientAddresses = Set.fromList netReceiverAddresses <> adrReceiverMails
   let jAllRecipientAddresses = Set.map getAddress (Set.fromList (AddressEqIgnoreName <$> netReceiverAddresses) <> Set.map AddressEqIgnoreName adrReceiverMails)
   forM_ jAllRecipientAddresses $ \raddr ->
@@ -145,7 +145,7 @@ commR CommunicationRoute{..} =  do
       decrypt' cID = do
         uid <- decrypt cID
         whenIsJust crRecipientAuth $ guardAuthResult <=< ($ uid)
-        getEntity uid  
+        getEntity uid
   cUser <- maybeAuth
   (chosenRecipients, suggestedRecipients) <- runDB $ (,)
     <$> (maybe id cons cUser . catMaybes <$> (mapM decrypt' =<< lookupGlobalGetParams GetRecipient))
@@ -155,7 +155,7 @@ commR CommunicationRoute{..} =  do
   MsgRenderer mr <- getMsgRenderer
   mbCurrentRoute <- getCurrentRoute
   globalCC <- getsYesod $ view _appCommunicationGlobalCC
-  
+
   let
     lookupUser :: UserId -> (UserDisplayName,UserSurname)
     lookupUser =
@@ -163,7 +163,7 @@ commR CommunicationRoute{..} =  do
           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
-  
+
     chosenRecipients' = Map.fromList $
       [ ( (BoundedPosition $ RecipientGroup g, pos)
         , (Right recp, recp `elem` map entityKey chosenRecipients)
@@ -174,9 +174,9 @@ commR CommunicationRoute{..} =  do
       [ ( (BoundedPosition   RecipientCustom, pos)
         , (recp, True)
         )
-      | (pos, recp) <- zip [0..] 
+      | (pos, recp) <- zip [0..]
           ( mcons (Left <$> globalCC)
-            (Right <$> Set.toList (Set.fromList (map entityKey chosenRecipients) \\ Set.fromList (concatMap (map entityKey) $ view _2 <$> suggestedRecipients)))
+            (Right <$> Set.toList (Set.fromList (map entityKey chosenRecipients) \\ Set.fromList (concatMap (map entityKey . view _2) suggestedRecipients)))
           )
       ]
     activeCategories = map RecipientGroup (view _1 <$> suggestedRecipients) `snoc` RecipientCustom
@@ -243,7 +243,7 @@ commR CommunicationRoute{..} =  do
         postProcess = Set.fromList . map fst . filter snd . Map.elems
 
   recipientsListMsg <- messageI Info MsgCommRecipientsList
-  
+
   attachmentsMaxSize <- getsYesod $ view _appCommunicationAttachmentsMaxSize
   let attachmentField = genericFileField $ return FileField
         { fieldIdent = Nothing
@@ -261,9 +261,9 @@ commR CommunicationRoute{..} =  do
     <*> ( 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) 
+            <*> fmap fold (aopt (convertFieldM (runConduit . (.| C.foldMap Set.singleton)) yieldMany attachmentField)
                               (fslI MsgCommAttachments & setTooltip MsgCommAttachmentsTip) Nothing)
-        )    
+        )
   formResult commRes $ \case
     (comm, BtnCommunicationSend) -> do
       runDBJobs . runConduit $ transPipe (mapReaderT lift) (crJobs comm) .| sinkDBJobs
@@ -272,13 +272,13 @@ commR CommunicationRoute{..} =  do
     (comm, BtnCommunicationTest) -> do
       runDBJobs . runConduit $ transPipe (mapReaderT lift) (crTestJobs comm) .| sinkDBJobs
       addMessageI Info MsgCommTestSuccess
-  
+
   let formWdgt = wrapForm commWdgt def
         { formMethod   = POST
         , formAction   = SomeRoute <$> mbCurrentRoute
         , formEncoding = commEncoding
         , formSubmit   = FormNoSubmit
-        }  
+        }
   siteLayoutMsg crHeading $ do
     setTitleI crTitle
     let commTestTip = $(i18nWidgetFile "comm-test-tip")

src/Handler/Utils/Company.hs

@@ -21,66 +21,138 @@ import qualified Database.Esqueleto.PostgreSQL   as E
 import Handler.Utils.Users
 import Handler.Utils.Widgets
 
+-- Snippet to restrict to primary company only
+--  E.&&. E.notExists (do
+--      othr <- E.from $ E.table @UserCompany
+--      E.where_ $ othr E.^. UserCompanyPriority E.>.  userCompany E.^. UserCompanyPriority
+--          E.&&.  othr E.^. UserCompanyUser     E.==. userCompany E.^. UserCompanyUser
+--          E.&&.  othr E.^. UserCompanyCompany  E.!=. E.val cid                       -- redundant due to > above, but likely performance improving
+--    )
+
 company2msg :: CompanyId -> SomeMessage UniWorX
 company2msg = text2message . ciOriginal . unCompanyKey
 
 wgtCompanies :: UserId -> DB (Maybe Widget)
 wgtCompanies = \uid -> do
-    companies <- E.select $ do 
+    companies <- E.select $ do
       (usrComp :& comp) <- E.from $ E.table @UserCompany `E.innerJoin` E.table @Company
         `E.on` (\(usrComp :& comp) -> 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.^. CompanyShorthand, comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor, usrComp E.^. UserCompanyPriority)
     let (mPri, topCmp, otherCmp) = procCmp mPri companies
-        resWgt = 
+        resWgt =
           [whamlet|
             $forall c <- topCmp
               <p>
                 ^{c}
             $forall c <- otherCmp
               <p>
-                #{c}
+                ^{c}
           |]
     return $ toMaybe (notNull topCmp) resWgt
-  where 
-    procCmp _ [] = (0, [],[])
+  where
+    procCmp _ [] = (0, [], [])
     procCmp maxPri ((E.Value cmpSh, E.Value cmpName, E.Value cmpSpr, E.Value cmpPrio) : cs) =
-      let cmpWgt = companyWidget (cmpSh, cmpName, cmpSpr)
-          isTop  = cmpPrio >= maxPri
+      let isTop  = cmpPrio >= maxPri
+          cmpWgt = companyWidget isTop (cmpSh, cmpName, cmpSpr)
           (accPri,accTop,accRem) = procCmp maxPri cs
-      in (max cmpPrio accPri, bool accTop (cmpWgt : accTop) isTop, bool (cmpName : accRem) accRem isTop) -- lazy evaluation after repmin example
+      in (max cmpPrio accPri, bool accTop (cmpWgt : accTop) isTop, bool (cmpWgt : accRem) accRem isTop) -- lazy evaluation after repmin example, don't factor out the bool!
 
--- TODO: use this function in company view Handler.Firm #157
--- | add all company supervisors for a given users
-addCompanySupervisors :: (MonadIO m, BackendCompatible SqlBackend backend, PersistQueryWrite backend, PersistUniqueWrite backend) 
-                      => Key Company -> Key User -> ReaderT backend m ()
-addCompanySupervisors cid uid = 
-  E.insertSelectWithConflict
-    UniqueUserSupervisor
-    ( do 
-        userCompany <- E.from $ E.table @UserCompany
-        E.where_ $ userCompany E.^. UserCompanyCompany E.==. E.val cid
-            E.&&.  userCompany E.^. UserCompanySupervisor
-        return $ UserSupervisor
-          E.<#  (userCompany E.^. UserCompanyUser)
-          E.<&>  E.val uid
-          E.<&> (userCompany E.^. UserCompanySupervisorReroute)
-          E.<&>  E.justVal cid
-          E.<&>  E.justVal (tshow SupervisorReasonCompanyDefault)
-    )
-    (\current excluded -> -- Supervision between chosen individuals exists already; keep old reason and company, if exists
-        [ UserSupervisorCompany E.=. E.coalesce [current  E.^. UserSupervisorCompany, excluded E.^. UserSupervisorCompany] -- do we want this? Ok, since we delete unconditionally first?!
-        , UserSupervisorReason  E.=. E.coalesce [current  E.^. UserSupervisorReason , excluded E.^. UserSupervisorReason ]
-        ] 
-    )
+type AnySuperReason = Either SupervisorReason (Maybe Text)
 
 
+addDefaultSupervisors' :: CompanyId -> NonEmpty UserId -> DB Int64
+addDefaultSupervisors' = addDefaultSupervisors $ Just $ tshow SupervisorReasonCompanyDefault
+
+-- adds the default company supervisors as supervisor to a given set of users, which themselves may belong to any company
+-- if no reason is given, SupervisorReasonCompanyDefault is used, except if reason == Just "NULL"
+addDefaultSupervisors :: Maybe Text -> CompanyId -> NonEmpty UserId -> DB Int64
+addDefaultSupervisors reason cid employees = do
+  E.insertSelectWithConflictCount UniqueUserSupervisor
+    (do
+      (spr :& usr) <- E.from $ E.table @UserCompany `E.crossJoin` E.toValues employees
+      E.where_ $ spr E.^. UserCompanyCompany E.==. E.val cid
+          E.&&.  spr E.^. UserCompanySupervisor
+      E.distinct $ return $ UserSupervisor
+        E.<#  (spr E.^. UserCompanyUser)
+        E.<&>  usr
+        E.<&> (spr E.^. UserCompanySupervisorReroute)
+        E.<&> E.justVal cid
+        E.<&> case reason of
+                Nothing     -> E.justVal $ tshow SupervisorReasonCompanyDefault
+                Just "NULL" -> E.nothing
+                other       -> E.val other
+    )
+    (\old new ->
+      [ UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications
+      , UserSupervisorCompany E.=. E.justVal cid
+      , UserSupervisorReason  E.=. E.coalesce [new E.^. UserSupervisorReason, old E.^. UserSupervisorReason] -- keep existing reason, if no new one was given
+      ])
+
+
+-- like `Handler.Utils.addDefaultSupervisors`, but selects all employees of given companies from database, optionally filtered by being under supervision of a given individual
+-- TODO: check redundancies
+addDefaultSupervisorsFor ::  (CompanyId ~ Element mono, MonoFoldable mono) => Maybe Text -> Maybe UserId -> Bool -> mono -> DB Int64
+addDefaultSupervisorsFor reason mbSuperId mutualSupervision cids = do
+  E.insertSelectWithConflictCount UniqueUserSupervisor
+    (do
+      (spr :& usr) <- E.from $ E.table @UserCompany `E.innerJoin` E.table @UserCompany `E.on` (\(spr :& usr) -> spr E.^. UserCompanyCompany E.==. usr E.^. UserCompanyCompany)
+      E.where_ $ E.and $ guardMonoid (not mutualSupervision)
+                            [ E.not__ $ usr E.^. UserCompanySupervisor ]
+                        <>  maybeEmpty mbSuperId (\sprId -> [E.exists $ do
+                              superv <- E.from $ E.table @UserSupervisor
+                              E.where_ $ superv E.^. UserSupervisorSupervisor E.==. E.val sprId
+                                  E.&&.  superv E.^. UserSupervisorUser       E.==. usr E.^. UserCompanyUser
+                            ])
+                        <>  [          spr E.^. UserCompanySupervisor
+                            , spr E.^. UserCompanyCompany `E.in_` E.vals cids
+                            , usr E.^. UserCompanyCompany `E.in_` E.vals cids
+                            ]
+      E.distinct $ return $ UserSupervisor
+        E.<#  (spr E.^. UserCompanyUser)
+        E.<&> (usr E.^. UserCompanyUser)
+        E.<&> (spr E.^. UserCompanySupervisorReroute)
+        E.<&> E.just (spr E.^. UserCompanyCompany)
+        E.<&> E.val reason
+    )
+    (\old new ->
+        [ UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications
+        , UserSupervisorCompany E.=. new E.^. UserSupervisorCompany
+        , UserSupervisorReason  E.=. E.coalesce [new E.^. UserSupervisorReason, old E.^. UserSupervisorReason] -- keep existing reason, if no new one was given
+        ] )
+
+-- like `addDefaultSupervisors`, but selects all employees of given companies from database
+-- TODO: check redundancies
+addDefaultSupervisorsAll ::  (CompanyId ~ Element mono, MonoFoldable mono) => Maybe Text -> Bool -> mono -> DB Int64
+addDefaultSupervisorsAll reason mutualSupervision cids = do
+  E.insertSelectWithConflictCount UniqueUserSupervisor
+    (do
+      (spr :& usr) <- E.from $ E.table @UserCompany `E.innerJoin` E.table @UserCompany `E.on` (\(spr :& usr) -> spr E.^. UserCompanyCompany E.==. usr E.^. UserCompanyCompany)
+      E.where_ $ E.and $ guardMonoid (not mutualSupervision)
+                            [ E.not__ $ usr E.^. UserCompanySupervisor ]
+                        <>  [          spr E.^. UserCompanySupervisor
+                            , spr E.^. UserCompanyCompany `E.in_` E.vals cids
+                            , usr E.^. UserCompanyCompany `E.in_` E.vals cids
+                            ]
+      E.distinct $ return $ UserSupervisor
+        E.<#  (spr E.^. UserCompanyUser)
+        E.<&> (usr E.^. UserCompanyUser)
+        E.<&> (spr E.^. UserCompanySupervisorReroute)
+        E.<&> E.just (spr E.^. UserCompanyCompany)
+        E.<&> E.val reason
+    )
+    (\old new ->
+        [ UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications
+        , UserSupervisorCompany E.=. new E.^. UserSupervisorCompany
+        , UserSupervisorReason  E.=. E.coalesce [old E.^. UserSupervisorReason, new E.^. UserSupervisorReason] -- keep any existing reason
+        ] )
+
 -- | removes user supervisorship on switch. WARNING: problems are not yet written to DB via reportProblem yet
 switchAvsUserCompany :: Bool -> Bool -> UserId -> CompanyId -> DB ([Update User], [AdminProblem])
 switchAvsUserCompany usrPostEmailUpds keepOldCompanySupervs uid newCompanyId = do
     usrRec      <- get404 uid
-    newCompany  <- get404 newCompanyId 
+    newCompany  <- get404 newCompanyId
     mbUsrComp   <- getUserPrimaryCompany uid
     mbOldComp   <- (get . userCompanyCompany) `traverseJoin` mbUsrComp
     mbUsrAvs    <- if usrPostEmailUpds then getBy (UniqueUserAvsUser uid) else return Nothing
@@ -89,26 +161,32 @@ switchAvsUserCompany usrPostEmailUpds keepOldCompanySupervs uid newCompanyId = d
         usrPostUp = toMaybe (usrPostEmailUpds && fromMaybe False (liftA2 isSimilarMarkup usrPostAddr avsPostAddr))
                       (UserPostAddress =. Nothing)                                                   -- use company address indirectly instead
         usrPrefPost = userPrefersPostal usrRec
-        usrPrefPostUp = toMaybe (Just usrPrefPost == (mbOldComp ^? _Just . _companyPrefersPostal)) 
+        usrPrefPostUp = toMaybe (Just usrPrefPost == (mbOldComp ^? _Just . _companyPrefersPostal))
                       (UserPrefersPostal  =. companyPrefersPostal newCompany)
-        usrEmail :: UserEmail       = userDisplayEmail usrRec
+        -- newCmpEmail :: UserEmail = fromMaybe "" $ companyEmail newCompany
+        usrDisplayEmail :: UserEmail       = userDisplayEmail usrRec
         avsEmail :: Maybe UserEmail = mbUsrAvs ^? _Just . _entityVal . _userAvsLastFirmInfo . _Just . _avsFirmPrimaryEmail . _Just . from _CI
-        usrEmailUp = toMaybe (usrPostEmailUpds && avsEmail == Just usrEmail) (UserDisplayEmail =. "")
-        usrUpdate = catMaybes [usrPostUp, usrPrefPostUp, usrEmailUp]
+        usrDisplayEmailUp = toMaybe (usrPostEmailUpds && avsEmail == Just usrDisplayEmail) (UserDisplayEmail =. "") -- delete DisplayEmail, if equal to AVS Firm Email
+        usrUpdate = catMaybes [usrPostUp, usrPrefPostUp, usrDisplayEmailUp]
                 --  [UserPostAddress =. Nothing, UserPrefersPostal =. companyPrefersPostal newCompany] -- unconditional
-    -- update uid usrUpdate    
+
+        newUserComp       = UserCompany uid newCompanyId False False 1 True Nothing -- default value for new company insertion, if no update can be done
+        superReasonComDef = tshow SupervisorReasonCompanyDefault
+
+    -- update uid usrUpdate
     -- repsertSuperiorSupervisor is not called here, since the Superior is indepentent of the actual company association
     case mbUsrComp of
       Nothing -> do -- create company user
         void $ insertUnique newUserComp
-        addCompanySupervisors newCompanyId uid
+        void $ addDefaultSupervisors Nothing newCompanyId $ singleton uid
         return (usrUpdate, mempty)
-      Just UserCompany{userCompanyCompany=oldCompanyId, userCompanyPriority=oldPrio, userCompanySupervisor=oldSuper, userCompanySupervisorReroute=oldSuperReroute}
+      Just UserCompany{userCompanyCompany=oldCompanyId, userCompanyPriority=oldPrio, userCompanySupervisor=oldSuper, userCompanySupervisorReroute=oldSuperReroute, userCompanyReason=oldAssocReason}
         | newCompanyId == oldCompanyId -> return mempty -- nothing to do
-        | otherwise -> do -- switch company             
-            void $ upsertBy (UniqueUserCompany uid newCompanyId) newUserComp
-              [UserCompanyPriority =. succ oldPrio, UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False, UserCompanyUseCompanyAddress =. True]
-            -- supervised by uid            
+        | otherwise -> do -- switch company
+            when (isNothing oldAssocReason) $ deleteBy $ UniqueUserCompany uid oldCompanyId
+            void $ upsertBy (UniqueUserCompany uid newCompanyId) newUserComp{userCompanyPriority = succ oldPrio}
+              [UserCompanyPriority =. succ oldPrio, UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False, UserCompanyUseCompanyAddress =. True, UserCompanyReason =. Nothing]
+            -- supervised by uid
             supervisees :: [(Entity UserSupervisor, E.Value Bool)] <- E.select $ do
               usrSup <- E.from $ E.table @UserSupervisor
               E.where_ $ usrSup E.^. UserSupervisorSupervisor E.==. E.val uid
@@ -118,27 +196,48 @@ switchAvsUserCompany usrPostEmailUpds keepOldCompanySupervs uid newCompanyId = d
                     othSup <- E.from $ E.table @UserSupervisor
                     E.where_ $ usrSup E.^. UserSupervisorUser     E.==. othSup E.^. UserSupervisorUser
                         E.&&.  othSup E.^. UserSupervisorCompany  E.~=. E.val oldCompanyId
-                        E.&&.  othSup E.^. UserSupervisorReason   E.~=. E.val superReasonComDef                    
+                        E.&&.  othSup E.^. UserSupervisorReason   E.~=. E.val superReasonComDef
               return (usrSup, singleSup)
             newlyUnsupervised <- guardMonoidM (notNull supervisees) $ do
-              E.delete $ do 
+              E.delete $ do
                 usrSup <- E.from $ E.table @UserSupervisor
                 E.where_ $ usrSup E.^. UserSupervisorId `E.in_` E.vals (fmap (entityKey . fst) supervisees)
               return $  [ AdminProblemSupervisorLeftCompany subid oldCompanyId oldSuperReroute
-                        | (Entity{entityVal=UserSupervisor{userSupervisorUser=subid}}, E.Value True)  <- supervisees ]              
+                        | (Entity{entityVal=UserSupervisor{userSupervisorUser=subid}}, E.Value True)  <- supervisees ]
             -- supervisors of uid
             let superDeftFltr     = (UserSupervisorUser ==. uid) : (UserSupervisorReason  ~=. superReasonComDef)
                 oldSubFltr        = (UserSupervisorCompany ~=. oldCompanyId) <> superDeftFltr
             oldAPs <- if keepOldCompanySupervs
               then updateWhereCount oldSubFltr [UserSupervisorReason =. Nothing]
               else deleteWhereCount oldSubFltr
-            addCompanySupervisors newCompanyId uid
+            void $ addDefaultSupervisors Nothing newCompanyId $ singleton uid
             newAPs <- count $ (UserSupervisorCompany ==. Just newCompanyId) : superDeftFltr
             let isNoLongerSupervised = not keepOldCompanySupervs && oldAPs > 0 && newAPs <= 0
                 problems = bcons oldSuper             (AdminProblemSupervisorNewCompany uid oldCompanyId newCompanyId oldSuperReroute)
                          $ bcons isNoLongerSupervised (AdminProblemNewlyUnsupervised uid (Just oldCompanyId) newCompanyId)
                            newlyUnsupervised
             return (usrUpdate ,problems)
-  where 
-    newUserComp       = UserCompany uid newCompanyId False False 1 True -- default value for new company insertion, if no update can be done
-    superReasonComDef = tshow SupervisorReasonCompanyDefault
+
+defaultSupervisorReasonFilter :: [Filter UserSupervisor]
+defaultSupervisorReasonFilter =
+        [UserSupervisorReason  ==. Nothing]
+    ||. [UserSupervisorReason  ==. Just (tshow SupervisorReasonCompanyDefault)]
+    ||. [UserSupervisorReason  ==. Just (tshow SupervisorReasonAvsSuperior   )]
+--  ||. [UserSupervisorReason <-. Nothing : [Just $ tshow r | r <- [SupervisorReasonCompanyDefault, SupervisorReasonAvsSuperior]]] -- Does <-. work with Nothing?
+
+-- | remove supervisors for given users; maybe restricted to those linked to given companies or supervisors
+deleteDefaultSupervisorsForUsers :: [CompanyId] -> [UserId] -> NonEmpty UserId -> DB Int64
+deleteDefaultSupervisorsForUsers cids sprs usrs =
+    deleteWhereCount
+      $ bcons (notNull cids) (UserSupervisorCompany     <-. (cids <&> Just))
+      $ bcons (notNull sprs) (UserSupervisorSupervisor  <-.  sprs)
+      $ (UserSupervisorUser <-. toList usrs) : defaultSupervisorReasonFilter
+
+-- | retrieve maximum company user priority fo a user
+getCompanyUserMaxPrio :: UserId -> DB Int
+getCompanyUserMaxPrio uid = do
+  mbMaxPrio <- E.selectOne $ do
+    usrCmp <- E.from $ E.table @UserCompany
+    E.where_ $ usrCmp E.^. UserCompanyUser E.==. E.val uid
+    return . E.max_ $ usrCmp E.^. UserCompanyPriority
+  return $ maybe 1 (fromMaybe 1 . E.unValue) mbMaxPrio

src/Handler/Utils/Course.hs

@@ -109,14 +109,14 @@ showCourseEventRoom uid courseEvent = E.or
   ]
 
 getCourseQualifications :: ( MonadHandler m
-                           , backend ~ SqlBackend                           
-                           ) 
+                           , backend ~ SqlBackend
+                           )
                         => CourseId -> ReaderT backend m [Entity Qualification]
-getCourseQualifications cid = Ex.select $ do 
+getCourseQualifications cid = Ex.select $ do
   (qual :& courseQual) <-
     Ex.from $      Ex.table @Qualification
     `Ex.innerJoin` Ex.table @CourseQualification
-    `Ex.on` (\(qual :& courseQual) -> qual E.^. QualificationId E.==. courseQual E.^. CourseQualificationQualification) 
+    `Ex.on` (\(qual :& courseQual) -> qual E.^. QualificationId E.==. courseQual E.^. CourseQualificationQualification)
   Ex.where_ $ courseQual E.^. CourseQualificationCourse E.==. E.val cid
-  Ex.orderBy [E.asc $ courseQual E.^. CourseQualificationSortOrder]
+  Ex.orderBy [E.asc $ courseQual E.^. CourseQualificationSortOrder, E.asc $ qual E.^. QualificationName]
   pure qual

src/Handler/Utils/DateTime.hs

@@ -10,7 +10,8 @@ module Handler.Utils.DateTime
   , toTimeOfDay
   , toMidnight, beforeMidnight, toMidday, toMorning
   , toFullHour, roundDownToMinutes, addHours
-  , formatDiffDays, formatCalendarDiffDays
+  , formatDiffDays, formatDiffHours
+  , formatCalendarDiffDays
   , formatTime'
   , formatTime, formatTimeUser, formatTimeW, formatTimeMail
   , formatTimeRange, formatTimeRangeW, formatTimeRangeMail
@@ -144,8 +145,8 @@ getDateTimeFormatUser sel mUser = do
 
 getDateTimeFormatUser' :: SelDateTimeFormat -> User -> DateTimeFormat
 getDateTimeFormatUser' SelFormatDateTime usr = usr & userDateTimeFormat
-getDateTimeFormatUser' SelFormatDate     usr = usr & userDateFormat 
-getDateTimeFormatUser' SelFormatTime     usr = usr & userTimeFormat   
+getDateTimeFormatUser' SelFormatDate     usr = usr & userDateFormat
+getDateTimeFormatUser' SelFormatTime     usr = usr & userTimeFormat
 
 getDateTimeFormatter :: (MonadHandler m, HandlerSite m ~ UniWorX, YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId) => m DateTimeFormatter
 getDateTimeFormatter = do
@@ -160,7 +161,7 @@ getDateTimeFormatterUser mUser = do
   return $ mkDateTimeFormatter locale formatMap appTZ
 
 getDateTimeFormatterUser' :: (MonadHandler m) => User -> m DateTimeFormatter
-getDateTimeFormatterUser' usr = do 
+getDateTimeFormatterUser' usr = do
   locale <- getTimeLocale
   let formatMap = flip getDateTimeFormatUser' usr
   return $ mkDateTimeFormatter locale formatMap appTZ
@@ -263,18 +264,21 @@ formatDiffDays t
     inHours   = tshow $ convertBy nominalHour
     inMinutes = tshow $ convertBy nominalMinute
 
+formatDiffHours :: Integral a => a -> Text
+formatDiffHours = pack . iso8601Show . calendarTimeTime . secondsToNominalDiffTime . (* 3600) . fromIntegral
+
 formatCalendarDiffDays :: CalendarDiffDays -> Text
-formatCalendarDiffDays = pack . iso8601Show  
+formatCalendarDiffDays = pack . iso8601Show
 
 setYear :: Integer -> Day -> Day
 setYear year date = fromGregorian year m d
   where
     (_,m,d) = toGregorian date
 
-getYear :: Day -> Integer 
+getYear :: Day -> Integer
 getYear date = y
-  where 
-    (y,_,_) = toGregorian date    
+  where
+    (y,_,_) = toGregorian date
 
 dayOfWeekDiff :: DayOfWeek -> DayOfWeek -> Int
 dayOfWeekDiff a b = mod (fromEnum a - fromEnum b) 7
@@ -301,14 +305,19 @@ addLocalDays n utct = localTimeToUTCTZ appTZ newLocal
     newDay   = addDays n oldDay
     newLocal = oldLocal { localDay = newDay }
 
+-- This is just a Remineder
+-- addMonths :: Integer -> UTCTime -> UTCTime
+-- addMonths = addGregorianMonthsRollOver
+
+
 ----------------------
 -- CalendarDiffDays --
 ----------------------
 
-fromMonths :: Integral a => a -> CalendarDiffDays 
+fromMonths :: Integral a => a -> CalendarDiffDays
 fromMonths (toInteger -> m) = CalendarDiffDays { cdMonths = m, cdDays = 0 } -- above is equivalent
 
-fromDays :: Integral a => a -> CalendarDiffDays 
+fromDays :: Integral a => a -> CalendarDiffDays
 fromDays (toInteger -> d) = CalendarDiffDays { cdMonths = 0, cdDays = d }
 
 addDiffDaysClip :: CalendarDiffDays -> UTCTime -> UTCTime
@@ -388,7 +397,7 @@ formatTimeRangeMail = formatTimeRange' formatTimeMail
 formatGregorianW :: (YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId) => Integer -> Int -> Int -> WidgetFor UniWorX ()
 formatGregorianW y m d = formatTimeW SelFormatDate $ fromGregorian y m d
 
-instance Csv.ToField ZonedTime where 
+instance Csv.ToField ZonedTime where
   toField = Csv.toField . iso8601Show
 
 -- also see Data.Time.Clock.Instances

src/Handler/Utils/Form.hs

@@ -77,7 +77,7 @@ import qualified Data.Text.Lazy.Builder as Builder
 -- import Control.Monad.Catch.Pure (runCatch)
 
 import qualified Data.List.NonEmpty as NonEmpty
-  
+
 {-# ANN module ("HLint: ignore Use const" :: String) #-}
 
 
@@ -217,7 +217,7 @@ optionalAction'' negated minp justAct fs@FieldSettings{..} defActive csrf = do
   let actionViews = over (mapped . _fvInput) (\w -> $(widgetFile "widgets/multi-action/optional-action")) actionViews'
 
   return (doRes >>= bool (pure Nothing) (Just <$> actionRes), over _fvInput (mappend $ toWidget csrf) doView : actionViews)
-           
+
 optionalAction :: AForm Handler a
                -> FieldSettings UniWorX
                -> Maybe Bool
@@ -236,7 +236,7 @@ optionalActionA :: AForm Handler a
                 -> Maybe Bool
                 -> AForm Handler (Maybe a)
 optionalActionA = optionalActionA' mpopt
-  
+
 optionalActionNegatedA :: AForm Handler a
                        -> FieldSettings UniWorX
                        -> Maybe Bool
@@ -740,8 +740,7 @@ uploadModeForm fs prev = multiActionA actions fs (classifyUploadMode <$> prev)
                 let iStart = maybe 0 (succ . fst) $ Map.lookupMax oldRess
                  in pure $ Map.singleton iStart fileRes
           return (addRes', formWidget')
-        miCell _ initFile _ nudge csrf =
-          sFileForm nudge (Just initFile) csrf
+        miCell _ initFile _ nudge = sFileForm nudge (Just initFile)
         miDelete :: MassInputDelete ListLength
         miDelete = miDeleteList
         miAddEmpty _ _ _ = Set.empty
@@ -966,9 +965,9 @@ genericFileField mkOpts = Field{..}
       $logDebugS "genericFileField.getPermittedFiles" $ "Additional: " <> tshow fieldAdditionalFiles
       $logDebugS "genericFileField.getPermittedFiles" $ "Session: " <> tshow sessionFiles'
       return $ mconcat
-        [ Map.filter (views _3 $ (||) <$> not . fieldOptionForce <*> not . fieldOptionDefault) $ fieldAdditionalFiles ^. _FileReferenceFileReferenceTitleMap 
+        [ Map.filter (views _3 $ (||) <$> not . fieldOptionForce <*> not . fieldOptionDefault) $ fieldAdditionalFiles ^. _FileReferenceFileReferenceTitleMap
         , sessionFiles'
-        , Map.filter (views _3 $ (&&) <$> fieldOptionForce <*> fieldOptionDefault) $ fieldAdditionalFiles ^. _FileReferenceFileReferenceTitleMap 
+        , Map.filter (views _3 $ (&&) <$> fieldOptionForce <*> fieldOptionDefault) $ fieldAdditionalFiles ^. _FileReferenceFileReferenceTitleMap
         ]
 
     handleUpload :: FileField FileReference -> Maybe Text -> ConduitT (File Handler) FileReference (YesodDB UniWorX) ()
@@ -1002,7 +1001,7 @@ genericFileField mkOpts = Field{..}
     fieldParse :: [Text] -> [FileInfo] -> m (Either (SomeMessage (HandlerSite m)) (Maybe FileUploads))
     fieldParse vals files' = runExceptT $ do
       let files = filter (not . null . fileName) files'
-      
+
       opts@FileField{..} <- liftHandler mkOpts
 
       mIdent <- fmap getFirst . flip foldMapM vals $ \v ->
@@ -1116,7 +1115,7 @@ genericFileField mkOpts = Field{..}
                   fuiChecked
                     | Right sentVals' <- sentVals
                     = fuiTitle `Set.member` sentVals'
-                    | Just (_, _, FileFieldUserOption{..}) <- Map.lookup fuiTitle $ fieldAdditionalFiles ^. _FileReferenceFileReferenceTitleMap 
+                    | Just (_, _, FileFieldUserOption{..}) <- Map.lookup fuiTitle $ fieldAdditionalFiles ^. _FileReferenceFileReferenceTitleMap
                     = fieldOptionDefault
                     | otherwise = False
                   fuiSession = fuiTitle `Map.notMember` view _FileReferenceFileReferenceTitleMap fieldAdditionalFiles
@@ -1201,7 +1200,7 @@ zipFileField :: Bool -- ^ Unpack zips?
               -> Bool -- ^ Empty files ok?
               -> Field Handler FileUploads
 zipFileField doUnpack permittedExtensions emptyOk = zipFileField' doUnpack permittedExtensions emptyOk Nothing
-  
+
 zipFileField' :: Bool -- ^ Unpack zips?
               -> Maybe (NonNull (Set Extension)) -- ^ Restrictions on file extensions
               -> Bool -- ^ Empty files ok?
@@ -1315,16 +1314,16 @@ sheetTypeAFormReq cId fs template = wFormToAForm $ do
 
     editableExams <- fmap Map.keysSet . flip mapFilterM (foldMap (\(Entity eId exam, Entity _ course, _) -> Map.singleton eId (exam, course)) examParts'') $ \(Exam{..}, Course{..}) ->
       hasWriteAccessTo $ CExamR courseTerm courseSchool courseShorthand examName EEditR
-  
+
     return (examParts'', editableExams)
 
   let
     examParts' = flip foldMap examParts'' $ \(eEnt@(Entity eId _), _, epEnt) -> guardOn @[] (eId `Set.member` editableExams) (eEnt, epEnt)
     examParts = flip sortOn examParts' $ \(Entity _ Exam{..}, Entity _ ExamPart{..}) -> (examName, examPartNumber)
-    
+
     doExamPartPoints = fmap classifySheetType template == Just ExamPartPoints'
                     || not (null examParts)
-    
+
     acts = Map.fromList $ catMaybes
       [ pure ( Normal', Normal <$> gradingReq )
       , pure ( Bonus' , Bonus  <$> gradingReq )
@@ -1346,7 +1345,7 @@ sheetTypeAFormReq cId fs template = wFormToAForm $ do
       Informational' -> return $ i18n MsgSheetTypeInfoInformational
       NotGraded' -> return $ i18n MsgSheetTypeInfoNotGraded
       ExamPartPoints' -> return $ i18n MsgSheetTypeInfoExamPartPoints
-  
+
   aFormToWForm . explainedMultiActionA acts opts fs $ classifySheetType <$> template
 
 sheetGroupAFormReq :: FieldSettings UniWorX -> Maybe SheetGroup -> AForm Handler SheetGroup
@@ -1468,7 +1467,7 @@ jsonField fieldKind = Field{..}
 {- was only used in workflows; if needed recreate MsgYAMLFieldDecodeFailure
 yamlField :: ( ToJSON a, FromJSON a
              , MonadHandler m
-             , RenderMessage (HandlerSite m) FormMessage             
+             , RenderMessage (HandlerSite m) FormMessage
              )
           => Field m a
 yamlField = Field{..}
@@ -1483,7 +1482,14 @@ yamlField = Field{..}
           #{either id (decodeUtf8 . Yaml.encode) val}
       |]
     fieldEnctype = UrlEncoded
--}   
+-}
+
+
+boolField' :: ( MonadHandler m
+              , HandlerSite m ~ UniWorX
+              )
+          => Field m Bool
+boolField' = boolField (Just $ SomeMessage MsgBoolIrrelevant) -- MsgBoolIrrelevant is shown if the field is optional
 
 boolField :: ( MonadHandler m
              , HandlerSite m ~ UniWorX
@@ -2309,7 +2315,7 @@ examModeForm mPrev = examMode
   <*> customPresetForm examRequiredEquipmentEither (Just (SomeMessage MsgExamModeFormNone, Nothing)) (Just (SomeMessage MsgExamModeFormCustom, Nothing)) (id &&& Just . examRequiredEquipmentPresetWidget) (apreq htmlField (fslI MsgExamModeFormRequiredEquipment)) (fslI MsgExamModeFormRequiredEquipment & setTooltip MsgExamModeFormRequiredEquipmentIdentificationTip) (examRequiredEquipment <$> mPrev)
   where
     examMode examSynchronicity examOnline examAids examRequiredEquipment = ExamMode{..}
-    
+
     examAidsEither :: Iso' ExamAids (Either StoredMarkup ExamAidsPreset)
     examAidsEither = iso examAidsToEither examAidsFromEither
       where examAidsToEither (ExamAidsPreset p) = Right p

src/Handler/Utils/Qualification.hs

@@ -19,16 +19,20 @@ import qualified Database.Esqueleto.Utils as E
 
 import Handler.Utils.Widgets  (statusHtml)
 
+-- | Compute new valid date from old one and from validDuration in months
+--   Mainly to document which add months functions to use
+computeNewValidDate :: Integral a => a -> Day -> Day
+computeNewValidDate = addGregorianMonthsRollOver . toInteger
+
 statusQualificationBlock :: Bool -> Html
 statusQualificationBlock s = statusHtml (bool Error Success s) $ iconQualificationBlock s
 
-
 -- needs refactoring, probbably no longer helpful
 mkQualificationBlocked :: QualificationStandardReason -> UTCTime -> QualificationUserId -> QualificationUserBlock
 mkQualificationBlocked reason qualificationUserBlockFrom qualificationUserBlockQualificationUser = QualificationUserBlock{..}
-   where 
-     qualificationUserBlockReason  = tshow reason    
-     qualificationUserBlockUnblock = False 
+   where
+     qualificationUserBlockReason  = tshow reason
+     qualificationUserBlockUnblock = False
      qualificationUserBlockBlocker = Nothing
 
 -- somewhat dangerous, if not used with latest effective block
@@ -48,13 +52,13 @@ quserToNotify cutoff quser qblock = -- either recently become invalid with no pr
                 quser E.^. QualificationUserScheduleRenewal
       E.&&. ((  quser E.^. QualificationUserValidUntil E.<. E.val  (utctDay cutoff)
           E.&&. quser E.^. QualificationUserValidUntil E.>. E.day  (quser E.^. QualificationUserLastNotified)
-          E.&&. E.not_ (E.isFalse (qblock E.?. QualificationUserBlockUnblock)) -- not currently blocked
+          E.&&. E.not__ (E.isFalse (qblock E.?. QualificationUserBlockUnblock)) -- not currently blocked
         ) E.||. ( -- was recently blocked
-                        E.isFalse (qblock E.?. QualificationUserBlockUnblock) 
+                        E.isFalse (qblock E.?. QualificationUserBlockUnblock)
           E.&&. qblock E.?. QualificationUserBlockFrom E.>. E.just (quser E.^. QualificationUserLastNotified)
         ))
 
--- condition to ensure that the lastest QualificationUserBlock was picked, better to be used in join-on clauses, since inside a where-clause it might not work as intended
+-- | condition to ensure that the lastest QualificationUserBlock was picked, better to be used in join-on clauses, since inside a where-clause it might not work as intended
 isLatestBlockBefore :: E.SqlExpr (Maybe (Entity QualificationUserBlock)) -> E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value Bool)
 isLatestBlockBefore qualBlock cutoff = (cutoff E.>~. qualBlock E.?. QualificationUserBlockFrom) E.&&. E.notExists (do
     newerBlock <- E.from $ E.table @QualificationUserBlock
@@ -67,10 +71,24 @@ isLatestBlockBefore qualBlock cutoff = (cutoff E.>~. qualBlock E.?. Qualificatio
                ))
   )
 
+-- | condition to ensure that the lastest QualificationUserBlock was picked, better to be used in join-on clauses, since inside a where-clause it might not work as intended
+--   variant for inner joins
+isLatestBlockBefore' :: E.SqlExpr (Entity QualificationUserBlock) -> E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value Bool)
+isLatestBlockBefore' qualBlock cutoff = (cutoff E.>. qualBlock E.^. QualificationUserBlockFrom) E.&&. E.notExists (do
+    newerBlock <- E.from $ E.table @QualificationUserBlock
+    E.where_ $          newerBlock E.^. QualificationUserBlockQualificationUser E.==. qualBlock E.^. QualificationUserBlockQualificationUser
+        E.&&.           newerBlock E.^. QualificationUserBlockFrom              E.<=. cutoff
+        E.&&.           newerBlock E.^. QualificationUserBlockId                E.!=. qualBlock E.^. QualificationUserBlockId
+        E.&&.  ((       newerBlock E.^. QualificationUserBlockFrom              E.>.  qualBlock E.^. QualificationUserBlockFrom)
+          E.||. (       newerBlock E.^. QualificationUserBlockUnblock           -- in case of equal timestamps, any unblock wins
+                 E.&&. (newerBlock E.^. QualificationUserBlockFrom              E.==. qualBlock E.^. QualificationUserBlockFrom)
+               ))
+  )
+
 -- cutoff can be `E.val now` or even `Database.Esqueleto.PostgreSQL.now_`
 quserBlockAux :: Bool -> E.SqlExpr (E.Value UTCTime) -> (E.SqlExpr (E.Value QualificationUserId) -> E.SqlExpr (E.Value Bool)) -> Maybe (E.SqlExpr (Entity QualificationUserBlock) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (E.Value Bool)
-quserBlockAux negCond cutoff checkQualUserId mbBlockCondition = bool E.notExists E.exists negCond $ do 
-  qualUserBlock <- E.from $ E.table @QualificationUserBlock 
+quserBlockAux negCond cutoff checkQualUserId mbBlockCondition = bool E.notExists E.exists negCond $ do
+  qualUserBlock <- E.from $ E.table @QualificationUserBlock
   E.where_  $ E.not_ (qualUserBlock E.^. QualificationUserBlockUnblock)
       E.&&. (qualUserBlock E.^. QualificationUserBlockFrom E.<=. cutoff)
       E.&&. checkQualUserId (qualUserBlock E.^. QualificationUserBlockQualificationUser)
@@ -83,11 +101,11 @@ quserBlockAux negCond cutoff checkQualUserId mbBlockCondition = bool E.notExists
       )
   whenIsJust mbBlockCondition (E.where_ . ($ qualUserBlock))
 
--- | Test whether a QualificationUser was blocked/unblocked at a given day; negCond: True:isBlocked False:isUnblocked 
+-- | Test whether a QualificationUser was blocked/unblocked at a given day; negCond: True:isBlocked False:isUnblocked
 quserBlock :: Bool -> UTCTime -> E.SqlExpr (Entity QualificationUser) -> E.SqlExpr (E.Value Bool)
 quserBlock negCond cutoff qualUser = quserBlockAux negCond (E.val cutoff) (E.==. (qualUser E.^. QualificationUserId)) Nothing
 
--- | Variant of `isBlocked` for outer joins              
+-- | Variant of `isBlocked` for outer joins
 quserBlock' :: Bool -> UTCTime -> E.SqlExpr (Maybe (Entity QualificationUser)) -> E.SqlExpr (E.Value Bool)
 quserBlock' negCond cutoff qualUser = quserBlockAux negCond (E.val cutoff) (E.=?. (qualUser E.?. QualificationUserId)) Nothing
 
@@ -108,15 +126,17 @@ validQualification' cutoff qualUser =
            E.&&. quserBlock' False cutoff qualUser
 
 -- selectValidQualifications :: QualificationId -> [UserId] -> UTCTime -> DB [Entity QualificationUser]
-selectValidQualifications :: 
-  ( MonadIO m
-  , BackendCompatible SqlBackend backend
-  , PersistQueryRead backend
-  , PersistUniqueRead backend
-  ) => QualificationId -> [UserId] -> UTCTime -> ReaderT backend m [Entity QualificationUser]
-selectValidQualifications qid uids cutoff = 
+-- selectValidQualifications ::
+--   ( MonadIO m
+--   , BackendCompatible SqlBackend backend
+--   , PersistQueryRead backend
+--   , PersistUniqueRead backend
+--   ) => QualificationId -> [UserId] -> UTCTime -> ReaderT backend m [Entity QualificationUser]
+selectValidQualifications :: (MonadIO m, E.SqlBackendCanRead backend)
+  => QualificationId -> [UserId] -> UTCTime -> ReaderT backend m [Entity QualificationUser]
+selectValidQualifications qid uids cutoff =
   -- cutoff <- utctDay <$> liftIO getCurrentTime
-  E.select $ do 
+  E.select $ do
     qUser <- E.from $ E.table @QualificationUser
     E.where_ $  (qUser E.^. QualificationUserQualification E.==. E.val qid)
           E.&&.  qUser E.^. QualificationUserUser `E.in_` E.valList uids
@@ -138,7 +158,7 @@ upsertQualificationUser  qualificationUserQualification startTime qualificationU
   let qualificationUserLastRefresh = utctDay startTime
   Entity quid _ <- upsert
     QualificationUser
-      { qualificationUserFirstHeld        = qualificationUserLastRefresh      
+      { qualificationUserFirstHeld        = qualificationUserLastRefresh
       , qualificationUserScheduleRenewal  = fromMaybe True mbScheduleRenewal
       , qualificationUserLastNotified     = utctDayMidnight qualificationUserLastRefresh
       , ..
@@ -147,7 +167,7 @@ upsertQualificationUser  qualificationUserQualification startTime qualificationU
       [ QualificationUserScheduleRenewal    =. scheduleRenewal              | Just scheduleRenewal <- [mbScheduleRenewal]
       ] ++
       [ QualificationUserValidUntil         =. qualificationUserValidUntil
-      , QualificationUserLastRefresh        =. qualificationUserLastRefresh      
+      , QualificationUserLastRefresh        =. qualificationUserLastRefresh
       ]
     )
   authUsr <- liftHandler maybeAuthId
@@ -162,8 +182,8 @@ upsertQualificationUser  qualificationUserQualification startTime qualificationU
     }
 
 -- | Renew an existing valid qualification, ignoring all blocks otherwise
--- renewValidQualificationUsers :: QualificationId -> Maybe UTCTime -> [UserId] -> DB Int -- not general enough for use in YesodJobDB
-renewValidQualificationUsers :: 
+-- renewValidQualificationUsers :: QualificationId -> Maybe QualificationChangeReason -> Maybe UTCTime -> [UserId] -> DB Int -- not general enough for use in YesodJobDB
+renewValidQualificationUsers ::
   ( AuthId (HandlerSite m) ~ Key User
   , IsPersistBackend (YesodPersistBackend (HandlerSite m))
   , BaseBackend (YesodPersistBackend (HandlerSite m)) ~ SqlBackend
@@ -174,7 +194,7 @@ renewValidQualificationUsers ::
   , YesodAuthPersist (HandlerSite m)
   , HasAppSettings (HandlerSite m)
   , MonadHandler m
-  , MonadCatch m  
+  , MonadCatch m
   ) => QualificationId -> Maybe QualificationChangeReason -> Maybe UTCTime -> [UserId] -> ReaderT (YesodPersistBackend (HandlerSite m)) m Int
 renewValidQualificationUsers qid reason renewalTime uids =
   -- The following short code snippet suffices in principle, but would not allow audit log entries. Are these still needed?
@@ -182,15 +202,17 @@ renewValidQualificationUsers qid reason renewalTime uids =
   --   E.set qu [ QualificationUserValidUntil E.+=. E.interval (CalendarDiffDays 2 0) ] -- TODO: for Testing only
   --   E.where_ $ (qu E.^. QualificationUserQualification E.==. E.val qid )
   --       E.&&.  (qu E.^. QualificationUserUser `E.in_` E.valList uids)
-  get qid >>= \case     
+  get qid >>= \case
+    Just Qualification{qualificationElearningRenews=False}
+      | Just (Right (QualificationRenewELearningBy _)) <- reason -> return 0
     Just Qualification{qualificationValidDuration=Just renewalMonths} -> do
       cutoff <- maybe (liftIO getCurrentTime) return renewalTime
       quEntsAll <- selectValidQualifications qid uids cutoff
       let cutoffday   = utctDay cutoff
           maxValidTo  = addGregorianMonthsRollOver (toInteger $ renewalMonths `div` 2) cutoffday
           quEnts      = filter (\q -> maxValidTo >= (q ^. _entityVal . _qualificationUserValidUntil)) quEntsAll
-      forM_ quEnts $ \(Entity quId QualificationUser{..}) -> do 
-        let newValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) qualificationUserValidUntil        
+      forM_ quEnts $ \(Entity quId QualificationUser{..}) -> do
+        let newValidTo = computeNewValidDate renewalMonths qualificationUserValidUntil
         update quId [ QualificationUserValidUntil   =. newValidTo
                     , QualificationUserLastRefresh  =. cutoffday
                     ]
@@ -206,7 +228,7 @@ renewValidQualificationUsers qid reason renewalTime uids =
     _ -> return (-1) -- qualificationId not found, isNothing qualificationValidDuration, etc.
 
 -- | Block or unblock some users for a given reason, but only if they are not already blocked (essential assumption that is actually used)
-qualificationUserBlocking :: 
+qualificationUserBlocking ::
   ( AuthId (HandlerSite m) ~ Key User
   , IsPersistBackend (YesodPersistBackend (HandlerSite m))
   , BaseBackend (YesodPersistBackend (HandlerSite m)) ~ SqlBackend
@@ -221,13 +243,13 @@ qualificationUserBlocking ::
   , Num n
   ) => QualificationId -> [UserId] -> Bool -> Maybe UTCTime -> QualificationChangeReason -> Bool -> ReaderT (YesodPersistBackend (HandlerSite m)) m n
 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]
+  $logInfoS "BLOCK" $ Text.intercalate " - " [tshow qid, tshow unblock, tshow mbBlockTime, tshow reason, tshow notify, "#Users:" <> tshow (length uids), tshow uids] -- this message can get very long on test systems
   authUsr <- liftHandler maybeAuthId
   now <- liftIO getCurrentTime
-  let blockTime = fromMaybe now mbBlockTime      
-  -- -- Code would work, but problematic 
+  let blockTime = fromMaybe now mbBlockTime
+  -- -- Code would work, but problematic
   -- oks <- E.insertSelectCount . E.from $ \qualificationUser -> do
-  --   E.where_ $ qualificationUser E.^. QualificationUserQualification E.==. E.val qid 
+  --   E.where_ $ qualificationUser E.^. QualificationUserQualification E.==. E.val qid
   --       E.&&.  qualificationUser E.^. QualificationUserUser E.in_ E.valList uid
   --       E.&&.  quserBlock unblock blockTime qualificationUser -- only unblock blocked qualification and vice versa
   --   return $ QualificationUserBlock
@@ -238,7 +260,7 @@ qualificationUserBlocking qid uids unblock mbBlockTime (qualificationChangeReaso
   --     E.<&> E.val authUsr
   toChange <- E.select $ do
     qualUser <- E.from $ E.table @QualificationUser
-    E.where_ $ qualUser E.^. QualificationUserQualification E.==. E.val qid 
+    E.where_ $ qualUser E.^. QualificationUserQualification E.==. E.val qid
         E.&&.  qualUser E.^. QualificationUserUser `E.in_` E.valList uids
         E.&&.  quserBlock unblock blockTime qualUser -- only unblock blocked qualification and vice versa
     return (qualUser E.^. QualificationUserId, qualUser E.^. QualificationUserUser)
@@ -258,7 +280,7 @@ qualificationUserBlocking qid uids unblock mbBlockTime (qualificationChangeReaso
     }
   return $ fromIntegral $ length newBlocks
 
-qualificationUserUnblockByReason :: 
+qualificationUserUnblockByReason ::
   ( AuthId (HandlerSite m) ~ Key User
   , IsPersistBackend (YesodPersistBackend (HandlerSite m))
   , BaseBackend (YesodPersistBackend (HandlerSite m)) ~ SqlBackend
@@ -273,11 +295,39 @@ qualificationUserUnblockByReason ::
   , Num n
   ) => QualificationId -> [UserId] -> Maybe UTCTime -> QualificationChangeReason -> QualificationChangeReason -> Bool -> ReaderT (YesodPersistBackend (HandlerSite m)) m n
 qualificationUserUnblockByReason qid uids mbUnblockTime (qualificationChangeReasonText -> reason) undo_reason notify = do
-  cutoff <- maybe (liftIO getCurrentTime) return mbUnblockTime 
+  cutoff <- maybe (liftIO getCurrentTime) return mbUnblockTime
   toUnblock <- E.select $ do
     quser <- E.from $ E.table @QualificationUser
     E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid
         E.&&.  quser E.^. QualificationUserUser `E.in_` E.valList uids
         E.&&.  quserBlockAux True (E.val cutoff) (E.==. (quser E.^. QualificationUserId)) (Just (\qblock -> (qblock E.^. QualificationUserBlockReason) E.==. E.val reason))
     return $ quser E.^. QualificationUserUser
-  qualificationUserBlocking qid (E.unValue <$> toUnblock) True mbUnblockTime undo_reason notify 
+  qualificationUserBlocking qid (E.unValue <$> toUnblock) True mbUnblockTime undo_reason notify
+
+
+-----------
+-- Forms --
+-----------
+
+
+qualificationOption :: Entity Qualification -> Option QualificationId
+qualificationOption (Entity qid Qualification{..}) =
+  let qsh = ciOriginal $ unSchoolKey qualificationSchool
+  in  Option{ optionDisplay       = ciOriginal qualificationName      <> " ("  <> qsh <> ")"
+            , optionExternalValue = toPathPiece $ ciOriginal qualificationShorthand <> "___" <> qsh  -- both a publicly known already
+            , optionInternalValue = qid
+            }
+
+qualificationsOptionList :: [Entity Qualification] -> OptionList QualificationId
+qualificationsOptionList = mkOptionList . map qualificationOption
+
+{- Should we encrypt the external value or simply rely on uniqueness? --TODO: still used in Handler.Admin.Avs
+qualOpt :: Entity Qualification -> Handler (Option QualificationId)
+qualOpt (Entity qualId qual) = do
+  cQualId :: CryptoUUIDQualification <- encrypt qualId
+  return $ Option
+    { optionDisplay       = ciOriginal $ qualificationName qual
+    , optionInternalValue = qualId
+    , optionExternalValue = tshow cQualId
+    }
+-}

src/Handler/Utils/Table/Cells.hs

@@ -14,7 +14,7 @@ import Handler.Utils.DateTime
 import Handler.Utils.Widgets
 import Handler.Utils.Occurrences
 import Handler.Utils.LMS (lmsUserStatusWidget)
-import Handler.Utils.Qualification (isValidQualification) 
+import Handler.Utils.Qualification (isValidQualification)
 
 type CourseLink = (TermId, SchoolId, CourseShorthand) -- TODO: Refactor with WithHoles !
 
@@ -32,6 +32,7 @@ spacerCell = cell [whamlet| |]
 semicolonCell :: IsDBTable m a => DBCell m a
 semicolonCell = cell [whamlet|; |]
 
+-- | Contribute to DBResult. BEWARE: only shown cells are executed; pagination makes tellCell useless for rowcounts; instead use dbtProj for computations on all rows regardless of pagination
 tellCell :: IsDBTable m a => a -> DBCell m a -> DBCell m a
 tellCell = flip mappend . writerCell . tell
 
@@ -41,16 +42,23 @@ cellTell = flip tellCell
 indicatorCell :: IsDBTable m Any => DBCell m Any -- For dbTables that return a Bool to indicate content
 indicatorCell = writerCell . tell $ Any True
 
+addIndicatorCell :: IsDBTable m Any => DBCell m Any -> DBCell m Any
+addIndicatorCell = tellCell $ Any True
+
 writerCell :: IsDBTable m w => WriterT w m () -> DBCell m w
 writerCell act = mempty & cellContents %~ (<* act)
 
--- for documentation purposes 
+-- for documentation purposes
 cellMaybe :: IsDBTable m b => (a -> DBCell m b) -> Maybe a -> DBCell m b
 cellMaybe = foldMap
 
 maybeCell :: IsDBTable m b => Maybe a -> (a -> DBCell m b) -> DBCell m b
 maybeCell = flip foldMap
 
+boolCell :: IsDBTable m b => Bool -> DBCell m b -> DBCell m b
+boolCell True   c = c
+boolCell False  _ = mempty
+
 htmlCell :: (IsDBTable m a, ToMarkup c) => c -> DBCell m a
 htmlCell = cell . toWidget . toMarkup
 
@@ -62,7 +70,7 @@ sqlCell :: (IsDBTable (YesodDB UniWorX) a) => YesodDB UniWorX Widget -> DBCell (
 sqlCell act = mempty & cellContents .~ lift act
 
 -- TODO: Formulate variant of sqlCell that types for tables having actions, i.e. MForm istead of YesodDB?
--- sqlCell' :: (IsDBTable (MForm Handler) a) => _ -> DBCell (MForm Handler) a 
+-- sqlCell' :: (IsDBTable (MForm Handler) a) => _ -> DBCell (MForm Handler) a
 -- sqlCell' = flip (set' cellContents) mempty
 
 -- | Highlight table cells with warning: Is not yet implemented in frontend.
@@ -158,14 +166,14 @@ 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 
+modalCellLarge content
   | length content > 32 = modalCell  content
   | otherwise           = stringCell content
 
 markupCellLargeModal :: IsDBTable m a => StoredMarkup -> DBCell m a
 markupCellLargeModal mup
   | markupIsSmallish mup = cell $ toWidget mup
-  | otherwise = modalCell mup  
+  | otherwise = modalCell mup
 
 -----------------
 -- Datatype cells
@@ -221,44 +229,44 @@ cellHasUserLink toLink user =
 
 -- | 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 = 
+cellHasUserModal toLink user =
   let userEntity = user ^. hasEntityUser
       uid   = userEntity ^. _entityKey
       nWdgt = nameWidget (userEntity ^. _entityVal . _userDisplayName) (userEntity ^.  _entityVal . _userSurname)
-      lWdgt = do 
+      lWdgt = do
                 uuid <- liftHandler $ encrypt uid
-                modalAccess nWdgt nWdgt False $ 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 = 
+cellHasUserModalAdmin toLink user =
   let userEntity = user ^. hasEntityUser
       uid   = userEntity ^. _entityKey
       nWdgt = nameWidget (userEntity ^. _entityVal . _userDisplayName) (userEntity ^.  _entityVal . _userSurname)
-      lWdgt = do 
+      lWdgt = do
                 uuid <- liftHandler $ encrypt uid
-                modal nWdgt $ Left $ SomeRoute $ toLink uuid                
+                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 = 
+cellEditUserModal user =
   let userEntity = user ^. hasEntityUser
       uid   = userEntity ^. _entityKey
-      nWdgt = toWidget $ icon IconUserEdit      
-      lWdgt = do 
+      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 = 
+cellEditUserModalAdmin user =
   let userEntity = user ^. hasEntityUser
       uid   = userEntity ^. _entityKey
-      nWdgt = toWidget $ icon IconUserEdit      
-      lWdgt = do 
+      nWdgt = toWidget $ icon IconUserEdit
+      lWdgt = do
                 uuid <- liftHandler $ encrypt uid
                 modal nWdgt (Left $ SomeRoute $ ForProfileR uuid)
   in cell lWdgt
@@ -267,23 +275,23 @@ cellHasMatrikelnummer :: (IsDBTable m a, HasUser u) => u -> DBCell m a
 cellHasMatrikelnummer = maybe mempty textCell . view _userMatrikelnummer
 
 cellHasMatrikelnummerLinked :: (IsDBTable m a, HasEntity u User) => Bool -> u -> DBCell m a
-cellHasMatrikelnummerLinked isAdmin usr 
-    | Just matNr <- usrEntity ^. _userMatrikelnummer = cell $ do 
+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 
+  where
     usrEntity = usr ^. hasEntityUser
 
 cellHasMatrikelnummerLinkedAdmin :: (IsDBTable m a, HasEntity u User) => u -> DBCell m a
-cellHasMatrikelnummerLinkedAdmin usr 
-    | Just matNr <- usrEntity ^. _userMatrikelnummer = cell $ do 
+cellHasMatrikelnummerLinkedAdmin usr
+    | Just matNr <- usrEntity ^. _userMatrikelnummer = cell $ do
         uuid <- liftHandler $ encrypt $ usrEntity ^. _entityKey
-        modal (text2widget matNr) (Left $ SomeRoute $ AdminAvsUserR uuid)        
+        modal (text2widget matNr) (Left $ SomeRoute $ AdminAvsUserR uuid)
     | otherwise = mempty
-  where 
+  where
     usrEntity = usr ^. hasEntityUser
 
 
@@ -371,6 +379,25 @@ companyIdCell cid = companyCell csh csh False
   where
     csh = unCompanyKey cid
 
+-- | Uses DB Lookup to link to a qualification by id only, use sparingly!
+qualificationIdCell :: (IsDBTable m c) => QualificationId -> DBCell m c
+qualificationIdCell qid = anchorCellM' qual link name
+  where
+    qual = liftHandler $ runDBRead $ get qid
+    link (Just Qualification{..}) = QualificationR qualificationSchool qualificationShorthand
+    link Nothing = HelpR
+    name Nothing = text2widget "Error: unknown QID"
+    name (Just Qualification{..}) = citext2widget qualificationName
+
+qualificationIdShortCell :: (IsDBTable m c) => QualificationId -> DBCell m c
+qualificationIdShortCell qid = anchorCellM' qual link name
+  where
+    qual = liftHandler $ runDBRead $ get qid
+    link (Just Qualification{..}) = QualificationR qualificationSchool qualificationShorthand
+    link Nothing = HelpR
+    name Nothing = text2widget "Error: unknown QID"
+    name (Just Qualification{..}) = citext2widget qualificationShorthand
+
 qualificationCell :: (IsDBTable m c, HasQualification a) => a -> DBCell m c
 qualificationCell (view hasQualification -> Qualification{..}) = anchorCell link name
   where
@@ -393,7 +420,7 @@ qualificationDescrCell (view hasQualification -> q@Qualification{..}) = qualific
 qualificationValidIconCell :: (IsDBTable m c, HasQualificationUser a, HasQualificationUserBlock b) => Day -> Maybe b -> a -> DBCell m c
 qualificationValidIconCell d qb qu = do
   blockIcon $ isValidQualification d qu qb
-  where 
+  where
     blockIcon = cell . toWidget . iconQualificationBlock
 
 qualificationValidUntilCell :: (IsDBTable m c, HasQualificationUser a, HasQualificationUserBlock b) => Day -> Maybe b -> a -> DBCell m c
@@ -402,11 +429,11 @@ qualificationValidUntilCell = qualificationValidUntilCell' (Just LmsUserAllR)
 qualificationValidUntilCell' :: (IsDBTable m c, HasQualificationUser a, HasQualificationUserBlock b) => Maybe (CryptoUUIDUser -> Route UniWorX) -> Day -> Maybe b -> a -> DBCell m c
 qualificationValidUntilCell' mbToLink d qb qu = cell $ case mbToLink of
     Nothing     -> headWgt <> dateWgt
-    Just toLink -> do 
+    Just toLink -> do
       uuid <- liftHandler $ encrypt $ qu ^. hasQualificationUser . _qualificationUserUser
       let modalWgt = modalAccess dateWgt dateWgt False $ toLink uuid
       headWgt <> modalWgt
-  where       
+  where
     dateWgt = formatTimeW SelFormatDate (qu ^. hasQualificationUser . _qualificationUserValidUntil)
     iconWgt = toWidget $ iconQualificationBlock $ isValidQualification d qu qb
     headWgt = iconWgt <> [whamlet|&emsp;|]
@@ -416,18 +443,18 @@ qualificationValidReasonCell = qualificationValidReasonCell' (Just LmsUserAllR)
 
 qualificationValidReasonCell' :: (IsDBTable m c, HasQualificationUser a, HasQualificationUserBlock b) => Maybe (CryptoUUIDUser -> Route UniWorX) -> Bool -> Day -> Maybe b -> a -> DBCell m c
 qualificationValidReasonCell' mbToLink showReason d qb qu = ic <> foldMap blc qb
-  where     
+  where
     ic = cell . toWidget . iconQualificationBlock $ isValidQualification d qu qb
     blc (view hasQualificationUserBlock -> QualificationUserBlock{..})
-      | showReason = spacerCell <> dc qualificationUserBlockFrom <> spacerCell <> modalCellLarge qualificationUserBlockReason           
+      | showReason = spacerCell <> dc qualificationUserBlockFrom <> spacerCell <> modalCellLarge qualificationUserBlockReason
       | qualificationUserBlockUnblock = mempty
       | otherwise  = spacerCell <> dateCell qualificationUserBlockFrom
-    dc tstamp 
+    dc tstamp
       | Just toLink <- mbToLink = cell $ do
           uuid <- liftHandler $ encrypt uid
           let dWgt = formatTimeW SelFormatDate tstamp
           modalAccess dWgt dWgt False $ toLink uuid
-        --  anchorCellM (toLink <$> encrypt uid) 
+        --  anchorCellM (toLink <$> encrypt uid)
       | otherwise = dateCell tstamp
     uid = qu ^. hasQualificationUser . _qualificationUserUser
 
@@ -438,15 +465,15 @@ qualificationValidReasonCell'' mbToLink showReason d qb qu extValid = ic <> icEr
     icErr = cell . toWidget . isBad $ quValid /= extValid
     ic = cell . toWidget $ iconQualificationBlock quValid
     blc (view hasQualificationUserBlock -> QualificationUserBlock{..})
-      | showReason = spacerCell <> dc qualificationUserBlockFrom <> spacerCell <> modalCellLarge qualificationUserBlockReason           
+      | showReason = spacerCell <> dc qualificationUserBlockFrom <> spacerCell <> modalCellLarge qualificationUserBlockReason
       | qualificationUserBlockUnblock = mempty
       | otherwise  = spacerCell <> dateCell qualificationUserBlockFrom
-    dc tstamp 
+    dc tstamp
       | Just toLink <- mbToLink = cell $ do
           uuid <- liftHandler $ encrypt uid
           let dWgt = formatTimeW SelFormatDate tstamp
           modalAccess dWgt dWgt False $ toLink uuid
-        --  anchorCellM (toLink <$> encrypt uid) 
+        --  anchorCellM (toLink <$> encrypt uid)
       | otherwise = dateCell tstamp
     uid = qu ^. hasQualificationUser . _qualificationUserUser
 
@@ -496,7 +523,7 @@ lmsStatusCell extendedInfo mkLink = wgtCell . lmsUserStatusWidget extendedInfo m
 
 lmsStateCell :: IsDBTable m a => LmsState -> DBCell m a
 lmsStateCell LmsFailed  = iconBoolCell False
-lmsStateCell LmsOpen    = iconSpacerCell 
+lmsStateCell LmsOpen    = iconSpacerCell
 lmsStateCell LmsPassed  = iconBoolCell True
 
 avsPersonNoCell :: (IsDBTable m c, HasUserAvs a) => a -> DBCell m c
@@ -515,7 +542,7 @@ avsPersonNoLinkedCellAdmin a = cell $ do
   modal nWgt (Left $ SomeRoute $ AdminAvsUserR uuid)
 
 avsPersonCardCell :: (IsDBTable m c) => Set AvsDataPersonCard -> DBCell m c
-avsPersonCardCell cards = wgtCell 
+avsPersonCardCell cards = wgtCell
     [whamlet|
       $newline never
       <ul .list--iconless .list--inline .list--comma-separated>
@@ -523,6 +550,6 @@ avsPersonCardCell cards = wgtCell
           <li>
             _{c}
     |]
-  where 
+  where
     validCards  = Set.filter avsDataValid cards
     validColors = Set.toDescList $ Set.map avsDataCardColor validCards

src/Handler/Utils/Table/Columns.hs

@@ -417,12 +417,16 @@ fltrUserNameUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map F
 fltrUserNameUI = fltrUserNameLinkUI
 
 fltrUserNameLinkUI ::  Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
-fltrUserNameLinkUI = fltrUserNameLinkHdrUI MsgTableCourseMembers  
+fltrUserNameLinkUI = fltrUserNameLinkHdrUI MsgTableCourseMembers
 
 fltrUserNameLinkHdrUI :: (RenderMessage UniWorX msg) => msg -> Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
-fltrUserNameLinkHdrUI msg mPrev = 
+fltrUserNameLinkHdrUI msg mPrev =
   prismAForm (singletonFilter "user-name") mPrev $ aopt textField (fslI msg)
 
+fltrUserDisplayNameHdrUI :: (RenderMessage UniWorX msg) => msg -> Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
+fltrUserDisplayNameHdrUI msg mPrev =
+  prismAForm (singletonFilter "user-display-name") mPrev $ aopt textField (fslI msg)
+
 fltrUserNameEmailUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
 fltrUserNameEmailUI = fltrUserNameEmailHdrUI MsgTableCourseMembers
 
@@ -686,7 +690,7 @@ fltrRelevantStudyFeaturesTerms queryTermUser = singletonMap "features-terms" . F
 
 fltrRelevantStudyFeaturesTermsUI :: DBFilterUI
 fltrRelevantStudyFeaturesTermsUI = fltrStudyTermsUI
-  
+
 fltrRelevantStudyFeaturesDegree :: OpticFilterColumn' t (Set Text) (E.SqlExpr (E.Value TermId), E.SqlExpr (E.Value UserId))
 fltrRelevantStudyFeaturesDegree queryTermUser = singletonMap "features-degree" . FilterColumn $ \t criterias ->
   E.subSelectOr . E.from $ \(term `E.InnerJoin` studyFeatures) -> do
@@ -705,7 +709,7 @@ fltrRelevantStudyFeaturesDegree queryTermUser = singletonMap "features-degree" .
 fltrRelevantStudyFeaturesDegreeUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
 fltrRelevantStudyFeaturesDegreeUI mPrev =
   prismAForm (singletonFilter "features-degree") mPrev $ aopt textField (fslI MsgTableDegreeName)
-  
+
 fltrRelevantStudyFeaturesSemester :: OpticFilterColumn' t (Set Text) (E.SqlExpr (E.Value TermId), E.SqlExpr (E.Value UserId))
 fltrRelevantStudyFeaturesSemester queryTermUser = singletonMap "features-semester" . FilterColumn $ \t criterias ->
   E.subSelectOr . E.from $ \(term `E.InnerJoin` studyFeatures) -> do
@@ -741,13 +745,13 @@ fltrQualificationHdrUI msg mPrev = prismAForm (singletonFilter "qualification" .
 
 {-
 -- colUserCompany :: (HandlerSite (DBCell m) ~ UniWorX, IsDBTable m c, HasEntity a User) => Colonnade Sortable a (DBCell m c)
-colUserCompany = sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \heu -> do   
+colUserCompany = sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \heu -> do
       let uid = heu ^. hasEntity . _entityKey
       companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
         E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid
         E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
         return (comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor)
-      let companies = intersperse (text2markup ", ") $ 
+      let companies = intersperse (text2markup ", ") $
             (\(E.Value cmpName, E.Value cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> companies'
           icnSuper = text2markup " " <> icon IconSupervisor
       cell $ toWgt $ mconcat companies
@@ -756,13 +760,13 @@ colUserCompany = sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \
 -- PROBLEM: how to type sqlCell compatible with dbTable that as actions, i.e. MForm instead of YesodDB?
 colUserCompany :: (IsDBTable (YesodDB UniWorX) c, HasEntity a User) => Colonnade Sortable a (DBCell (YesodDB UniWorX) c)
 colUserCompany = sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \heu ->
-      let uid = heu ^. hasEntity . _entityKey in 
-      sqlCell $ do 
+      let uid = heu ^. hasEntity . _entityKey in
+      sqlCell $ do
         companies' <- E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
           E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid
           E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
           return (comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor)
-        let companies = intersperse (text2markup ", ") $ 
+        let companies = intersperse (text2markup ", ") $
               (\(E.Value cmpName, E.Value cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> companies'
             icnSuper = text2markup " " <> icon IconSupervisor
         pure $ toWgt $ mconcat companies
@@ -803,12 +807,12 @@ fltrCompanyNameNr query = ("company-name-number", FilterColumn $ \needle (setFol
     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       
+        fltrCno     = mkExactFilter              (query >>> (E.^. CompanyAvsId))     needle numCrits
     in if null numCrits
         then fltrCName E.||. fltrCShort
-        else fltrCName E.||. fltrCShort E.||. fltrCno      
+        else fltrCName E.||. fltrCShort E.||. fltrCno
     )
-  where 
+  where
     setFoldMap :: (Text -> Set.Set Text) -> Set.Set Text -> Set.Set Text
     setFoldMap = foldMap
 
@@ -825,22 +829,22 @@ fltrCompanyNameNrHdrUI msg mPrev =
 ---------
 
 
-fltrAVSCardNos :: (IsFilterColumnHandler t ([Text] -> Handler (a -> E.SqlExpr (E.Value Bool))), IsString k) 
+fltrAVSCardNos :: (IsFilterColumnHandler t ([Text] -> Handler (a -> E.SqlExpr (E.Value Bool))), IsString k)
               => (a -> E.SqlExpr (Entity User)) -> Map k (FilterColumn t fs)
 fltrAVSCardNos queryUser = Map.singleton "avs-card" fch
-  where 
+  where
     fch = FilterColumnHandler $ \case
       [] -> return (const E.true)
       cs -> do
         let crds = mapMaybe parseAvsCardNo $ foldMap anySeparatedText cs
         toutsecs <- getsYesod $ preview $ _appAvsConf . _Just . _avsTimeout
-        maybeTimeoutHandler toutsecs (try $ queryAvsCardNos crds) >>= \case 
-          Nothing               -> addMessageI Error MsgAvsCommunicationTimeout 
+        maybeTimeoutHandler toutsecs (try $ queryAvsCardNos crds) >>= \case
+          Nothing               -> addMessageI Error MsgAvsCommunicationTimeout
                                 >> return (const E.false)
           (Just (Left err))     -> addMessage  Error (someExc2Html err)
                                 >> return (const E.false)
           (Just (Right (null -> True))) -> return (const E.false)
-          (Just (Right apids)) -> return $ 
+          (Just (Right apids)) -> return $
             \(queryUser -> user) ->
               E.exists $ E.from $ \usrAvs ->
                 E.where_ $ usrAvs E.^. UserAvsUser E.==. user E.^. UserId
@@ -849,8 +853,8 @@ fltrAVSCardNos queryUser = Map.singleton "avs-card" fch
     someExc2Html (SomeException e) = text2Html $ tshow e
 
 fltrAVSCardNosUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
-fltrAVSCardNosUI mPrev = 
-  prismAForm (singletonFilter "avs-card" ) mPrev $ 
+fltrAVSCardNosUI mPrev =
+  prismAForm (singletonFilter "avs-card" ) mPrev $
     aopt textField (fslI MsgAvsCardNo & setTooltip (SomeMessages [SomeMessage MsgTableFilterComma, SomeMessage MsgAvsQueryNeeded]))
 
 

src/Handler/Utils/Table/Pagination.hs

@@ -84,7 +84,7 @@ import Data.Ratio ((%))
 import qualified Data.Foldable as Foldable
 
 import qualified Yesod.Form.Functions as Yesod
-  
+
 import qualified Database.Esqueleto.Legacy as E
 import qualified Database.Esqueleto.Utils as E
 import qualified Database.Esqueleto.Internal.Internal as E (SqlSelect,unsafeSqlValue)
@@ -170,7 +170,7 @@ dbFilterKey ident = toPathPiece . WithIdent ident
 
 
 data SomeExprValue = forall a. PersistField a => SomeExprValue { getSomeExprValue :: E.SqlExpr (E.Value a) }
-  
+
 data SortColumn t r' = forall a. PersistField a => SortColumn           { getSortColumn :: t -> E.SqlExpr (E.Value a) }
                      | forall a. PersistField a => SortColumnNullsInv   { getSortColumn :: t -> E.SqlExpr (E.Value a) }
                      | forall a. PersistField a => SortColumnNeverNull  { getSortColumn :: t -> E.SqlExpr (E.Value a) }
@@ -264,7 +264,7 @@ instance Monoid (DBTProjFilterPost r') where
 data FilterColumn t fs = forall a. IsFilterColumn t a => FilterColumn a
                        | forall a. IsFilterColumnHandler t a => FilterColumnHandler a
                        | forall a. IsFilterProjected fs a => FilterProjected a
-                       
+
 
 filterColumn :: FilterColumn t fs -> Maybe ([Text] -> t -> E.SqlExpr (E.Value Bool))
 filterColumn (FilterColumn f) = Just $ filterColumn' f
@@ -292,9 +292,9 @@ instance IsFilterColumn t cont => IsFilterColumn t (t -> cont) where
 
 instance {-# OVERLAPPABLE #-} (PathPiece (Element l), IsFilterColumn t cont, MonoPointed l, Monoid l) => IsFilterColumn t (l -> cont) where
   filterColumn' cont is' = filterColumn' (cont $ is' ^. mono' _PathPiece) is'
-  
-class IsFilterColumnHandler t a where 
-  filterColumnHandler' :: a -> [Text] -> Handler (t -> E.SqlExpr (E.Value Bool))  
+
+class IsFilterColumnHandler t a where
+  filterColumnHandler' :: a -> [Text] -> Handler (t -> E.SqlExpr (E.Value Bool))
 
 instance IsFilterColumnHandler t ([Text] -> Handler (t -> E.SqlExpr (E.Value Bool))) where
   filterColumnHandler' fin args = fin args
@@ -482,7 +482,7 @@ data DBCsvMode
   | DBCsvAbort
 
 makePrisms ''DBCsvMode
-  
+
 data DBCsvDiff r' csv k'
   = DBCsvDiffNew
     { dbCsvNewKey :: Maybe k'
@@ -519,7 +519,7 @@ makeLenses_ ''DBCsvException
 
 instance (Typeable k', Show k') => Exception (DBCsvException k')
 
-  
+
 data DBTProjCtx fs r = DBTProjCtx
   { dbtProjFilter :: fs
   , dbtProjRow :: DBRow r
@@ -613,7 +613,7 @@ data DBStyle r = DBStyle
   }
 
 data DBSTemplateMode r = DBSTDefault { dbstmNumber :: Int64 -> Bool, dbstmShowNumber :: Int64 -> Bool }
-                       | DBSTCourse 
+                       | DBSTCourse
                            (Lens' r (Entity Course))           -- course
                            (Traversal' r (Entity User))        -- lecturers
                            (Lens' r Bool)                      -- isRegistered
@@ -666,7 +666,7 @@ multiFilter key = prism' fromInner fromOuter
       -- 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
   , DBTableKey k'
@@ -750,7 +750,7 @@ dbtProjId :: forall fs r r'.
              ( fs ~ (), DBRow r ~ r' )
           => ReaderT (DBTProjCtx fs r) (MaybeT (ReaderT SqlBackend (HandlerFor UniWorX))) r'
 dbtProjId = dbtProjId'
-  
+
 dbtProjSimple' :: forall fs r r' r''.
                   DBRow r'' ~ r'
                => (r -> DB r'')
@@ -1059,7 +1059,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
   doSorting <- or2M
     (getsYesod . views _appBotMitigations $ Set.notMember SettingBotMitigationOnlyLoggedInTableSorting)
     (is _Just <$> maybeAuthId)
-  
+
   let
     sortingOptions = mkOptionList
       [ Option t' (SortingSetting t d) t'
@@ -1112,7 +1112,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
            <|> piInput
 
   psShortcircuit <- (== Just dbtIdent') <$> lookupCustomHeader HeaderDBTableShortcircuit
-  
+
   let
     -- adjustPI = over _piSorting $ guardOnM doSorting -- probably not neccessary; not displaying the links should be enough for now
     ((errs, PaginationSettings{..}), paginationInput@PaginationInput{..})
@@ -1217,8 +1217,8 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
     --               && all (is _Just) filterSql
 
     -- psLimit' = bool PagesizeAll psLimit selectPagesize
-  
-  filterHandler <- case csvMode of 
+
+  filterHandler <- case csvMode of
     FormSuccess DBCsvImport{} -> return mempty -- don't execute Handler actions for unneeded filters upon csv _import_
     _other -> liftHandler $ forM psFilter' $ \(fc,args) -> mapM ($ args) $ filterColumnHandler fc
 
@@ -1240,7 +1240,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
           Just ps -> E.where_ $ dbtRowKey t `E.sqlIn` ps              -- Note that multiple where_ are indeed concatenated
           _other  -> return ()
         let filterAppT = Map.foldr (\fc expr -> maybe expr ((: expr) . ($ t)) fc) []
-            sqlFilters = filterAppT filterHandler <> filterAppT filterSql  -- Note that <> on the maps won't work as intended, since keys are present in both            
+            sqlFilters = filterAppT filterHandler <> filterAppT filterSql  -- Note that <> on the maps won't work as intended, since keys are present in both
         unless (null sqlFilters) $ E.where_ $ E.and sqlFilters
     return (E.unsafeSqlValue "count(*) OVER ()" :: E.SqlExpr (E.Value Int64), dbtRowKey t, res)
 
@@ -1279,7 +1279,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
     exData <- hoistMaybe dbtCsvExampleData
     hdr <- lift $ dbtCsvHeader Nothing
     exportUrl <- toTextUrl (currentRoute, [(toPathPiece GetCsvExampleData, "")])
-    return $(widgetFile "table/csv-example") 
+    return $(widgetFile "table/csv-example")
 
   formResult csvMode $ \case
     DBCsvAbort{} -> do
@@ -1470,7 +1470,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
     guardM doAltRep
 
     cts <- reqAccept <$> getRequest
-    
+
     altRep <- hoistMaybe <=< asum $ do
       mRep <- hoistMaybe . selectRep' extraReps' =<< cts
       return . return $ mRep <&> \case
@@ -1520,7 +1520,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
                        -> State.modify $ (:) (n, beforeSize, cellSize)
                      | otherwise -> return ()
               let rowspanAcc'' = rowspanAcc'
-                    & traverse . _1 %~ pred 
+                    & traverse . _1 %~ pred
               whenIsJust (flattenAnnotated v) $ go rowspanAcc''
 
             compCellSize :: forall h' c. [(Int, Int, Int)] -> [Sized (Maybe Int) h' c] -> Sized (Maybe Int) h' c -> (Int, Maybe Int)
@@ -1634,7 +1634,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
                      addMessageI Success . MsgCsvImportSuccessful $ length acts'
                      E.transactionSave
                      redirect finalDest
-              
+
     _other -> return ((FormMissing, mempty), mempty)
   formResult csvImportConfirmRes $ \case
     (_, BtnCsvImportAbort) -> do
@@ -1661,7 +1661,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
 
     setParam :: Text -> Maybe Text -> QueryText -> QueryText
     setParam key = setParams key . maybeToList
-    
+
 
 dbTableWidget :: Monoid x
               => PSValidator (HandlerFor UniWorX) x
@@ -1784,7 +1784,7 @@ anchorCellCM cache routeM widget = anchorCellCM' cache routeM id (const widget)
 
 anchorCellM' :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a) => WidgetFor UniWorX x -> (x -> url) -> (x -> wgt) -> DBCell m a
 anchorCellM' xM x2route x2widget = linkEitherCellM' xM x2route (x2widget, x2widget)
-  
+
 anchorCellCM' :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a, Binary cache) => cache -> WidgetFor UniWorX x -> (x -> url) -> (x -> wgt) -> DBCell m a
 anchorCellCM' cache xM x2route x2widget = linkEitherCellCM' cache xM x2route (x2widget, x2widget)
 
@@ -1855,7 +1855,7 @@ maybeLinkEitherCellCM' mCache xM x2route (x2widgetAuth,x2widgetUnauth) = cell $
 
 listCell :: (IsDBTable m a, MonoFoldable mono) => mono -> (Element mono -> DBCell m a) -> DBCell m a
 listCell = listCell' . return
-  
+
 listCell' :: (IsDBTable m a, MonoFoldable mono) => WriterT a m mono -> (Element mono -> DBCell m a) -> DBCell m a
 listCell' mkXS mkCell = ilistCell' (otoList <$> mkXS) $ const mkCell
 
@@ -1926,7 +1926,7 @@ dbSelect :: forall x h r i a. (Headedness h, Monoid' x)
          -> Colonnade h (DBRow r) (DBCell (MForm (HandlerFor UniWorX)) x)
 -- dbSelect resLens selLens genIndex = Colonnade.singleton (headednessPure $ i18nCell MsgSelectColumn) $ formCell resLens genIndex genForm
 dbSelect resLens selLens genIndex = Colonnade.singleton (headednessPure $ mempty & cellAttrs <>~ pure ("uw-hide-columns--no-hide","")) $ formCell resLens genIndex genForm
-  where    
+  where
     genForm _ mkUnique = do
       (selResult, selWidget) <- mreq checkBoxField (fsUniq mkUnique "select") (Just False)
       return (set selLens <$> selResult, [whamlet|^{fvWidget selWidget}|])
@@ -1936,7 +1936,7 @@ dbSelectIf :: forall x h r i a. (Headedness h, Monoid' x)
          => Lens' x (FormResult (DBFormResult i a (DBRow r)))
          -> Setter' a Bool
          -> (DBRow r -> MForm (HandlerFor UniWorX) i)
-         -> (DBRow r -> Bool) 
+         -> (DBRow r -> Bool)
          -> Colonnade h (DBRow r) (DBCell (MForm (HandlerFor UniWorX)) x)
 dbSelectIf resLens selLens genIndex condition = Colonnade.singleton (headednessPure $ mempty & cellAttrs <>~ [("uw-hide-columns--no-hide", mempty)] ) fCell
   where
@@ -1945,9 +1945,9 @@ dbSelectIf resLens selLens genIndex condition = Colonnade.singleton (headednessP
       (selResult, selWidget) <- mreq checkBoxField ((bool inputDisabled id $ condition row) $ fsUniq mkUnique "select") (Just False) -- produces disabled field, but still checked by master checkbox from header
       --(selResult, selWidget) <- mreq (bool noField checkBoxField $ condition row) (fsUniq mkUnique "select") (Just False) -- omits field entirely, but also removes master checkbox from header
       {- Similar to previous: omits field entirely, but also removes master checkbox from header
-      (selResult, selWidget) <- if condition row 
+      (selResult, selWidget) <- if condition row
           then mreq checkBoxField (fsUniq mkUnique "select") (Just False)
-          else return (FormMissing, FieldView "" Nothing "" mempty Nothing False) 
+          else return (FormMissing, FieldView "" Nothing "" mempty Nothing False)
       -}
       return (set selLens <$> selResult, [whamlet|^{fvWidget selWidget}|])
 

src/Handler/Utils/Users.hs

@@ -89,7 +89,7 @@ getUserPrimaryCompanyAddress uid prj = runMaybeT $ do
   company <- MaybeT $ get cid
   -- hoistMaybe $ prj company
   MaybeT $ pure $ prj company
-  
+
 
 -- | result (True, Nothing, Nothing) indicates that neither userEmail nor userPostAddress is known
 getPostalPreferenceAndAddress :: Entity User -> DB (Bool, Maybe [Text], Maybe UserEmail)
@@ -111,18 +111,18 @@ getPostalPreferenceAndAddress' usr = do
       finalPref   = (usrPrefPost && isJust (fst pa)) || isNothing (fst em)
       -- finalPref   = isJust (fst pa) && (usrPrefPost || isNothing (fst em))
   return (finalPref, pa, em)
- 
+
 getEmailAddressFor :: UserId -> DB (Maybe Address)
 getEmailAddressFor = maybeM (return Nothing) getEmailAddress . getEntity
 
 getJustEmailAddressFor :: UserId -> DB Address
 getJustEmailAddressFor = maybeThrowM ExceptionUserHasNoEmail . getEmailAddressFor
-    
+
 getJustEmailAddress :: Entity User -> DB Address
 getJustEmailAddress = maybeThrowM ExceptionUserHasNoEmail . getEmailAddress
 
 getEmailAddress :: Entity User -> DB (Maybe Address)
-getEmailAddress usr@Entity{entityVal=User{userDisplayName}} = toAddress <<$>> getUserEmail usr  
+getEmailAddress usr@Entity{entityVal=User{userDisplayName}} = toAddress <<$>> getUserEmail usr
   where toAddress = Address (Just userDisplayName) . CI.original
 
 getUserEmail :: Entity User -> DB (Maybe UserEmail)
@@ -159,12 +159,12 @@ getPostalAddress Entity{entityKey=uid, entityVal=User{..}}
         getUserPrimaryCompanyAddress uid companyPostAddress >>= \case
           (Just pa)
               -> prefixMarkupName pa
-          Nothing 
+          Nothing
             | Just abt <- userCompanyDepartment
               -> return $ Just $ if | "BVD" `isPrefixOf` abt -> [userDisplayName, abt, "Bodenverkehrsdienste"]
                                     | otherwise              -> [userDisplayName, abt, "Hausbriefkasten"     ]
             | otherwise -> return Nothing
-  where 
+  where
     prefixMarkupName = return . Just . (userDisplayName :) . html2textlines
 
 --  primed variant returns storedMarkup without prefixed userDisplayName and whether updates are automatic
@@ -174,15 +174,15 @@ getPostalAddress' Entity{entityKey=uid, entityVal=User{..}}
     = do
         muavs <- getBy $ UniqueUserAvsUser uid
         let auto = userPostAddress == muavs ^? _Just . _userAvsLastFirmInfo . _Just . _avsFirmPostAddress . _Just -- Recall: using _Just with ^. on Nothing yields mempty
-        return (userPostAddress, auto)        
+        return (userPostAddress, auto)
   | otherwise
     = do
         getUserPrimaryCompanyAddress uid companyPostAddress >>= \case
           res@(Just _)
               -> return (res, True)
-          Nothing 
+          Nothing
             | Just abt <- userCompanyDepartment
-              -> return $ (,True) $ Just $ plaintextToStoredMarkup $ textUnlines $ 
+              -> return $ (,True) $ Just $ plaintextToStoredMarkup $ textUnlines $
                     if  | "BVD" `isPrefixOf` abt -> [userDisplayName, abt, "Bodenverkehrsdienste"]
                         | otherwise              -> [userDisplayName, abt, "Hausbriefkasten"     ]
             | otherwise -> return (Nothing, True)
@@ -214,10 +214,10 @@ getReceiversFor uids = (E.unValue <<$>>) $ E.select $ E.distinct $ do
 
 -- | return underlings for currently logged in user
 getSupervisees :: DB (Set UserId)
-getSupervisees = do 
+getSupervisees = do
   uid <- requireAuthId
   svs <- userSupervisorUser . entityVal <<$>> selectList [UserSupervisorSupervisor ==. uid] [Asc UserSupervisorUser]
-  return $ Set.insert uid $ Set.fromAscList svs 
+  return $ Set.insert uid $ Set.fromAscList svs
 
 
 computeUserAuthenticationDigest :: AuthenticationMode -> Digest SHA3_256
@@ -408,10 +408,10 @@ assimilateUser :: UserId -- ^ @newUserId@
 -- Fatal errors are thrown, non-fatal warnings are returned
 assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
   -- retrieve user entities first, to ensure they both exist
-  (oldUserEnt, newUserEnt) <- do 
+  (oldUserEnt, newUserEnt) <- do
       oldUser <- getEntity oldUserId
       newUser <- getEntity newUserId
-      case (oldUser, newUser) of 
+      case (oldUser, newUser) of
         (Just old, Just new) -> return (old,new)
         _ -> tellError UserAssimilateCouldNotDetermineUserIdents
   let oldUser = oldUserEnt ^. _entityVal
@@ -914,7 +914,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
 
   -- Qualifications and ongoing LMS
   -- LmsUser: insertSelectWithConflict impossible due to 2 simultaneous uniqueness constraints; UniqueLmsIdent requires proper update, prohibits insert and then delete
-  -- updateWhere [ LmsUserUser ==. oldUserId ] [ LmsUserUser =. newUserId ] -- might fail due to UniqueLmsQualficationUuser
+  -- updateWhere [ LmsUserUser ==. oldUserId ] [ LmsUserUser =. newUserId ] -- might fail due to UniqueLmsQualificationUuser
   oldLms <- selectList [ LmsUserUser ==. oldUserId ] [ Asc LmsUserQualification ]
   newLms <- selectList [ LmsUserUser ==. newUserId ] [ Asc LmsUserQualification ]
   let projQ = lmsUserQualification . entityVal
@@ -931,13 +931,13 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
       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          
+      E.where_ $  oldQual E.^. QualificationUserUser          E.==. E.val oldUserId
       return (oldQual, newQual)
-  forM_ usrQualis $ \case 
+  forM_ usrQualis $ \case
     (Entity oldQKey _, Nothing) -> update oldQKey [ QualificationUserUser =. newUserId ] -- update must succeed if there is not RHS in the join
     (Entity oldQKey oldQUsr, Just (Entity newQKey newQUsr)) -> do
       updateWhere [ QualificationUserBlockQualificationUser ==. oldQKey ] [ QualificationUserBlockQualificationUser =. newQKey ]
-      update newQKey 
+      update newQKey
         [ QualificationUserValidUntil       =. (max `on` view _qualificationUserValidUntil     ) oldQUsr newQUsr
         , QualificationUserLastRefresh      =. (max `on` view _qualificationUserLastRefresh    ) oldQUsr newQUsr
         , QualificationUserFirstHeld        =. (min `on` view _qualificationUserFirstHeld      ) oldQUsr newQUsr
@@ -945,7 +945,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
         , QualificationUserLastNotified     =. (max `on` view _qualificationUserLastNotified   ) oldQUsr newQUsr
         ]
       delete oldQKey
-  -- deleteWhere [ QualificationUserUser ==. oldUserId ] -- no longer needed  
+  -- deleteWhere [ QualificationUserUser ==. oldUserId ] -- no longer needed
 
   -- PrintJobs
   updateWhere [ PrintJobRecipient ==. Just oldUserId ] [ PrintJobRecipient =. Just newUserId ]
@@ -963,10 +963,10 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
         E.<&> (userSupervisor E.^. UserSupervisorCompany)
         E.<&> (userSupervisor E.^. UserSupervisorReason)
     )
-    (\current excluded -> 
-        [ UserSupervisorRerouteNotifications E.=. (current E.^. UserSupervisorRerouteNotifications E.||. excluded E.^. UserSupervisorRerouteNotifications)  
-        , UserSupervisorCompany E.=. E.coalesce [current E.^. UserSupervisorCompany, excluded E.^. UserSupervisorCompany] 
-        , UserSupervisorReason  E.=. E.coalesce [current E.^. UserSupervisorReason , excluded E.^. UserSupervisorReason] 
+    (\current excluded ->
+        [ UserSupervisorRerouteNotifications E.=. (current E.^. UserSupervisorRerouteNotifications E.||. excluded E.^. UserSupervisorRerouteNotifications)
+        , UserSupervisorCompany E.=. E.coalesce [current E.^. UserSupervisorCompany, excluded E.^. UserSupervisorCompany]
+        , UserSupervisorReason  E.=. E.coalesce [current E.^. UserSupervisorReason , excluded E.^. UserSupervisorReason]
         ] )
   deleteWhere [ UserSupervisorSupervisor ==. oldUserId]
 
@@ -981,10 +981,10 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
         E.<&> (userSupervisor E.^. UserSupervisorCompany)
         E.<&> (userSupervisor E.^. UserSupervisorReason)
     )
-    (\current excluded -> 
+    (\current excluded ->
         [ UserSupervisorRerouteNotifications E.=. (current E.^. UserSupervisorRerouteNotifications E.||. excluded E.^. UserSupervisorRerouteNotifications)
-        , UserSupervisorCompany E.=. E.coalesce [current E.^. UserSupervisorCompany, excluded E.^. UserSupervisorCompany] 
-        , UserSupervisorReason  E.=. E.coalesce [current E.^. UserSupervisorReason , excluded E.^. UserSupervisorReason] 
+        , UserSupervisorCompany E.=. E.coalesce [current E.^. UserSupervisorCompany, excluded E.^. UserSupervisorCompany]
+        , UserSupervisorReason  E.=. E.coalesce [current E.^. UserSupervisorReason , excluded E.^. UserSupervisorReason]
         ] )
   deleteWhere [ UserSupervisorUser ==. oldUserId]
 
@@ -1000,23 +1000,25 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
         E.<&> (userCompany E.^. UserCompanySupervisorReroute)
         E.<&> (userCompany E.^. UserCompanyPriority)
         E.<&> (userCompany E.^. UserCompanyUseCompanyAddress)
+        E.<&> (userCompany E.^. UserCompanyReason)
     )
-    (\current excluded -> 
+    (\current excluded ->
       [ UserCompanySupervisor         E.=. E.greatest (current E.^. UserCompanySupervisor)        (excluded E.^. UserCompanySupervisor)       -- t > f
       , UserCompanyPriority           E.=. E.greatest (current E.^. UserCompanyPriority)          (excluded E.^. UserCompanyPriority)
       , UserCompanyUseCompanyAddress  E.=. E.greatest (current E.^. UserCompanyUseCompanyAddress) (excluded E.^. UserCompanyUseCompanyAddress)
+      , UserCompanyReason             E.=. E.coalesce [current E.^. UserCompanyReason             ,excluded E.^. UserCompanyReason]
       ]
     )
   deleteWhere [ UserCompanyUser ==. oldUserId]
 
   mbOldAvsId <- getBy $ UniqueUserAvsUser oldUserId
-  mbNewAvsId <- getBy $ UniqueUserAvsUser newUserId  
-  case (mbOldAvsId,mbNewAvsId) of 
-    (Nothing, _) 
+  mbNewAvsId <- getBy $ UniqueUserAvsUser newUserId
+  case (mbOldAvsId,mbNewAvsId) of
+    (Nothing, _)
       -> return ()
-    (Just Entity{entityVal=UserAvs{userAvsPersonId=oldAvsId}}, Just _) 
+    (Just Entity{entityVal=UserAvs{userAvsPersonId=oldAvsId}}, Just _)
       -> deleteBy (UniqueUserAvsId oldAvsId)
-    (Just Entity{entityVal=oldUserAvs}, Nothing) 
+    (Just Entity{entityVal=oldUserAvs}, Nothing)
       -> void $ upsertBySafe (UniqueUserAvsId (oldUserAvs ^. _userAvsPersonId)) oldUserAvs{userAvsUser=newUserId} (_userAvsUser .~ newUserId)
 
   -- merge some optional / incomplete user fields
@@ -1025,7 +1027,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
                             oldV  = oldUserEnt ^. ufl
                             newV  = newUserEnt ^. ufl
                         in toMaybe (cmp oldV newV) (uf =. oldV)
-                        
+
       mergeMaybe :: forall b . PersistField b => EntityField User (Maybe b) -> Maybe (Update User)
       mergeMaybe = mergeBy (\oldV newV -> isNothing newV && isJust oldV)
 
@@ -1045,14 +1047,14 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
                 (UserPostLastUpdate =. oldUser ^. _userPostLastUpdate)
       , toMaybe ((isJust (newUser ^. _userPostAddress) || isJust (oldUser ^. _userPostAddress))
                   && (newUser ^. _userPrefersPostal || oldUser ^. _userPrefersPostal))
-                (UserPrefersPostal =. True)      
+                (UserPrefersPostal =. True)
       , mergeMaybe UserPinPassword
       , mergeMaybe UserLanguages
       , mergeMaybe UserSex
       , mergeMaybe UserBirthday
       , mergeMaybe UserTelephone
       , mergeMaybe UserMobile
-      ]  
+      ]
 
   delete oldUserId
   let oldUsrIdent = oldUser ^. _userIdent

src/Handler/Utils/Widgets.hs

@@ -61,11 +61,18 @@ nameWidget displayName surname = toWidget $ nameHtml displayName surname
 userWidget :: HasUser c => c -> Widget
 userWidget x = nameWidget (x ^. _userDisplayName) (x ^._userSurname)
 
+userIdWidget :: UserId -> Widget
+userIdWidget uid = maybeM (msg2widget MsgUserUnknown) userWidget (liftHandler $ runDBRead $ get uid)
+
 linkUserWidget :: HasRoute UniWorX url => (CryptoUUIDUser -> url) -> Entity User -> Widget
-linkUserWidget lnk (Entity uid usr) = do 
+linkUserWidget lnk (Entity uid usr) = do
   uuid <- encrypt uid
   simpleLink (userWidget usr) (lnk uuid)
 
+-- | like linkUserWidget, but on Id only. Requires DB access, use with caution
+linkUserIdWidget :: HasRoute UniWorX url => (CryptoUUIDUser -> url) -> UserId -> Widget
+linkUserIdWidget lnk uid = maybeM (msg2widget MsgUserUnknown) (linkUserWidget lnk . Entity uid) (liftHandler $ runDBRead $ get uid)
+
 userEmailWidget :: HasUser c => c -> Widget
 userEmailWidget x = nameEmailWidget (x ^. _userDisplayEmail) (x ^. _userDisplayName) (x ^. _userSurname)
 
@@ -86,18 +93,36 @@ nameHtml :: Text -> Text -> Html
 nameHtml displayName surname
   | null surname = toHtml displayName
   | otherwise = case reverse $ T.splitOn surname displayName of
-      [_notContained] -> [shamlet|$newline never
+      [_notContained]
+        | (suffix:prefixes) <- reverse $ T.splitOn (T.toTitle surname) (T.toTitle displayName), notNull prefixes ->
+          let prefix = T.intercalate surname $ reverse prefixes
+          in [shamlet|$newline never
+                #{prefix} #
+                <b .surname>#{surname}
+                \ #{suffix}
+              |]
+        | (suffix:prefixes) <- reverse $ T.splitOn (fullyNormalize surname) (fullyNormalize displayName), notNull prefixes ->
+          let prefix = T.intercalate surname $ reverse prefixes
+          in [shamlet|$newline never
+                #{prefix} #
+                <b .surname>#{surname}
+                \ #{suffix}
+              |]
+        | otherwise -> [shamlet|$newline never
                             #{displayName} (
                             <b .surname>#{surname}
                             )|]
       (suffix:prefixes) ->
         let prefix = T.intercalate surname $ reverse prefixes
         in [shamlet|$newline never
-              #{prefix}
+              #{prefix} #
               <b .surname>#{surname}
-              #{suffix}
+              \ #{suffix}
             |]
       [] -> error "Data.Text.splitOn returned empty list in violation of specification."
+  where
+    fullyNormalize :: Text -> Text
+    fullyNormalize = T.toTitle . T.unwords . map text2asciiAlphaNum . T.words
 
 nameHtml' :: HasUser u => u -> Html
 nameHtml' u = nameHtml (u ^. _userDisplayName) (u ^. _userSurname)
@@ -134,15 +159,37 @@ modalAccess wdgtNo wdgtYes writeAccess route = do
     else       wdgtNo
 
 -- also see Handler.Utils.Table.Cells.companyCell
-companyWidget :: (CompanyShorthand, CompanyName, Bool) -> Widget
-companyWidget (csh, cname, isSupervisor) = simpleLink (toWgt name) curl
+companyWidget :: Bool -> (CompanyShorthand, CompanyName, Bool) -> Widget
+companyWidget isPrimary (csh, cname, isSupervisor)
+  | isPrimary, isSupervisor = simpleLink (toWgt $ name <>                   iconSupervisor) curl
+  | isPrimary               = simpleLink (toWgt   name                                    ) curl
+  |            isSupervisor =             toWgt   name <> simpleLink (toWgt iconSupervisor) curl
+  | otherwise               =             toWgt   name
   where
     curl = FirmUsersR csh
     corg = ciOriginal cname
-    name 
-      | isSupervisor = text2markup (corg <> " ") <> icon IconSupervisor
+    name
+      | isSupervisor = text2markup (corg <> " ")
       | otherwise    = text2markup  corg
 
+
+---------------------
+-- Status Tooltips --
+---------------------
+
+-- | generate a generic colored icon to display success or failure to user
+mkErrorFlag :: Handler (Maybe Bool -> Widget)
+mkErrorFlag = do
+  -- we abuse messageTooltip for colored icons here
+  msgSuccessTooltip <- messageI Success MsgMessageSuccess
+  msgWarningTooltip <- messageI Warning MsgMessageWarning
+  msgErrorTooltip   <- messageI Error   MsgMessageError
+  let flagError Nothing       = messageTooltip msgWarningTooltip
+      flagError (Just False)  = messageTooltip msgErrorTooltip
+      flagError (Just True)   = messageTooltip msgSuccessTooltip
+  return flagError
+
+
 ----------
 -- HEAT --
 ----------
@@ -260,15 +307,15 @@ roomReferenceWidget RoomReferenceLink{..} = $(widgetFile "widgets/room-reference
 -- Data.Aeson.Encode.Pretty.encodePretty did not render in Html properly, hence jsonWidget
 jsonWidget :: ToJSON a => a -> Widget
 jsonWidget x = jsonWidgetAux $ toJSON x
-  where 
+  where
     jsonWidgetAux :: Value -> Widget
     jsonWidgetAux  Null       = [whamlet|Null|]
     jsonWidgetAux (Bool   b)  = toWidget $ boolSymbol b
     jsonWidgetAux (String s)  = [whamlet|#{s}|]
-    jsonWidgetAux (Number n) 
+    jsonWidgetAux (Number n)
       | isInteger n           = [whamlet|#{formatScientific Fixed   (Just 0) n}|]
       | otherwise             = [whamlet|#{formatScientific Generic Nothing  n}|]
-    jsonWidgetAux (Array  l)       
+    jsonWidgetAux (Array  l)
       | 1 >= length l = foldMap jsonWidgetAux l -- empty arrays don't show
       | otherwise     =
         [whamlet|
@@ -285,4 +332,3 @@ jsonWidget x = jsonWidgetAux $ toJSON x
               <dt .deflist__dt>#{k}
               <dd .deflist__dd>^{jsonWidgetAux v}
         |]
-      

src/Jobs/Crontab.hs

@@ -110,7 +110,7 @@ determineCrontab = execWriterT $ do
     sheetJobs (Entity nSheet Sheet{..}) = do
       for_ (max <$> sheetVisibleFrom <*> sheetActiveFrom) $ \aFrom -> do
         tellPrewarmJobs (JobCtlPrewarmSheetFile nSheet SheetExercise) aFrom
-        
+
         when (isn't _JobsOffload appJobMode) $ do
           tell $ HashMap.singleton
             (JobCtlQueue $ JobQueueNotification NotificationSheetActive{..})
@@ -181,7 +181,7 @@ determineCrontab = execWriterT $ do
 
   runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ sheetJobs
 
-  
+
   when (isn't _JobsOffload appJobMode) $ do
     case appJobFlushInterval of
       Just interval | maybe True (> 0) appJobMaxFlush -> tell $ HashMap.singleton
@@ -396,28 +396,41 @@ determineCrontab = execWriterT $ do
     whenIsJust appJobLmsQualificationsEnqueueHour $ \hour -> tell $ HashMap.singleton
       (JobCtlQueue JobLmsQualificationsEnqueue)
       Cron
-        { cronInitial   = CronAsap  -- time after scheduling 
+        { cronInitial   = CronAsap  -- time after scheduling
         , cronRepeat    = CronRepeatScheduled $ cronCalendarAny { cronDayOfWeek = CronMatchSome . impureNonNull . Set.fromList $ [1..5]
-                                                                , cronHour   = cronMatchOne hour -- cronHour = CronMatchSome (impureNonNull $ Set.fromList [3,15] ) 
+                                                                , cronHour   = cronMatchOne hour -- cronHour = CronMatchSome (impureNonNull $ Set.fromList [3,15] )
                                                                 , cronMinute = cronMatchOne 2
                                                                 , cronSecond = cronMatchOne 27
                                                                 }
         , cronRateLimit = 600        -- minimal time between two executions, before the second job is skipped
         , cronNotAfter  = Right CronNotScheduled       -- maximal delay of an execution, before it is skipped entirely
-        }      
+        }
 
     whenIsJust appJobLmsQualificationsDequeueHour $ \hour -> tell $ HashMap.singleton
       (JobCtlQueue JobLmsQualificationsDequeue)
       Cron
-        { cronInitial   = CronAsap  -- time after scheduling 
+        { cronInitial   = CronAsap  -- time after scheduling
         , cronRepeat    = CronRepeatScheduled $ cronCalendarAny { cronDayOfWeek = CronMatchSome . impureNonNull . Set.fromList $ [1..5]
-                                                                , cronHour   = cronMatchOne hour -- cronHour = CronMatchSome (impureNonNull $ Set.fromList [3,15] ) 
+                                                                , cronHour   = cronMatchOne hour -- cronHour = CronMatchSome (impureNonNull $ Set.fromList [3,15] )
                                                                 , cronMinute = cronMatchOne 7
                                                                 , cronSecond = cronMatchOne 27
                                                                 }
         , cronRateLimit = 600        -- minimal time between two executions, before the second job is skipped
         , cronNotAfter  = Right CronNotScheduled       -- maximal delay of an execution, before it is skipped entirely
-        }   
+        }
+
+    when (notNull (avsLicenceSynchTimes appAvsLicenceSynchConf)) $ tell $ HashMap.singleton
+      (JobCtlQueue JobSynchroniseAvsLicences)
+      Cron
+        { cronInitial = CronAsap
+        , cronRateLimit = 10                          -- minimal time between two executions, before the second job is skipped
+        , cronNotAfter  = Right CronNotScheduled      -- maximal delay of an execution, before it is skipped entirely
+        , cronRepeat    = CronRepeatScheduled $ cronCalendarAny { cronDayOfWeek = CronMatchSome . impureNonNull . Set.fromList $ [1..5] --weekdays only
+                                                                , cronHour      = CronMatchSome . impureNonNull . Set.fromList $ avsLicenceSynchTimes appAvsLicenceSynchConf
+                                                                , cronMinute    = cronMatchOne 1
+                                                                , cronSecond    = cronMatchOne 3
+                                                                }
+        }
 
     let
       correctorNotifications :: Map (UserId, SheetId) (Max UTCTime) -> WriterT (Crontab JobCtl) (ReaderT SqlReadBackend (HandlerFor UniWorX)) ()
@@ -455,7 +468,7 @@ determineCrontab = execWriterT $ do
             ExamPart{examPartExam} <- MaybeT . $cachedHereBinary epId $ get epId
             Exam{..} <- MaybeT . $cachedHereBinary examPartExam $ get examPartExam
             return examFinished
-          notifyTime <- hoistMaybe . nBot $ maybe NTop (max `on` NTop) examFinishedTime submissionRatingTime 
+          notifyTime <- hoistMaybe . nBot $ maybe NTop (max `on` NTop) examFinishedTime submissionRatingTime
           tell $ HashMap.singleton
             (JobCtlQueue . JobQueueNotification $ NotificationSubmissionRated subId)
             Cron

src/Jobs/Handler/LMS.hs

@@ -46,12 +46,15 @@ fetchRefreshQualifications qidJob = do
   qids <- E.select $ do
             q <- E.from $ E.table @Qualification
             E.where_ $  E.isJust (q E.^. QualificationRefreshWithin)
+                  E.||. E.isJust (q E.^. QualificationRefreshReminder)
+                  E.||.           q E.^. QualificationExpiryNotification
             pure $ q E.^. QualificationId
   forM_ qids $ \(E.unValue -> qid) ->
     queueDBJob $ qidJob qid
 
 
 -- | enlist expiring qualification holders to e-learning
+--   Second reminders sent for users with validQualifications and open LMS only
 --   NOTE: getting rid of QualificationId parameter and using a DB-join fails, since addGregorianDurationClip cannot be performed within DB
 dispatchJobLmsEnqueue :: QualificationId -> JobHandler UniWorX
 dispatchJobLmsEnqueue qid = JobHandlerAtomic act
@@ -62,62 +65,66 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act
       let qshort = CI.original $ qualificationShorthand quali
       $logInfoS "LMS" $ "Notifying about expiring qualification " <> qshort
       now <- liftIO getCurrentTime
-      case qualificationRefreshWithin quali of
-        Nothing -> return () -- TODO: no renewal period, no reminders currently
-        (Just renewalPeriod) -> do
-          let nowaday     = utctDay now
-              renewalDate = addGregorianDurationClip renewalPeriod nowaday
-              sendReminders remindPeriod = do
-                let remindDate = addGregorianDurationClip remindPeriod nowaday
-                reminders <- E.select $ do -- TODO: refactor to remove some redundancies with later query
-                  (luser :& quser) <- E.from $ E.table @LmsUser `E.innerJoin` E.table @QualificationUser
-                    `E.on` (\(luser :& quser) -> luser E.^. LmsUserQualification E.==. quser E.^. QualificationUserQualification
-                                          E.&&.  luser E.^. LmsUserUser          E.==. quser E.^. QualificationUserUser
-                            )
-                  E.where_ $  quser E.^. QualificationUserQualification E.==. E.val qid
-                        E.&&. quser E.^. QualificationUserScheduleRenewal
-                        E.&&. quser E.^. QualificationUserValidUntil E.<=. E.val remindDate
-                        E.&&. validQualification now quser
-                        E.&&. E.isNothing (luser E.^. LmsUserEnded)
-                        E.&&. E.isNothing (luser E.^. LmsUserStatus)
-                        E.&&. E.isJust    (luser E.^. LmsUserNotified)
-                        -- E.&&. ((day_ (luser E.^. LmsUserNotified) E.+. E.interval remindPeriod) E.<. quser E.^. QualificationUserValidUntil) -- not sure whether may throw runtime errors, so we check in Haskell-Land instead
-                  return (luser, quser E.^. QualificationUserValidUntil)
-                forM_ reminders $ \case
-                  (Entity _ LmsUser{lmsUserUser=luser, lmsUserNotified=Just lnotified}, E.Value quValidUntil)
-                    | addGregorianDurationClip remindPeriod (utctDay lnotified) < quValidUntil ->
-                        queueDBJob JobUserNotification
-                          { jRecipient    = luser
-                          , jNotification = NotificationQualificationRenewal { nQualification = qid, nReminder = True }
-                          }
-                  _ -> return ()
-          -- send second reminders first, before enqueing even more
-          ifNothingM (qualificationRefreshReminder quali) () sendReminders
-
-          renewalUsers <- E.select $ do
-            quser <- E.from $ E.table @QualificationUser
-            E.where_ $  quser E.^. QualificationUserQualification E.==. E.val qid
-                  E.&&. quser E.^. QualificationUserScheduleRenewal
-                  E.&&. quser E.^. QualificationUserValidUntil E.<=. E.val renewalDate
-                  E.&&. (quser `qualificationValid` now)
-                  E.&&. E.notExists (do
-                          luser <- E.from $ E.table @LmsUser
-                          E.where_ $  luser E.^. LmsUserQualification E.==. E.val qid
-                                E.&&. luser E.^. LmsUserUser E.==. quser E.^. QualificationUserUser
-                                E.&&. E.isNothing (luser E.^. LmsUserEnded)
-                        )
-            pure quser
-          let usr_job :: Entity QualificationUser -> Job
-              usr_job quser =
-                let uid = quser ^. _entityVal . _qualificationUserUser
-                    uex = quser ^. _entityVal . _qualificationUserValidUntil
-                in if qualificationElearningStart quali
-                    then JobLmsEnqueueUser { jQualification = qid, jUser = uid  }
-                    else JobUserNotification { jRecipient = uid, jNotification =
-                              NotificationQualificationExpiry { nQualification = qid, nExpiry = uex }
-                         }
-          forM_ renewalUsers (queueDBJob . usr_job)
-          logInterface "LMS" (qshort <> "-enq") True (Just $ length renewalUsers) ""
+      let nowaday = utctDay now
+      -- send second reminders first, before enqueing even more, but only for users with currently open LMS and still valid Qualificiations
+      whenIsJust (qualificationRefreshReminder quali) $ \remindPeriod -> do
+        let remindDate = addGregorianDurationClip remindPeriod nowaday
+        reminders <- E.select $ do
+          (luser :& quser) <- E.from $ E.table @LmsUser `E.innerJoin` E.table @QualificationUser
+            `E.on` (\(luser :& quser) -> luser E.^. LmsUserQualification E.==. quser E.^. QualificationUserQualification
+                                  E.&&.  luser E.^. LmsUserUser          E.==. quser E.^. QualificationUserUser
+                    )
+          E.where_ $  quser E.^. QualificationUserQualification E.==. E.val qid
+                E.&&. quser E.^. QualificationUserScheduleRenewal
+                E.&&. quser E.^. QualificationUserValidUntil E.<=. E.val remindDate
+                E.&&. validQualification now quser
+                E.&&. E.isNothing (luser E.^. LmsUserEnded)
+                E.&&. E.isNothing (luser E.^. LmsUserStatus)
+                E.&&. E.isJust    (luser E.^. LmsUserNotified)
+                -- E.&&. ((day_ (luser E.^. LmsUserNotified) E.+. E.interval remindPeriod) E.<. quser E.^. QualificationUserValidUntil) -- not sure whether this may throw runtime errors, so we check in Haskell-Land instead
+          return (luser, quser E.^. QualificationUserValidUntil)
+        forM_ reminders $ \case
+          (Entity _ LmsUser{lmsUserUser=luser, lmsUserNotified=Just lnotified}, E.Value quValidUntil)
+            | addGregorianDurationClip remindPeriod (utctDay lnotified) < quValidUntil ->
+                queueDBJob JobUserNotification
+                  { jRecipient    = luser
+                  , jNotification = NotificationQualificationRenewal { nQualification = qid, nReminder = True }
+                  }
+          _ -> return ()
+      -- send initial reminders
+      whenIsJust (qualificationRefreshWithin quali) $ \renewalPeriod -> do  -- no refreshWithin, no first reminders
+        let renewalDate = addGregorianDurationClip renewalPeriod nowaday
+        renewalUsers <- E.select $ do
+          quser <- E.from $ E.table @QualificationUser
+          E.where_ $  quser E.^. QualificationUserQualification E.==. E.val qid
+                E.&&. quser E.^. QualificationUserScheduleRenewal
+                E.&&. quser E.^. QualificationUserValidUntil E.<=. E.val renewalDate
+                E.&&. (quser `qualificationValid` now)
+                E.&&. E.notExists (do
+                        luser <- E.from $ E.table @LmsUser
+                        E.where_ $  luser E.^. LmsUserQualification E.==. E.val qid
+                              E.&&. luser E.^. LmsUserUser E.==. quser E.^. QualificationUserUser
+                              E.&&. E.isNothing (luser E.^. LmsUserEnded)
+                      )
+          pure quser
+        let usr_job :: Entity QualificationUser -> Maybe Job
+            usr_job quser =
+              let uid = quser ^. _entityVal . _qualificationUserUser
+                  uex = quser ^. _entityVal . _qualificationUserValidUntil
+                  unf = quser ^. _entityVal . _qualificationUserLastNotified
+                  nfy_cutoff = addGregorianDurationClip renewalPeriod $ utctDay unf
+                  do_notify  = uex > nfy_cutoff || (uex == nfy_cutoff && utctDayTime now >= utctDayTime unf)
+              in if
+                  | qualificationElearningStart quali     -- repetition avoided since LmsUser does not exist
+                    -> Just $ JobLmsEnqueueUser { jQualification = qid, jUser = uid }
+                  | do_notify                             -- repetition avoided by QualificationUserLastNotified
+                    -> Just $ JobUserNotification
+                        { jRecipient    = uid
+                        , jNotification = NotificationQualificationExpiry { nQualification = qid, nExpiry = uex }
+                        }
+                  | otherwise -> Nothing
+        forM_ renewalUsers (flip whenIsJust queueDBJob . usr_job)
+        logInterface "LMS" (qshort <> "-enq") True (Just $ length renewalUsers) ""
 
 dispatchJobLmsEnqueueUser :: QualificationId -> UserId -> JobHandler UniWorX
 dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act
@@ -129,7 +136,7 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act
           qprefix = fst <$> Text.uncons (Text.toLower qshort)
       identsInUseVs <- E.select $ do
         lui <- E.from $
-          ( (E.^. LmsUserIdent)     <$> E.from (E.table @LmsUser    ) ) -- no filter by Qid, since LmsIdents must be unique across all
+          ( (E.^. LmsUserIdent)     <$> E.from (E.table @LmsUser    ) ) -- no filter by qid, since LmsIdents must be unique across all
           `E.union_`
           ( (E.^. LmsReportIdent)   <$> E.from (E.table @LmsReport  ) ) -- V2
         E.orderBy [E.asc lui]
@@ -152,20 +159,20 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act
             , lmsUserEnded         = Nothing
             , lmsUserResetTries    = False
             , lmsUserLocked        = True    -- initially display locked, since it is not yet available until the first feedback
-            }         
+            }
           -- startLmsUser :: YesodJobDB UniWorX (Maybe (Entity LmsUser))
           startLmsUser = do
-            lpw <- randomLMSpw            
+            lpw <- randomLMSpw
             maybeM (pure Nothing) (E.insertUniqueEntity . mkLmsUser lpw) (randomLMSIdentBut qprefix identsInUse)
             -- runMaybeT $ do
             --   lid <- MaybeT $ randomLMSIdentBu qprefix identsInUse
             --   MaybeT $ E.insertUniqueEntity $ mkLmsUser lpw lid
       getBy uniqLmsUse >>= \case
-        Just Entity{entityVal=LmsUser{..}} 
-          | isNothing lmsUserEnded, isNothing lmsUserStatus || lmsUserStatus == Just LmsSuccess -> do 
+        Just Entity{entityVal=LmsUser{..}}
+          | isNothing lmsUserEnded, isNothing lmsUserStatus || lmsUserStatus == Just LmsSuccess -> do
             uuid :: CryptoUUIDUser <- encrypt uid
             $logErrorS "LMS" $ "Generating fresh LmsIdent failed for uuid " <> tshow uuid <> " and qid " <> tshow qid <> " due to LMS still existing!"
-        other -> do 
+        other -> do
           when (isJust other) $ deleteBy uniqLmsUse
           untilJustMaxM maxLmsUserIdentRetries startLmsUser >>= \case
             Nothing  -> do
@@ -203,6 +210,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
               -- E.&&.  E.isNothing (luser E.^. LmsUserEnded)
               E.&&.  E.not__ (validQualification now quser)
           pure (luser E.?. LmsUserId, quser E.^. QualificationUserUser)
+      -- TODO: why do we block expired users again? to notify?
       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 ]
       -- let expiredLearners = catMaybes (E.unValue . fst <$> expiredUsers)
@@ -211,7 +219,7 @@ 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
-      let dequeueInfo = "Blocked qualification holders " <> tshow nrBlocked <> " out of 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
@@ -265,7 +273,7 @@ dispatchJobLmsReports :: QualificationId -> JobHandler UniWorX
 dispatchJobLmsReports qid = JobHandlerAtomic act
   where
     -- act :: YesodJobDB UniWorX ()
-    act = whenM (exists [LmsReportQualification ==. qid]) $ do -- executing twice must be prohibited due to assertion that ALL learners are always sent (D fails otherwise)
+    act = whenM (exists [LmsReportQualification ==. qid]) $ do -- executing twice must be prohibited due to assertion that ALL learners are always sent (E fails otherwise)
       now <- liftIO getCurrentTime
       -- DEBUG 2rows; remove later
       totalrows <- count [LmsReportQualification ==. qid]
@@ -336,7 +344,7 @@ dispatchJobLmsReports qid = JobHandlerAtomic act
                 -- 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 reason 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 and only if validDuration is set and elearningRenews is true; transcribes to audit log
                 update luid [LmsUserStatus =. Just LmsSuccess, LmsUserStatusDay =. repDay]
                 return $ Sum ok_renew
           in lrepQry lrFltrSuccess
@@ -405,7 +413,7 @@ dispatchJobLmsReports qid = JobHandlerAtomic act
             E.<&> E.false)
         E.insertSelect $ do
           lrl <- E.from $ E.table @LmsReportLog
-          E.where_ $ E.not_ (lrl E.^. LmsReportLogMissing)
+          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

src/Jobs/Handler/Print.hs

@@ -18,34 +18,52 @@ import qualified Data.Text as Text
 
 -- import           Database.Persist.Sql (deleteWhereCount)
 -- import           Database.Esqueleto.Experimental ((:&)(..))
--- import qualified Database.Esqueleto.Experimental as E
--- import qualified Database.Esqueleto.Legacy as E
+import qualified Database.Esqueleto.Experimental as E
+import qualified Database.Esqueleto.Utils as E
 -- import qualified Database.Esqueleto.PostgreSQL as E -- for insertSelect variant
--- import qualified Database.Esqueleto.Utils as E
+-- import qualified Database.Esqueleto.Legacy as E
 
-
-jobPrintAckChunkSize :: Int 
+jobPrintAckChunkSize :: Int
 jobPrintAckChunkSize = 64
 
+-- | Maximum length difference between received and stored apcIdent
+--   APC sometimes sends ids back that are shorter than expected
+apcIdentMaxDiff :: Int
+apcIdentMaxDiff = 3
+
 -- needed, since JobPrintAck cannot requeue itself due to JobNoQueueSame (and having no parameters)
 dispatchJobPrintAckAgain :: JobHandler UniWorX
 dispatchJobPrintAckAgain = JobHandlerException act
-  where 
+  where
     act = void $ queueJob JobPrintAck
       -- liftIO $ threadDelay 3e6 -- wait 3s before continuing UPDATE: no wait needed
-      
+
 
 dispatchJobPrintAck :: JobHandler UniWorX
 dispatchJobPrintAck = JobHandlerException act
-  where    
+  where
     act = do
-      moretodo <- runDB $ do 
+      moretodo <- runDB $ do
         aliases <- selectList [] [Desc PrintAckIdAliasPriority]
         let ftransAliases = id : fmap (\Entity{entityVal=PrintAckIdAlias{printAckIdAliasNeedle=n, printAckIdAliasReplacement=r}} -> Text.replace n r) aliases
-            ackOneId ackt apci = selectKeysList [PrintJobApcIdent ==. apci, PrintJobAcknowledged ==. Nothing] [Asc PrintJobCreated, LimitTo 1] >>= \case
-                [pjid]  ->  update pjid [PrintJobAcknowledged =. Just ackt] >>
-                            return True
-                _       ->  return False
+            ackOneId ackt apci = selectKeysList [PrintJobApcIdent ==. apci, PrintJobAcknowledged ==. Nothing] [Asc PrintJobCreated, LimitTo 1] >>= \case -- mark oldest as done, if there are multiple with the same identifier
+                [pjid]  ->  update pjid [PrintJobAcknowledged =. Just ackt] $> True
+                _       ->  do
+                  pjcs <- E.select $ do
+                    let len_apci   = Text.length apci
+                        ifx_bounds = (E.val $  len_apci - apcIdentMaxDiff, E.val $ len_apci + apcIdentMaxDiff)
+                    pj <- E.from $ E.table @PrintJob
+                    E.where_ $ E.isNothing (pj E.^. PrintJobAcknowledged)
+                        E.&&. (E.length_ (pj E.^. PrintJobApcIdent) `E.between` ifx_bounds)
+                        E.&&. (E.isInfixOf (E.val apci) (pj E.^. PrintJobApcIdent)
+                         E.||. E.isInfixOf (pj E.^. PrintJobApcIdent) (E.val apci)
+                              )
+                    E.orderBy [E.asc $ pj E.^. PrintJobCreated] -- mark oldest printjob as done, if there are multiple matching jobs
+                    E.limit 1
+                    return $ pj E.^. PrintJobId
+                  case pjcs of
+                    [E.Value pjid] -> update pjid [PrintJobAcknowledged =. Just ackt] $> True
+                    _              -> return False
             procOneId oks Entity{entityKey=paid, entityVal=PrintAcknowledge{printAcknowledgeApcIdent=Text.strip -> apci, printAcknowledgeTimestamp=ackt}} =
                 orM [ackOneId ackt $ ftrans apci | ftrans <- ftransAliases] >>= \case
                   True  -> delete paid                                      >> return (succ oks)

src/Jobs/Handler/SendNotification/Qualification.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022-23 Steffen Jost <jost@tcs.ifi.lmu.de>
+-- SPDX-FileCopyrightText: 2022-24 Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -22,40 +22,38 @@ import Text.Hamlet
 
 
 dispatchNotificationQualificationExpiry :: QualificationId -> Day -> UserId -> Handler ()
-dispatchNotificationQualificationExpiry nQualification dExpiry jRecipient = userMailT jRecipient $ do
-  (recipient@User{..}, Qualification{..}) <- liftHandler . runDB $ (,)
-    <$> getJust jRecipient
-    <*> getJust nQualification    
-
+dispatchNotificationQualificationExpiry nQualification dExpiry jRecipient = do
+  now <- liftIO getCurrentTime
   encRecipient :: CryptoUUIDUser <- liftHandler $ encrypt jRecipient
+  (recipient@User{..}, Qualification{..}) <- runDB $ (,)
+    <$> getJust jRecipient
+    <*> getJust nQualification
   let entRecipient = Entity jRecipient recipient
       qname = CI.original qualificationName
-  expiryDate <- formatTimeUser SelFormatDate dExpiry $ Just entRecipient
-
-  $logDebugS "LMS" $ "Notify " <> tshow encRecipient <> " about expiry of qualification " <> qname
-
-  replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
-  setSubjectI $ MsgMailSubjectQualificationExpiry qname
-
-  editNotifications <- mkEditNotifications jRecipient
-
-  addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/qualificationExpiry.hamlet")
+  userMailT jRecipient $ do
+    expiryDate <- formatTimeUser SelFormatDate dExpiry $ Just entRecipient
+    replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
+    setSubjectI $ MsgMailSubjectQualificationExpiry qname
+    editNotifications <- mkEditNotifications jRecipient
+    addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/qualificationExpiry.hamlet")
+  runDB $ updateBy (UniqueQualificationUser nQualification jRecipient) [QualificationUserLastNotified =. now]
+  $logDebugS "LMS" $ "Notified " <> tshow encRecipient <> " about soonish expiry of qualification " <> qname
 
 
 dispatchNotificationQualificationExpired :: QualificationId -> UserId -> Handler ()
-dispatchNotificationQualificationExpired nQualification jRecipient = do  
+dispatchNotificationQualificationExpired nQualification jRecipient = do
   encRecipient :: CryptoUUIDUser <- encrypt jRecipient
   encRecShort <- encrypt jRecipient
   dbRes <- runDB $ (,,)
     <$> get jRecipient
     <*> get nQualification
-    <*> getBy (UniqueQualificationUser nQualification jRecipient)    
+    <*> getBy (UniqueQualificationUser nQualification jRecipient)
 
-  case dbRes of 
+  case dbRes of
     ( Just User{..}, Just Qualification{..}, Just (Entity quId QualificationUser{..})) -> do
       now <- liftIO getCurrentTime
       qub_entry <- entityVal <<$>> runDB (selectRelevantBlock now quId)
-      let block = filterMaybe (not . qualificationUserBlockUnblock) qub_entry 
+      let block = filterMaybe (not . qualificationUserBlockUnblock) qub_entry
       urender <- getUrlRender
       let expDay  = maybe qualificationUserValidUntil (min qualificationUserValidUntil . utctDay . qualificationUserBlockFrom) block
           qname   = CI.original qualificationName
@@ -81,7 +79,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  $logInfoS  "LMS" $ "Suppressed repeated notification " <> tshow encRecipient <> " about expired qualification " <> qname
+        else  $logInfoS  "LMS" $ "Suppressed repeated notification " <> tshow encRecipient <> " about expired qualification " <> qname -- should no longer happen to using quserToNotify filter in Jobs.Handler.Lms, but sometimes does after restarts
     _ ->  $logErrorS "LMS" $ "Failed to notify " <> tshow encRecipient <> " about expired qualification " <> tshow nQualification
 
 
@@ -94,30 +92,31 @@ dispatchNotificationQualificationRenewal nQualification nReminder jRecipient = d
     <*> get nQualification
     <*> getBy (UniqueQualificationUser    nQualification jRecipient)
     <*> getBy (UniqueLmsQualificationUser nQualification jRecipient)
-  case query of 
+  case query of
     (Just User{userDisplayName, userSurname}, Just Qualification{..}, Just (Entity _ QualificationUser{..}), Just(Entity luid LmsUser{..})) -> do
       let qname = CI.original qualificationName
-          letter = LetterRenewQualificationF
-            { lmsLogin     = lmsUserIdent
-            , lmsPin       = lmsUserPin
-            , qualHolderID = jRecipient
-            , qualHolderDN = userDisplayName 
-            , qualHolderSN = userSurname
-            , qualExpiry   = qualificationUserValidUntil
-            , qualId       = nQualification            
-            , qualName     = qname
-            , qualShort    = CI.original qualificationShorthand                                
-            , qualSchool   = qualificationSchool            
-            , qualDuration = qualificationValidDuration
-            , isReminder   = nReminder
+          letter = LetterRenewQualification
+            { lmsLogin      = lmsUserIdent
+            , lmsPin        = lmsUserPin
+            , qualHolderID  = jRecipient
+            , qualHolderDN  = userDisplayName
+            , qualHolderSN  = userSurname
+            , qualExpiry    = qualificationUserValidUntil
+            , qualId        = nQualification
+            , qualName      = qname
+            , qualShort     = CI.original qualificationShorthand
+            , qualSchool    = qualificationSchool
+            , qualDuration  = qualificationValidDuration
+            , qualRenewAuto = qualificationElearningRenews
+            , qualELimit    = qualificationElearningLimit
+            , isReminder    = nReminder
             }
       $logInfoS "LMS" $ "Notify " <> tshow encRecipient <> " for renewal of qualification " <> qname
       notifyOk <- sendEmailOrLetter jRecipient letter
-      when notifyOk $ do 
+      when notifyOk $ do
         now <- liftIO getCurrentTime
         runDB $ update luid [ LmsUserNotified =. Just now]
     (_, Nothing, _, _) -> $logErrorS "LMS" $ "Notify " <> tshow encRecipient <> " for renewal failed: Qualification " <> tshow nQualification <> " does not exist!"
     (Nothing, _, _, _) -> $logErrorS "LMS" $ "Notify " <> tshow encRecipient <> " for renewal failed: User does not exist!"
     (_, _, Nothing, _) -> $logErrorS "LMS" $ "Notify " <> tshow encRecipient <> " for renewal failed: QualificationUser does not exist, i.e. user does not have this qualification!"
     (_, _, _, Nothing) -> $logWarnS  "LMS" $ "Notify " <> tshow encRecipient <> " for renewal failed: LmsUser does not exist!"
-    

src/Jobs/Handler/SynchroniseAvs.hs

@@ -3,15 +3,18 @@
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
 module Jobs.Handler.SynchroniseAvs
-  ( dispatchJobSynchroniseAvs  
+  ( dispatchJobSynchroniseAvs
   -- , dispatchJobSynchroniseAvsId
-  -- , dispatchJobSynchroniseAvsUser  
+  -- , dispatchJobSynchroniseAvsUser
   , dispatchJobSynchroniseAvsQueue
+  , dispatchJobSynchroniseAvsLicences
   ) where
 
 import Import
 
+import qualified Data.Text            as Text
 import qualified Data.Set             as Set
+-- import qualified Data.Map             as Map
 import qualified Data.Conduit.List as C
 
 import           Database.Esqueleto.Experimental ((:&)(..))
@@ -23,10 +26,11 @@ import qualified Database.Esqueleto.Utils as E
 import Jobs.Queue
 
 import Handler.Utils.Avs
+import Handler.Utils.Qualification
 
 -- pause is a date in the past; don't synch again if the last synch was after pause
 dispatchJobSynchroniseAvs :: Natural -> Natural -> Natural -> Maybe Day -> JobHandler UniWorX
-dispatchJobSynchroniseAvs numIterations epoch iteration pause  
+dispatchJobSynchroniseAvs numIterations epoch iteration pause
   = JobHandlerException . runDB $ do
       now <- liftIO getCurrentTime
       todos <- runConduit $ readUsers .| filterIteration now .| sinkList
@@ -44,13 +48,13 @@ dispatchJobSynchroniseAvs numIterations epoch iteration pause
         userIteration = toInteger (hash epoch `hashWithSalt` userId) `mod` toInteger numIterations
         currentIteration = toInteger iteration `mod` toInteger numIterations
       $logDebugS "SynchronisAvs" [st|User ##{tshow (fromSqlKey userId)}: AVS sync on #{tshow userIteration}/#{tshow numIterations}, now #{tshow currentIteration}|]
-      guard $ userIteration == currentIteration      
-      return $ AvsSync userId now pause      
+      guard $ userIteration == currentIteration
+      return $ AvsSync userId now pause
 
 -- dispatchJobSynchroniseAvsId :: AvsPersonId -> Maybe Day -> JobHandler UniWorX
--- dispatchJobSynchroniseAvsId apid pause = JobHandlerException $     
---     maybeM insertUnknown processKnown $ runDB $ getBy (UniqueUserAvsId apid)    
---   where 
+-- dispatchJobSynchroniseAvsId apid pause = JobHandlerException $
+--     maybeM insertUnknown processKnown $ runDB $ getBy (UniqueUserAvsId apid)
+--   where
 --     processKnown Entity{entityVal=UserAvs{userAvsUser=uid}} = workJobSychronizeAvs uid pause
 --     insertUnknown = void $ maybeCatchAll $ Just <$> upsertAvsUserById apid
 
@@ -66,7 +70,7 @@ dispatchJobSynchroniseAvs numIterations epoch iteration pause
 --     --           , avsSyncPause        = pause
 --     --           }
 --     --   [ \oldSync -> (AvsSyncPause E.=. E.greatest (E.val pause) (oldSync E.^. AvsSyncPause)) oldSync ] -- causes Esqueleto to call undefined at Database.Esqueleto.Internal.Internal.renderUpdates:1308
---     runDB $ maybeM 
+--     runDB $ maybeM
 --       (insert_ AvsSync{avsSyncUser=uid, avsSyncCreationTime=now, avsSyncPause=pause})
 --       (\Entity{entityKey=asid, entityVal=AvsSync{avsSyncPause=oldPause}} ->
 --         update asid [AvsSyncPause =. max pause oldPause, AvsSyncCreationTime =. now])
@@ -78,10 +82,10 @@ dispatchJobSynchroniseAvs numIterations epoch iteration pause
 -- dispatchJobSynchroniseAvsQueue = JobHandlerException $ do
 --     (unlinked,linked) <- runDB $ do
 --       jobs <- E.select (do
---           (avsSync :& usrAvs) <- E.from $  E.table @AvsSync 
+--           (avsSync :& usrAvs) <- E.from $  E.table @AvsSync
 --                               `E.leftJoin` E.table @UserAvs
 --             `E.on` (\(avsSync :& usrAvs) -> avsSync E.^. AvsSyncUser E.=?. usrAvs E.?. UserAvsUser)
---           let pause    = avsSync E.^. AvsSyncPause  
+--           let pause    = avsSync E.^. AvsSyncPause
 --               lastSync = usrAvs  E.?. UserAvsLastSynch
 --           E.where_ $  E.isNothing pause
 --                 E.||. E.isNothing lastSync
@@ -91,22 +95,22 @@ dispatchJobSynchroniseAvs numIterations epoch iteration pause
 --       let (syncIds, unlinked, linked) = foldl' discernJob mempty jobs
 --       E.deleteWhere [AvsSyncId <-. syncIds]
 --       return (unlinked, linked)
-    
+
 --     void $ updateAvsUserByIds  linked
 --     void $ linktoAvsUserByUIDs unlinked
 --     -- we do not reschedule failed synchs here in order to avoid a loop
---   where 
+--   where
 --     discernJob (accSync, accUid, accApi) (E.Value k,           _, E.Value (Just api)) = (k:accSync, accUid, Set.insert api accApi)
 --     discernJob (accSync, accUid, accApi) (E.Value k, E.Value uid, E.Value  Nothing  ) = (k:accSync, Set.insert uid accUid, accApi)
-    
+
 dispatchJobSynchroniseAvsQueue :: JobHandler UniWorX
-dispatchJobSynchroniseAvsQueue = JobHandlerException $ do    
-    jobs <- runDB $ do
+dispatchJobSynchroniseAvsQueue = JobHandlerException $ do
+    jobs <- runDBRead $ do
       E.select (do
-          (avsSync :& usrAvs) <- E.from $  E.table @AvsSync 
+          (avsSync :& usrAvs) <- E.from $  E.table @AvsSync
                               `E.leftJoin` E.table @UserAvs
             `E.on` (\(avsSync :& usrAvs) -> avsSync E.^. AvsSyncUser E.=?. usrAvs E.?. UserAvsUser)
-          let pause    = avsSync E.^. AvsSyncPause  
+          let pause    = avsSync E.^. AvsSyncPause
               lastSync = usrAvs  E.?. UserAvsLastSynch
               proceed  =        E.isNothing pause
                           E.||. E.isNothing lastSync
@@ -118,13 +122,66 @@ dispatchJobSynchroniseAvsQueue = JobHandlerException $ do
       -- E.truncateTable $ AvsSync (error "truncateTable: AvsSyncUser not needed") now Nothing
       -- return jobs
     let (unlinked, linked) = foldl' discernJob mempty jobs
-    $logInfoS "SynchronisAvs" [st|AVS synch performing for #{length linked} AVS linked users and #{length unlinked} unlinked users|]
+    $logInfoS "SynchronisAvs" [st|AVS synch start for #{length linked} AVS linked users and #{length unlinked} unlinked users|]
     void $ updateAvsUserByIds  linked
     void $ linktoAvsUserByUIDs unlinked
     runDB $ deleteWhere [AvsSyncUser <-. (E.unValue . fst3 <$> jobs)]
-    $logInfoS "SynchronisAvs" [st|AVS synch performed for #{length linked} AVS linked users and #{length unlinked} unlinked users|]
+    $logInfoS "SynchronisAvs" [st|AVS synch end for #{length linked} AVS linked users and #{length unlinked} unlinked users|]
     -- we do not reschedule failed synchs here in order to avoid a loop
-  where 
+  where
     discernJob accs (         _ , E.Value (Just api), E.Value True  ) = accs & over _2 (Set.insert api)
     discernJob accs (E.Value uid, E.Value  Nothing  , E.Value True  ) = accs & over _1 (Set.insert uid)
     discernJob accs (         _ ,                 _ , E.Value False ) = accs
+
+
+-----------------
+-- AVS Licences
+
+dispatchJobSynchroniseAvsLicences :: JobHandler UniWorX
+-- dispatchJobSynchroniseAvsLicences = error "TODO"
+dispatchJobSynchroniseAvsLicences = JobHandlerException $ do -- when (synchLevel > 0) $ do
+  AvsLicenceSynchConf
+    { avsLicenceSynchLevel        = synchLevel   -- SynchLevel corresponds to tables of ProblemAvsSynchR: 4=top grant R, 3= reduce R->F, 2= grant F, 1= revoke F
+    , avsLicenceSynchReasonFilter = reasonFilter
+    , avsLicenceSynchMaxChanges   = maxChanges
+    } <- getsYesod $ view _appAvsLicenceSynchConf
+
+  let procLic :: AvsLicence -> Bool -> Set AvsPersonId -> Handler ()
+      procLic aLic up apids
+        | n <- Set.size apids, n > 0 =
+          let subtype = Text.cons (bool '↧' '↥' up) $ Text.singleton $ licence2char aLic
+              logit errm = runDB $ logInterface' "AVS" subtype False (isNothing errm) (Just n) (fromMaybe "Automatic synch" errm)
+              catchAllAvs = flip catch (\err -> logit (Just $ tshow (err :: SomeException)) >> return (-1))
+          in if NTop (Just n) <= NTop maxChanges
+              then do
+                oks <- catchAllAvs $ setLicencesAvs $ Set.map (AvsPersonLicence aLic) apids
+                when (oks > 0) $ logit $ toMaybe (oks /= n) [st|Only #{tshow oks}/#{tshow n} licence changes accepted by AVS|]
+              else
+                logit $ Just [st|Too many changes at once. Consider increasing avs-licence-synch-max-changes #{tshow maxChanges}|]
+        | otherwise = return ()
+
+  (AvsLicenceDifferences{..}, rsChanged) <- retrieveDifferingLicences
+  -- prevent automatic changes to users blocked with certain reasons and with currently being associated with multiple companies
+  reasonFltrdIds <- ifNothingM reasonFilter mempty $ \reasons -> do
+    now <- liftIO getCurrentTime
+    firmBlocks <- runDBRead $ E.select $ do
+      (uavs :& _qualUser :& qblock) <- E.from $ E.table @UserAvs
+        `E.innerJoin` E.table @QualificationUser      `E.on` (\(uavs :& qualUser) -> uavs E.^. UserAvsUser E.==. qualUser E.^. QualificationUserUser)
+        `E.innerJoin` E.table @QualificationUserBlock `E.on` (\(_uavs :& qualUser :& qblock) ->
+            qualUser E.^. QualificationUserId E.==. qblock E.^. QualificationUserBlockQualificationUser
+            E.&&. qblock `isLatestBlockBefore'` E.val now)
+      E.where_ $ (qblock E.^. QualificationUserBlockReason E.~*. E.val reasons)
+          E.&&.  uavs E.^. UserAvsPersonId `E.in_` E.vals (Set.unions [avsLicenceDiffRevokeAll, avsLicenceDiffRevokeRollfeld, avsLicenceDiffGrantVorfeld, avsLicenceDiffGrantRollfeld])
+      return $ uavs E.^. UserAvsPersonId
+    return $ Set.fromList $ map E.unValue firmBlocks
+
+  let fltrIds
+        | synchLevel >= 5 = id
+        | synchLevel >= 3 = flip Set.difference   reasonFltrdIds
+        | otherwise       = flip Set.difference $ reasonFltrdIds `Set.union` rsChanged
+
+  when (synchLevel >= 1) $ procLic AvsNoLicence       False $ fltrIds avsLicenceDiffRevokeAll        --revoke    Vorfeld and maybe also Rollfeld
+  when (synchLevel >= 2) $ procLic AvsLicenceVorfeld  True  $ fltrIds avsLicenceDiffGrantVorfeld     --grant     Vorfeld
+  when (synchLevel >= 3) $ procLic AvsLicenceVorfeld  False $ fltrIds avsLicenceDiffRevokeRollfeld   --downgrade Rollfeld -> Vorfeld
+  when (synchLevel >= 4) $ procLic AvsLicenceRollfeld True  $ fltrIds avsLicenceDiffGrantRollfeld    --grant     Rollfeld
+

src/Jobs/Handler/SynchroniseLdap.hs

@@ -3,7 +3,9 @@
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
 module Jobs.Handler.SynchroniseLdap
-  ( dispatchJobSynchroniseLdap, dispatchJobSynchroniseLdapUser
+  ( dispatchJobSynchroniseLdap
+  , dispatchJobSynchroniseLdapUser
+  , dispatchJobSynchroniseLdapAll
   , SynchroniseLdapException(..)
   ) where
 
@@ -49,7 +51,7 @@ dispatchJobSynchroniseLdapUser jUser = JobHandlerException $ do
     Just ldapPool ->
       runDB . void . runMaybeT . handleExc $ do
         user@User{userIdent,userLdapPrimaryKey} <- MaybeT $ get jUser
-        let upsertIdent = maybe userIdent CI.mk userLdapPrimaryKey 
+        let upsertIdent = maybe userIdent CI.mk userLdapPrimaryKey
         $logInfoS "SynchroniseLdap" [st|Synchronising #{upsertIdent}|]
 
         reTestAfter <- getsYesod $ view _appLdapReTestFailover
@@ -62,3 +64,6 @@ dispatchJobSynchroniseLdapUser jUser = JobHandlerException $ do
     handleExc
       = catchMPlus (Proxy @CampusUserException)
       . catchMPlus (Proxy @CampusUserConversionException)
+
+dispatchJobSynchroniseLdapAll :: JobHandler UniWorX
+dispatchJobSynchroniseLdapAll = JobHandlerAtomic . runConduit $ selectSource [] [] .| C.mapM_ (queueDBJob . JobSynchroniseLdapUser . entityKey)

src/Jobs/Types.hs

@@ -97,18 +97,20 @@ data Job
                               , jIteration :: Natural
                               }
   | JobSynchroniseLdapUser    { jUser :: UserId }
+  | JobSynchroniseLdapAll
   | JobSynchroniseAvs         { jNumIterations
                               , jEpoch
                               , jIteration :: Natural
                               , jSynchAfter :: Maybe Day
                               }
-  -- | JobSynchroniseAvsUser     { jUser :: UserId
+  --   JobSynchroniseAvsUser     { jUser :: UserId
   --                             , jSynchAfter :: Maybe Day
   --                             }
-  -- | JobSynchroniseAvsId       { jAvsId      :: AvsPersonId
+  --   JobSynchroniseAvsId       { jAvsId      :: AvsPersonId
   --                             , jSynchAfter :: Maybe Day
-  --                             }                              
-  | JobSynchroniseAvsQueue  
+  --                             }
+  | JobSynchroniseAvsQueue
+  | JobSynchroniseAvsLicences
   | JobChangeUserDisplayEmail { jUser :: UserId
                               , jDisplayEmail :: UserEmail
                               }
@@ -207,7 +209,7 @@ type family ChildrenJobChildren a where
 
 instance (Ord b', HasTypesCustom JobChildren a' b' a b) => HasTypesCustom JobChildren (Set a') (Set b') a b where
   typesCustom = iso Set.toList Set.fromList . traverse . typesCustom @JobChildren
-  
+
 
 classifyJob :: Job -> String
 classifyJob job = unpack tag
@@ -225,7 +227,7 @@ data JobCtlPrewarmSource
   deriving anyclass (Hashable, NFData)
 
 makeLenses_ ''JobCtlPrewarmSource
-  
+
 deriveJSON defaultOptions
   { constructorTagModifier = camelToPathPiece' 3
   , fieldLabelModifier = camelToPathPiece' 1
@@ -276,7 +278,7 @@ data JobHandler site
   = JobHandlerAtomic    (YesodJobDB site ())
   | JobHandlerException (HandlerFor site ())
   | forall a. JobHandlerAtomicWithFinalizer (YesodJobDB site a) (a -> HandlerFor site ())
-  | forall a. JobHandlerAtomicDeferrableWithFinalizer (ReaderT SqlReadBackend (HandlerFor site) a) (a -> HandlerFor site ())  
+  | forall a. JobHandlerAtomicDeferrableWithFinalizer (ReaderT SqlReadBackend (HandlerFor site) a) (a -> HandlerFor site ())
 
 makePrisms ''JobHandler
 
@@ -338,7 +340,7 @@ prioritiseJob  _                              = JobPrioBatch
 data JobNoQueueSame = JobNoQueueSame | JobNoQueueSameTag
   deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)
   deriving anyclass (Universe, Finite)
-  
+
 jobNoQueueSame :: Job -> Maybe JobNoQueueSame
 jobNoQueueSame = \case
   JobSendNotification{jNotification}  -> notifyNoQueueSame jNotification
@@ -349,32 +351,33 @@ jobNoQueueSame = \case
   JobDeleteTransactionLogIPs{}        -> Just JobNoQueueSame
   JobSynchroniseLdap{}                -> Just JobNoQueueSame
   JobSynchroniseLdapUser{}            -> Just JobNoQueueSame
+  JobSynchroniseLdapAll{}             -> Just JobNoQueueSameTag
   JobSynchroniseAvs{}                 -> Just JobNoQueueSame
   -- JobSynchroniseAvsUser{}             -> Just JobNoQueueSame
   -- JobSynchroniseAvsId{}               -> Just JobNoQueueSame
-  JobSynchroniseAvsQueue{}            -> Just JobNoQueueSame  
+  JobSynchroniseAvsQueue{}            -> Just JobNoQueueSame
   JobChangeUserDisplayEmail{}         -> Just JobNoQueueSame
   JobPruneSessionFiles{}              -> Just JobNoQueueSameTag
   JobPruneUnreferencedFiles{}         -> Just JobNoQueueSameTag
   JobInjectFiles{}                    -> Just JobNoQueueSameTag
   JobPruneFallbackPersonalisedSheetFilesKeys{} -> Just JobNoQueueSameTag
   JobRechunkFiles{}                   -> Just JobNoQueueSameTag
-  JobDetectMissingFiles{}             -> Just JobNoQueueSameTag  
+  JobDetectMissingFiles{}             -> Just JobNoQueueSameTag
   JobLmsQualificationsEnqueue         -> Just JobNoQueueSame
   JobLmsEnqueue     {}                -> Just JobNoQueueSame
   JobLmsEnqueueUser {}                -> Just JobNoQueueSame
   JobLmsQualificationsDequeue         -> Just JobNoQueueSame
-  JobLmsDequeue     {}                -> Just JobNoQueueSame  
+  JobLmsDequeue     {}                -> Just JobNoQueueSame
   JobLmsReports     {}                -> Just JobNoQueueSame
   JobPrintAck       {}                -> Just JobNoQueueSame
   JobPrintAckAgain  {}                -> Just JobNoQueueSame
   _                                   -> Nothing
 
 notifyNoQueueSame :: Notification -> Maybe JobNoQueueSame
-notifyNoQueueSame = \case 
+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 
+  NotificationQualificationExpired{} -> Just JobNoQueueSame
   _                                  -> Nothing
 
 jobMovable :: JobCtl -> Bool
@@ -389,7 +392,7 @@ makePrisms ''JobQueue
 
 jqInsert' :: TimeSpec -> JobCtl -> JobQueue -> JobQueue
 jqInsert' cTime job = force . over _JobQueue $ PQ.insertBehind (prioritiseJob job, Down cTime) job
-  
+
 jqInsert :: JobCtl -> JobQueue -> STM JobQueue
 jqInsert job queue = do
   cTime <- unsafeIOToSTM $ getTime Monotonic

src/Mail.hs

@@ -38,7 +38,7 @@ module Mail
   , setDate, setDateCurrent
   , getMailSmtpData
   , _addressName, _addressEmail
-  , _mailFrom, _mailTo, _mailCc, _mailBcc, _mailReplyTo, _mailReplyTo', _mailHeaders, _mailHeader, _mailParts
+  , _mailFrom, _mailTo, _mailCc, _mailBcc, _mailReplyTo, _mailReplyTo', _mailHeaders, _mailHeader, _mailHeader', _mailParts
   , _partType, _partEncoding, _partDisposition, _partFilename, _partHeaders, _partContent
   ) where
 
@@ -140,9 +140,9 @@ import Web.HttpApiData (ToHttpApiData(toHeader))
 
 newtype AddressEqIgnoreName = AddressEqIgnoreName { getAddress :: Address }
   deriving (Show, Generic)
-instance Eq AddressEqIgnoreName where 
+instance Eq AddressEqIgnoreName where
   (==)    = (==)    `on` (addressEmail . getAddress)
-instance Ord AddressEqIgnoreName where 
+instance Ord AddressEqIgnoreName where
   compare = compare `on` (addressEmail . getAddress)
 
 
@@ -159,16 +159,19 @@ _partFilename = _partDisposition . dispositionFilename
     dispositionFilename _  DefaultDisposition       = pure DefaultDisposition
 
 _mailHeader :: CI ByteString -> Traversal' Mail Text
-_mailHeader hdrName = _mailHeaders . traverse . filtered (views _1 $ (== hdrName) . CI.mk) . _2
+_mailHeader = (_mailHeaders .) . _mailHeader'
 
-_mailReplyTo' :: Lens' Mail Text 
+_mailHeader' :: CI ByteString -> Traversal' Headers Text
+_mailHeader' hdrName = traverse . filtered (views _1 $ (== hdrName) . CI.mk) . _2
+
+_mailReplyTo' :: Lens' Mail Text
 _mailReplyTo' = _mailHeaders . _headerReplyTo'
 
-_headerReplyTo' :: Lens' Headers Text 
+_headerReplyTo' :: Lens' Headers Text
 --  Functor f => (Text -> f Text) -> [(ByteString, Text)] -> f [(ByteString, Text)]
 _headerReplyTo' f hdrs = (\x -> insertAssoc replyto x hdrs) <$> f (maybeMonoid $ lookup replyto hdrs)
-  where 
-    replyto = "Reply-To"        
+  where
+    replyto = "Reply-To"
 
 _mailReplyTo :: Lens' Mail Address
 _mailReplyTo = _mailHeaders . _headerReplyTo
@@ -176,8 +179,8 @@ _mailReplyTo = _mailHeaders . _headerReplyTo
 _headerReplyTo :: Lens' Headers Address
 --  Functor f => (Address -> f Address) -> [(ByteString, Text)] -> f [(ByteString, Text)]
 _headerReplyTo f hdrs = (\x -> insertAssoc replyto (renderAddress x) hdrs) <$> f (fromString $ unpack $ maybeMonoid $ lookup replyto hdrs)
-  where 
-    replyto = "Reply-To"        
+  where
+    replyto = "Reply-To"
     -- _addressEmail :: Lens' Address Text might help to simplify this code?
 
 newtype MailT m a = MailT { _unMailT :: RWST MailContext MailSmtpData Mail m a }
@@ -270,7 +273,7 @@ instance Exception MailException
 class Yesod site => YesodMail site where
   defaultFromAddress :: (MonadHandler m, HandlerSite m ~ site) => m Address
   defaultFromAddress = Address Nothing . ("yesod@" <>) . pack <$> liftIO getHostName
-  
+
   envelopeFromAddress :: (MonadHandler m, HandlerSite m ~ site) => m Text
   envelopeFromAddress = addressEmail <$> defaultFromAddress
 
@@ -336,12 +339,12 @@ defMailT :: ( MonadHandler m
               -> MailT m a
               -> m a
 defMailT ls (MailT mailC) = do
-  fromAddress <- defaultFromAddress  
-  (ret, mail0, smtpData0) <- runRWST mailC ls (emptyMail fromAddress)  
+  fromAddress <- defaultFromAddress
+  (ret, mail0, smtpData0) <- runRWST mailC ls (emptyMail fromAddress)
   mail1 <- maybeT (return mail0) $ do
     guardM useReplyToInstead -- if sender must be fixed within ObjectIdDomain, use replyTo instead
     domain <- mailObjectIdDomain
-    let sender = mail0 ^. _mailFrom 
+    let sender = mail0 ^. _mailFrom
         isdomainaddress = (Text.isInfixOf `on` Text.toCaseFold) domain (sender ^. _addressEmail) -- not sure how to use CI.mk and isInfixOf here
     $logDebugS "Mail" $ "Use ReplyTo instead of Sender: " <> tshow isdomainaddress <> " From was: " <> renderAddress sender <> " From is: " <> renderAddress fromAddress
     guard isdomainaddress -- allowing foreign senders might be Fraport specific; maybe remove this guard
@@ -378,7 +381,7 @@ instance Semigroup (PrioritisedAlternatives m) where
   (<>) = mappenddefault
 
 instance Monoid (PrioritisedAlternatives m) where
-  mempty = memptydefault  
+  mempty = memptydefault
 
 class YesodMail site => ToMailPart site a where
   type MailPartReturn site a :: Type
@@ -452,14 +455,14 @@ instance YesodMail site => ToMailPart site YamlValue where
     _partContent .= PartContent (fromStrict $ Yaml.encode val)
 
 
-data NamedMailPart a = NamedMailPart { disposition :: Disposition, namedPart :: a } 
+data NamedMailPart a = NamedMailPart { disposition :: Disposition, namedPart :: a }
 
 instance ToMailPart site a => ToMailPart site (NamedMailPart a) where
   type MailPartReturn site (NamedMailPart a) = MailPartReturn site a
-  toMailPart nmp = do 
-    r <- toMailPart $ namedPart nmp 
+  toMailPart nmp = do
+    r <- toMailPart $ namedPart nmp
     _partDisposition .= disposition nmp
-    return r    
+    return r
 
 
 addAlternatives :: (MonadMail m)
@@ -546,7 +549,7 @@ lookupMailHeader :: MonadHeader m => MailHeader -> m (Maybe Text)
 lookupMailHeader = fmap listToMaybe . getMailHeaders
 
 mapMailHeader ::  MonadHeader m => MailHeader -> (Text -> Text) -> m ()
-mapMailHeader header f = modifyHeaders $ adjustAssoc f header 
+mapMailHeader header f = modifyHeaders $ adjustAssoc f header
 
 replaceMailHeaderI :: ( RenderMessage site msg
                       , MonadMail m
@@ -642,5 +645,5 @@ getMailSmtpData = execWriterT $ do
 
   tell $ mempty
     { smtpRecipients = recps
-    , smtpEnvelopeFrom = Last $ Just from 
+    , smtpEnvelopeFrom = Last $ Just from
     }

src/Model/Types/Avs.hs

@@ -31,7 +31,7 @@ import Data.Aeson
 import Data.Aeson.Types as Aeson
 
 import Utils.Postal (validPostAddressText)
-import Utils.Mail (pickValidEmail)
+import Utils.Mail (pickValidEmail, canonicalPhone)
 
 
 {-
@@ -176,12 +176,17 @@ instance FromJSON AvsCardNo where
 instance ToJSON AvsCardNo where
   toJSON (AvsCardNo cno) = toJSON $ normalizeAvsCardNo cno
 normalizeAvsCardNo :: Text -> Text
-normalizeAvsCardNo = Text.justifyRight 8 '0'
+normalizeAvsCardNo = Text.justifyRight 8 '0' . Text.strip
 
 instance Canonical AvsCardNo where
   canonical AvsCardNo{..} = AvsCardNo $ normalizeAvsCardNo avsCardNo
   -- canonical = AvsCardNo . normalizeAvsCardNo . avsCardNo
 
+instance Canonical (Maybe AvsCardNo) where
+  canonical (Just AvsCardNo{avsCardNo=(Text.strip -> acn)})
+    | not (Text.null acn) = Just $ AvsCardNo $ normalizeAvsCardNo acn
+  canonical _ = Nothing
+
 
 data AvsFullCardNo = AvsFullCardNo { avsFullCardNo :: AvsCardNo, avsFullCardVersion :: AvsVersionNo }
   deriving (Eq, Ord, Generic, NFData)
@@ -211,7 +216,7 @@ instance PersistFieldSql AvsFullCardNo where
 parseAvsCardNo :: Text -> Maybe (Either AvsCardNo AvsFullCardNo)
 parseAvsCardNo = splitDigitsByDot AvsCardNo (AvsFullCardNo . AvsCardNo)
 
-discernAvsCardPersonalNo :: Text -> Maybe (Either AvsInternalPersonalNo AvsFullCardNo) 
+discernAvsCardPersonalNo :: Text -> Maybe (Either AvsInternalPersonalNo AvsFullCardNo)
 discernAvsCardPersonalNo = splitDigitsByDot mkAvsInternalPersonalNo (AvsFullCardNo . AvsCardNo)
 
 -- | Just implies that argument is a whole number or decimal with one single digit after the point. Helper functions receive digit-parts without dot
@@ -222,7 +227,7 @@ splitDigitsByDot fl fr (Text.span Char.isDigit -> (c, pv))
     = Just $ Left $ fl c
   | Just ('.', v) <- Text.uncons pv
   , Just (Char.isDigit -> True, "") <- Text.uncons v
-    = Just $ Right $ fr c v 
+    = Just $ Right $ fr c v
 splitDigitsByDot _ _ _ = Nothing
 
 -- The AVS API requires PersonIds sometimes as as mere numbers `AvsPersonId` and sometimes as tagged objects `AvsObjPersonId`
@@ -448,7 +453,7 @@ deriveJSON defaultOptions
   } ''AvsStatusPerson
 
 makeLenses_ ''AvsStatusPerson
-  
+
 
 data AvsDataPerson = AvsDataPerson
       { avsPersonFirstName          :: Text                         -- WARNING: name stored as is, but AVS does contain weird whitespaces
@@ -496,6 +501,12 @@ deriveJSON defaultOptions
   } ''AvsDataPerson
 -}
 
+{- Did not work as intended! Verify, if needed again.
+hasMultipleFirms :: AvsDataPerson -> Bool
+hasMultipleFirms AvsDataPerson{avsPersonPersonCards=crds} =
+  1 < Set.size (Set.filter isJust $ Set.map avsDataFirm crds)
+-}
+
 data AvsPersonLicence = AvsPersonLicence
       { avsLicenceRampLicence  :: AvsLicence
       , avsLicencePersonID     :: AvsPersonId
@@ -546,20 +557,20 @@ _avsInfoDisplayName :: Lens' AvsPersonInfo Text
 _avsInfoDisplayName = lens g s
   where
     g AvsPersonInfo{avsInfoFirstName, avsInfoLastName} = Text.append avsInfoFirstName $ Text.cons ' ' avsInfoLastName
-    s api dn = let (Text.strip -> fn, Text.strip -> ln) = Text.breakOnEnd " " dn 
+    s api dn = let (Text.strip -> fn, Text.strip -> ln) = Text.breakOnEnd " " dn
                in api{avsInfoFirstName = fn, avsInfoLastName = ln}
 
 
 instance FromJSON AvsPersonInfo where
   parseJSON = withObject "AvsPersonInfo" $ \o -> AvsPersonInfo
-    <$> o .:   "PersonsNo"                                      -- NOTE: PersonsNo, not PersonNo as elsewhere
-    <*> o .:   "FirstName"
-    <*> o .:   "LastName"
-    <*> o .:   "RampLicence"
-    <*> o .:?  "DateOfBirth"
-    <*> o .:?! "PersonEMail"
-    <*> o .:?! "PersonMobilePhoneNo"
-    <*> o .:?! "InternalPersonalNo"
+    <$>  o .:   "PersonsNo"                                      -- NOTE: PersonsNo, not PersonNo as elsewhere
+    <*>  o .:   "FirstName"
+    <*>  o .:   "LastName"
+    <*>  o .:   "RampLicence"
+    <*>  o .:?  "DateOfBirth"
+    <*>  o .:?! "PersonEMail"
+    <*> (o .:?! "PersonMobilePhoneNo" <&> fmap canonicalPhone)
+    <*>  o .:?! "InternalPersonalNo"
 
 
 instance ToJSON AvsPersonInfo where
@@ -598,7 +609,7 @@ instance {-# OVERLAPS #-} Canonical (Maybe AvsFirmCommunication) where
 makeLenses_ ''AvsFirmCommunication
 _avsCommunicationAddress :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmCommunication (Maybe Text)
 _avsCommunicationAddress = to mkAddr
-  where 
+  where
     mkAddr AvsFirmCommunication{..} = composeAddress avsCommunicationStreetANDHouseNo avsCommunicationZIPCode avsCommunicationCity avsCommunicationCountry
 
 instance FromJSON AvsFirmCommunication where
@@ -636,41 +647,43 @@ makeLenses_ ''AvsFirmInfo
 -- additional convenience lenses:
 
 _avsFirmPostAddress :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe StoredMarkup)
+-- _avsFirmPostAddress :: Getter AvsFirmInfo (Maybe StoredMarkup)
 _avsFirmPostAddress = to mkPost
   where
     mkPost afi@AvsFirmInfo{avsFirmFirm} =
-        let someAddr = afi ^. _avsFirmPostAddressSimple 
+        let someAddr = afi ^. _avsFirmPostAddressSimple
             prefAddr = plaintextToStoredMarkup . (avsFirmFirm <>) . Text.cons '\n'
         in prefAddr <$> someAddr
 
 -- | company post address without company name, better suited for comparisons
 _avsFirmPostAddressSimple :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe Text)
+-- _avsFirmPostAddressSimple :: Getter AvsFirmInfo (Maybe Text)
 _avsFirmPostAddressSimple = to mkPost
   where
     mkPost AvsFirmInfo{..} =
         let firmAddr = composeAddress avsFirmStreetANDHouseNo avsFirmZIPCode avsFirmCity avsFirmCountry
             commAddr = avsFirmCommunication ^. _Just . _avsCommunicationAddress
-        in  asum $ [res | res@(Just addr) <- [commAddr, firmAddr], validPostAddressText addr] 
+        in  asum $ [res | res@(Just addr) <- [commAddr, firmAddr], validPostAddressText addr]
 
 _avsFirmPrimaryEmail :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe Text)
 _avsFirmPrimaryEmail = to mkEmail
   where
     mkEmail afi =
-      let candidates =  catMaybes 
+      let candidates =  catMaybes
               [ afi ^. _avsFirmCommunication . _Just . _avsCommunicationEMail
-              , afi ^. _avsFirmEMailSuperior   -- only set for Fraport departments, hence this is a non-personal department wide email suitable as company email
               , afi ^. _avsFirmEMail
+              , afi ^. _avsFirmEMailSuperior   -- only set for Fraport departments, hence this is a non-personal department wide email suitable as company email
               ]
       in pickValidEmail candidates -- should we return an invalid email rather than none?
 
 -- | Not sure this is useful, since postal is ignored if there is no post address anyway
 _avsFirmPrefersPostal :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo Bool
 _avsFirmPrefersPostal = to mkPostPref
-  where 
+  where
     mkPostPref afi = isJust (afi ^. _avsFirmPostAddress) || isNothing (afi ^. _avsFirmPrimaryEmail)
 
 -- Note _avsFirmAddress is never empty; always includes the company name; consider using user _avsFirmPostAddress instead
--- _avsFirmAddress :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo Text 
+-- _avsFirmAddress :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo Text
 -- _avsFirmAddress = to mkAddr
 --   where
 --     mkAddr AvsFirmInfo{..} =
@@ -716,6 +729,24 @@ data AvsDataContact = AvsDataContact
 
 makeLenses_ ''AvsDataContact
 
+_avsContactPrimaryEmail :: (Profunctor p, Contravariant f) => Optic' p f AvsDataContact (Maybe Text)
+_avsContactPrimaryEmail = to mkEmail
+  where
+    mkEmail adc =
+      let candidates = catMaybes
+            [ adc ^. _avsContactFirmInfo   . _avsFirmCommunication . _Just . _avsCommunicationEMail
+            , adc ^. _avsContactFirmInfo   . _avsFirmEMail
+            , adc ^. _avsContactPersonInfo . _avsInfoPersonEMail
+            -- , adc ^. _avsContactFirmInfo   . _avsFirmEMailSuperior   -- only set for Fraport departments, hence this is a non-personal department wide email suitable as company email. Superior email is used as systemEmail only.
+            ]
+      in pickValidEmail candidates -- should we return an invalid email rather than none?
+
+-- _avsContactPrimaryPostAddress :: (Profunctor p, Contravariant f) => Optic' p f AvsDataContact (Maybe StoredMarkup)
+-- _avsContactPrimaryPostAddress :: (Functor f, Contravariant f) => (Maybe StoredMarkup -> f (Maybe StoredMarkup)) -> AvsDataContact -> f AvsDataContact
+_avsContactPrimaryPostAddress :: Getter AvsDataContact (Maybe StoredMarkup)
+_avsContactPrimaryPostAddress = _avsContactFirmInfo . _avsFirmPostAddress
+
+
 -- instance Canonical AvsDataContact where
 --   canonical = over _avsContactPersonInfo canonical
 --             . over _avsContactFirmInfo   canonical
@@ -816,6 +847,25 @@ deriveJSON defaultOptions
   , rejectUnknownFields   = False
   } ''AvsQueryPerson
 
+-- | fix common problem of card no being given in a single field with a dot or containing whitespace
+fixAvsQueryPerson :: AvsQueryPerson -> AvsQueryPerson
+fixAvsQueryPerson AvsQueryPerson{avsPersonQueryVersionNo=Nothing, avsPersonQueryCardNo=Just (AvsCardNo (Text.strip -> acn0)),..}
+  | Just (Right AvsFullCardNo{avsFullCardNo=acn1, avsFullCardVersion=avc1}) <- parseAvsCardNo acn0
+    = AvsQueryPerson
+        { avsPersonQueryCardNo             = Just acn1
+        , avsPersonQueryVersionNo          = Just avc1
+        , avsPersonQueryFirstName          = canonical avsPersonQueryFirstName
+        , avsPersonQueryLastName           = canonical avsPersonQueryLastName
+        , avsPersonQueryInternalPersonalNo = canonical avsPersonQueryInternalPersonalNo
+        }
+fixAvsQueryPerson AvsQueryPerson{..} = AvsQueryPerson
+        { avsPersonQueryCardNo             = canonical avsPersonQueryCardNo
+        , avsPersonQueryVersionNo          = canonical avsPersonQueryVersionNo
+        , avsPersonQueryFirstName          = canonical avsPersonQueryFirstName
+        , avsPersonQueryLastName           = canonical avsPersonQueryLastName
+        , avsPersonQueryInternalPersonalNo = canonical avsPersonQueryInternalPersonalNo
+        }
+
 newtype AvsQueryStatus = AvsQueryStatus (Set AvsPersonId)
   deriving (Show, Generic)
   deriving newtype (Eq, Ord, NFData, Binary)
@@ -834,7 +884,7 @@ deriveJSON defaultOptions ''AvsQueryGetLicences
 
 data AvsQueryGetAllLicences = AvsQueryGetAllLicences -- for convenience, encoding AvsQueryGetLicences (AvsObjPersonId avsPersonIdZero)
   deriving (Eq, Ord, Show, Generic)
-  
+
 newtype AvsQuerySetLicences = AvsQuerySetLicences (Set AvsPersonLicence)
   deriving (Eq, Ord, Show, Generic)
 deriveJSON defaultOptions ''AvsQuerySetLicences

src/Model/Types/Lms.hs

@@ -8,13 +8,13 @@ Description: Types for Learning Management System Interface operated by Know how
 
 -}
 module Model.Types.Lms
-  ( module Model.Types.Lms 
+  ( module Model.Types.Lms
   ) where
 
 import Import.NoModel
 -- import qualified Data.Map as Map
 -- import Data.Map ((!))
-import Database.Persist.Sql 
+import Database.Persist.Sql
 import qualified Database.Esqueleto.Experimental as E
 import qualified Data.Csv as Csv
 import qualified Data.Time.Format as Time
@@ -28,19 +28,19 @@ instance E.SqlString LmsIdent
 makeLenses_ ''LmsIdent
 
 deriveJSON defaultOptions
-  { constructorTagModifier = camelToPathPiece' 1  
+  { constructorTagModifier = camelToPathPiece' 1
   , fieldLabelModifier = camelToPathPiece' 2
-  , omitNothingFields = True  
-  } ''LmsIdent 
+  , omitNothingFields = True
+  } ''LmsIdent
 
 -- TODO: Is this a good idea? An ordinary Enum and a separate Day column in the DB would be better, e.g. allowing use of insertSelect in Jobs.Handler.LMS?
 -- ...also see similar type QualificationBlocked
 data LmsStatus = LmsExpired
-               | LmsBlocked               
+               | LmsBlocked
                | LmsSuccess
-  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, NFData, Universe, Finite)  
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, NFData, Universe, Finite)
 
--- embedRenderMessage ''UniWorX ''LmsStatus (uncurry ((<>) . (<> "Status")) . Text.splitAt 3) -- moved to src/Foundation.hs
+-- embedRenderMessage ''UniWorX ''LmsStatus (uncurry ((<>) . (<> "Status")) . Text.splitAt 3) -- moved to src/Foundation.I18n
 
 deriveJSON  defaultOptions
   { constructorTagModifier = camelToPathPiece' 1      -- remove lms from constructor
@@ -59,22 +59,22 @@ instance Csv.ToField LmsStatus where
 data QualificationStandardReason
       = QualificationRenewELearningBy       LmsIdent
       | QualificationBlockFailedELearningBy LmsIdent
-      | QualificationBlockFailedELearning      
+      | QualificationBlockFailedELearning
       | QualificationBlockReturnedByCompany
       | QualificationBlockExpired
-      
+
   -- deriving (Eq, Ord, Enum, Bounded, Universe, Finite)
 
 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  QualificationBlockFailedELearning        = "E-Learning durchgefallen"
   show  QualificationBlockReturnedByCompany      = "Rückgabe Firma"
   show  QualificationBlockExpired                = "Abgelaufen"
-  
+
 {-
 qualificationBlockedReasonText :: QualificationStandardReason -> Text
-qualificationBlockedReasonText = 
+qualificationBlockedReasonText =
   let dictionary :: Map.Map QualificationStandardReason Text = Map.fromList [(r, tshow r) | r <- universeF]
   in (dictionary !) -- cannot fail due to universeF
 
@@ -95,13 +95,13 @@ newtype LmsBool = LmsBool { lms2bool :: Bool }
 _lmsBool :: Iso' Bool LmsBool
 _lmsBool = iso LmsBool lms2bool
 
-instance Csv.ToField LmsBool where 
+instance Csv.ToField LmsBool where
   toField (LmsBool False) = "0"
   toField (LmsBool True ) = "1"
-  
-instance Csv.FromField LmsBool where 
+
+instance Csv.FromField LmsBool where
   parseField "0" = pure $ LmsBool False
-  parseField "1" = pure $ LmsBool True 
+  parseField "1" = pure $ LmsBool True
   parseField  _  = mempty
 
 -- | Only to be used in LMS interface communicating user status
@@ -110,18 +110,18 @@ data LmsState = LmsFailed | LmsOpen | LmsPassed
 
 instance Csv.ToField LmsState where
   toField LmsFailed = "0"
-  toField LmsOpen   = "1"          
+  toField LmsOpen   = "1"
   toField LmsPassed = "2"
 
 instance Csv.FromField LmsState where
   parseField "0" = pure LmsFailed
   parseField "1" = pure LmsOpen
   parseField "2" = pure LmsPassed
-  parseField _   = mempty    
+  parseField _   = mempty
 
 deriveJSON  defaultOptions
   { constructorTagModifier = camelToPathPiece' 1      -- remove lms from constructor
-  , fieldLabelModifier     = camelToPathPiece' 1      
+  , fieldLabelModifier     = camelToPathPiece' 1
   , sumEncoding = UntaggedValue
   } ''LmsState
 derivePersistFieldJSON ''LmsState
@@ -132,21 +132,21 @@ nullaryPathPiece ''LmsState $ camelToPathPiece' 1
 newtype LmsDay = LmsDay { lms2day :: Day }
   deriving (Eq, Ord, Read, Show, Generic)
 
-_lmsDay :: Iso' Day LmsDay 
+_lmsDay :: Iso' Day LmsDay
 _lmsDay = iso LmsDay lms2day
 
 -- | Format for day for LMS interface
-lmsDayFormat :: String 
+lmsDayFormat :: String
 lmsDayFormat = "%d-%m-%Y" -- fixed in LMS interface desctiption, due defaultTimeLocale, should not use named entities like weekdays or month names
 
-instance Csv.ToField LmsDay where 
+instance Csv.ToField LmsDay where
   toField (LmsDay d) = Csv.toField $ Time.formatTime Time.defaultTimeLocale lmsDayFormat d -- TimeLocale should not matter since format string does not use names; getTimeLocale requires MonadHandler
 
-instance Csv.FromField LmsDay where 
+instance Csv.FromField LmsDay where
 --  parseField = fmap LmsDay . parseLmsDay <=< Csv.parseField
 --    where parseLmsDay = Time.parseTimeM True Time.defaultTimeLocale lmsDayFormat
-  parseField i = do 
-    s <- Csv.parseField i 
+  parseField i = do
+    s <- Csv.parseField i
     d <- Time.parseTimeM True Time.defaultTimeLocale lmsDayFormat s
          <|> iso8601ParseM s -- Know-How AG considers supplying iso8601 dates in the future
     return $ LmsDay d
@@ -155,21 +155,21 @@ instance Csv.FromField LmsDay where
 newtype LmsTimestamp = LmsTimestamp { lms2timestamp :: UTCTime }
   deriving (Eq, Ord, Read, Show, Generic)
 
-_lmsTimestamp :: Iso' UTCTime LmsTimestamp 
+_lmsTimestamp :: Iso' UTCTime LmsTimestamp
 _lmsTimestamp = iso LmsTimestamp lms2timestamp
 
 -- | Format for day for LMS interface
-lmsTimestampFormat :: String 
+lmsTimestampFormat :: String
 lmsTimestampFormat = "%d-%m-%Y %T" -- fixed in LMS interface desctiption, due defaultTimeLocale, should not use named entities like weekdays or month names
 
-instance Csv.ToField LmsTimestamp where 
+instance Csv.ToField LmsTimestamp where
   toField (LmsTimestamp d) = Csv.toField $ Time.formatTime Time.defaultTimeLocale lmsTimestampFormat d -- TimeLocale should not matter since format string does not use names; getTimeLocale requires MonadHandler
 
-instance Csv.FromField LmsTimestamp where 
+instance Csv.FromField LmsTimestamp where
 --  parseField = fmap LmsDay . parseLmsDay <=< Csv.parseField
 --    where parseLmsDay = Time.parseTimeM True Time.defaultTimeLocale lmsDayFormat
-  parseField i = do 
-      s <- Csv.parseField i 
+  parseField i = do
+      s <- Csv.parseField i
       d <- Time.parseTimeM True Time.defaultTimeLocale lmsTimestampFormat s
             <|> (utctDayMidnight <$> Time.parseTimeM True Time.defaultTimeLocale lmsDayFormat s)
             <|> iso8601ParseM s -- Know-How AG considers supplying iso8601 dates in the future

src/Model/Types/Mail.hs

@@ -34,6 +34,7 @@ import Data.ByteString.Base32
 
 import qualified Data.CaseInsensitive as CI
 
+import qualified Database.Esqueleto.Experimental as E
 
 -- ^ `NotificationSettings` is for now a series of boolean checkboxes, i.e. a mapping @NotificationTrigger -> Bool@
 --
@@ -121,7 +122,7 @@ instance PathPiece BounceSecret where
   toPathPiece = CI.foldCase . encodeBase32Unpadded . BA.convert
   fromPathPiece = fmap BounceSecret . digestFromByteString <=< either (const Nothing) Just . decodeBase32Unpadded . encodeUtf8
 
-newtype MailContent = MailContent [Alternatives]
+newtype MailContent = MailContent {getMailContent :: [Alternatives]}
   deriving (Eq, Show, Generic)
   deriving newtype (ToJSON, FromJSON)
   deriving anyclass (Binary, NFData)
@@ -140,3 +141,5 @@ instance PersistFieldSql MailContentReference where
   sqlType _ = sqlType $ Proxy @(Digest SHA3_512)
 
 derivePersistFieldJSON ''MailHeaders
+
+instance E.SqlString MailHeaders

src/Model/Types/Markup.hs

@@ -9,7 +9,7 @@ module Model.Types.Markup
   , markdownToStoredMarkup
   , esqueletoMarkupOutput
   , I18nStoredMarkup
-  , markupIsSmallish  
+  , markupIsSmallish
   , html2textlines
   , isSimilarMarkup
   ) where
@@ -53,7 +53,7 @@ data StoredMarkup = StoredMarkup
   deriving anyclass (Binary, Hashable, NFData)
 
 isSimilarMarkup :: StoredMarkup -> StoredMarkup -> Bool
-isSimilarMarkup StoredMarkup{markupInputFormat=af, markupInput=ai} 
+isSimilarMarkup StoredMarkup{markupInputFormat=af, markupInput=ai}
                 StoredMarkup{markupInputFormat=bf, markupInput=bi}
               = af==bf && ai == bi
 
@@ -74,7 +74,7 @@ plaintextToStoredMarkup :: Textual t => t -> StoredMarkup
 plaintextToStoredMarkup (repack -> t) = StoredMarkup
   { markupInputFormat = MarkupPlaintext
   , markupInput = t
-  , markupOutput = plaintextToHtml $ LT.toStrict t
+  , markupOutput = plainTextToHtml $ LT.toStrict t
   }
 preEscapedToStoredMarkup :: Textual t => t -> StoredMarkup
 preEscapedToStoredMarkup (repack -> t) = StoredMarkup
@@ -86,8 +86,8 @@ markdownToStoredMarkup :: Textual t => t -> StoredMarkup
 markdownToStoredMarkup (repack -> t) = StoredMarkup
   { markupInputFormat = MarkupMarkdown
   , markupInput = t
-  , markupOutput = plaintextToHtml $ LT.toStrict t
-  }  
+  , markupOutput = plainTextToHtml $ LT.toStrict t
+  }
 
 
 esqueletoMarkupOutput :: E.SqlExpr (E.Value StoredMarkup) -> E.SqlExpr (E.Value Html)

src/Model/Types/Misc.hs

@@ -65,9 +65,11 @@ data SupervisorReason
   deriving (Eq, Ord, Enum, Bounded, Generic)
   deriving anyclass (Universe, Finite, NFData)
 
+-- NOTE: it is intentional not to have an embedRenderMessage here; within the DB, we allow arbitrary text, but we do match on these ones to recognise certain functions
+--       so do not change values here without a proper migration
 instance Show SupervisorReason where
   show SupervisorReasonCompanyDefault = "Firmenstandard"
-  show SupervisorReasonAvsSuperior    = "Vorgesetzer"
+  show SupervisorReasonAvsSuperior    = "Vorgesetzter"
   show SupervisorReasonUnknown        = "Unbekannt"