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

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

@@ -114,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
@@ -121,19 +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
-AdminProblemInfoTooltip: Nur Teile der folgenden englische Begriffe sind derzeit möglich: new-company, supervisor-new-company, supervisor-left-company, superior-change, newly-unsupervised und unknown
 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 Vorgesetzer.
+AdminProblemCompanySuperiorChange: Neuer firmenweiter Vorgesetzter.
-AdminProblemCompanySuperiorPrevious: Ehemaliger Vorgesetzer: 
+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
@@ -148,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

@@ -114,25 +114,27 @@ 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
 AdminProblemCreated: Recognized
 AdminProblemInfo: Problem
-AdminProblemInfoTooltip: Only parts of the following keys currently work here: new-company, supervisor-new-company, supervisor-left-company, superior-change, newly-unsupervised und unknown
 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: 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
@@ -148,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/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
 
@@ -15,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
+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 keine aktiven Ansprechpartnerbeziehungen wurden 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.
@@ -33,7 +37,8 @@ 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 sup@Int64 sub@Int64: #{uc} #{pluralDE uc "Firmenassoziation" "Firmenassoziationen"} entfernt. #{noneMoreDE sup "" (tshow sup <> "Ansprechpartnerbeziehungen wegen entferntem Ansprechpartner gelöschtt. ")} #{noneMoreDE sub "" (tshow sup <> "Ansprechpartnerbeziehungen wegen entfernten Angesprochenen gelöscht.")}
+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)}
@@ -42,7 +47,7 @@ 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
@@ -51,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
@@ -59,6 +66,7 @@ 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

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
 
@@ -15,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
+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 no active supervisions were 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.
@@ -33,7 +37,8 @@ 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 sup sub: #{pluralENsN uc "Company association"} deleted. #{noneMoreEN sup "" ((pluralENsN sup "supervision") <> " removed due to eliminated supervisors.")} #{noneMoreEN sub "" ((pluralENsN sub "supervision") <> " removed due to eliminated supervisees.")}
+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 nspr nrem: #{nspr} individual supervisors set for #{nusr} company associates#{bool "." (" and " <> tshow nrem <> " other individual supervisions terminated.") (nrem >0)}
@@ -42,7 +47,7 @@ FirmSuperActNotify: Send message
 FirmSuperActSwitchSuper: Change default company supervisor
 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
@@ -51,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}
@@ -59,6 +66,7 @@ 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

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

@@ -29,7 +29,7 @@ Remarks: Hinweis:
 
 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}/#{n} #{pluralDE m "übergeordneter" "übergeordnete"} Ansprechpartner mit Benachrichtigungsumleitung#{noneMoreDE l "" (", davon " <> tshow l <> " mit postalischer Benachrichtigung")}
+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")}

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

@@ -29,7 +29,7 @@ Remarks: Remark:
 
 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}/#{n} #{pluralENs m "supervisor"} with active notification rerouting#{noneMoreEN l "" (", and " <> tshow l <> "of these prefer postal notifications")}
+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")}

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

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"}
+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
+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"}
+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
+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

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

@@ -12,6 +12,7 @@ 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"}

messages/uniworx/misc/en-eu.msg

@@ -12,6 +12,7 @@ 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"}

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

@@ -153,6 +153,7 @@ 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

@@ -153,6 +153,7 @@ 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,6 +79,7 @@ TableCompany: Firma
 TableCompanyFilter: Firma oder Nummer
 TableCompanyShort: Firmenkürzel
 TableCompanies: Firmen
+TablePrimeCompany: Primäre Firma
 TableCompanyNo: Firmennummer
 TableCompanyNos: Firmennummern
 TableCompanyUser: Firmenangehöriger

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

@@ -79,6 +79,7 @@ TableCompany: Company
 TableCompanyFilter: Company/Nr
 TableCompanyShort: Company shorthand
 TableCompanies: Companies
+TablePrimeCompany: Primary company
 TableCompanyNo: Company number
 TableCompanyNos: Company numbers
 TableCompanyUser: Associate

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

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

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

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

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

nix/docker/version.json

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

package-lock.json

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

package.json

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

package.yaml

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

routes

@@ -71,16 +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

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
+reportAdminProblem problem = do
-  problemLogTime <- liftIO getCurrentTime
   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

@@ -282,6 +282,11 @@ data AdminProblem
     , 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

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/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
@@ -53,6 +55,7 @@ module Database.Esqueleto.Utils
   , day, day', dayMaybe, interval, diffDays, diffTimes
   , exprLift
   , explicitUnsafeCoerceSqlExprValue
+  , psqlVersion_
   , truncateTable
   , module Database.Esqueleto.Utils.TH
   ) where
@@ -163,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)
@@ -415,6 +436,18 @@ mkContainsFilterWithCommaPlus cast lenslike row (foldMap commaSeparatedText -> c
     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
@@ -656,6 +689,7 @@ infixl 8 ->.
 
 infixl 8 ->>.
 
+-- 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
 
@@ -781,6 +815,8 @@ 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)

src/Foundation/Navigation.hs

@@ -122,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
@@ -133,6 +134,7 @@ 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
@@ -2533,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/Handler/Admin.hs

@@ -9,8 +9,9 @@ module Handler.Admin
 import Import
 
 -- import Data.Either
-import qualified Data.Set as Set
+import qualified Data.Set  as Set
-import qualified Data.Map as Map
+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
@@ -86,14 +89,14 @@ handleAdminProblems mbProblemTable = do
       <*> allRDriversHaveFs now
       <*> (not <$> exists [PrintJobAcknowledged ==. Nothing, PrintJobCreated  <. cutOffOldTime])
       <*> (not <$> exists [PrintAcknowledgeProcessed ==. False])
-      <*> mkInterfaceLogTable flagError mempty
+      <*> mkInterfaceLogTable mempty
   let interfacesBadNr = length $ filter (not . snd) interfaceOks
       -- interfacesOk = all snd interfaceOks
 
   diffLics <- try retrieveDifferingLicences >>= \case
     -- (Left (UnsupportedContentType "text/html" resp)) -> Left $ text2widget "Html received"
     (Left e) -> return $ Left $ text2widget $ tshow (e :: SomeException)
-    (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)
@@ -139,12 +142,34 @@ postAdminProblemsR = do
       addMessageI mkind $ msg oks
       when (oks > 0) $ reloadKeepGetParams AdminProblemsR -- reload to update all tables
 
-getProblemUnreachableR :: Handler Html
+getProblemUnreachableR,  postProblemUnreachableR :: Handler Html
-getProblemUnreachableR = do
+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>
+        <h3>_{MsgProblemsUnreachableButtons}
+        ^{noreachUsersWgt}
       <section>
         #{length unreachables} _{MsgProblemsUnreachableBody}
         <ul>
@@ -316,7 +341,13 @@ 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
@@ -326,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
@@ -349,14 +380,20 @@ mkProblemLogTable = over _1 postprocess <$> dbTable validator DBTable{..}
     dbtFilter = mconcat
       [ single ("user"    , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to queryUser)   (E.?. UserDisplayName))
       , single ("solver"  , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to querySolver) (E.?. UserDisplayName))
-      , single ("problem" , FilterColumn . E.mkContainsFilter  $ views (to queryProblem) ((E.->>. "problem").(E.^. ProblemLogInfo)))
       , 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 "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   & setTooltip MsgAdminProblemInfoTooltip)
+      , 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)
       ]

src/Handler/Admin/Avs.hs

@@ -266,33 +266,128 @@ postAdminAvsR = do
 
 
   (qryLicForm, qryLicRes) <- runButtonForm FIDAvsQueryLicenceDiffs
-  mbQryLic <- case qryLicRes of
+  (mbQryLic :: Maybe Widget, mbAutoDiffs :: Maybe Html) <- case qryLicRes of
-    Nothing -> return Nothing
+    Nothing -> return mempty
     (Just BtnCheckLicences) -> do
       res <- try $ do
         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
+          let showLics l =
-              r_grant = showLics AvsLicenceRollfeld
+                let chgs = Set.filter ((l ==) . avsLicenceRampLicence) diffs
-              f_set   = showLics AvsLicenceVorfeld
+                in if Set.null chgs
-              revoke  = showLics AvsNoLicence
+                    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:
+              <h2>Licence check AVS-ID differences:
-              <h3>Grant R:
+              <dl .deflist>
-              <p>
+                <dt .deflist__dt>Grant R (#{rg_size}):
-                #{r_grant}
+                <dd .deflist__dd>#{r_grant}
-              <h3>Set to F:
+
-              <p>
+                <dt .deflist__dt>Set to F (#{fs_size}):
-                #{f_set}
+                <dd .deflist__dd>#{f_set}
-              <h3>Revoke licence:
+
-              <p>
+                <dt .deflist__dt>Revoke licence (#{rv_size}):
-                #{revoke}
+                <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
+          <$> mkLicTbl "avsLicDiffRevokeVorfeld"  AvsLicenceVorfeld   avsLicenceDiffRevokeAll
-          <*> mkLicenceTable apidStatus "avsLicDiffGrantVorfeld"   AvsNoLicence        avsLicenceDiffGrantVorfeld
+          <*> mkLicTbl "avsLicDiffGrantVorfeld"   AvsNoLicence        avsLicenceDiffGrantVorfeld
-          <*> mkLicenceTable apidStatus "avsLicDiffRevokeRollfeld" AvsLicenceRollfeld  avsLicenceDiffRevokeRollfeld
+          <*> mkLicTbl "avsLicDiffRevokeRollfeld" AvsLicenceRollfeld  avsLicenceDiffRevokeRollfeld -- downgrade to Vorfeld
-          <*> mkLicenceTable apidStatus "avsLicDiffGrantRollfeld"  AvsNoLicence        avsLicenceDiffGrantRollfeld
+          <*> mkLicTbl "avsLicDiffGrantRollfeld"  AvsNoLicence        avsLicenceDiffGrantRollfeld
 
   now <- liftIO getCurrentTime
   let procRes :: AvsLicence -> (LicenceTableActionData, Set AvsPersonId) -> Handler ()
@@ -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,9 +624,11 @@ 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 :: AvsPersonIdMapPersonCard -> Set AvsPersonId -> Text -> AvsLicence -> Set AvsPersonId -> DB (FormResult (LicenceTableActionData, Set AvsPersonId), Widget)
-mkLicenceTable apidStatus dbtIdent aLic apids = do
+mkLicenceTable apidStatus rsChanged dbtIdent aLic apids = do
-  currentRoute <- fromMaybe (error "mkLicenceTable called from 404-handler") <$> liftHandler getCurrentRoute
+  (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
 
@@ -571,7 +669,18 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do
                   (\(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

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,6 +228,9 @@ 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
@@ -327,6 +332,17 @@ 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)}
+    |]
 
 
 

src/Handler/Firm.hs

@@ -97,7 +97,7 @@ firmActionMap mr isAdmin acts = mconcat (mkAct isAdmin <$> acts)
                   <$> aopt boolField'                       (fslI MsgFirmActResetSuperKeep)                     (Just $ Just False)
                   <*> aopt checkBoxField                    (fslI MsgFirmActResetMutualSupervision)             (Just $ Just True )
     mkAct _     FirmActAddSupervisors   = singletonMap FirmActAddSupervisors   $ FirmActAddSupervisorsData
-                  <$> areq (textField & cfAnySeparatedSet)  (fslI MsgTableIsDefaultSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip)  Nothing
+                  <$> 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)
@@ -666,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
@@ -675,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 }
@@ -739,29 +742,28 @@ embedRenderMessage ''UniWorX ''FirmUserAction id
 
 data FirmUserActionData = FirmUserActNotifyData
                         | FirmUserActResetSupervisionData
-                            { firmUserActResetKeepOldSupers     :: Maybe Bool
+                            { firmUserActResetSupers            :: Maybe Bool
-                            -- , firmUserActResetMutualSupervision :: Maybe Bool
                             }
                         | FirmUserActSetSupervisorData
-                            {  firmUserActSetSuperNames   :: Maybe (Set Text)
+                            { firmUserActSetSuperNames          :: Maybe (Set Text)
-                            ,  firmUserActSetSuperIds     :: Maybe [UserId]
+                            , firmUserActSetSuperIds            :: Maybe [UserId]
-                            ,  firmUserActSetSuperReason  :: Maybe Text
+                            , firmUserActSetSuperReason         :: Maybe Text
-                            ,  firmUserActSetSuperReroute :: Bool
+                            , firmUserActSetSuperReroute        :: Bool
-                            ,  firmUserActSetSuperKeep    :: Bool
+                            , firmUserActResetSupers            :: Maybe Bool
                             }
                         | FirmUserActMkSuperData
-                            { firmUserActMkSuperReroute   :: Maybe Bool }
+                            { firmUserActMkSuperReroute         :: Maybe Bool }
                         | FirmUserActChangeDetailsData
-                            { firmUserActDetailPriority     :: Maybe Int
+                            { firmUserActDetailPriority         :: Maybe Int
-                            , firmUserActDetailReason       :: Maybe Text
+                            , firmUserActDetailReason           :: Maybe Text
                             }
                         | FirmUserActChangeContactData
-                            { firmUserActPostalAddr         :: Maybe StoredMarkup
+                            { firmUserActPostalAddr             :: Maybe StoredMarkup
-                            , firmUserActUseCompanyPostal   :: Maybe Bool
+                            , firmUserActUseCompanyPostal       :: Maybe Bool
-                            , firmUserActPostalPref         :: Maybe Bool
+                            , firmUserActPostalPref             :: Maybe Bool
                             }
                         | FirmUserActRemoveData
-                            { firmUserActRemoveKeepSuper :: Bool
+                            { firmUserActRemoveSupers           :: Bool
                             }
   deriving (Eq, Ord, Show, Generic)
 
@@ -801,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 MsgTableSuperior     , [opt | (opt, _         , True ) <- procSupers])
-             , (mr MsgFirmSuperIrregular, [opt | (opt, Just False) <- procSupers])
+             , (mr MsgFirmSuperDefault  , [opt | (opt, Just True , False) <- procSupers])
-             , (mr MsgFirmSuperForeign  , [opt | (opt, Nothing   ) <- 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.||.  (usrCmp E.?. UserCompanyReason E.?=. E.val reasonSuperior)
         E.||.  E.exists (firmQuerySupervisedBy cid Nothing usr)
-    return (usr E.^. UserId, usr E.^. UserDisplayName, usrCmp E.?. UserCompanySupervisor)
+    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
@@ -962,25 +967,24 @@ mkFirmUserTable isAdmin cid = do
         acts = mconcat
           [ guardMonoid isAdmin $ singletonMap FirmUserActNotify $ pure FirmUserActNotifyData
           , singletonMap FirmUserActResetSupervision $ FirmUserActResetSupervisionData
-              <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep)         (Just $ Just False)
+              <$> aopt (boolFieldCustom (SomeMessage MsgFirmActResetSupersRemoveAll) (SomeMessage MsgFirmActResetSupersRemoveAps) $ Just $ SomeMessage MsgFirmActResetSupersKeepAll) (fslI MsgFirmActResetSuperKeep) (Just $ Just False)
-              -- <*> aopt checkBoxField                                      (fslI MsgFirmActResetMutualSupervision) (Just $ Just True )
           , singletonMap FirmUserActSetSupervisor $ FirmUserActSetSupervisorData
               <$> aopt (textField & cfAnySeparatedSet)                    (fslI MsgFirmNewSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing
               <*> aopt supervisorsField                                   (fslI MsgFirmSetSupervisor & setTooltip MsgMultiSelectTip)                          Nothing
-              <*> aopt (textField & cfStrip & addDatalist superReasons)   (fslI MsgUserSupervisorReason  & setTooltip MsgUserSupervisorReasonTooltip)          Nothing
+              <*> aopt (textField & cfStrip & addDatalist superReasons)   (fslI MsgUserSupervisorReason  & setTooltip MsgUserSupervisorReasonTooltip)         Nothing
-              <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip)        (Just False)
+              <*> areq  boolField'                                        (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip)        (Just False)
-              <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep)                                                     (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 FirmUserActChangeDetails $ FirmUserActChangeDetailsData
-              <$> aopt intField                                           (fslI MsgCompanyUserPriority & setTooltip MsgCompanyUserPriorityTip) Nothing
-              <*> aopt (textField & cfStrip & addDatalist userReasons)    (fslI MsgUserCompanyReason & setTooltip (SomeMessages [SomeMessage MsgUserCompanyReasonTooltip, SomeMessage MsgNullDeletes])) Nothing
           , singletonMap FirmUserActChangeContact $ FirmUserActChangeContactData
               <$> 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 . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep)                                                     (Just False)
+              <$> areq boolField'       (fslI MsgFirmActRemoveSupers) (Just True)
           ]
         dbtParams = DBParamsForm
           { dbParamsFormMethod = POST
@@ -1047,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
@@ -1054,9 +1062,7 @@ 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
+        delSupers <- resetSupers firmUserActResetSupers uids
-          then deleteDefaultSupervisorsForUsers [] [] uids
-          else return 0
         newSupers <- addDefaultSupervisors Nothing cid uids
         addMessageI Info $ MsgFirmResetSupervision delSupers newSupers
       reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
@@ -1075,8 +1081,7 @@ postFirmUsersR fsh = do
                   <li>#{usr}
               |]
         in addMessageModal Error (i18n . MsgCourseParticipantsRegisterNotFoundInAvs $ length usersNotFound) (Right msgContent)
-      delSupers <- runDB
+      delSupers <- runDB $ resetSupers firmUserActResetSupers uids
-         $ bool (deleteDefaultSupervisorsForUsers [cid] [] uids) (return 0) firmUserActSetSuperKeep
         <* 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
@@ -1113,11 +1118,15 @@ postFirmUsersR fsh = do
             allok = bool Warning Success $ nrChanged == total
         addMessageI allok $ MsgFirmUserActChangeResult nrChanged total
         reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
-    (FirmUserActRemoveData{}, Set.toList -> uids) -> do
+    (FirmUserActRemoveData{..}, Set.toList -> uids) -> do
-      (nrUc, nrSuper, nrSubs) <- runDB $ deleteCompanyUser cid uids
+      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 $ nrUc == total
+          allok = bool Warning Success $ total == nrUc
-      addMessageI allok $ MsgFirmuserActRemoveResult nrUc nrSuper nrSubs
+      addMessageI allok $ someMessages [MsgFirmUserActRemoveResult nrUc, MsgFirmRemoveSupervision nrSuper nrSubs]
       reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
 
   formFirmAction <- runFirmActionFormPost cid (FirmUsersR fsh) isAdmin [FirmActNotify, FirmActResetSupervision, FirmActAddSupervisors, FirmActChangeContactFirm, FirmActChangeContactUser]
@@ -1147,7 +1156,7 @@ data FirmSuperActionData = FirmSuperActNotifyData
                             , firmSuperActSwitchReroute :: Maybe Bool
                             }
                          | FirmSuperActRMSuperDefData
-                            { firmSuperActRMSuperActive :: Maybe Bool }
+                            { firmSuperActRMSuperActive ::       Bool }
 
   deriving (Eq, Ord, Show, Generic)
 
@@ -1198,20 +1207,22 @@ mkFirmSuperTable :: Bool -> CompanyId -> DB (FormResult (FirmSuperActionData, Se
 mkFirmSuperTable isAdmin cid = do
   msgSupervisorUnchanged <- messageI Info MsgFirmSuperActSwitchSuperInfo
   let
-    reasonSuperior = Just $ tshow SupervisorReasonAvsSuperior
+    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.where_ $  E.isTrue (usrCmp E.?. UserCompanySupervisor) E.||. E.exists (firmQuerySupervisedBy cid Nothing usr)
-              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.exists (firmQuerySupervisedBy cid (Just (\usrSpr -> usrSpr E.^. UserSupervisorReason E.==. E.val reasonSuperior)) usr)
+                 -- , (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, isSuperior) -> do
@@ -1232,15 +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
-          , sortable (Just "def-super")   (i18nCell MsgTableIsDefaultSupervisor) $ \row ->
+              Nothing      -> iconCell IconSupervisorForeign
-              let mb = row ^. resultSuperCompanyDefaultSuper
+              (Just True ) -> iconCell IconSupervisor
-                  sp = row ^. resultSuperCompanySuperior
+              (Just False) -> iconSpacerCell
-              in case (mb,sp) of
+          , sortable Nothing  (i18nCell MsgTableSuperior) $ view resultSuperCompanySuperior >>> flip ifIconCell IconSuperior
-                  (_     , True) -> iconCell IconSuperior
-                  (Nothing   ,_) -> iconCell IconSupervisorForeign
-                  (Just True ,_) -> iconCell IconSupervisor
-                  (Just False,_) -> iconSpacerCell
           , sortable (Just "def-reroute") (i18nCell MsgTableIsDefaultReroute)    $ \(view resultSuperCompanyDefaultReroute -> mb) -> tickmarkCell (mb == Just True)
           , sortable Nothing (i18nCell MsgTableUserEdit) $ \(view resultSuperUser -> entUsr) -> cellEditUserModal entUsr
           ]
@@ -1263,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' (fslI MsgFirmSuperDefault)  (Just $ Just True)
-              <*> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableIsDefaultReroute)      Nothing
+              <*> 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
@@ -1320,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
+        <*> optRemove (deleteWhereCount [UserSupervisorCompany ==. Just cid, UserSupervisorSupervisor <-. uids])
-              then return 0
+        <*> optRemove (deleteWhereCount [UserSupervisorCompany ==. Just cid, UserSupervisorUser       <-. uids])
-              else E.deleteCount $ do
+      let total = fromIntegral $ length uids
-                spr <- E.from $ E.table @UserSupervisor
+          allok = bool Warning Success $ total == nrRmSuper
-                E.where_ $ spr E.^. UserSupervisorSupervisor `E.in_` E.vals uids
+      addMessageI allok $ someMessages [MsgRemoveSupervisors nrRmSuper, MsgFirmRemoveSupervision nrRmSupers nrRmSubs]
-                    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
       reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
     (FirmSuperActSwitchSuperData{..}, Set.toList -> uids) -> do
       let (fltrSpr, changes) = case (firmSuperActSwitchSuper, firmSuperActSwitchReroute) of
@@ -1352,7 +1374,7 @@ postFirmSupersR fsh = do
 
   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")

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 
+  where
-    -- vnr_full :: Text = $(embedStringFile "nix/docker/version.json") -- nix/ files not accessible during container construction  
+    -- vnr_full :: Text = $(embedStringFile "nix/docker/version.json") -- nix/ files not accessible during container construction
     cTime :: UTCTime
-    cTime = $compileTime
+    cTime = $compileTime
-
-    ddays :: UTCTime -> UTCTime -> Double
-    ddays tstart tstop = (/100) $ fromIntegral $ round $ diffUTCTime tstop tstart / (36 * 24)

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
+  (res, twgt) <- runDB $ mkInterfaceLogTable interfs
-  msgSuccessTooltip <- messageI Success MsgMessageSuccess
-  -- msgWarningTooltip <- messageI Warning MsgMessageWarning
-  msgErrorTooltip   <- messageI Error   MsgMessageError
-  let flagError = messageTooltip . bool msgErrorTooltip msgSuccessTooltip
-  (res, twgt) <- runDB $ mkInterfaceLogTable flagError interfs
   let missing = notNull [ifce | (UniqueInterfaceHealth ifce _subt _writ) <- reqIfs, ifce `notElem` (fst <$> res) ]
       allok   = all snd res
   return (missing, allok, res, twgt)
@@ -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 :: ReqBanInterfaceHealth -> DB ([(Text,Bool)], Widget)
-mkInterfaceLogTable flagError interfs@(reqIfs, banIfs) = do
+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
@@ -148,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 && (hours < 0 || now <= addHours hours logtime)
+                status  = (success || hours <= -100) && (hours < 0 || now <= addHours hours logtime)
-            in tellCell [(iface,status)] $
+            in tellCell [(iface,status)] $ wgtCell $ flagError $ toMaybe (success || not status) status
-                wgtCell $ flagError status
         , sortable (Just "interface") (i18nCell MsgInterfaceName      ) $ \(view (resultILog . _interfaceLogInterface) -> n) -> textCell n
         , sortable (Just "subtype")   (i18nCell MsgInterfaceSubtype   ) $ textCell . view (resultILog . _interfaceLogSubtype)
         , sortable (Just "write")     (i18nCell MsgInterfaceWrite     ) $ (`ifIconCell` IconEdit) . view (resultILog . _interfaceLogWrite)
         , sortable (Just "time")      (i18nCell MsgInterfaceLastSynch ) $ dateTimeCell . view (resultILog . _interfaceLogTime)
-        , sortable Nothing            (i18nCell MsgInterfaceFreshness ) $ numCell . view resultHours
+        , sortable (Just "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
@@ -189,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
@@ -258,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

@@ -220,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
@@ -242,8 +241,7 @@ ltcExample :: LmsTableCsv
 ltcExample = LmsTableCsv
     { ltcDisplayName    = "Max Mustermann"
     , ltcEmail          = "m.mustermann@example.com"
-    , ltcCompany        = Just "Example Brothers LLC, SecondaryJobs Inc"
+    , ltcCompany        = Just "Example Brothers LLC"
-    , ltcCompanyNumbers = CsvSemicolonList [27,69]
     , ltcValidUntil     = succ compDay
     , ltcLastRefresh    = compDay
     , ltcFirstHeld      = pred $ pred compDay
@@ -285,8 +283,7 @@ instance CsvColumnsExplained LmsTableCsv where
   csvColumnsExplanations = genericCsvColumnsExplanations ltcOptions $ Map.fromList
     [ ('ltcDisplayName    , SomeMessage MsgLmsUser)
     , ('ltcEmail          , SomeMessage MsgTableLmsEmail)
-    , ('ltcCompany        , SomeMessage MsgTableCompanies)
+    , ('ltcCompany        , SomeMessage MsgTablePrimeCompany)
-    , ('ltcCompanyNumbers , SomeMessage MsgTableCompanyNos)
     , ('ltcValidUntil     , SomeMessage MsgLmsQualificationValidUntil)
     , ('ltcLastRefresh    , SomeMessage MsgTableQualificationLastRefresh)
     , ('ltcFirstHeld      , SomeMessage MsgTableQualificationFirstHeld)
@@ -320,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
@@ -337,8 +334,8 @@ resultQualBlock = _dbrOutput . _4 . _Just
 resultPrintAck :: Traversal' LmsTableData [Maybe UTCTime]
 resultPrintAck = _dbrOutput . _5 . _unValue . _Just
 
-resultCompanyUser :: Lens' LmsTableData [Entity UserCompany]
+resultCompanyId :: Traversal' LmsTableData CompanyId
-resultCompanyUser = _dbrOutput . _6
+resultCompanyId = _dbrOutput . _6 . _unValue . _Just
 
 resultValidQualification :: Lens' LmsTableData Bool
 resultValidQualification = _dbrOutput . _7 . _unValue
@@ -406,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
@@ -421,12 +419,16 @@ lmsTableQuery now qid (qualUser `E.InnerJoin` user `E.InnerJoin` lmsUser `E.Left
     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.where_ $ E.isJust (pj E.^. PrintJobLmsUser)
-                        E.&&. ((lmsUser E.^. LmsUserIdent) E.=?. (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!
+          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!
+          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
+                  E.arrayAggWith E.AggModeAll (pj E.^. PrintJobAcknowledged) pjOrder
-    return (qualUser, user, lmsUser, qualBlock, printAcknowledged, validQualification now qualUser)
+        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
@@ -435,25 +437,26 @@ mkLmsTable :: ( Functor h, ToSortable h
            => Bool
            -> Entity Qualification
            -> Map LmsTableAction (AForm Handler LmsTableActionData)
-           -> (Map CompanyId Company -> cols)
+           -> ((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
+  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
+
     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
+    dbtProj = dbtProjId
-      cmpUsr <- selectList [UserCompanyUser ==. entityKey usr] [Desc UserCompanyPriority, Asc UserCompanyCompany, LimitTo 1]
+    dbtColonnade = cols getCompanyName
-      return (qualUsr, usr, lmsUsr, qUsrBlock, printAcks, cmpUsr, validQ)
-    dbtColonnade = cols cmpMap
     dbtSorting = mconcat
       [ single $ sortUserNameLink   queryUser
       , single $ sortUserEmail      queryUser
@@ -544,25 +547,20 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
         doEncode' = LmsTableCsv
           <$>  view    (resultUser     . _entityVal . _userDisplayName)
           <*>  view    (resultUser     . _entityVal . _userDisplayEmail)
-          <*> (view     resultCompanyUser >>= getCompanies)
+          <*>  preview (resultCompanyId . to getCompanyName . _CI)
-          <*> (view     resultCompanyUser >>= getCompanyNos)
+          <*>  view    (resultQualUser  . _entityVal . _qualificationUserValidUntil)
-          <*>  view    (resultQualUser . _entityVal . _qualificationUserValidUntil)
+          <*>  view    (resultQualUser  . _entityVal . _qualificationUserLastRefresh)
-          <*>  view    (resultQualUser . _entityVal . _qualificationUserLastRefresh)
+          <*>  view    (resultQualUser  . _entityVal . _qualificationUserFirstHeld)
-          <*>  view    (resultQualUser . _entityVal . _qualificationUserFirstHeld)
           <*>  preview (resultQualBlock . _entityVal . _qualificationUserBlockUnblock . _not)
           <*>  preview (resultQualBlock . _entityVal . _qualificationUserBlockFrom)
-          <*>  view    (resultLmsUser  . _entityVal . _lmsUserIdent)
+          <*>  view    (resultLmsUser   . _entityVal . _lmsUserIdent)
-          <*>  view    (resultLmsUser  . _entityVal . _lmsUserStatus)
+          <*>  view    (resultLmsUser   . _entityVal . _lmsUserStatus)
-          <*>  view    (resultLmsUser  . _entityVal . _lmsUserStatusDay)
+          <*>  view    (resultLmsUser   . _entityVal . _lmsUserStatusDay)
-          <*>  view    (resultLmsUser  . _entityVal . _lmsUserStarted)
+          <*>  view    (resultLmsUser   . _entityVal . _lmsUserStarted)
-          <*>  view    (resultLmsUser  . _entityVal . _lmsUserDatePin)
+          <*>  view    (resultLmsUser   . _entityVal . _lmsUserDatePin)
-          <*>  view    (resultLmsUser  . _entityVal . _lmsUserReceived)
+          <*>  view    (resultLmsUser   . _entityVal . _lmsUserReceived)
-          <*>  view    (resultLmsUser  . _entityVal . _lmsUserNotified) -- TODO: only exports last email date / print job sending date, not print acknowledge
+          <*>  view    (resultLmsUser   . _entityVal . _lmsUserNotified) -- TODO: only exports last email date / print job sending date, not print acknowledge
-          <*>  view    (resultLmsUser  . _entityVal . _lmsUserEnded)
+          <*>  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))
 
     dbtCsvDecode = Nothing
     dbtExtraReps = []
@@ -627,16 +625,12 @@ postLmsR sid qsh = do
               -- <*> aopt (commentField MsgQualificationActBlockSupervisor) (fslI MsgMessageWarning) Nothing
               <*  aformMessage msgRestartWarning
           ]
-        colChoices cmpMap = mconcat
+        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) ->
+          , sortable (Just "user-company") (i18nCell MsgTablePrimeCompany) $ \(preview resultCompanyId -> mcid) ->
-              let cs =  [ companyCell (unCompanyKey cmpId) cmpName cmpSpr
+              maybeEmpty mcid $ \cid -> companyCell (unCompanyKey cid) (getCompanyName cid) False
-                        | Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps
-                        , let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap
-                        ]
-              in intercalate spacerCell cs
           , colUserMatriclenr isAdmin
           -- , sortable (Just "validity")      (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser)
           , sortable (Just "first-held")    (i18nCell MsgTableQualificationFirstHeld)  $ \(   view $ resultQualUser . _entityVal . _qualificationUserFirstHeld   -> d)  -> dayCell d

src/Handler/MailCenter.hs

@@ -8,6 +8,7 @@ module Handler.MailCenter
   ( getMailCenterR, postMailCenterR
   , getMailHtmlR
   , getMailPlainR
+  , getMailAttachmentR
   ) where
 
 import Import
@@ -96,7 +97,7 @@ mkMCTable = do
       , sortable Nothing (i18nCell MsgCommSubject) $ \(view resultMail -> Entity k v) ->
           let subject = v ^? _sentMailHeaders . _mailHeaders' . _mailHeader' "Subject"
               linkWgt = maybe (msg2widget MsgUtilEMail) text2widget subject
-          in anchorCellM (MailPlainR <$> encrypt k) linkWgt
+          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
       ]
@@ -107,12 +108,14 @@ mkMCTable = do
     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.mkContainsFilter                     $ views (to queryMail)        (E.str2text . (E.^. SentMailHeaders)))
+      , 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
@@ -161,6 +164,27 @@ postMailCenterR = do
     $(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]
 
@@ -178,6 +202,7 @@ handleMailShow hdr prefTypes cusm = 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>
@@ -212,15 +237,16 @@ handleMailShow hdr prefTypes cusm = do
               #{decodeEncodedWord r}
 
       <section>
-        $forall mc <- mcontent
+        $forall pt <- mparts
-          $maybe pt <- selectAlternative prefTypes mc
+          ^{part2widget cusm pt}
-            <p>
-              ^{part2widget pt}
     |]
-    -- Include for Debugging:
+      -- Include for Debugging:
-    -- ^{jsonWidget (sm ^. _sentMailHeaders)}
+      -- <section>
-    -- ^{jsonWidget (sentMailContentContent cn)}
+      --   <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
@@ -232,34 +258,76 @@ selectAlternative (fmap decodeUtf8 -> prefTypes) allAlts = aux prefTypes 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 n) = [whamlet|<h3>Attachment #{n}|]
+disposition2widget (AttachmentDisposition _) = [whamlet|<h3>_{MsgMailFileAttachment}|]
-disposition2widget (InlineDisposition     n) = [whamlet|<h3>#{n}|]
+disposition2widget (InlineDisposition     n) = [whamlet|<h3>_{MsgMenuMailAttachment} #{n}|]
 disposition2widget  DefaultDisposition       = mempty
 
-part2widget :: Part -> Widget
+part2widget :: CryptoUUIDSentMail -> Part -> Widget
-part2widget Part{partContent=NestedParts ps} =
+part2widget cusm Part{partContent=NestedParts ps} =
   [whamlet|
-    <section>
       $forall p <- ps
-        <p>
+        ^{part2widget cusm p}
-          ^{part2widget p}
   |]
-part2widget Part{partContent=PartContent (LB.toStrict -> pc), partType=pt, partDisposition=dispo} =
+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 typePlain = toWidget $ preEscapedToHtml $ plainTextToHtml $ decodeUtf8 pc
-      | pt == decodeUtf8 typeHtml  = toWidget $ preEscapedToHtml $ decodeUtf8 pc -- preEscapedToHtml :: ToMarkup a => a -> Html
+      | 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
-      | otherwise = [whamlet|part2widget cannot decode parts of type #{pt} yet.|]
+      | 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

src/Handler/Profile.hs

@@ -35,6 +35,7 @@ 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 qualified Database.Esqueleto.PostgreSQL as E
 
 import qualified Data.Text as Text
 import Data.List (inits)
@@ -605,6 +606,7 @@ 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
@@ -675,14 +677,24 @@ makeProfileData usrEnt@(Entity uid usrVal@User{..}) = do
   qualificationsTable  <- mkQualificationsTable  now  uid -- Tabelle mit allen Qualifikationen
   supervisorsTable     <- mkSupervisorsTable          uid -- Tabelle mit allen Supervisors
   superviseesTable     <- mkSuperviseesTable actualPrefersPostal uid -- Tabelle mit allen Supervisees
-  let supervisorsWgt :: Widget =
+  countUnderlings <- E.select $ do
-        let ((getSum -> nrSupers, getSum -> nrReroute, getSum -> nrLetter), tWgt) = supervisorsTable
+    spr <- E.from $ E.table @UserSupervisor
-        in  maybeTable' (MsgProfileSupervisor nrSupers nrReroute) (Just MsgProfileNoSupervisor)
+    E.where_ $ spr E.^. UserSupervisorSupervisor E.==. E.val uid
-                        (toMaybe (nrReroute > 0) $ msg2widget $ MsgProfileSupervisorRemark nrSupers nrReroute nrLetter) (nrSupers > 0, tWgt)
+    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 ((getSum -> nrSubs, getSum -> nrReroute), tWgt) = superviseesTable
+        let (nrUnderlings, nrUndersReroute) = errorCount countUnderlings
-        in  maybeTable' (MsgProfileSupervisee nrSubs nrReroute) (Just MsgProfileNoSupervisee)
+        in maybeTable' (MsgProfileSupervisee nrUnderlings nrUndersReroute) (Just MsgProfileNoSupervisee)
-                        (toMaybe (nrReroute > 0) $ msg2widget $ MsgProfileSuperviseeRemark nrSubs nrReroute) (nrSubs > 0, tWgt)
+                       (toMaybe (nrUndersReroute > 0) $ msg2widget $ MsgProfileSuperviseeRemark nrUnderlings nrUndersReroute) (nrUnderlings > 0, superviseesTable)
   -- let examTable, ownTutorialTable, tutorialTable :: Widget
   --     examTable        = i18n MsgPersonalInfoExamAchievementsWip
   --     ownTutorialTable = i18n MsgPersonalInfoOwnTutorialsWip
@@ -1093,10 +1105,10 @@ instance HasUser TblSupervisorData where
   hasUser = _dbrOutput . _1 . _entityVal
 
 -- | Table listing all supervisor of the given user
-mkSupervisorsTable :: UserId -> DB ((Sum Int, Sum Int, Sum Int), Widget)
+mkSupervisorsTable :: UserId -> DB Widget
-mkSupervisorsTable uid = dbTableWidget validator DBTable{..}
+mkSupervisorsTable uid = dbTableWidget' validator DBTable{..}
   where
-    dbtIdent = "userSupervisedBy" :: Text
+    dbtIdent = "supervisors" :: Text
     dbtStyle = def
 
     dbtSQLQuery (usr `E.InnerJoin` spr) = do
@@ -1114,8 +1126,7 @@ mkSupervisorsTable uid = dbTableWidget validator DBTable{..}
         , sortable (Just "reroute") (i18nCell MsgTableRerouteActive) $ \row ->
             let isReroute = row ^. resultUserSupervisor . _entityVal ._userSupervisorRerouteNotifications
                 isLetter  = row ^. resultUser . _userPrefersPostal
-            in  tellCell (Sum 1, Sum $ fromEnum isReroute, Sum $ fromEnum $ isReroute && isLetter) $
+            in  if isReroute
-                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)
@@ -1146,10 +1157,10 @@ mkSupervisorsTable uid = dbTableWidget validator DBTable{..}
 
 
 -- | Table listing all persons supervised by the given user
-mkSuperviseesTable ::Bool -> UserId -> DB ((Sum Int, Sum Int), Widget)
+mkSuperviseesTable ::Bool -> UserId -> DB Widget
-mkSuperviseesTable userPrefersPostal uid = dbTableWidget validator DBTable{..}
+mkSuperviseesTable userPrefersPostal uid = dbTableWidget' validator DBTable{..}
   where
-    dbtIdent = "userSupervisedBy" :: Text
+    dbtIdent = "supervisees" :: Text
     dbtStyle = def
 
     dbtSQLQuery (usr `E.InnerJoin` spr) = do
@@ -1167,7 +1178,7 @@ mkSuperviseesTable userPrefersPostal uid = dbTableWidget validator DBTable{..}
         -- , 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  tellCell (Sum 1, Sum $ fromEnum isReroute) $ boolCell isReroute $ iconCell IconReroute <> iconCellLetterOrEmail
+            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
         ]

src/Handler/Qualification.hs

@@ -96,12 +96,12 @@ mkQualificationAllTable isAdmin = do
               maybeCell (qualificationDescription quali) markupCellLargeModal
           , 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 MsgQualificationRefreshWithin    & cellTooltips [SomeMessage MsgQualificationRefreshWithinTooltip  , SomeMessage MsgTableDiffDaysTooltip]) $
-              foldMap (textCell . formatCalendarDiffDays             ) . view (resultAllQualification . _qualificationRefreshWithin)
           , sortable Nothing (i18nCell MsgQualificationRefreshReminder  & cellTooltips [SomeMessage MsgQualificationRefreshReminderTooltip, SomeMessage MsgTableDiffDaysTooltip]) $
               foldMap (textCell . formatCalendarDiffDays             ) . view (resultAllQualification . _qualificationRefreshReminder)
           , sortable (Just "noteexpiry") (i18nCell MsgQualificationExpiryNotification & cellTooltip MsgQualificationExpiryNotificationTooltip)
@@ -158,7 +158,6 @@ data QualificationTableCsv = QualificationTableCsv   -- Q..T..C.. -> qtc..
   { qtcDisplayName    :: UserDisplayName
   , qtcEmail          :: UserEmail
   , qtcCompany        :: Maybe Text
-  , qtcCompanyNumbers :: CsvSemicolonList Int
   , qtcValidUntil     :: Day
   , qtcLastRefresh    :: Day
   , qtcBlockStatus    :: Maybe Bool
@@ -174,8 +173,7 @@ qtcExample :: QualificationTableCsv
 qtcExample = QualificationTableCsv
     { qtcDisplayName    = "Max Mustermann"
     , qtcEmail          = "m.mustermann@example.com"
-    , qtcCompany        = Just "Example Brothers LLC, SecondaryJobs Inc"
+    , qtcCompany        = Just "Example Brothers LLC"
-    , qtcCompanyNumbers = CsvSemicolonList [27,69]
     , qtcValidUntil     = compDay
     , qtcLastRefresh    = compDay
     , qtcBlockStatus    = Nothing
@@ -209,8 +207,7 @@ instance CsvColumnsExplained QualificationTableCsv where
   csvColumnsExplanations = genericCsvColumnsExplanations qtcOptions $ Map.fromList
     [ ('qtcDisplayName    , SomeMessage MsgLmsUser)
     , ('qtcEmail          , SomeMessage MsgTableLmsEmail)
-    , ('qtcCompany        , SomeMessage MsgTableCompanies)
+    , ('qtcCompany        , SomeMessage MsgTablePrimeCompany)
-    , ('qtcCompanyNumbers , SomeMessage MsgTableCompanyNos)
     , ('qtcValidUntil     , SomeMessage MsgLmsQualificationValidUntil)
     , ('qtcLastRefresh    , SomeMessage MsgTableQualificationLastRefresh)
     , ('qtcBlockStatus    , SomeMessage MsgInfoQualificationBlockStatus)
@@ -238,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
@@ -252,8 +249,8 @@ resultLmsUser = _dbrOutput . _3 . _Just
 resultQualBlock :: Traversal' QualificationTableData (Entity QualificationUserBlock)
 resultQualBlock = _dbrOutput . _4 . _Just
 
-resultCompanyUser :: Lens' QualificationTableData [Entity UserCompany]
+resultCompanyId :: Traversal' QualificationTableData CompanyId
-resultCompanyUser = _dbrOutput . _5
+resultCompanyId = _dbrOutput . _5 . _unValue . _Just
 
 
 instance HasEntity QualificationTableData User where
@@ -340,6 +337,7 @@ 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
@@ -351,7 +349,11 @@ qualificationTableQuery now qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJo
     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)
+    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 ::
@@ -361,17 +363,19 @@ mkQualificationTable ::
            => Bool
            -> Entity Qualification
            -> Map QualificationTableAction (AForm Handler QualificationTableActionData)
-           -> (Map CompanyId Company -> cols)
+           -> ((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
+  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)
@@ -380,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
+    dbtProj = dbtProjId
-      -- cmps <- E.select . E.from $ \(usrComp `E.InnerJoin` comp) -> do
+    dbtColonnade = cols getCompanyName
-      --   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
     dbtSorting = mconcat
       [ single $ sortUserNameLink   queryUser
       , single $ sortUserEmail      queryUser
@@ -471,8 +468,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
         doEncode' = QualificationTableCsv
           <$>  view    (resultUser     . _entityVal . _userDisplayName)
           <*>  view    (resultUser     . _entityVal . _userDisplayEmail)
-          <*> (view     resultCompanyUser >>= getCompanies)
+          <*>  preview (resultCompanyId . to getCompanyName . _CI)
-          <*> (view     resultCompanyUser >>= getCompanyNos)
           <*>  view    (resultQualUser . _entityVal . _qualificationUserValidUntil)
           <*>  view    (resultQualUser . _entityVal . _qualificationUserLastRefresh)
           <*>  preview (resultQualBlock. _entityVal . _qualificationUserBlockUnblock . _not)
@@ -480,10 +476,6 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
           <*>  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
@@ -551,7 +543,7 @@ postQualificationR sid qsh = do
           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 }
@@ -585,16 +577,12 @@ postQualificationR sid qsh = do
           ] isAdmin
         linkLmsUser     = toMaybe isAdmin (LmsUserR sid qsh)
         linkUserName    = bool ForProfileR ForProfileDataR isAdmin
-        colChoices cmpMap = mconcat
+        colChoices getCompanyName = mconcat
           [ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
           , colUserNameModalHdr MsgLmsUser linkUserName
           , colUserEmail
-          , sortable (Just "user-company") (i18nCell MsgTableCompany) $ \( view resultCompanyUser -> cmps) ->
+          , sortable (Just "user-company") (i18nCell MsgTablePrimeCompany) $ \(preview resultCompanyId -> mcid) ->
-              let cs =  [ companyCell (unCompanyKey cmpId) cmpName cmpSpr
+              maybeEmpty mcid $ \cid -> companyCell (unCompanyKey cid) (getCompanyName cid) False
-                        | Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps
-                        , let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap
-                        ]
-              in intercalate spacerCell cs
           , 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

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
 
@@ -191,18 +191,19 @@ postUsersR = do
         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
         [ singletonMap UserLdapSync      $ pure UserLdapSyncData
         , singletonMap UserAvsSync       $ pure UserAvsSyncData
         , singletonMap UserAddSupervisor $ UserAddSupervisorData
-            <$> apopt (textField & cfAnySeparatedSet) (fslI MsgTableSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing
+            <$> apopt (textField & cfAnySeparatedSet) (fslI MsgTableSupervisor       & setTooltip MsgCourseParticipantsRegisterUsersFieldTip)     Nothing
-            <*> apopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just True)
+            <*> 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 (textField & cfAnySeparatedSet) (fslI MsgTableSupervisor       & setTooltip MsgCourseParticipantsRegisterUsersFieldTip)     Nothing
-            <*> apopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just True)
+            <*> 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
@@ -424,7 +425,8 @@ postUsersR = do
 
   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

src/Handler/Utils.hs

@@ -163,19 +163,23 @@ 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
 -- note that adminProblemCompany/adminProblemCompanyOld and adminProblemUser are automatically displayed within their own columns
+-- WARNING: this function should correspond with adminProblem2Text
 adminProblemCell AdminProblemNewCompany{}
   = i18nCell MsgAdminProblemNewCompany
 adminProblemCell AdminProblemSupervisorNewCompany{adminProblemCompanyNew, adminProblemSupervisorReroute}
   = i18nCell (MsgAdminProblemSupervisorNewCompany adminProblemSupervisorReroute) <> companyIdCell adminProblemCompanyNew
 adminProblemCell AdminProblemSupervisorLeftCompany{adminProblemSupervisorReroute}
   = i18nCell (MsgAdminProblemSupervisorLeftCompany adminProblemSupervisorReroute)
-adminProblemCell AdminProblemCompanySuperiorChange{adminProblemUserOld=Nothing}
+adminProblemCell AdminProblemCompanySuperiorChange{adminProblemUserOld}
-  = i18nCell MsgAdminProblemCompanySuperiorChange
+  = i18nCell MsgAdminProblemCompanySuperiorChange <> previousSuperior adminProblemUserOld
-adminProblemCell AdminProblemCompanySuperiorChange{adminProblemUserOld=Just uid}
+adminProblemCell AdminProblemCompanySuperiorNotFound{..}
-  = i18nCell MsgAdminProblemCompanySuperiorChange <> spacerCell <> i18nCell MsgAdminProblemCompanySuperiorPrevious <> anchorCellM (AdminUserR <$> encrypt uid) (userIdWidget uid)
+  = i18nCell (MsgAdminProblemCompanySuperiorNotFound (fromMaybe "???" adminProblemEmail)) <> previousSuperior adminProblemUserOld
 adminProblemCell AdminProblemNewlyUnsupervised{adminProblemCompanyNew}
   = i18nCell MsgAdminProblemNewlyUnsupervised <> companyIdCell adminProblemCompanyNew
 adminProblemCell AdminProblemUnknown{adminProblemText}
@@ -184,6 +188,42 @@ adminProblemCell AdminProblemUnknown{adminProblemText}
 company2msg :: CompanyId -> SomeMessage UniWorX
 company2msg = text2message . ciOriginal . unCompanyKey
 
+-- 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]
@@ -193,8 +233,10 @@ msgAdminProblem AdminProblemSupervisorLeftCompany{adminProblemCompany=comp, admi
   SomeMessages [SomeMessage $ MsgAdminProblemSupervisorLeftCompany rer, text2message ": ", company2msg comp]
 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]
+  SomeMessages [SomeMessage   MsgAdminProblemNewlyUnsupervised, text2message ": ", maybe (text2message "???") company2msg comp, text2message " -> ", company2msg newComp]
 msgAdminProblem AdminProblemUnknown{adminProblemText=err} = return $
   someMessages ["Problem: ", err]
 

src/Handler/Utils/Avs.hs

@@ -22,7 +22,7 @@ module Handler.Utils.Avs
   , computeDifferingLicences
   -- , synchAvsLicences
   , queryAvsFullStatus
-  -- , lookupAvsUser, lookupAvsUsers
+  , lookupAvsUser, lookupAvsUsers
   , AvsException(..)
   , updateReceivers
   , AvsPersonIdMapPersonCard
@@ -99,10 +99,10 @@ 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' :: (MonadHandler m, MonadCatch m, RenderMessage (HandlerSite m) AvsException) => m (Maybe a) -> m (Maybe a)
--- catchAll2log' = voidMaybe $ catchAVShandler True True False mempty
+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)
@@ -329,6 +329,8 @@ updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAv
       let usrId = userAvsUser usravs
       usr <- MaybeT $ get usrId
       lift $ do -- maybeT no longer needed from here onwards
+        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
@@ -380,71 +382,73 @@ updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAv
                       , UserAvsLastCardNo     =. newAvsCardNo
                       ]
 
-        -- update company association & supervision
+        usr_up2 <- guardMonoidM (oldAvsFirmInfo /= Just newAvsFirmInfo) $ do
-        Entity{entityKey=newCompanyId} <- upsertAvsCompany newAvsFirmInfo oldAvsFirmInfo
+          -- update company association & supervision
-        oldCompanyEnt <- getAvsCompany `traverseJoin` oldAvsFirmInfo
+          newCompanyEnt@Entity{entityKey=newCompanyId} <- upsertAvsCompany newAvsFirmInfo oldAvsFirmInfo
-        primaryCompanyId <- userCompanyCompany <<$>> getUserPrimaryCompany usrId
+          upsertCompanySuperior newCompanyEnt newAvsFirmInfo oldAvsFirmInfo usrId   -- ensure firmInfo superior is supervisor for this user
-        let oldCompanyId = entityKey <$> oldCompanyEnt
+          oldCompanyEnt <- getAvsCompany `traverseJoin` oldAvsFirmInfo
-            -- oldCompanyMb = entityVal <$> oldCompanyEnt
+          primaryCompanyId <- userCompanyCompany <<$>> getUserPrimaryCompany usrId
-            -- pst_up  = if
+          let oldCompanyId = entityKey <$> oldCompanyEnt
-            --           -- | isNothing oldCompanyMb || oldCompanyId == primaryCompanyId                                              -- refactor could replace next 4 lines
+              -- oldCompanyMb = entityVal <$> oldCompanyEnt
-            --           --   -> mkUpdate'      usr newCompany oldCompanyMb $ CheckUpdate UserPrefersPostal _companyPrefersPostal  -- always update if company association is fresh (case should not occur in practice though)
+              -- pst_up  = if
-            --           | isNothing oldCompanyMb
+              --           -- | isNothing oldCompanyMb || oldCompanyId == primaryCompanyId                                              -- refactor could replace next 4 lines
-            --             -> mkUpdateDirect usr newCompany              $ CheckUpdate UserPrefersPostal _companyPrefersPostal  -- always update if company association is fresh (case should not occur in practice though)
+              --           --   -> mkUpdate'      usr newCompany oldCompanyMb $ 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
+              --           | isNothing oldCompanyMb
-            --             -> mkUpdate       usr newCompany oldCompanyMb $ CheckUpdate UserPrefersPostal _companyPrefersPostal  -- possibly change postal preference
+              --             -> mkUpdateDirect usr newCompany              $ CheckUpdate UserPrefersPostal _companyPrefersPostal  -- always update if company association is fresh (case should not occur in practice though)
-            --           | otherwise
+              --           | oldCompanyId == primaryCompanyId -- && isJust oldCompanyId -- is ensured by previous line
-            --             -> Nothing
+              --             -> mkUpdate       usr newCompany oldCompanyMb $ CheckUpdate UserPrefersPostal _companyPrefersPostal  -- possibly change postal preference
-            superReasonComDef = tshow SupervisorReasonCompanyDefault
+              --           | otherwise
-            newUserComp = UserCompany usrId newCompanyId False False 1 True Nothing -- default value for new company insertion, if no update can be done
+              --             -> 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
 
-        usr_up2 <- case oldAvsFirmInfo of
+          case oldAvsFirmInfo of
-          _ | Just newCompanyId == oldCompanyId                                               -- company unchanged entirely
+            _ | Just newCompanyId == oldCompanyId                                               -- company unchanged entirely
-              -> return mempty                                                                --  => do nothing
+                -> return mempty                                                                --  => do nothing
-          (Just oafi) |  isJust    (view _avsFirmPostAddressSimple  oafi)
+            (Just oafi) |  isJust    (view _avsFirmPostAddressSimple  oafi)
-                      && ((==) `on` view _avsFirmPostAddressSimple) oafi newAvsFirmInfo       -- non-empty company address unchanged OR
+                        && ((==) `on` view _avsFirmPostAddressSimple) oafi newAvsFirmInfo       -- non-empty company address unchanged OR
-                      || isJust    (view _avsFirmPrimaryEmail       oafi)
+                        || isJust    (view _avsFirmPrimaryEmail       oafi)
-                      && ((==) `on` view _avsFirmPrimaryEmail)      oafi newAvsFirmInfo       -- non-empty company primary email unchanged
+                        && ((==) `on` view _avsFirmPrimaryEmail)      oafi newAvsFirmInfo       -- non-empty company primary email unchanged
-              -> do                                                                           --  => just update user company association, keeping supervision privileges
+                -> do                                                                           --  => just update user company association, keeping supervision privileges
-                  case oldCompanyId of
+                    case oldCompanyId of
-                    Nothing -> void $ insertUnique newUserComp -- it's ok if this already exists
+                      Nothing -> void $ insertUnique newUserComp -- it's ok if this already exists
-                    Just ocid -> do
+                      Just ocid -> do
-                      void $ upsertBySafe (UniqueUserCompany usrId ocid) newUserComp (_userCompanyCompany .~ newCompanyId)  -- keep default supervisor settings
+                        void $ upsertBySafe (UniqueUserCompany usrId ocid) newUserComp (_userCompanyCompany .~ newCompanyId)  -- keep default supervisor settings
-                      void $ updateWhere [ UserSupervisorSupervisor ==. usrId                                               -- update company-related supervisions
+                        void $ updateWhere [ UserSupervisorSupervisor ==. usrId                                               -- update company-related supervisions
-                                         , UserSupervisorCompany ==. Just ocid                                              -- to new company, regardless of
+                                          , UserSupervisorCompany ==. Just ocid                                              -- to new company, regardless of
-                                         , UserSupervisorReason ==. Just superReasonComDef]                                 -- user
+                                          , UserSupervisorReason ==. Just superReasonComDef]                                 -- user
-                                         [ UserSupervisorCompany =. Just newCompanyId]
+                                          [ UserSupervisorCompany =. Just newCompanyId]
-                  return mempty
+                    return mempty
-          _ | Just newCompanyId == primaryCompanyId                                           -- old primaryCompany is now also AVS-company
+            _ | Just newCompanyId == primaryCompanyId                                           -- old primaryCompany is now also AVS-company
-              -> do
+                -> do
-                  whenIsJust oldCompanyId $ \oldCid -> do
+                    whenIsJust oldCompanyId $ \oldCid -> do
-                    deleteBy $ UniqueUserCompany usrId oldCid
+                      deleteBy $ UniqueUserCompany usrId oldCid
-                    deleteWhere $ (UserSupervisorUser ==. usrId):(UserSupervisorCompany ==. oldCompanyId):(UserSupervisorReason ~=. superReasonComDef)
+                      deleteWhere $ (UserSupervisorUser ==. usrId):(UserSupervisorCompany ==. oldCompanyId):(UserSupervisorReason ~=. superReasonComDef)
-                  return mempty
+                    return mempty
-          _                                                                                   -- company changed completely
+            _                                                                                   -- company changed completely
-              -> do
+                -> do
-                  (pst_up, problems) <- switchAvsUserCompany False False usrId newCompanyId
+                    (pst_up, problems) <- switchAvsUserCompany False False usrId newCompanyId
-                  mapM_ reportAdminProblem problems
+                    mapM_ reportAdminProblem problems
-                  -- Following line does not type, hence additional parameter needed
+                    -- 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 [ 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
+                    return pst_up
-                  -- SPECIALISED CODE, PROBABLY DEPRECATED
+                    -- SPECIALISED CODE, PROBABLY DEPRECATED
-                  -- switch user company, keeping old priority
+                    -- switch user company, keeping old priority
-                  -- (getBy . UniqueUserCompany usrId) `traverseJoin` oldCompanyId >>= \case
+                    -- (getBy . UniqueUserCompany usrId) `traverseJoin` oldCompanyId >>= \case
-                  --   Nothing ->
+                    --   Nothing ->
-                  --     void $ insertUnique newUserComp
+                    --     void $ insertUnique newUserComp
-                  --   Just Entity{entityKey=ucidOld, entityVal=UserCompany{userCompanyCompany, userCompanySupervisor, userCompanySupervisorReroute, userCompanyPriority}} -> do
+                    --   Just Entity{entityKey=ucidOld, entityVal=UserCompany{userCompanyCompany, userCompanySupervisor, userCompanySupervisorReroute, userCompanyPriority}} -> do
-                  --     when userCompanySupervisor $ reportAdminProblem $ AdminProblemSupervisorNewCompany usrId userCompanyCompany newCompanyId userCompanySupervisorReroute
+                    --     when userCompanySupervisor $ reportAdminProblem $ AdminProblemSupervisorNewCompany usrId userCompanyCompany newCompanyId userCompanySupervisorReroute
-                  --     delete ucidOld
+                    --     delete ucidOld
-                  --     void $ insertUnique newUserComp{userCompanyPriority} -- keep priority, if insert succeeds
+                    --     void $ insertUnique newUserComp{userCompanyPriority} -- keep priority, if insert succeeds
-                  -- -- adjust supervison
+                    -- -- adjust supervison
-                  -- let oldCompDefSuperFltr = mconcat [UserSupervisorCompany ~~. oldCompanyId, UserSupervisorReason ~=. superReasonComDef]
+                    -- let oldCompDefSuperFltr = mconcat [UserSupervisorCompany ~~. oldCompanyId, UserSupervisorReason ~=. superReasonComDef]
-                  -- deleteWhere $          (UserSupervisorSupervisor ==. usrId) : oldCompDefSuperFltr
+                    -- deleteWhere $          (UserSupervisorSupervisor ==. usrId) : oldCompDefSuperFltr
-                  -- oldAPs <- deleteWhereCount $ (UserSupervisorUser ==. usrId) : oldCompDefSuperFltr
+                    -- oldAPs <- deleteWhereCount $ (UserSupervisorUser ==. usrId) : oldCompDefSuperFltr
-                  -- addDefaultSupervisors' newCompanyId $ singleton usrId
+                    -- addDefaultSupervisors' newCompanyId $ singleton usrId
-                  -- newAPs <- count $ (UserSupervisorUser ==. usrId) : (UserSupervisorCompany ==. Just newCompanyId) : (UserSupervisorReason ~=. superReasonComDef)
+                    -- newAPs <- count $ (UserSupervisorUser ==. usrId) : (UserSupervisorCompany ==. Just newCompanyId) : (UserSupervisorReason ~=. superReasonComDef)
-                  -- when (oldAPs > 0 && newAPs <= 0) $ reportAdminProblem $ AdminProblemNewlyUnsupervised usrId oldCompanyId newCompanyId
+                    -- when (oldAPs > 0 && newAPs <= 0) $ reportAdminProblem $ AdminProblemNewlyUnsupervised usrId oldCompanyId newCompanyId
-                  -- return pst_up
+                    -- 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
@@ -493,13 +497,12 @@ createAvsUserById muid api = do
         -- check for matching existing user
         let internalPersNo :: Maybe Text = cpi ^? _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo
             -- persMail  :: Maybe UserEmail = cpi ^? _avsInfoPersonEMail . _Just . from _CI
-        oldUsr <- runDBRead $ do
+        oldUsr <- runDB $ do
-          mbUid <- if isJust muid
+          mbUid <- firstJustM $ return muid : maybe [] (\ipn ->
-              then return muid
+                [ getKeyByFilter [UserCompanyPersonalNumber ==. Just ipn] -- must ensure filter isnt ==. Nothing
-              else firstJustM $ catMaybes
+                , catchAll2log' (Just . entityKey <$> ldapLookupAndUpsert ipn) -- attempt to insert by LDAP first
-                [ internalPersNo <&> (\ipn -> getKeyByFilter [UserCompanyPersonalNumber ==. Just ipn]) -- must ensure filter isnt ==. Nothing
-                -- , persMail       <&> guessUserByEmail -- this did not work, as unfortunately, superiors are sometimes listed under _avsInfoPersonEMail!
                 ]
+                ) internalPersNo
           mbUAvs <- (getBy . UniqueUserAvsUser) `traverseJoin` mbUid
           return (mbUid, mbUAvs)
         usrCardNo <- queryAvsFullCardNo api
@@ -563,8 +566,8 @@ createAvsUserById muid api = do
               return uid
 
 
-getAvsCompanyId :: AvsFirmInfo -> DB (Maybe CompanyId)
+-- getAvsCompanyId :: AvsFirmInfo -> DB (Maybe CompanyId)
-getAvsCompanyId = fmap (fmap entityKey) . getAvsCompany
+-- 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))
@@ -585,16 +588,18 @@ getAvsCompany afi =
 
 -- | 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}|]
+    $logInfoS "AVS" [st|upsertAvsCompany: old #{tshow mbOldAvsFirmInfo} new #{tshow newAvsFirmInfo} ent-new #{tshow mbFirmEnt}|]
-    cmpEnt <- case (mbFirmEnt, mbOldAvsFirmInfo) of
+    case mbFirmEnt of
-      (Nothing, _) -> do                                                                                  -- insert new company, neither AvsId nor Shorthand exist in DB
+      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
@@ -606,11 +611,12 @@ 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
+      (Just Entity{entityKey=firmid, entityVal=firm}) -> do                                          -- possibly update existing company, if isJust oldAvsFirmInfo and identical AvsFirmNo and changes occurred
-        let cmp_ups = mapMaybe  (mkUpdate'            firm newAvsFirmInfo oldAvsFirmInfo) firmInfo2company
+        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}|]
@@ -629,10 +635,8 @@ upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do
                | otherwise -> $logInfoS "AVS" $ "Update company shorthand failed for " <> ciOriginal cmp_key <> " and " <> ciOriginal alt_key
             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
-    void $ upsertCompanySuperior (Just $ entityKey cmpEnt, newAvsFirmInfo) mbOldAvsFirmInfo                -- ensure firmInfo superior is supervisor
-    return cmpEnt
   where
     firmInfo2key =
         CheckUpdate CompanyShorthand   $ _avsFirmAbbreviation  . from _CI  -- Updating primary key works in principle thanks to OnUpdateCascade, but fails due to update get
@@ -645,94 +649,73 @@ upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do
       -- , CheckUpdate CompanyPrefersPostal _avsFirmPrefersPostal          -- Guessing here is not useful, since postal preference is ignored anyway when there is only one option available
       ]
 
--- upsert company supervisor from AvsFirmEMailSuperior
-upsertCompanySuperior :: (Maybe CompanyId, AvsFirmInfo) -> Maybe AvsFirmInfo -> DB (Maybe (CompanyId, UserId))
-upsertCompanySuperior (mbCid, newAfi) mbOldAfi
-    | Just supemail <- newAfi ^. _avsFirmEMailSuperior -- superior given
-      = runMaybeT $ do
-        cid <- MaybeT $ altM (pure mbCid) (getAvsCompanyId newAfi)
-        supid <- MaybeT $ altM (guessUserByEmail $ stripCI supemail)
-                               (catchAVShandler True True False Nothing $ Just . entityKey <$> ldapLookupAndUpsert supemail)
-        lift $ do
-          oldChanges <- runMaybeT $ do -- remove old superior, if any
-            oldAfi <- MaybeT $ pure mbOldAfi
-            oldEml <- MaybeT $ pure $ oldAfi ^. _avsFirmEMailSuperior
-            oldCid <- MaybeT $ getAvsCompanyId oldAfi
-            oldSup <- MaybeT $ guessUserByEmail $ stripCI oldEml
-            let supChange = oldSup /= supid
-            when (supChange && oldCid == cid) $ lift $ do
-              -- deleteWhere [UserCompanyCompany ==. cid, UserCompanyUser ==. oldSup] -- remove old supervisor from company NOTE: we leave this to the oldSuperior's AVS update
-              -- switch supervison
-              -- updateWhere [UserSupervisorCompany ==. Just cid, UserSupervisorSupervisor ==. oldSup, UserSupervisorReason ==. reasonSuperior] [UserSupervisor =. supid] -- not safe, could violate uniqueness
-              E.update $ \usuper -> do
-                E.set usuper [ UserSupervisorSupervisor E.=. E.val supid ]
-                E.where_ $ usuper E.^. UserSupervisorSupervisor E.==. E.val oldSup
-                    E.&&.  usuper E.^. UserSupervisorCompany    E.==. E.justVal cid
-                    E.&&.  usuper E.^. UserSupervisorReason     E.==. E.val reasonSuperior
-                    E.&&. E.notExists (do
-                        newSuper <- E.from $ E.table @UserSupervisor
-                        E.where_ $ newSuper E.^. UserSupervisorSupervisor E.==. E.val supid
-                            E.&&.  newSuper E.^. UserSupervisorUser       E.==. newSuper E.^. UserSupervisorUser
-                      )
-              deleteOldSuperior oldSup cid    -- remove un-updateable remainders, if any
-            return (supChange, oldSup)
-          let supChange = fst <$> oldChanges
-              oldSup    = snd <$> oldChanges
-          unless (supChange == Just False) $ do
-            -- upsert new superior company supervisor
-            mbMaxPrio <- E.selectOne $ do
-              usrCmp <- E.from $ E.table @UserCompany
-              E.where_ $ usrCmp E.^. UserCompanyUser E.==. E.val supid
-              return . E.max_ $ usrCmp E.^. UserCompanyPriority
-            let maxPrio = maybe 1 (fromMaybe 1 . E.unValue) mbMaxPrio
-            suprEnt <- upsertBy (UniqueUserCompany supid cid)
-                                  (UserCompany supid cid True False maxPrio True reasonSuperior)
-                                  [UserCompanySupervisor =. True, UserCompanyPriority =. maxPrio, UserCompanyReason =. reasonSuperior]
-            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.val (suprEnt ^. _entityVal . _userCompanySupervisorReroute)
-                  E.<&> E.justVal cid
-                  E.<&> E.val reasonSuperior
-              )
-              (\_old new ->
-                [ -- UserSupervisorSupervisor E.=. new E.^. UserSupervisorSupervisor  -- this is already given in case of conflict
-                  UserSupervisorCompany               E.=. new E.^. UserSupervisorCompany
-                , UserSupervisorReason                E.=. new E.^. UserSupervisorReason
-                , UserSupervisorRerouteNotifications  E.=. new E.^. UserSupervisorRerouteNotifications
-                ]
-              )
-            reportAdminProblem $ AdminProblemCompanySuperiorChange supid cid oldSup
-          return (cid,supid)
-    | Just oldSupeEmail <- mbOldAfi ^. _Just . _avsFirmEMailSuperior -- no more superior, delete old one
-      = do
-          void $ runMaybeT $ do
-            oldAfi <- MaybeT $ pure mbOldAfi
-            oldCid <- MaybeT $ getAvsCompanyId oldAfi
-            oldSup <- MaybeT $ guessUserByEmail $ stripCI oldSupeEmail
-            lift $ deleteOldSuperior oldSup oldCid
-          return Nothing
-    | otherwise -- neither new nor old superior
-      = return Nothing
-  where
-    reasonSuperior = Just $ tshow SupervisorReasonAvsSuperior
 
-    deleteOldSuperior oldSup oldCid =
+-- | adjust superiors, assumes that CompanyUser exists for all usrs for given company; does not work otherwise
-      deleteWhere [ UserSupervisorSupervisor ==. oldSup
+upsertCompanySuperior :: Entity Company -> AvsFirmInfo -> Maybe AvsFirmInfo -> UserId -> DB () -- may return superior (Maybe UserId), but currently not needed
-                  , UserSupervisorCompany ==. Just oldCid
+upsertCompanySuperior Entity{entityKey=cid, entityVal=Company{}} newAfi oldAfi usrId =
-                  , UserSupervisorReason ==. reasonSuperior
+  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)
@@ -903,30 +886,32 @@ 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' :: 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]
+        ] ++ [AvsPersonLicence (bool AvsLicenceRollfeld AvsLicenceVorfeld $ even $ avsPersonId avsid) avsid
+             | Entity _ UserAvs{userAvsPersonId = avsid} <- avsUsrs
+             ]
 #else
   allLicences  <- avsQueryNoCache AvsQueryGetAllLicences
 #endif
@@ -942,7 +927,7 @@ retrieveDifferingLicences' getStatus = do
               ] <>
               [ AvsStatusPerson  avsid $ Set.singleton $ mkAdpc (even $ avsPersonId avsid) AvsCardColorGelb | Entity _ UserAvs{userAvsPersonId = avsid} <- avsUsrs ]
 #else
-  let statQry = avsLicenceDifferences2LicenceIds lDiff
+  let statQry = avsLicenceDifferences2LicenceIds $ fst lDiff
   lStat <- if getStatus && notNull statQry
             then avsQueryNoCache (AvsQueryStatus statQry)
               -- `catch` handler
@@ -954,7 +939,7 @@ retrieveDifferingLicences' getStatus = do
   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
@@ -965,7 +950,7 @@ getDifferingLicences (AvsResponseGetLicences licences) = do
       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) <-
@@ -991,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
       setTo2      = (rollGrant Set.\\ vorfRevoke) `Set.intersection` (vorfGrant `Set.union` vorORrollfeld) -- grant maneuvering driving licence
-  return AvsLicenceDifferences
+      rsChanged   = rollfeld `Set.intersection` Set.unions [vorfRevoke, rollRevoke, setTo1up] -- maneuvering driving licences to downgrade in AVS
-    { avsLicenceDiffRevokeAll      = setTo0
+      alds = AvsLicenceDifferences
-    , avsLicenceDiffGrantVorfeld   = setTo1up
+              { avsLicenceDiffRevokeAll      = setTo0
-    , avsLicenceDiffRevokeRollfeld = setTo1down
+              , avsLicenceDiffGrantVorfeld   = setTo1up
-    , avsLicenceDiffGrantRollfeld  = setTo2
+              , 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/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

@@ -169,6 +169,10 @@ switchAvsUserCompany usrPostEmailUpds keepOldCompanySupervs uid newCompanyId = d
         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
+
+        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
@@ -180,7 +184,7 @@ switchAvsUserCompany usrPostEmailUpds keepOldCompanySupervs uid newCompanyId = d
         | newCompanyId == oldCompanyId -> return mempty -- nothing to do
         | otherwise -> do -- switch company
             when (isNothing oldAssocReason) $ deleteBy $ UniqueUserCompany uid oldCompanyId
-            void $ upsertBy (UniqueUserCompany uid newCompanyId) newUserComp
+            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
@@ -213,15 +217,13 @@ switchAvsUserCompany usrPostEmailUpds keepOldCompanySupervs uid newCompanyId = d
                          $ bcons isNoLongerSupervised (AdminProblemNewlyUnsupervised uid (Just oldCompanyId) newCompanyId)
                            newlyUnsupervised
             return (usrUpdate ,problems)
-  where
-    newUserComp       = UserCompany uid newCompanyId False False 1 True Nothing -- 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 r | r <- [SupervisorReasonCompanyDefault, SupervisorReasonAvsSuperior]]]
+    ||. [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
@@ -231,10 +233,11 @@ deleteDefaultSupervisorsForUsers cids sprs usrs =
       $ bcons (notNull sprs) (UserSupervisorSupervisor  <-.  sprs)
       $ (UserSupervisorUser <-. toList usrs) : defaultSupervisorReasonFilter
 
--- | deletes user company association and all company related supervision
+-- | retrieve maximum company user priority fo a user
--- WARNING: does not check for admin problems!
+getCompanyUserMaxPrio :: UserId -> DB Int
-deleteCompanyUser :: CompanyId -> [UserId] -> DB (Int64, Int64, Int64)
+getCompanyUserMaxPrio uid = do
-deleteCompanyUser cid uids = (,,)
+  mbMaxPrio <- E.selectOne $ do
-    <$> deleteWhereCount  [UserCompanyCompany    ==.      cid,  UserCompanyUser          <-. uids]
+    usrCmp <- E.from $ E.table @UserCompany
-    <*> deleteWhereCount ((UserSupervisorCompany ==. Just cid):(UserSupervisorSupervisor <-. uids) : defaultSupervisorReasonFilter)
+    E.where_ $ usrCmp E.^. UserCompanyUser E.==. E.val uid
-    <*> deleteWhereCount ((UserSupervisorCompany ==. Just cid):(UserSupervisorUser       <-. uids) : defaultSupervisorReasonFilter)
+    return . E.max_ $ usrCmp E.^. UserCompanyPriority
+  return $ maybe 1 (fromMaybe 1 . E.unValue) mbMaxPrio

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' SelFormatDate     usr = usr & userDateFormat
-getDateTimeFormatUser' SelFormatTime     usr = usr & userTimeFormat   
+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 
+  where
-    (y,_,_) = toGregorian date    
+    (y,_,_) = toGregorian date
 
 dayOfWeekDiff :: DayOfWeek -> DayOfWeek -> Int
 dayOfWeekDiff a b = mod (fromEnum a - fromEnum b) 7
@@ -310,10 +314,10 @@ addLocalDays n utct = localTimeToUTCTZ appTZ newLocal
 -- 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
@@ -393,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/Qualification.hs

@@ -58,7 +58,7 @@ quserToNotify cutoff quser qblock = -- either recently become invalid with no pr
           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
@@ -71,6 +71,20 @@ 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

src/Handler/Utils/Table/Cells.hs

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

src/Handler/Utils/Widgets.hs

@@ -173,6 +173,23 @@ companyWidget isPrimary (csh, cname, isSupervisor)
       | 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 --
 ----------

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

@@ -67,7 +67,7 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act
       now <- liftIO getCurrentTime
       let nowaday = utctDay now
       -- send second reminders first, before enqueing even more, but only for users with currently open LMS and still valid Qualificiations
-      ifNothingM (qualificationRefreshReminder quali) () $ \remindPeriod -> do
+      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
@@ -91,33 +91,40 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act
                   , jNotification = NotificationQualificationRenewal { nQualification = qid, nReminder = True }
                   }
           _ -> return ()
-
+      -- send initial reminders
-      ifNothingM (qualificationRefreshWithin quali) () $ \renewalPeriod -> do  -- no refreshWithin, no first reminders
+      whenIsJust (qualificationRefreshWithin quali) $ \renewalPeriod -> do  -- no refreshWithin, no first reminders
-          let renewalDate = addGregorianDurationClip renewalPeriod nowaday
+        let renewalDate = addGregorianDurationClip renewalPeriod nowaday
-          renewalUsers <- E.select $ do
+        renewalUsers <- E.select $ do
-            quser <- E.from $ E.table @QualificationUser
+          quser <- E.from $ E.table @QualificationUser
-            E.where_ $  quser E.^. QualificationUserQualification E.==. E.val qid
+          E.where_ $  quser E.^. QualificationUserQualification E.==. E.val qid
-                  E.&&. quser E.^. QualificationUserScheduleRenewal
+                E.&&. quser E.^. QualificationUserScheduleRenewal
-                  E.&&. quser E.^. QualificationUserValidUntil E.<=. E.val renewalDate
+                E.&&. quser E.^. QualificationUserValidUntil E.<=. E.val renewalDate
-                  E.&&. (quser `qualificationValid` now)
+                E.&&. (quser `qualificationValid` now)
-                  E.&&. E.notExists (do
+                E.&&. E.notExists (do
-                          luser <- E.from $ E.table @LmsUser
+                        luser <- E.from $ E.table @LmsUser
-                          E.where_ $  luser E.^. LmsUserQualification E.==. E.val qid
+                        E.where_ $  luser E.^. LmsUserQualification E.==. E.val qid
-                                E.&&. luser E.^. LmsUserUser E.==. quser E.^. QualificationUserUser
+                              E.&&. luser E.^. LmsUserUser E.==. quser E.^. QualificationUserUser
-                                E.&&. E.isNothing (luser E.^. LmsUserEnded)
+                              E.&&. E.isNothing (luser E.^. LmsUserEnded)
-                        )
+                      )
-            pure quser
+          pure quser
-          let usr_job :: Entity QualificationUser -> Job
+        let usr_job :: Entity QualificationUser -> Maybe Job
-              usr_job quser =
+            usr_job quser =
-                let uid = quser ^. _entityVal . _qualificationUserUser
+              let uid = quser ^. _entityVal . _qualificationUserUser
-                    uex = quser ^. _entityVal . _qualificationUserValidUntil
+                  uex = quser ^. _entityVal . _qualificationUserValidUntil
-                in if qualificationElearningStart quali
+                  unf = quser ^. _entityVal . _qualificationUserLastNotified
-                    then JobLmsEnqueueUser { jQualification = qid, jUser = uid  }
+                  nfy_cutoff = addGregorianDurationClip renewalPeriod $ utctDay unf
-                    else JobUserNotification { jRecipient = uid, jNotification =
+                  do_notify  = uex > nfy_cutoff || (uex == nfy_cutoff && utctDayTime now >= utctDayTime unf)
-                              NotificationQualificationExpiry { nQualification = qid, nExpiry = uex }
+              in if
-                         }
+                  | qualificationElearningStart quali     -- repetition avoided since LmsUser does not exist
-          forM_ renewalUsers (queueDBJob . usr_job)
+                    -> Just $ JobLmsEnqueueUser { jQualification = qid, jUser = uid }
-          logInterface "LMS" (qshort <> "-enq") True (Just $ length renewalUsers) ""
+                  | 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

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,24 +22,22 @@ import Text.Hamlet
 
 
 dispatchNotificationQualificationExpiry :: QualificationId -> Day -> UserId -> Handler ()
-dispatchNotificationQualificationExpiry nQualification dExpiry jRecipient = userMailT jRecipient $ do
+dispatchNotificationQualificationExpiry nQualification dExpiry jRecipient = do
-  (recipient@User{..}, Qualification{..}) <- liftHandler . runDB $ (,)
+  now <- liftIO getCurrentTime
+  encRecipient :: CryptoUUIDUser <- liftHandler $ encrypt jRecipient
+  (recipient@User{..}, Qualification{..}) <- runDB $ (,)
     <$> getJust jRecipient
     <*> getJust nQualification
-
-  encRecipient :: CryptoUUIDUser <- liftHandler $ encrypt jRecipient
   let entRecipient = Entity jRecipient recipient
       qname = CI.original qualificationName
-  expiryDate <- formatTimeUser SelFormatDate dExpiry $ Just entRecipient
+  userMailT jRecipient $ do
-
+    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
-  replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
+    editNotifications <- mkEditNotifications jRecipient
-  setSubjectI $ MsgMailSubjectQualificationExpiry qname
+    addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/qualificationExpiry.hamlet")
-
+  runDB $ updateBy (UniqueQualificationUser nQualification jRecipient) [QualificationUserLastNotified =. now]
-  editNotifications <- mkEditNotifications jRecipient
+  $logDebugS "LMS" $ "Notified " <> tshow encRecipient <> " about soonish expiry of qualification " <> qname
-
-  addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/qualificationExpiry.hamlet")
 
 
 dispatchNotificationQualificationExpired :: QualificationId -> UserId -> Handler ()
@@ -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
 
 

src/Jobs/Handler/SynchroniseAvs.hs

@@ -7,11 +7,14 @@ module Jobs.Handler.SynchroniseAvs
   -- , dispatchJobSynchroniseAvsId
   -- , 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,6 +26,7 @@ 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
@@ -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
     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,6 +97,7 @@ data Job
                               , jIteration :: Natural
                               }
   | JobSynchroniseLdapUser    { jUser :: UserId }
+  | JobSynchroniseLdapAll
   | JobSynchroniseAvs         { jNumIterations
                               , jEpoch
                               , jIteration :: Natural
@@ -109,6 +110,7 @@ data Job
   --                             , jSynchAfter :: Maybe Day
   --                             }
   | JobSynchroniseAvsQueue
+  | JobSynchroniseAvsLicences
   | JobChangeUserDisplayEmail { jUser :: UserId
                               , jDisplayEmail :: UserEmail
                               }
@@ -349,6 +351,7 @@ jobNoQueueSame = \case
   JobDeleteTransactionLogIPs{}        -> Just JobNoQueueSame
   JobSynchroniseLdap{}                -> Just JobNoQueueSame
   JobSynchroniseLdapUser{}            -> Just JobNoQueueSame
+  JobSynchroniseLdapAll{}             -> Just JobNoQueueSameTag
   JobSynchroniseAvs{}                 -> Just JobNoQueueSame
   -- JobSynchroniseAvsUser{}             -> Just JobNoQueueSame
   -- JobSynchroniseAvsId{}               -> Just JobNoQueueSame

src/Model/Types/Avs.hs

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

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

@@ -69,7 +69,7 @@ data SupervisorReason
 --       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"
 
 

src/Settings.hs

@@ -102,6 +102,8 @@ data AppSettings = AppSettings
     -- ^ Configuration settings for accessing the LDAP-directory
     , appAvsConf                :: Maybe AvsConf
     -- ^ Configuration settings for accessing AVS Server (= Ausweis Verwaltungs System)
+    , appAvsLicenceSynchConf    :: AvsLicenceSynchConf
+    -- ^ Configuration settings for automatically synching driving licences with AVS
     , appLprConf                :: LprConf
     -- ^ Configuration settings for accessing a printer queue via lpr for letter mailing
     , appSmtpConf               :: Maybe SmtpConf
@@ -248,11 +250,11 @@ data AppSettings = AppSettings
 
     , appCommunicationAttachmentsMaxSize :: Maybe Natural
     , appCommunicationGlobalCC :: Maybe UserEmail
-    
+
     , appFileChunkingParams     :: FastCDCParameters
 
     , appLegalExternal          :: Set LegalExternal
-    
+
     } deriving Show
 
 
@@ -335,6 +337,21 @@ data AvsConf = AvsConf
   , avsCacheExpiry  :: DiffTime -- Seconds, only for non-licence related queries
   } deriving (Show)
 
+data AvsLicenceSynchConf = AvsLicenceSynchConf
+  { avsLicenceSynchTimes        :: [Natural]    -- hours, when a synch should occur
+  , avsLicenceSynchLevel        :: Int          -- 0: No synch, 1: revoke Vorfeld, 2: Grant Vorfeld, 3: Downgrade to Vorfeld, 4: Grant Rollfeld
+  , avsLicenceSynchReasonFilter :: Maybe Text   -- regular expression matched case-insensitive against latest block/grant reason, preventing automatic synch to users with this reason AND being associated with multiple companies
+  , avsLicenceSynchMaxChanges   :: Maybe Int    -- abort synch for group, if there are too many changes overall
+  } deriving (Show)
+
+instance Default AvsLicenceSynchConf where
+  def = AvsLicenceSynchConf
+        { avsLicenceSynchTimes        = []
+        , avsLicenceSynchLevel        = 0
+        , avsLicenceSynchReasonFilter = Nothing
+        , avsLicenceSynchMaxChanges   = Nothing
+        }
+
 data LprConf = LprConf
   { lprHost :: String
   , lprPort :: Int
@@ -423,11 +440,11 @@ data SettingBotMitigation
   deriving anyclass (Universe, Finite)
 
 data LegalExternal = LegalExternal
-  { externalLanguage :: Lang 
+  { externalLanguage :: Lang
   , externalImprint :: Text
   , externalDataProtection :: Text
   , externalTermsOfUse :: Text
-  , externalPayments :: Text    
+  , externalPayments :: Text
   }
   deriving (Eq, Ord, Read, Show, Generic)
 makeLenses_ ''LegalExternal
@@ -523,7 +540,7 @@ instance FromJSON LmsConf where
     lmsUploadHeader       <- o .:  "upload-header"
     lmsUploadDelimiter    <- o .:? "upload-delimiter"
     lmsDownloadHeader     <- o .:  "download-header"
-    lmsDownloadDelimiter  <- o .:  "download-delimiter"    
+    lmsDownloadDelimiter  <- o .:  "download-delimiter"
     lmsDownloadCrLf       <- o .:  "download-cr-lf"
     lmsDeletionDays       <- o .:  "deletion-days"
     return LmsConf{..}
@@ -540,7 +557,17 @@ instance FromJSON AvsConf where
     avsCacheExpiry  <- o .: "cache-expiry"
     return AvsConf{..}
 
-makeLenses_ ''AvsConf    
+makeLenses_ ''AvsConf
+
+instance FromJSON AvsLicenceSynchConf where
+  parseJSON = withObject "AvsLicenceSynch" $ \o -> do
+    avsLicenceSynchTimes        <- o .:  "times"
+    avsLicenceSynchLevel        <- o .:  "level"
+    avsLicenceSynchReasonFilter <- o .:? "reason-filter"
+    avsLicenceSynchMaxChanges   <- o .:? "max-changes"
+    return AvsLicenceSynchConf{..}
+
+makeLenses_ ''AvsLicenceSynchConf
 
 instance FromJSON LprConf where
   parseJSON = withObject "LprConf" $ \o -> do
@@ -611,7 +638,7 @@ instance FromJSON ServerSessionSettings where
       , ServerSession.setPersistentCookies <$> persistentCookies
       ])
 
-instance FromJSON LegalExternal where 
+instance FromJSON LegalExternal where
   parseJSON = withObject "LegalExternal" $ \o -> do
     externalLanguage <- o .: "language"
     externalImprint <- o .: "imprint"
@@ -640,6 +667,7 @@ instance FromJSON AppSettings where
         appLdapConf               <- P.fromList . mapMaybe (assertM nonEmptyHost) <$> o .:? "ldap" .!= []
         appLmsConf                <- o .: "lms-direct"
         appAvsConf                <- assertM (not . null . avsPass)  <$> o .:? "avs"
+        appAvsLicenceSynchConf    <- o .:? "avs-licence-synch" .!= def
         appLprConf                <- o .: "lpr"
         appSmtpConf               <- assertM (not . null . smtpHost) <$> o .:? "smtp"
         let validMemcachedConf MemcachedConf{memcachedConnectInfo = Memcached.ConnectInfo{..}} = and

src/Utils.hs

@@ -813,6 +813,19 @@ checkAsc :: Ord a => [a] -> Bool
 checkAsc (x:r@(y:_)) = x<=y && checkAsc r
 checkAsc _ = True
 
+-- return a part of a list between two given elements, if it exists
+listBracket :: Eq a => (a,a) -> [a] -> Maybe [a]
+listBracket _     []    = Nothing
+listBracket b@(s,e) (h:t)
+    | s == h    = listUntil  [] t
+    | otherwise = listBracket b t
+  where
+    listUntil _      [] = Nothing
+    listUntil l1 (h1:t1)
+      | e == h1   = Just $ reverse l1
+      | otherwise = listUntil (h1:l1) t1
+
+
 ----------
 -- Sets --
 ----------

src/Utils/Form.hs

@@ -320,6 +320,7 @@ data FormIdentifier
   | FIDAddSupervisor
   | FIDFirmUserChangeRequest
   | FIDFirmAction
+  | FIDUnreachableUsersAction
   deriving (Eq, Ord, Read, Show)
 
 instance PathPiece FormIdentifier where

src/Utils/Icon.hs

@@ -122,7 +122,7 @@ data Icon
   --  IconMagic           -- indicates automatic updates
   | IconReroute           -- for notification rerouting
   | IconTop               -- indicating highest number/quantity/priority for something
-
+  | IconWildcard
   deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic)
   deriving anyclass (Universe, Finite, NFData)
 
@@ -222,6 +222,7 @@ iconText = \case
     -- IconMagic                   -> "wand-magic"
     IconReroute                 -> "directions"
     IconTop                     -> "arrow-to-top"
+    IconWildcard                -> "asterisk"
 nullaryPathPiece ''Icon $ camelToPathPiece' 1
 deriveLift ''Icon
 
@@ -331,6 +332,10 @@ iconQualificationBlock :: Bool -> Markup
 iconQualificationBlock True   = icon IconCertificate
 iconQualificationBlock False  = icon IconBlocked
 
+iconWriteReadOnly :: Bool -> Markup
+iconWriteReadOnly True  = icon IconEdit
+iconWriteReadOnly False = icon IconVisible
+
 ----------------
 -- For documentation on how to avoid these unneccessary functions
 -- we implement them here just once for the first icon:

src/Utils/Lens.hs

@@ -316,6 +316,7 @@ makeLenses_ ''AuthorshipStatementDefinition
 makeLenses_ ''PrintJob
 
 makeLenses_ ''InterfaceLog
+makeLenses_ ''InterfaceHealth
 makeLenses_ ''AdminProblem
 makeLenses_ ''ProblemLog
 

src/Utils/Message.hs

@@ -228,3 +228,5 @@ messageTooltip Message{..} = let urgency = statusToUrgencyClass messageStatus
                                  tooltip = toWidget messageContent :: WidgetFor site ()
                                  isInlineTooltip = False
                              in $(whamletFile "templates/widgets/tooltip.hamlet")
+
+-- also see Handler.Utils.Widgets.mkErrorFlag for generic error icon tooltips

src/Utils/Pandoc.hs

@@ -17,13 +17,21 @@ import qualified Text.Pandoc as P
 
 
 markdownToHtml :: Html  -> Either P.PandocError Html
-markdownToHtml html = P.runPure $ P.writeHtml5 htmlWriterOptions =<< P.readMarkdown markdownReaderOptions (toStrict $ renderHtml html)
+markdownToHtml html  = P.runPure $ P.writeHtml5 htmlWriterOptions =<< P.readMarkdown markdownReaderOptions (toStrict $ renderHtml html)
 
-plaintextToHtml :: Text -> Html
+htmlToPlainText :: Html -> Either P.PandocError Text
-plaintextToHtml text = fromRight (toMarkup text) $ P.runPure $
+htmlToPlainText html = P.runPure $ P.writePlain htmlWriterOptions =<< P.readHtml     markdownReaderOptions (toStrict $ renderHtml html)
+
+plainTextToHtml :: Text -> Html
+plainTextToHtml text = fromRight (toMarkup text) $ P.runPure $
   P.writeHtml5 htmlWriterOptions =<< P.readMarkdown markdownReaderOptions text
   -- Line below does not work as intended, also see Handler.Utils.Pandoc.plaintextToMarkdownWith which uses this code
-  -- where pandoc = P.Pandoc mempty [P.Plain [P.Str text]] 
+  -- where pandoc = P.Pandoc mempty [P.Plain [P.Str text]]
+
+plainHtmlToHtml :: Text -> Html
+plainHtmlToHtml text = fromRight (toMarkup text) $ P.runPure $
+  P.writeHtml5 htmlWriterOptions =<< P.readHtml markdownReaderOptions text
+
 
 
 htmlReaderOptions, markdownReaderOptions :: P.ReaderOptions

templates/admin-problems.hamlet

@@ -1,6 +1,6 @@
 $newline never
 
-$# SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
+$# SPDX-FileCopyrightText: 2022-24 Steffen Jost <s.jost@fraport.de>
 $#
 $# SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -62,7 +62,9 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
       $else
         _{MsgInterfacesOk}
     ^{interfaceTable}
-
+    <p>
+      <a href=@{ConfigInterfacesR}>
+        _{MsgConfigInterfacesHeading}
 <section>
   <h2>
     _{MsgProblemsHeadingMisc}

templates/avs.hamlet

@@ -35,6 +35,9 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
   $maybe answer <- mbQryLic
     <p>
       ^{answer}  
+  $maybe autodiffs <- mbAutoDiffs
+    <p>
+      #{autodiffs}
 
 <section>
   <p> 

templates/i18n/avs-synchronisation/de-de-formal.hamlet

@@ -35,7 +35,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
   <p>
     ^{tb2}
   <h3>
-    Fahrbrechtigung Rollfeld ungültig in FRADrive, aber im AVS vorhanden
+    Fahrbrechtigung Rollfeld ungültig in FRADrive, aber im AVS vorhanden und Fahrberechtigung Vorfeld gültig in FRADrive
   <p>
     ^{tb1down}
   <h3>
@@ -43,7 +43,41 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
   <p>
     ^{tb1up}
   <h3>
-    Keine gültige Fahrberechtigung in FRADrive, aber im AVS vorhanden
+    Keine gültige Fahrberechtigung in FRADrive, aber im AVS vorhanden (Roll- oder Vorfeld)
   <p>
     ^{tb0}
-    
+    
+$if notNull avsLicenceSynchTimes
+  <section>
+    <h2>
+      Automatische AVS Fahrlizenzen Sychronisation
+    <p>
+      <dl .deflist>
+        <dt .deflist__dt>
+          Uhrzeiten Synchronisation
+        <dd .deflist__dd>
+          Werktags, wenige Minuten nach folgenden vollen Stunden: #{tshow avsLicenceSynchTimes}
+        <dt .deflist__dt>
+          Synchronisationslevel
+        <dd .deflist__dd>
+          <strong>#{avsLicenceSynchLevel}: #
+          $case avsLicenceSynchLevel
+            $of 1
+              Nur Vorfeld-Fahrberechtigungen entziehen
+            $of 2 
+              Vorfeld-Fahrberechtigungen entziehen und gewähren
+            $of 3
+              Vorfeld-Fahrberechtigungen entziehen und gewähren, #
+              so wie Rollfeld-Fahrberechtigungen zu Vorfeld-Fahrberechtigungen herabstufen
+            $of _
+              Vorfeld- und Rollfeld-Fahrberechtigungen entziehen und gewähren
+        $maybe reasons <- avsLicenceSynchReasonFilter
+          <dt .deflist__dt>
+            Ausnahmen
+          <dd .deflist__dd>
+            Keine automatische Synchronisation, wenn die Begründung des letzten Un-/Blocks zu diesen regulären Ausdruck passt: #{reasons}
+        $maybe maxChange <- avsLicenceSynchMaxChanges
+          <dt .deflist__dt>
+            Maximal Änderungen
+          <dd .deflist__dd>
+            Keine Synchronisation eines Levels durchführen, welches mehr als #{maxChange} Änderungen hätte

templates/i18n/avs-synchronisation/en-eu.hamlet

@@ -35,7 +35,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
   <p>
     ^{tb2}
   <h3>
-    Maneuvering area driving licence 'R' invalid in FRADrive, but valid in AVS
+    Maneuvering area driving licence 'R' invalid in FRADrive, but valid in AVS and having a valid 'F' in FRADrive
   <p>
     ^{tb1down}
   <h3>
@@ -43,6 +43,40 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
   <p>
     ^{tb1up}
   <h3>
-    No valid driving licence in FRADrive, but having a driving licence in AVS
+    No valid driving licence in FRADrive, but having any driving licence in AVS (maneuvering or apron)
   <p>
     ^{tb0}
+
+$if notNull avsLicenceSynchTimes
+  <section>
+    <h2>
+      Automatic AVS licence sychronisation
+    <p>
+      <dl .deflist>
+        <dt .deflist__dt>
+          Synchronisation times
+        <dd .deflist__dd>
+          Synchronize on weekdays, few minutes after each full hour: #{tshow avsLicenceSynchTimes}
+        <dt .deflist__dt>
+          Synchronisation level
+        <dd .deflist__dd>
+          <strong>#{avsLicenceSynchLevel}: #
+          $case avsLicenceSynchLevel
+            $of 1
+              Revoke apron driving licences only
+            $of 2 
+              Grant and revoke apron driving licences only
+            $of 3
+              Grant and revoke apron driving licences and downgrade maneuvering area licences to apron driving licences
+            $of _
+              Grant and revoke all driving licences automatically
+        $maybe reasons <- avsLicenceSynchReasonFilter
+          <dt .deflist__dt>
+            Exemptions
+          <dd .deflist__dd>
+            Do not synchronize changes where the last un-/block reason matches #{reasons}
+        $maybe maxChange <- avsLicenceSynchMaxChanges
+          <dt .deflist__dt>
+            Max changes
+          <dd .deflist__dd>
+            Do not synchronize a licence level if the number of changes exceeds #{maxChange}

templates/i18n/config-interfaces/de-de-formal.hamlet

@@ -0,0 +1,42 @@
+$newline never
+
+$# SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
+$#
+$# SPDX-License-Identifier: AGPL-3.0-or-later
+
+<section>
+  <h2>
+    _{MsgConfigInterfacesHeading}
+  <div>
+    <p>
+      Eine Schnittstelle gilt als fehlgeschlagen, wenn die letzte Transaktion dieser Schnittstelle ein konkreten Fehler lieferte, #
+      oder wenn seit einer gewissen Zugriffsfrist kein erneuter Erfolg für diese Schnittstelle registriert wurde. #
+    <p>
+      Diese Zeitspanne beträgt normalerweise: #{defWarnTime} #
+    <p>
+      Mit der nachfolgend gezeigten Tabelle kann diese Zugriffsfrist zwischen letztem Erfolg und dem Anzeigen eines Fehlers aufgrund #
+      des Ausbleibens eines erneuten Erfolges für einzelne Schnittstellen geändert werden. #
+      Einträge mit unspezifiertem _{MsgInterfaceSubtype} und/oder _{MsgInterfaceWrite} betreffen alle drauf passenden Schnittstellen, #
+      sofern es keine anderen passenden, besser spezifizierten Einträge gibt. #
+    <p>
+      Die Zeitspanne ist hier immer in Stunden anzugeben. #
+      Eine negative Stundenzahl deaktiviert den Warnungsmechanismus für ausbleibende wiederholte Erfolge; #
+      in diesem Fall werden für die Schnittstelle nur tatsächliche Fehlschläge als Fehler gemeldet. #
+      Eine negative Zeitspanne von -100 oder weniger deaktiviert alle Warnungen für diese Schnittstelle.
+    <p>
+      ^{configTable}
+
+<section>
+  <h2>
+    _{MsgMenuInterfaces}  
+  <div>
+    <p>
+      Current interface health is shown here for reference
+    <p> 
+      $if interfacesBadNr > 0
+        _{MsgInterfacesFail interfacesBadNr}
+      $else
+        _{MsgInterfacesOk}
+    ^{interfaceTable}
+
+

templates/i18n/config-interfaces/en-eu.hamlet

@@ -0,0 +1,38 @@
+$newline never
+
+$# SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
+$#
+$# SPDX-License-Identifier: AGPL-3.0-or-later
+
+<section>
+  <h2>
+    _{MsgConfigInterfacesHeading}
+  <div>
+    <p>
+      An interface is flagged as failed, if an error is reported or if no new success had been reported within 
+      its maximum usage period, usually #{defWarnTime} #
+    <p>
+      The following table allows to change the time span between the last success and before an error is raised. #
+      A time value having _{MsgInterfaceSubtype} and/or _{MsgInterfaceWrite} left unspecified affects all matching interfeaces, #
+      unless another more specified matching row exists for a particular interface. #
+    <p>
+      The time span is configure by a number of hours. #
+      A negative hour value disables the raising of an error by time entirely; in this case, an error is only raised if the last interface transaction reported failure. #
+      A negative value of less than -100 disables all warnings for this interface.
+    <p>
+      ^{configTable}
+
+<section>
+  <h2>
+    _{MsgMenuInterfaces}  
+  <div>
+    <p>
+      Current interface health is shown here for reference
+    <p> 
+      $if interfacesBadNr > 0
+        _{MsgInterfacesFail interfacesBadNr}
+      $else
+        _{MsgInterfacesOk}
+    ^{interfaceTable}
+
+

templates/i18n/firm-supervisors/de-de-formal.hamlet

@@ -5,10 +5,15 @@ $#
 $# SPDX-License-Identifier: AGPL-3.0-or-later
 
 <section>
-  Bitte beachten, dass Ansprechpartner-Beziehung unabhängig von Firmenzugehörigkeit zwischen Einzelpersonen bestehen.
+  <p>
-  Daraus folgt zum Beispiel, dass wenn <em>x</em> ein Standard-Ansprechpartner für Firma <em>a</em> ist 
+    Bitte beachten: Ansprechpartner-Beziehung bestehen unabhängig von Firmenzugehörigkeit zwischen Einzelpersonen! #
-  und wenn <em>y</em> sowohl Firma <em>a</em> als auch <em>b</em> angehört, 
+  
-  dass dann <em>x</em> als firmenfremd in der Liste der Ansprechpartner von Firma <em>b</em> angezeigt wird.
+  <p>
+    Daraus folgt zum Beispiel, dass wenn <em>x</em> ein Standard-Ansprechpartner für Firma <em>a</em> ist #
+    und wenn <em>y</em> sowohl Firma <em>a</em> als auch <em>b</em> angehört, #
+    dass <em>x</em> als firmenfremd in der Liste der Ansprechpartner von Firma <em>b</em> angezeigt wird. #
+    Dies kann hier mit der Aktion "Firmenansprechpartner entfernen" nicht geändert werden, #
+    da die Ansprechpartnerbeziehung ja über eine andere Firma weiter existiert.
 
 ^{firmContactInfo}  
 

templates/i18n/firm-supervisors/en-eu.hamlet

@@ -5,9 +5,12 @@ $#
 $# SPDX-License-Identifier: AGPL-3.0-or-later
 
 <section>
-  Note that supervision is company independent. 
+  <p>
-  For example, if <em>x</em> is a regular supervisor for company <em>a</em> and <em>y</em> belongs to companies <em>a</em> and <em>b</em>, 
+    Note that supervisionship is company independent! #
-  then <em>x</em> will be listed as a foreign supervisor for company <em>b</em>.
+  <p>
+    For example, if <em>x</em> is a regular supervisor for company <em>a</em> and <em>y</em> belongs to companies <em>a</em> and <em>b</em>, #
+    then <em>x</em> will be listed as a foreign supervisor for company <em>b</em>. #
+    This cannot be changed through action "Remove default supervisor" here, since the external supervisionship persists.
 
 ^{firmContactInfo}
 

test/Database/Fill.hs

@@ -113,10 +113,10 @@ fillDb = do
     , userMobile = Nothing
     , userCompanyPersonalNumber = Just "00000"
     , userCompanyDepartment = Nothing
-    , userPinPassword = Nothing
+    , userPinPassword = Just "1234.5"
     , userPostAddress = Just $ markdownToStoredMarkup ("Büro 127   \nMathematisches Institut der Ludwig-Maximilians-Universität München   \nTheresienstr. 39   \nD-80333 München"::Text)
     , userPostLastUpdate = Nothing
-    , userPrefersPostal = True
+    , userPrefersPostal = False
     , userExamOfficeGetSynced = userDefaultExamOfficeGetSynced
     , userExamOfficeGetLabels = userDefaultExamOfficeGetLabels
     }
@@ -202,7 +202,7 @@ fillDb = do
     , userPinPassword = Nothing
     , userPostAddress = Nothing
     , userPostLastUpdate = Nothing
-    , userPrefersPostal = True
+    , userPrefersPostal = False
     , userExamOfficeGetSynced = userDefaultExamOfficeGetSynced
     , userExamOfficeGetLabels = userDefaultExamOfficeGetLabels
     }
@@ -655,14 +655,14 @@ fillDb = do
                           , let rcName  = CI.mk $ "Random Corp " <> tshow n <> bool "" " GmbH" (even n)
                           , let rcShort = CI.mk $ "RC" <> tshow n
                           ]
-  void . insert' $ UserCompany jost    fraportAg    True   True  0 False $ Just "Vorgesetzter"
+  void . insert' $ UserCompany jost    fraportAg    True   True  0 False $ Just $ tshow SupervisorReasonAvsSuperior
-  void . insert' $ UserCompany svaupel nice         True   False 2 False $ Just "Vorgesetzter"
+  void . insert' $ UserCompany svaupel nice         True   False 2 False $ Just $ tshow SupervisorReasonAvsSuperior
   void . insert' $ UserCompany svaupel ffacil       False  False 1 False $ Just "Irgendwas"
   void . insert' $ UserCompany svaupel bpol         True   False 2 False $ Just "Irgendwas"
   void . insert' $ UserCompany svaupel fraGround    True   False 1 False $ Just "Irgendwas"
   void . insert' $ UserCompany gkleen  nice         False  False 1 True  $ Just "Winterdienst"
   void . insert' $ UserCompany gkleen  fraGround    False  True  2 False $ Just "Irgendwas"
-  void . insert' $ UserCompany gkleen  bpol         False  True  1 False $ Just "Irgendwas"
+  void . insert' $ UserCompany gkleen  bpol         False  True  1 False $ Just $ tshow SupervisorReasonAvsSuperior
   void . insert' $ UserCompany fhamann bpol         False  False 1 True  $ Just "Irgendwas"
   void . insert' $ UserCompany fhamann ffacil       True   True  2 True  $ Just "Irgendwas"
   void . insert' $ UserCompany fhamann nice         False  False 3 False $ Just "Winterdienst"
@@ -687,14 +687,14 @@ fillDb = do
   -- void . insert' $ UserSupervisor svaupel gkleen    False
   -- void . insert' $ UserSupervisor svaupel fhamann   True
   -- void . insert' $ UserSupervisor sbarth tinaTester True
-  let supvs = [ UserSupervisor jost gkleen            True  (Just fraportAg)  (Just "Staff")
+  let supvs = [ UserSupervisor jost gkleen            True  (Just fraportAg)  (Just $ tshow SupervisorReasonAvsSuperior)
-              , UserSupervisor jost svaupel           False (Just fraportAg)  (Just "Staff")
+              , UserSupervisor jost svaupel           False (Just fraportAg)  (Just $ tshow SupervisorReasonAvsSuperior)
               , UserSupervisor jost sbarth            False (Just fraportAg)  (Just "Staff")
               , UserSupervisor jost tinaTester        True  (Just fraportAg)  (Just "Staff")
               , UserSupervisor jost jost              True  (Just fraportAg)  (Just "Staff")
               , UserSupervisor svaupel gkleen         False (Just nice)       (Just "Staff")
               , UserSupervisor svaupel fhamann        True  (Just nice)       (Just "Staff")
-              , UserSupervisor sbarth tinaTester      True  (Just nice)       (Just "Staff")
+              , UserSupervisor sbarth tinaTester      True  (Just nice)       (Just $ tshow SupervisorReasonAvsSuperior)
               , UserSupervisor gkleen fhamann         False (Just fraGround)  (Just "Staff")
               , UserSupervisor gkleen gkleen          True  (Just fraGround)  (Just "Staff")
               , UserSupervisor tinaTester tinaTester  False Nothing           (Just "Staff")
@@ -766,7 +766,7 @@ fillDb = do
   void . insert' $ QualificationUser jost       qid_r  (n_day   99) (n_day $  -11) (n_day $  -222) True (n_day' $ -9) -- TODO: better dates!
   void . insert' $ QualificationUser jost       qid_l  (n_day  999) (n_day $ -111) (n_day $ -2222) True (n_day' $ -9) -- TODO: better dates!
   void . insert' $ QualificationUser jost       qid_rp (n_day  999) (n_day $ -111) (n_day $ -2222) True (n_day' $ -9) -- TODO: better dates!
-  qfkleen <- insert' $ QualificationUser gkleen qid_f  (n_day 33) (n_day $ -4) (n_day $ -20) True  (n_day' $ -9)
+  qfkleen <- insert' $ QualificationUser gkleen qid_f  (n_day 10) (n_day $ -40) (n_day $ -120) True  (n_day' $ -20)
   void . insert  $ QualificationUserBlock qfkleen False (n_day' 1) "Future block"   (Just svaupel)
   void . insert' $ QualificationUser maxMuster  qid_f (n_day    0) (n_day $ -2) (n_day $  -8) False (n_day' $ -1)
   qfvaupel <- insert' $ QualificationUser svaupel    qid_f (n_day    2) (n_day $ -1) (n_day $  -2) True  (n_day' $ -9)