CHANGELOG.md

@@ -2,43 +2,6 @@
 
 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 && Object.keys(results).length > 0) rowInfo.results = results;
+    if (results && results !== {}) rowInfo.results = results;
     if (result !== undefined) rowInfo.result = result;
     this._addRow(rowInfo);
 

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

@@ -114,7 +114,6 @@ 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
@@ -122,20 +121,19 @@ 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 Vorgesetzter.
+AdminProblemCompanySuperiorChange: Neuer firmenweiter Vorgesetzer.
-AdminProblemCompanySuperiorNotFound t@Text: Neuer unbekannter firmenweiter Vorgesetzter mit E-Mail #{t}, keine Ansprechpartnerbeziehungen eingerichtet.
+AdminProblemCompanySuperiorPrevious: Ehemaliger Vorgesetzer: 
-AdminProblemCompanySuperiorPrevious: Ehemaliger Vorgesetzter: 
 AdminProblemNewlyUnsupervised: Fahrer hat keinen Firmenansprechpartner mehr nach AVS Firmenwechsel zu Firma 
 AdminProblemUser: Betroffener
 ProblemTableMarkSolved: Als erledigt markieren
@@ -150,13 +148,4 @@ InterfaceSubtype: Betreffend
 InterfaceWrite: Schreibend
 InterfaceSuccess: Rückmeldung
 InterfaceInfo: Nachricht
-InterfaceFreshness: Maximale Zugriffsfrist
+InterfaceFreshness: Prüfungszeitraum (h)
-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,27 +114,25 @@ 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
@@ -150,13 +148,4 @@ InterfaceSubtype: Affecting
 InterfaceWrite: Write
 InterfaceSuccess: Returned
 InterfaceInfo: Message
-InterfaceFreshness: Maximum usage period
+InterfaceFreshness: Check hours
-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-24 Steffen Jost <s.jost@fraport.de>
+# SPDX-FileCopyrightText: 2023 Steffen Jost <s.jost@fraport.de>
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -15,15 +15,11 @@ 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: #{ndef} Standardansprechpartner entfernt. 
+RemoveSupervisors ndef@Int64 nact@Int64: #{ndef} Standard Ansprechpartner entfernt#{bool ", aber keine aktiven Ansprechpartnerbeziehungen wurden deaktiviert" (", " <> tshow nact <> " aktive Ansprechpartnerbeziehungen gelöscht") (nact > 0)}
 FirmActChangeContactUser: Kontaktinformationen von allen Firmenangehörigen ändern
 FirmActChangeContactFirm: Kontaktinformationen der Firma ändern
 FirmActChangeContactFirmInfo: Firmenkontaktinformationen werden nur für neue Firmenangehörige verwendet, für die sonst keine Kontaktinformationen vorliegen.
@@ -37,8 +33,7 @@ FirmUserActRemove: Firmenassoziation entfernen
 FirmUserActMkSuper: Zum Firmenansprechpartner ernennen
 FirmUserActChangeDetailsResult n@Int64 t@Int64: Firmenassoziation von #{n}/#{t} #{pluralDE n "Firmenangehörigen" "Firmenangehörige"} wurden aktualisiert
 FirmUserActChangeResult n@Int64 t@Int64: Benachrichtigungseinstellung für #{n}/#{t} #{pluralDE n "Firmenangehörigen" "Firmenangehörige"} wurden geändert
-FirmUserActRemoveResult uc@Int64: #{uc} #{pluralDE uc "Firmenassoziation" "Firmenassoziationen"} entfernt. 
+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.")}
-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)}
@@ -47,7 +42,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: Aktive Ansprechpartnerbeziehungen innerhalb dieser Firma beenden?
+FirmSuperActRMSuperActive: Auch aktive Ansprechpartnerbeziehungen innerhalb dieser Firma beenden
 FirmsNotification: Firmen E-Mail versenden
 FirmNotification fsh@CompanyShorthand: E-Mail an #{fsh} senden
 FirmsNotificationTitle: Firmen benachrichtigen
@@ -56,9 +51,7 @@ 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
@@ -66,7 +59,6 @@ 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-24 Steffen Jost <s.jost@fraport.de>
+# SPDX-FileCopyrightText: 2023 Steffen Jost <s.jost@fraport.de>
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -15,15 +15,11 @@ 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: #{ndef} default supervisors removed.
+RemoveSupervisors ndef nact: #{ndef} default supervisors removed#{bool ", but no active supervisions were deactivated" (" and " <> tshow nact <> " active supervisions terminated") (nact > 0)}
 FirmActChangeContactUser: Change contact data for all company associates
 FirmActChangeContactFirm: Change company contact data
 FirmActChangeContactFirmInfo: The company contact data is only used for new company associates that would habe no contact information of their own otherwise.
@@ -37,8 +33,7 @@ FirmUserActRemove: Delete company association
 FirmUserActMkSuper: Mark as company supervisor
 FirmUserActChangeDetailsResult n t: #{n}/#{t} #{pluralENs n "company association"} updated
 FirmUserActChangeResult n t: Notification settings changed for #{n}/#{t} company #{pluralENs n "associate"}
-FirmUserActRemoveResult uc: #{pluralENsN uc "Company association"} deleted. 
+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.")}
-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)}
@@ -47,7 +42,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: Terminate active supervisions within this company?
+FirmSuperActRMSuperActive: Also remove active supervisions within this company
 FirmsNotification: Send company notification e-mail
 FirmNotification fsh: Send e-mail to #{fsh}
 FirmsNotificationTitle: Company notification
@@ -56,9 +51,7 @@ 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}
@@ -66,7 +59,6 @@ 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} von #{n} #{pluralDE m "übergeordneter" "übergeordnete"} Ansprechpartner mit Benachrichtigungsumleitung#{noneMoreDE l "" (", davon " <> tshow l <> " mit postalischer Benachrichtigung")}
+ProfileSupervisorRemark n@Int m@Int l@Int: #{m}/#{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} of #{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}/#{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,7 +22,6 @@ 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
@@ -38,10 +37,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, die Ausführung wird mehrere Minuten benötigen!
+SynchroniseAvsUserQueued n@Int: AVS-Synchronisation von #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} zwingend angestoßen
-SynchroniseAvsAllUsersQueued n@Int64: AVS-Synchronisation von allen #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} angestoßen, welche heute noch nicht synchronisiert wurden, die Ausführung wird eine Weile brauchen!
+SynchroniseAvsAllUsersQueued n@Int64: AVS-Synchronisation von allen #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} angestoßen, welche heute noch nicht synchronisiert wurden
-SynchroniseLdapUserQueued n@Int: LDAP-Synchronisation von #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} angestoßen, die Ausführung wird mehrere Minuten benötigen!
+SynchroniseLdapUserQueued n@Int: LDAP-Synchronisation von #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} angestoßen
-SynchroniseLdapAllUsersQueued: LDAP-Synchronisation von allen Benutzer:innen angestoßen, die Ausführung kann eine Weile brauchen!
+SynchroniseLdapAllUsersQueued: LDAP-Synchronisation von allen Benutzer:innen angestoßen
 UserListTitle: Komprehensive Benutzerliste
 AccessRightsSaved: Berechtigungen erfolgreich verändert
 AccessRightsNotChanged: Berechtigungen wurden nicht verändert

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

@@ -22,7 +22,6 @@ 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
@@ -38,10 +37,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"}, which may take several minutes to complete.
+SynchroniseAvsUserQueued n: Triggered forced AVS synchronisation of #{n} #{pluralEN n "user" "users"}
-SynchroniseAvsAllUsersQueued n: Triggered AVS synchronisation of all #{n} #{pluralEN n "user" "users"} that were not already synchronised today, which may take quite a while to complete.
+SynchroniseAvsAllUsersQueued n: Triggered AVS synchronisation of all #{n} #{pluralEN n "user" "users"} that were not already synchronised today
-SynchroniseLdapUserQueued n: Triggered LDAP synchronisation of #{n} #{pluralEN n "user" "users"}, which may take several minutes to complete.
+SynchroniseLdapUserQueued n: Triggered LDAP synchronisation of #{n} #{pluralEN n "user" "users"}
-SynchroniseLdapAllUsersQueued: Triggered LDAP synchronisation of all users, which may take quite a while to complete.
+SynchroniseLdapAllUsersQueued: Triggered LDAP synchronisation of all users
 UserListTitle: Comprehensive list of users
 AccessRightsSaved: Successfully updated permissions
 AccessRightsNotChanged: Permissions left unchanged

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

@@ -12,7 +12,6 @@ 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,7 +12,6 @@ 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,7 +153,6 @@ 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,7 +153,6 @@ 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,7 +79,6 @@ 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,7 +79,6 @@ 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,7 +83,6 @@ 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,7 +83,6 @@ 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=true    -- new company users prefers letters by post instead of email
+  prefersPostal   Bool    default=false   -- 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.79"
+  "version": "27.4.76"
 }

package-lock.json

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

package.json

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

package.yaml

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

routes

@@ -71,18 +71,16 @@
 /admin/avs/#CryptoUUIDUser    AdminAvsUserR    GET POST
 /admin/ldap                   AdminLdapR       GET POST
 /admin/problems               AdminProblemsR			 GET POST 
-/admin/problems/no-contact    ProblemUnreachableR  GET POST
+/admin/problems/no-contact    ProblemUnreachableR  GET
 /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,9 +1,7 @@
--- SPDX-FileCopyrightText: 2023-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
+-- SPDX-FileCopyrightText: 2023 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
-{-# LANGUAGE TypeApplications #-}
-
 module Audit
   ( module Audit.Types
   , AuditException(..)
@@ -19,8 +17,6 @@ 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
@@ -133,7 +129,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
 
@@ -177,25 +173,20 @@ 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, provided this problem has not already been reported and is still unsolved
+-- ^ Log a problem that needs interventions by admins 
 --
 --   - `problemLogTime` is now
 --   - `problemSolver` is Nothing, we do not record the person who caused it
-reportAdminProblem problem = do
+reportAdminProblem problem@(toJSON -> problemLogInfo) = do
+  problemLogTime <- liftIO getCurrentTime
   let problemLogSolved = Nothing
       problemLogSolver = Nothing
-      problemLogInfo   = toJSON problem
+  insert_ ProblemLog{..}
-  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,11 +282,6 @@ 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 [UserId <=. UserKey 12] [Asc UserIdent] :: ReaderT SqlBackend _ [Option UserIdent])
+    userList = fmap mkOptionList . runDB $ withReaderT projectBackend (map toOption <$> selectList [] [Asc UserIdent] :: ReaderT SqlBackend _ [Option UserIdent])
     toOption (Entity _ User{..}) = Option userDisplayName userIdent (CI.original userIdent)
 
 apDummy :: Text

src/Database/Esqueleto/Utils.hs

@@ -15,7 +15,6 @@ module Database.Esqueleto.Utils
   , (=?.), (?=.)
   , (=~.), (~=.)
   , (>~.), (<~.)
-  , (~.), (~*.), (!~.), (!~*.)
   , or, and
   , any, all
   , not__, parens
@@ -27,7 +26,6 @@ module Database.Esqueleto.Utils
   , mkContainsFilterWithSet, mkContainsFilterWithComma, mkContainsFilterWithCommaPlus
   , mkDayFilter, mkDayFilterFrom, mkDayFilterTo
   , mkExistsFilter, mkExistsFilterWithComma
-  --  , mkRegExFilterWith
   , anyFilter, allFilter
   , ascNullsFirst, descNullsLast
   , orderByList
@@ -55,7 +53,6 @@ module Database.Esqueleto.Utils
   , day, day', dayMaybe, interval, diffDays, diffTimes
   , exprLift
   , explicitUnsafeCoerceSqlExprValue
-  , psqlVersion_
   , truncateTable
   , module Database.Esqueleto.Utils.TH
   ) where
@@ -166,24 +163,6 @@ 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)
@@ -436,18 +415,6 @@ 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
@@ -689,7 +656,6 @@ 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
 
@@ -815,8 +781,6 @@ 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,7 +122,6 @@ 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
@@ -134,7 +133,6 @@ 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
@@ -2535,20 +2533,6 @@ 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, DBRead, Form, MsgRenderer, MailM, DBFile
+  , DB, Form, MsgRenderer, MailM, DBFile
   ) where
 
 import Import.NoFoundation
@@ -123,9 +123,8 @@ 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,9 +9,8 @@ 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
@@ -24,13 +23,11 @@ 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
@@ -89,14 +86,14 @@ handleAdminProblems mbProblemTable = do
       <*> allRDriversHaveFs now
       <*> (not <$> exists [PrintJobAcknowledged ==. Nothing, PrintJobCreated  <. cutOffOldTime])
       <*> (not <$> exists [PrintAcknowledgeProcessed ==. False])
-      <*> mkInterfaceLogTable mempty
+      <*> mkInterfaceLogTable flagError mempty
   let interfacesBadNr = length $ filter (not . snd) interfaceOks
       -- interfacesOk = all snd interfaceOks
 
   diffLics <- try retrieveDifferingLicences >>= \case
     -- (Left (UnsupportedContentType "text/html" resp)) -> Left $ text2widget "Html received"
     (Left e) -> return $ Left $ text2widget $ tshow (e :: SomeException)
-    (Right (AvsLicenceDifferences{..},_)) -> do
+    (Right AvsLicenceDifferences{..}) -> do
       let problemIds = avsLicenceDiffRevokeAll <> avsLicenceDiffGrantVorfeld <> avsLicenceDiffRevokeRollfeld <> avsLicenceDiffGrantRollfeld
       void $ runDB $ queueAvsUpdateByAID problemIds $ Just nowaday
       return $ Right
@@ -107,7 +104,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 . fst <$> retrieveDifferingLicences) `catches`
+  -- diffLics <- (procDiffLics <$> 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)
@@ -142,34 +139,12 @@ postAdminProblemsR = do
       addMessageI mkind $ msg oks
       when (oks > 0) $ reloadKeepGetParams AdminProblemsR -- reload to update all tables
 
-getProblemUnreachableR,  postProblemUnreachableR :: Handler Html
+getProblemUnreachableR :: Handler Html
-getProblemUnreachableR = postProblemUnreachableR
+getProblemUnreachableR = do
-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>
@@ -341,13 +316,7 @@ resultUser :: Traversal' ProblemLogTableData (Entity User)
 resultUser = _dbrOutput . _3 . _Just
 
 mkProblemLogTable :: DB (FormResult (ProblemTableActionData, Set ProblemLogId), Widget)
-mkProblemLogTable = do
+mkProblemLogTable = over _1 postprocess <$> dbTable validator DBTable{..}
-    -- 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
@@ -357,7 +326,7 @@ mkProblemLogTable = do
                     EL.on (solver E.?. UserId E.==. problem E.^. ProblemLogSolver)
                     return (problem, solver, usr)
     dbtRowKey = queryProblem >>> (E.^. ProblemLogId)
-    dbtProj = dbtProjFilteredPostId
+    dbtProj = dbtProjId
     dbtColonnade = formColonnade $ mconcat
       [ dbSelect (applying _2) id $ return . view (resultProblem . _entityKey)
       , sortable (Just "time")    (i18nCell MsgAdminProblemCreated) $ \(   view $ resultProblem . _entityVal . _problemLogTime   -> t) ->           dateTimeCell t
@@ -380,20 +349,14 @@ mkProblemLogTable = do
     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)
+      , prismAForm (singletonFilter "problem" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)                        (fslI MsgAdminProblemInfo   & setTooltip MsgAdminProblemInfoTooltip)
       , 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,128 +266,33 @@ postAdminAvsR = do
 
 
   (qryLicForm, qryLicRes) <- runButtonForm FIDAvsQueryLicenceDiffs
-  (mbQryLic :: Maybe Widget, mbAutoDiffs :: Maybe Html) <- case qryLicRes of
+  mbQryLic <- case qryLicRes of
-    Nothing -> return mempty
+    Nothing -> return Nothing
     (Just BtnCheckLicences) -> do
       res <- try $ do
         allLicences <- avsQueryNoCache AvsQueryGetAllLicences
         computeDifferingLicences allLicences
-      basediffs <- case res of
+      case res of
         (Right diffs) -> do
-          let showLics l =
+          let showLics l = Text.intercalate ", " $ fmap (tshow . avsLicencePersonID) $ Set.toList $ Set.filter ((l ==) . avsLicenceRampLicence) diffs
-                let chgs = Set.filter ((l ==) . avsLicenceRampLicence) diffs
+              r_grant = showLics AvsLicenceRollfeld
-                in if Set.null chgs
+              f_set   = showLics AvsLicenceVorfeld
-                    then ("[ ]", 0)
+              revoke  = showLics AvsNoLicence
-                    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 AVS-ID differences:
+              <h2>Licence check differences:
-              <dl .deflist>
+              <h3>Grant R:
-                <dt .deflist__dt>Grant R (#{rg_size}):
+              <p>
-                <dd .deflist__dd>#{r_grant}
+                #{r_grant}
-
+              <h3>Set to F:
-                <dt .deflist__dt>Set to F (#{fs_size}):
+              <p>
-                <dd .deflist__dd>#{f_set}
+                #{f_set}
-
+              <h3>Revoke licence:
-                <dt .deflist__dt>Revoke licence (#{rv_size}):
+              <p>
-                <dd .deflist__dd>#{revoke}
+                #{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
@@ -473,8 +378,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{..}, rsChanged), apidStatus) <- catchAllAvs' AdminR retrieveDifferingLicencesStatus
+  (AvsLicenceDifferences{..}, apidStatus) <- catchAllAvs' AdminR retrieveDifferingLicencesStatus
-  let mkLicTbl = mkLicenceTable apidStatus rsChanged
+
   --
   unknownLicenceOwners' <- whenNonEmpty avsLicenceDiffRevokeAll $ \neZeros ->
     runDB $ E.select $ do
@@ -529,10 +434,10 @@ getProblemAvsSynchR = do
 
   -- licence differences
   ((tres0,tb0),(tres1up,tb1up),(tres1down,tb1down),(tres2,tb2)) <- runDB $ (,,,)
-          <$> mkLicTbl "avsLicDiffRevokeVorfeld"  AvsLicenceVorfeld   avsLicenceDiffRevokeAll
+          <$> mkLicenceTable apidStatus "avsLicDiffRevokeVorfeld"  AvsLicenceVorfeld   avsLicenceDiffRevokeAll
-          <*> mkLicTbl "avsLicDiffGrantVorfeld"   AvsNoLicence        avsLicenceDiffGrantVorfeld
+          <*> mkLicenceTable apidStatus "avsLicDiffGrantVorfeld"   AvsNoLicence        avsLicenceDiffGrantVorfeld
-          <*> mkLicTbl "avsLicDiffRevokeRollfeld" AvsLicenceRollfeld  avsLicenceDiffRevokeRollfeld -- downgrade to Vorfeld
+          <*> mkLicenceTable apidStatus "avsLicDiffRevokeRollfeld" AvsLicenceRollfeld  avsLicenceDiffRevokeRollfeld
-          <*> mkLicTbl "avsLicDiffGrantRollfeld"  AvsNoLicence        avsLicenceDiffGrantRollfeld
+          <*> mkLicenceTable apidStatus "avsLicDiffGrantRollfeld"  AvsNoLicence        avsLicenceDiffGrantRollfeld
 
   now <- liftIO getCurrentTime
   let procRes :: AvsLicence -> (LicenceTableActionData, Set AvsPersonId) -> Handler ()
@@ -571,7 +476,6 @@ getProblemAvsSynchR = do
   formResult tres1up    $ procRes AvsLicenceVorfeld
   formResult tres0      $ procRes AvsNoLicence
 
-  AvsLicenceSynchConf{..} <- getsYesod $ view _appAvsLicenceSynchConf
   siteLayoutMsg MsgAvsTitleLicenceSynch $ do
     setTitleI   MsgAvsTitleLicenceSynch
     $(i18nWidgetFile "avs-synchronisation")
@@ -624,11 +528,9 @@ instance HasUser LicenceTableData where
 -- instance HasQualificationUser LicenceTableData where -- Not possible, since not all rows have a QualificationUser
 --   hasQualificationUser = resultQualUser . _entityVal
 
-mkLicenceTable :: AvsPersonIdMapPersonCard -> Set AvsPersonId -> Text -> AvsLicence -> Set AvsPersonId -> DB (FormResult (LicenceTableActionData, Set AvsPersonId), Widget)
+mkLicenceTable :: AvsPersonIdMapPersonCard -> Text -> AvsLicence -> Set AvsPersonId -> DB (FormResult (LicenceTableActionData, Set AvsPersonId), Widget)
-mkLicenceTable apidStatus rsChanged dbtIdent aLic apids = do
+mkLicenceTable apidStatus dbtIdent aLic apids = do
-  (currentRoute, usrHasAvsRerr) <- liftHandler $ (,)
+  currentRoute <- fromMaybe (error "mkLicenceTable called from 404-handler") <$> liftHandler getCurrentRoute
-    <$> (fromMaybe (error "mkLicenceTable called from 404-handler") <$> liftHandler getCurrentRoute)
-    <*> (messageTooltip <$> messageI Error MsgProblemAvsUsrHadR)
   avsQualifications <- selectList [QualificationAvsLicence !=. Nothing] [Asc QualificationName]
   now <- liftIO getCurrentTime
 
@@ -669,18 +571,7 @@ mkLicenceTable apidStatus rsChanged 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) $
+        , sortable (Just "qualification") (i18nCell MsgTableQualifications)          $ \(preview   resultQualification -> q) -> cellMaybe lmsShortCell q
-            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,9 +28,7 @@ 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
@@ -228,9 +226,6 @@ 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
@@ -332,17 +327,6 @@ 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 MsgFirmSuperDefault & setTooltip MsgCourseParticipantsRegisterUsersFieldTip)  Nothing
+                  <$> areq (textField & cfAnySeparatedSet)  (fslI MsgTableIsDefaultSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip)  Nothing
                   <*> areq checkBoxField                    (fslI MsgTableIsDefaultReroute)                                                             (Just True)
                   <*> aopt postalEmailField                 (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip)                                Nothing
                   <*> aopt (textField & cfStrip & addDatalist ucdefSuperReasons)
@@ -666,8 +666,6 @@ 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
@@ -677,8 +675,7 @@ 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 & setTooltip MsgFilterFirmExternTooltip)
+          , prismAForm (singletonFilter "company-postal"     . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterFirmExtern)
-          , prismAForm (singletonFilter "company-address")                            mPrev $ aopt textField (fslI MsgFirmAddress)
           , fltrQualificationHdrUI MsgFilterHasQualification mPrev
           ]
         dbtStyle =  def { dbsFilterLayout = defaultDBSFilterLayout }
@@ -742,28 +739,29 @@ embedRenderMessage ''UniWorX ''FirmUserAction id
 
 data FirmUserActionData = FirmUserActNotifyData
                         | FirmUserActResetSupervisionData
-                            { firmUserActResetSupers            :: Maybe Bool
+                            { firmUserActResetKeepOldSupers     :: 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
-                            , firmUserActResetSupers            :: Maybe Bool
+                            ,  firmUserActSetSuperKeep    :: 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
-                            { firmUserActRemoveSupers           :: Bool
+                            { firmUserActRemoveKeepSuper :: Bool
                             }
   deriving (Eq, Ord, Show, Generic)
 
@@ -803,27 +801,24 @@ mkFirmUserTable :: Bool -> CompanyId -> DB (FormResult (FirmUserActionData, Set
 mkFirmUserTable isAdmin cid = do
   mr <- getMessageRender
   let
-    reasonSuperior = Just $ tshow SupervisorReasonAvsSuperior
+    mkSprOption (E.Value uid, E.Value udn, E.Value mbSpr) = do
-    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, mbmbReason == Just reasonSuperior)
+      return (Option{ optionDisplay = udn, optionInternalValue = uid, optionExternalValue = uuid }, mbSpr)
 
     procOptions rawSupers = do
       procSupers <- traverse mkSprOption rawSupers
       return $ mkOptionListGrouped $ filter (notNull . snd)
-             [ (mr MsgTableSuperior     , [opt | (opt, _         , True ) <- procSupers])
+             [ (mr MsgFirmSuperDefault  , [opt | (opt, Just True ) <- procSupers])
-             , (mr MsgFirmSuperDefault  , [opt | (opt, Just True , False) <- procSupers])
+             , (mr MsgFirmSuperIrregular, [opt | (opt, Just False) <- procSupers])
-             , (mr MsgFirmSuperIrregular, [opt | (opt, Just False, False) <- procSupers])
+             , (mr MsgFirmSuperForeign  , [opt | (opt, Nothing   ) <- 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, usrCmp E.?. UserCompanyReason)
+    return (usr E.^. UserId, usr E.^. UserDisplayName, usrCmp E.?. UserCompanySupervisor)
   let
     -- supervisorField :: Field Handler UserId
     -- supervisorField  =      selectField' (Just $ SomeMessage MsgMultiNoSelection) $ procOptions rawSupers
@@ -967,24 +962,25 @@ mkFirmUserTable isAdmin cid = do
         acts = mconcat
           [ guardMonoid isAdmin $ singletonMap FirmUserActNotify $ pure FirmUserActNotifyData
           , singletonMap FirmUserActResetSupervision $ FirmUserActResetSupervisionData
-              <$> aopt (boolFieldCustom (SomeMessage MsgFirmActResetSupersRemoveAll) (SomeMessage MsgFirmActResetSupersRemoveAps) $ Just $ SomeMessage MsgFirmActResetSupersKeepAll) (fslI MsgFirmActResetSuperKeep) (Just $ Just False)
+              <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (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'                                        (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip)        (Just False)
+              <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip)        (Just False)
-              <*> aopt (boolFieldCustom (SomeMessage MsgFirmActResetSupersRemoveAll) (SomeMessage MsgFirmActResetSupersRemoveAps) $ Just $ SomeMessage MsgFirmActResetSupersKeepAll) (fslI MsgFirmActResetSuperKeep) (Just $ Just False)
+              <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep)                                                     (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'       (fslI MsgFirmActRemoveSupers) (Just True)
+              <$> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep)                                                     (Just False)
           ]
         dbtParams = DBParamsForm
           { dbParamsFormMethod = POST
@@ -1051,10 +1047,6 @@ 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
@@ -1062,7 +1054,9 @@ 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 <- resetSupers firmUserActResetSupers uids
+        delSupers <- if firmUserActResetKeepOldSupers == Just False
+          then deleteDefaultSupervisorsForUsers [] [] uids
+          else return 0
         newSupers <- addDefaultSupervisors Nothing cid uids
         addMessageI Info $ MsgFirmResetSupervision delSupers newSupers
       reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
@@ -1081,7 +1075,8 @@ postFirmUsersR fsh = do
                   <li>#{usr}
               |]
         in addMessageModal Error (i18n . MsgCourseParticipantsRegisterNotFoundInAvs $ length usersNotFound) (Right msgContent)
-      delSupers <- runDB $ resetSupers firmUserActResetSupers uids
+      delSupers <- runDB
+         $ 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
@@ -1118,15 +1113,11 @@ 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
-      let optRemove = if firmUserActRemoveSupers then id else const $ return 0
+      (nrUc, nrSuper, nrSubs) <- runDB $ deleteCompanyUser cid uids
-      (nrUc, nrSuper, nrSubs) <- runDB $ (,,)
-        <$> deleteWhereCount [UserCompanyCompany ==. cid, UserCompanyUser <-. uids]
-        <*> optRemove (deleteWhereCount [UserSupervisorCompany ==. Just cid, UserSupervisorSupervisor <-. uids])
-        <*> optRemove (deleteWhereCount [UserSupervisorCompany ==. Just cid, UserSupervisorUser       <-. uids])
       let total = fromIntegral $ length uids
-          allok = bool Warning Success $ total == nrUc
+          allok = bool Warning Success $ nrUc == total
-      addMessageI allok $ someMessages [MsgFirmUserActRemoveResult nrUc, MsgFirmRemoveSupervision nrSuper nrSubs]
+      addMessageI allok $ MsgFirmuserActRemoveResult nrUc nrSuper nrSubs
       reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
 
   formFirmAction <- runFirmActionFormPost cid (FirmUsersR fsh) isAdmin [FirmActNotify, FirmActResetSupervision, FirmActAddSupervisors, FirmActChangeContactFirm, FirmActChangeContactUser]
@@ -1156,7 +1147,7 @@ data FirmSuperActionData = FirmSuperActNotifyData
                             , firmSuperActSwitchReroute :: Maybe Bool
                             }
                          | FirmSuperActRMSuperDefData
-                            { firmSuperActRMSuperActive ::       Bool }
+                            { firmSuperActRMSuperActive :: Maybe Bool }
 
   deriving (Eq, Ord, Show, Generic)
 
@@ -1207,22 +1198,20 @@ mkFirmSuperTable :: Bool -> CompanyId -> DB (FormResult (FirmSuperActionData, Se
 mkFirmSuperTable isAdmin cid = do
   msgSupervisorUnchanged <- messageI Info MsgFirmSuperActSwitchSuperInfo
   let
-    reasonSuperior = tshow SupervisorReasonAvsSuperior
+    reasonSuperior = Just $ tshow SupervisorReasonAvsSuperior
     -- fsh = unCompanyKey cid
     resultDBTable = DBTable{..}
       where
         dbtSQLQuery = \(usr `E.LeftOuterJoin` usrCmp) -> do
           EL.on $ usr E.^. UserId E.=?. usrCmp E.?. UserCompanyUser E.&&. usrCmp E.?. UserCompanyCompany E.?=. E.val cid
-          E.where_ $  E.isTrue (usrCmp E.?. UserCompanySupervisor) E.||. E.exists (firmQuerySupervisedBy cid Nothing usr)
+          E.where_ $ E.isTrue (usrCmp E.?. UserCompanySupervisor)
-          -- let uc_reason = E.joinV (usrCmp E.?. UserCompanyReason)
+              E.||.  E.exists (firmQuerySupervisedBy cid Nothing usr)
           return ( usr
                  , usr & firmCountForSupervisor cid Nothing
                  , usr & firmCountForSupervisor cid (Just (E.^. UserSupervisorRerouteNotifications))
                  , usrCmp E.?. UserCompanySupervisor
                  , usrCmp E.?. UserCompanySupervisorReroute
-                 -- , (E.isJust uc_reason E.&&. uc_reason E.==. E.justVal reasonSuperior) -- NOTE: this is problematic, as obvious approaches caused errors such as: Failed to parse Haskell type bool, received PersistNull, since the SQL comparison with NULL returns NULL
+                 , E.exists (firmQuerySupervisedBy cid (Just (\usrSpr -> usrSpr E.^. UserSupervisorReason E.==. E.val reasonSuperior)) usr)
-                 , (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
@@ -1243,11 +1232,15 @@ 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 >>> \case
+          -- , sortable (Just "def-super")   (i18nCell MsgTableIsDefaultSupervisor) $ \(view resultSuperCompanyDefaultSuper   -> mb) -> case mb of { Nothing -> iconCell IconSupervisorForeign; Just True -> iconCell IconSupervisor; Just False -> iconSpacerCell }
-              Nothing      -> iconCell IconSupervisorForeign
+          , sortable (Just "def-super")   (i18nCell MsgTableIsDefaultSupervisor) $ \row ->
-              (Just True ) -> iconCell IconSupervisor
+              let mb = row ^. resultSuperCompanyDefaultSuper
-              (Just False) -> iconSpacerCell
+                  sp = row ^. resultSuperCompanySuperior
-          , sortable Nothing  (i18nCell MsgTableSuperior) $ view resultSuperCompanySuperior >>> flip ifIconCell IconSuperior
+              in case (mb,sp) of
+                  (_     , 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
           ]
@@ -1270,40 +1263,20 @@ 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' (fslI MsgFirmSuperDefault)  (Just $ Just True)
+              <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableIsDefaultSupervisor)  (Just $ Just True)
-              <*> aopt boolField' (fslI MsgTableIsDefaultReroute)      Nothing
+              <*> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableIsDefaultReroute)      Nothing
               <*  aformMessage msgSupervisorUnchanged
           , singletonMap FirmSuperActRMSuperDef $ FirmSuperActRMSuperDefData
-              <$> areq boolField' (fslI MsgFirmSuperActRMSuperActive) (Just True)
+              <$> aopt checkBoxField (fslI MsgFirmSuperActRMSuperActive) (Just $ Just True)
           ]
         dbtParams = DBParamsForm
           { dbParamsFormMethod = POST
@@ -1347,14 +1320,19 @@ postFirmSupersR fsh = do
   formResult fsprRes $ \case
     (_, uids) | null uids -> addMessageI Error MsgUtilEmptyChoice
     (FirmSuperActRMSuperDefData{..}, Set.toList -> uids) -> do
-      let optRemove = if firmSuperActRMSuperActive then id else const $ return 0
+      (nrRmSuper,nrRmActual) <- runDB $ (,)
-      (nrRmSuper,nrRmSupers,nrRmSubs) <- runDB $ (,,)
         <$> updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False]
-        <*> optRemove (deleteWhereCount [UserSupervisorCompany ==. Just cid, UserSupervisorSupervisor <-. uids])
+        <*> if firmSuperActRMSuperActive /= Just True
-        <*> optRemove (deleteWhereCount [UserSupervisorCompany ==. Just cid, UserSupervisorUser       <-. uids])
+              then return 0
-      let total = fromIntegral $ length uids
+              else E.deleteCount $ do
-          allok = bool Warning Success $ total == nrRmSuper
+                spr <- E.from $ E.table @UserSupervisor
-      addMessageI allok $ someMessages [MsgRemoveSupervisors nrRmSuper, MsgFirmRemoveSupervision nrRmSupers nrRmSubs]
+                E.where_ $ spr E.^. UserSupervisorSupervisor `E.in_` E.vals uids
+                    E.&&. E.exists (do
+                      usr <- E.from $ E.table @UserCompany
+                      E.where_ $ usr E.^. UserCompanyCompany E.==. E.val cid
+                          E.&&.  usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser
+                    )
+      addMessageI Info $ MsgRemoveSupervisors nrRmSuper nrRmActual
       reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
     (FirmSuperActSwitchSuperData{..}, Set.toList -> uids) -> do
       let (fltrSpr, changes) = case (firmSuperActSwitchSuper, firmSuperActSwitchReroute) of
@@ -1374,7 +1352,7 @@ postFirmSupersR fsh = do
 
   formFirmAction <- runFirmActionFormPost cid (FirmSupersR fsh) isAdmin [FirmActAddSupervisors, FirmActResetSupervision, FirmActChangeContactFirm]
 
-  siteLayout (citext2widget companyName) $ do
+  siteLayout (citext2widget fsh) $ do
     setTitle $ citext2Html $ fsh <> " Supers"
     let firmContactInfo = $(widgetFile "firm-contact-info")
     $(i18nWidgetFile "firm-supervisors")

src/Handler/Health.hs

@@ -6,7 +6,6 @@ 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
@@ -20,9 +19,6 @@ 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
@@ -81,12 +77,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
@@ -117,44 +113,34 @@ getInstanceR = do
 getStatusR :: Handler Html
 getStatusR = do
   starttime <- getsYesod appStartTime
-  dbTime <- runDBRead $ E.selectOne $ return E.now_
+  (currtime, env_version) <- liftIO $ (,) <$> getCurrentTime <*> lookupEnv "VERSION_NR"
-  (currtime,env_version) <- liftIO $ (,) <$> getCurrentTime <*> lookupEnv "VERSION_NR"
   -- ft <- formatTime'  "%Y-%m-%d %H:%M:%S" currtime
-  let diffTime :: UTCTime -> Text
+  withUrlRenderer 
-      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>
-            Current Application Time <br>
+            Instance Start <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: #{diffTime starttime}
+            Uptime: #{show $ ddays starttime currtime} days.
           <p>
             Compile Time <br>
             #{show cTime} #
-            Build age: #{diffTime cTime}
+            Build age: #{show $ ddays cTime currtime} days.
     |]
-  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,14 +8,12 @@ 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
@@ -26,8 +24,6 @@ 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
@@ -37,12 +33,6 @@ 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)
@@ -98,7 +88,12 @@ getHealthInterfaceR (dropWhile (=="force") -> ris) = do               -- for bac
 
 runInterfaceLogTable :: ReqBanInterfaceHealth -> Handler (Bool, Bool, [(Text,Bool)], Widget)
 runInterfaceLogTable interfs@(reqIfs,_) = do
-  (res, twgt) <- runDB $ mkInterfaceLogTable interfs
+  -- we abuse messageTooltip for colored icons here
+  msgSuccessTooltip <- messageI Success MsgMessageSuccess
+  -- msgWarningTooltip <- messageI Warning MsgMessageWarning
+  msgErrorTooltip   <- messageI Error   MsgMessageError
+  let flagError = messageTooltip . bool msgErrorTooltip msgSuccessTooltip
+  (res, twgt) <- runDB $ mkInterfaceLogTable flagError interfs
   let missing = notNull [ifce | (UniqueInterfaceHealth ifce _subt _writ) <- reqIfs, ifce `notElem` (fst <$> res) ]
       allok   = all snd res
   return (missing, allok, res, twgt)
@@ -106,14 +101,12 @@ runInterfaceLogTable interfs@(reqIfs,_) = do
 -- ihDebugShow :: Unique InterfaceHealth -> Text
 -- ihDebugShow (UniqueInterfaceHealth i s w) = "(" <> tshow i <> "," <> tshow s <> "," <> tshow w <> ")"
 
-mkInterfaceLogTable :: ReqBanInterfaceHealth -> DB ([(Text,Bool)], Widget)
+mkInterfaceLogTable :: (Bool -> Widget) -> ReqBanInterfaceHealth -> DB ([(Text,Bool)], Widget)
-mkInterfaceLogTable interfs@(reqIfs, banIfs) = do
+mkInterfaceLogTable flagError interfs@(reqIfs, banIfs) = do
     --   $logWarnS "DEBUG" $ tshow ([ihDebugShow x | x<- reqIfs], [ihDebugShow x | x<- banIfs])
-    flagError <- liftHandler $ do
+    void $ liftHandler $ timeoutHandler 42000001 $ runDB $ runInterfaceChecks interfs
-      void $ timeoutHandler 42000001 $ runDB $ runInterfaceChecks interfs -- ensure interface checkc are up to date
-      mkErrorFlag
     now <- liftIO getCurrentTime
-    dbTableDB ilvalidator DBTable{dbtColonnade=colonnade now flagError, ..}
+    dbTableDB ilvalidator DBTable{dbtColonnade=colonnade now, ..}
   where
     sanitize      = text2AlphaNumPlus ['+','-','_','Ä','Ö','Ü','ß','ä','ö','ü']
     dbtIdent      = "interface-log" :: Text
@@ -155,34 +148,32 @@ mkInterfaceLogTable 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 defaultInterfaceWarnHours)  -- if no default time is set, use a default instead
+      let ihour = E.coalesceDefault [ihealth E.?. InterfaceHealthHours] (E.val $ 3 * 24)  -- if no default time is set, use 3 days instead
       return (ilog, ihour)
 
     queryILog     :: (E.SqlExpr (Entity InterfaceLog) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity InterfaceHealth))) -> E.SqlExpr (Entity InterfaceLog)
     queryILog     = $(E.sqlLOJproj 2 1)
-    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 flagError = mconcat
+    colonnade now = mconcat
         [ sortable Nothing (i18nCell MsgInterfaceStatus) $ \row -> -- do
             let hours   = row ^. resultHours
                 -- defmsg  = row ^? resultErrMsg
                 logtime = row ^. resultILog . _interfaceLogTime
                 success = row ^. resultILog . _interfaceLogSuccess
                 iface   = row ^. resultILog . _interfaceLogInterface
-                status  = (success || hours <= -100) && (hours < 0 || now <= addHours hours logtime)
+                status  = success && (hours < 0 || now <= addHours hours logtime)
-            in tellCell [(iface,status)] $ wgtCell $ flagError $ toMaybe (success || not status) status
+            in tellCell [(iface,status)] $
+                wgtCell $ flagError status
         , sortable (Just "interface") (i18nCell MsgInterfaceName      ) $ \(view (resultILog . _interfaceLogInterface) -> n) -> textCell n
         , sortable (Just "subtype")   (i18nCell MsgInterfaceSubtype   ) $ textCell . view (resultILog . _interfaceLogSubtype)
         , sortable (Just "write")     (i18nCell MsgInterfaceWrite     ) $ (`ifIconCell` IconEdit) . view (resultILog . _interfaceLogWrite)
         , sortable (Just "time")      (i18nCell MsgInterfaceLastSynch ) $ dateTimeCell . view (resultILog . _interfaceLogTime)
-        , sortable (Just "hours")     (i18nCell MsgInterfaceFreshness & cellTooltips [SomeMessage MsgInterfaceFreshnessTooltip, SomeMessage MsgTableDiffDaysTooltip]
+        , sortable Nothing            (i18nCell MsgInterfaceFreshness ) $ numCell . view resultHours
-                                                                      ) $ 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
@@ -198,7 +189,6 @@ mkInterfaceLogTable 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
@@ -268,135 +258,3 @@ 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,6 +220,7 @@ data LmsTableCsv = LmsTableCsv   -- L..T..C.. -> ltc..
   { ltcDisplayName    :: UserDisplayName
   , ltcEmail          :: UserEmail
   , ltcCompany        :: Maybe Text
+  , ltcCompanyNumbers :: CsvSemicolonList Int
   , ltcValidUntil     :: Day
   , ltcLastRefresh    :: Day
   , ltcFirstHeld      :: Day
@@ -241,7 +242,8 @@ ltcExample :: LmsTableCsv
 ltcExample = LmsTableCsv
     { ltcDisplayName    = "Max Mustermann"
     , ltcEmail          = "m.mustermann@example.com"
-    , ltcCompany        = Just "Example Brothers LLC"
+    , ltcCompany        = Just "Example Brothers LLC, SecondaryJobs Inc"
+    , ltcCompanyNumbers = CsvSemicolonList [27,69]
     , ltcValidUntil     = succ compDay
     , ltcLastRefresh    = compDay
     , ltcFirstHeld      = pred $ pred compDay
@@ -283,7 +285,8 @@ instance CsvColumnsExplained LmsTableCsv where
   csvColumnsExplanations = genericCsvColumnsExplanations ltcOptions $ Map.fromList
     [ ('ltcDisplayName    , SomeMessage MsgLmsUser)
     , ('ltcEmail          , SomeMessage MsgTableLmsEmail)
-    , ('ltcCompany        , SomeMessage MsgTablePrimeCompany)
+    , ('ltcCompany        , SomeMessage MsgTableCompanies)
+    , ('ltcCompanyNumbers , SomeMessage MsgTableCompanyNos)
     , ('ltcValidUntil     , SomeMessage MsgLmsQualificationValidUntil)
     , ('ltcLastRefresh    , SomeMessage MsgTableQualificationLastRefresh)
     , ('ltcFirstHeld      , SomeMessage MsgTableQualificationFirstHeld)
@@ -317,7 +320,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]), E.Value (Maybe CompanyId), E.Value Bool)
+type LmsTableData = DBRow (Entity QualificationUser, Entity User, Entity LmsUser, Maybe (Entity QualificationUserBlock), E.Value (Maybe [Maybe UTCTime]), [Entity UserCompany], E.Value Bool)
 
 resultQualUser :: Lens' LmsTableData (Entity QualificationUser)
 resultQualUser = _dbrOutput . _1
@@ -334,8 +337,8 @@ resultQualBlock = _dbrOutput . _4 . _Just
 resultPrintAck :: Traversal' LmsTableData [Maybe UTCTime]
 resultPrintAck = _dbrOutput . _5 . _unValue . _Just
 
-resultCompanyId :: Traversal' LmsTableData CompanyId
+resultCompanyUser :: Lens' LmsTableData [Entity UserCompany]
-resultCompanyId = _dbrOutput . _6 . _unValue . _Just
+resultCompanyUser = _dbrOutput . _6
 
 resultValidQualification :: Lens' LmsTableData Bool
 resultValidQualification = _dbrOutput . _7 . _unValue
@@ -403,7 +406,6 @@ 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
@@ -419,16 +421,12 @@ 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
-        primeComp = E.subSelect . E.from $ \uc -> do
+    return (qualUser, user, lmsUser, qualBlock, printAcknowledged, validQualification now qualUser)
-          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
@@ -437,26 +435,25 @@ mkLmsTable :: ( Functor h, ToSortable h
            => Bool
            -> Entity Qualification
            -> Map LmsTableAction (AForm Handler LmsTableActionData)
-           -> ((CompanyId -> CompanyName) -> cols)
+           -> (Map CompanyId Company -> 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 $ 15 * diffMinute) ("CompanyDictionary"::Text) $ do
+  cmpMap <- memcachedBy (Just . Right $ 5 * 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 = dbtProjId
+    dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr, qUsrBlock, printAcks, validQ) -> do
-    dbtColonnade = cols getCompanyName
+      cmpUsr <- selectList [UserCompanyUser ==. entityKey usr] [Desc UserCompanyPriority, Asc UserCompanyCompany, LimitTo 1]
+      return (qualUsr, usr, lmsUsr, qUsrBlock, printAcks, cmpUsr, validQ)
+    dbtColonnade = cols cmpMap
     dbtSorting = mconcat
       [ single $ sortUserNameLink   queryUser
       , single $ sortUserEmail      queryUser
@@ -547,20 +544,25 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
         doEncode' = LmsTableCsv
           <$>  view    (resultUser     . _entityVal . _userDisplayName)
           <*>  view    (resultUser     . _entityVal . _userDisplayEmail)
-          <*>  preview (resultCompanyId . to getCompanyName . _CI)
+          <*> (view     resultCompanyUser >>= getCompanies)
-          <*>  view    (resultQualUser  . _entityVal . _qualificationUserValidUntil)
+          <*> (view     resultCompanyUser >>= getCompanyNos)
-          <*>  view    (resultQualUser  . _entityVal . _qualificationUserLastRefresh)
+          <*>  view    (resultQualUser . _entityVal . _qualificationUserValidUntil)
-          <*>  view    (resultQualUser  . _entityVal . _qualificationUserFirstHeld)
+          <*>  view    (resultQualUser . _entityVal . _qualificationUserLastRefresh)
+          <*>  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 = []
@@ -625,12 +627,16 @@ postLmsR sid qsh = do
               -- <*> aopt (commentField MsgQualificationActBlockSupervisor) (fslI MsgMessageWarning) Nothing
               <*  aformMessage msgRestartWarning
           ]
-        colChoices getCompanyName = mconcat
+        colChoices cmpMap = mconcat
           [ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultUser . _entityKey))
           , colUserNameModalHdrAdmin MsgLmsUser AdminUserR
           , colUserEmail
-          , sortable (Just "user-company") (i18nCell MsgTablePrimeCompany) $ \(preview resultCompanyId -> mcid) ->
+          , sortable (Just "user-company") (i18nCell MsgTableCompany) $ \( view resultCompanyUser -> cmps) ->
-              maybeEmpty mcid $ \cid -> companyCell (unCompanyKey cid) (getCompanyName cid) False
+              let cs =  [ companyCell (unCompanyKey cmpId) cmpName cmpSpr
+                        | Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps
+                        , let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap
+                        ]
+              in intercalate spacerCell cs
           , 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,7 +8,6 @@ module Handler.MailCenter
   ( getMailCenterR, postMailCenterR
   , getMailHtmlR
   , getMailPlainR
-  , getMailAttachmentR
   ) where
 
 import Import
@@ -97,7 +96,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 (MailHtmlR <$> encrypt k) linkWgt
+          in anchorCellM (MailPlainR <$> 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
       ]
@@ -108,14 +107,12 @@ 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.mkContainsFilterWithCommaPlus id     $ views (to queryMail)        (E.str2text . (E.^. SentMailHeaders)))
+      , single ("subject"   , FilterColumn . E.mkContainsFilter                     $ 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
@@ -164,27 +161,6 @@ 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]
 
@@ -202,7 +178,6 @@ 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>
@@ -237,16 +212,15 @@ handleMailShow hdr prefTypes cusm = do
               #{decodeEncodedWord r}
 
       <section>
-        $forall pt <- mparts
+        $forall mc <- mcontent
-          ^{part2widget cusm pt}
+          $maybe pt <- selectAlternative prefTypes mc
+            <p>
+              ^{part2widget pt}
     |]
-      -- Include for Debugging:
+    -- Include for Debugging:
-      -- <section>
+    -- ^{jsonWidget (sm ^. _sentMailHeaders)}
-      --   <h2>Debugging
+    -- ^{jsonWidget (sentMailContentContent cn)}
-      --   <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
@@ -258,76 +232,34 @@ 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 _) = [whamlet|<h3>_{MsgMailFileAttachment}|]
+disposition2widget (AttachmentDisposition n) = [whamlet|<h3>Attachment #{n}|]
-disposition2widget (InlineDisposition     n) = [whamlet|<h3>_{MsgMenuMailAttachment} #{n}|]
+disposition2widget (InlineDisposition     n) = [whamlet|<h3>#{n}|]
 disposition2widget  DefaultDisposition       = mempty
 
-part2widget :: CryptoUUIDSentMail -> Part -> Widget
+part2widget :: Part -> Widget
-part2widget cusm Part{partContent=NestedParts ps} =
+part2widget Part{partContent=NestedParts ps} =
   [whamlet|
+    <section>
       $forall p <- ps
-        ^{part2widget cusm p}
+        <p>
+          ^{part2widget p}
   |]
-part2widget cusm Part{partContent=PartContent (LB.toStrict -> pc), partType=pt, partDisposition=dispo} =
+part2widget 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 $ plainHtmlToHtml $ decodeUtf8 pc -- preEscapedToHtml :: ToMarkup a => a -> Html
+      | pt == decodeUtf8 typeHtml  = toWidget $ preEscapedToHtml $ decodeUtf8 pc -- preEscapedToHtml :: ToMarkup a => a -> Html
       | pt == decodeUtf8 typeJson  =
           let jw :: Aeson.Value -> Widget = jsonWidget
           in  either str2widget jw $ Aeson.eitherDecodeStrict' pc
-      | pt == decodeUtf8 typePDF
+      | otherwise = [whamlet|part2widget cannot decode parts of type #{pt} yet.|]
-      , 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,7 +35,6 @@ 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)
@@ -606,7 +605,6 @@ 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
@@ -677,24 +675,14 @@ 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
-  countUnderlings <- E.select $ do
+  let supervisorsWgt :: Widget =
-    spr <- E.from $ E.table @UserSupervisor
+        let ((getSum -> nrSupers, getSum -> nrReroute, getSum -> nrLetter), tWgt) = supervisorsTable
-    E.where_ $ spr E.^. UserSupervisorSupervisor E.==. E.val uid
+        in  maybeTable' (MsgProfileSupervisor nrSupers nrReroute) (Just MsgProfileNoSupervisor)
-    return (E.countRows, E.count (spr E.^. UserSupervisorId) `E.filterWhere` (spr E.^. UserSupervisorRerouteNotifications))
+                        (toMaybe (nrReroute > 0) $ msg2widget $ MsgProfileSupervisorRemark nrSupers nrReroute nrLetter) (nrSupers > 0, tWgt)
-  countSupervisors <- E.select $ do
-    spr <- E.from $ E.table @UserSupervisor
-    E.where_ $ spr E.^. UserSupervisorUser E.==. E.val uid
-    return (E.countRows, E.count (spr E.^. UserSupervisorId) `E.filterWhere` (spr E.^. UserSupervisorRerouteNotifications))
-  let errorCount ((E.Value x, E.Value y):_) = (x,y)
-      errorCount _ = (-1,-1)
-      supervisorsWgt :: Widget =
-        let (nrSupers, nrSupersReroute) = errorCount countSupervisors
-        in  maybeTable' (MsgProfileSupervisor nrSupers nrSupersReroute) (Just MsgProfileNoSupervisor)
-                        (toMaybe (nrSupersReroute > 0) $ msg2widget $ MsgProfileSupervisorRemark nrSupers nrSupersReroute 0) (nrSupers > 0, supervisorsTable)
       superviseesWgt :: Widget =
-        let (nrUnderlings, nrUndersReroute) = errorCount countUnderlings
+        let ((getSum -> nrSubs, getSum -> nrReroute), tWgt) = superviseesTable
-        in maybeTable' (MsgProfileSupervisee nrUnderlings nrUndersReroute) (Just MsgProfileNoSupervisee)
+        in  maybeTable' (MsgProfileSupervisee nrSubs nrReroute) (Just MsgProfileNoSupervisee)
-                       (toMaybe (nrUndersReroute > 0) $ msg2widget $ MsgProfileSuperviseeRemark nrUnderlings nrUndersReroute) (nrUnderlings > 0, superviseesTable)
+                        (toMaybe (nrReroute > 0) $ msg2widget $ MsgProfileSuperviseeRemark nrSubs nrReroute) (nrSubs > 0, tWgt)
   -- let examTable, ownTutorialTable, tutorialTable :: Widget
   --     examTable        = i18n MsgPersonalInfoExamAchievementsWip
   --     ownTutorialTable = i18n MsgPersonalInfoOwnTutorialsWip
@@ -1105,10 +1093,10 @@ instance HasUser TblSupervisorData where
   hasUser = _dbrOutput . _1 . _entityVal
 
 -- | Table listing all supervisor of the given user
-mkSupervisorsTable :: UserId -> DB Widget
+mkSupervisorsTable :: UserId -> DB ((Sum Int, Sum Int, Sum Int), Widget)
-mkSupervisorsTable uid = dbTableWidget' validator DBTable{..}
+mkSupervisorsTable uid = dbTableWidget validator DBTable{..}
   where
-    dbtIdent = "supervisors" :: Text
+    dbtIdent = "userSupervisedBy" :: Text
     dbtStyle = def
 
     dbtSQLQuery (usr `E.InnerJoin` spr) = do
@@ -1126,7 +1114,8 @@ mkSupervisorsTable uid = dbTableWidget' validator DBTable{..}
         , sortable (Just "reroute") (i18nCell MsgTableRerouteActive) $ \row ->
             let isReroute = row ^. resultUserSupervisor . _entityVal ._userSupervisorRerouteNotifications
                 isLetter  = row ^. resultUser . _userPrefersPostal
-            in  if isReroute
+            in  tellCell (Sum 1, Sum $ fromEnum isReroute, Sum $ fromEnum $ isReroute && isLetter) $
+                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)
@@ -1157,10 +1146,10 @@ mkSupervisorsTable uid = dbTableWidget' validator DBTable{..}
 
 
 -- | Table listing all persons supervised by the given user
-mkSuperviseesTable ::Bool -> UserId -> DB Widget
+mkSuperviseesTable ::Bool -> UserId -> DB ((Sum Int, Sum Int), Widget)
-mkSuperviseesTable userPrefersPostal uid = dbTableWidget' validator DBTable{..}
+mkSuperviseesTable userPrefersPostal uid = dbTableWidget validator DBTable{..}
   where
-    dbtIdent = "supervisees" :: Text
+    dbtIdent = "userSupervisedBy" :: Text
     dbtStyle = def
 
     dbtSQLQuery (usr `E.InnerJoin` spr) = do
@@ -1178,7 +1167,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  boolCell isReroute $ iconCell IconReroute <> iconCellLetterOrEmail
+            in  tellCell (Sum 1, Sum $ fromEnum isReroute) $ 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,6 +158,7 @@ data QualificationTableCsv = QualificationTableCsv   -- Q..T..C.. -> qtc..
   { qtcDisplayName    :: UserDisplayName
   , qtcEmail          :: UserEmail
   , qtcCompany        :: Maybe Text
+  , qtcCompanyNumbers :: CsvSemicolonList Int
   , qtcValidUntil     :: Day
   , qtcLastRefresh    :: Day
   , qtcBlockStatus    :: Maybe Bool
@@ -173,7 +174,8 @@ qtcExample :: QualificationTableCsv
 qtcExample = QualificationTableCsv
     { qtcDisplayName    = "Max Mustermann"
     , qtcEmail          = "m.mustermann@example.com"
-    , qtcCompany        = Just "Example Brothers LLC"
+    , qtcCompany        = Just "Example Brothers LLC, SecondaryJobs Inc"
+    , qtcCompanyNumbers = CsvSemicolonList [27,69]
     , qtcValidUntil     = compDay
     , qtcLastRefresh    = compDay
     , qtcBlockStatus    = Nothing
@@ -207,7 +209,8 @@ instance CsvColumnsExplained QualificationTableCsv where
   csvColumnsExplanations = genericCsvColumnsExplanations qtcOptions $ Map.fromList
     [ ('qtcDisplayName    , SomeMessage MsgLmsUser)
     , ('qtcEmail          , SomeMessage MsgTableLmsEmail)
-    , ('qtcCompany        , SomeMessage MsgTablePrimeCompany)
+    , ('qtcCompany        , SomeMessage MsgTableCompanies)
+    , ('qtcCompanyNumbers , SomeMessage MsgTableCompanyNos)
     , ('qtcValidUntil     , SomeMessage MsgLmsQualificationValidUntil)
     , ('qtcLastRefresh    , SomeMessage MsgTableQualificationLastRefresh)
     , ('qtcBlockStatus    , SomeMessage MsgInfoQualificationBlockStatus)
@@ -235,7 +238,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), E.Value (Maybe CompanyId))
+type QualificationTableData = DBRow (Entity QualificationUser, Entity User, Maybe (Entity LmsUser), Maybe (Entity QualificationUserBlock), [Entity UserCompany])
 
 resultQualUser :: Lens' QualificationTableData (Entity QualificationUser)
 resultQualUser = _dbrOutput . _1
@@ -249,8 +252,8 @@ resultLmsUser = _dbrOutput . _3 . _Just
 resultQualBlock :: Traversal' QualificationTableData (Entity QualificationUserBlock)
 resultQualBlock = _dbrOutput . _4 . _Just
 
-resultCompanyId :: Traversal' QualificationTableData CompanyId
+resultCompanyUser :: Lens' QualificationTableData [Entity UserCompany]
-resultCompanyId = _dbrOutput . _5 . _unValue . _Just
+resultCompanyUser = _dbrOutput . _5
 
 
 instance HasEntity QualificationTableData User where
@@ -337,7 +340,6 @@ 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
@@ -349,11 +351,7 @@ 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)
-    let primeComp = E.subSelect . E.from $ \uc -> do
+    return (qualUser, user, lmsUser, qualBlock)
-          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 ::
@@ -363,19 +361,17 @@ mkQualificationTable ::
            => Bool
            -> Entity Qualification
            -> Map QualificationTableAction (AForm Handler QualificationTableActionData)
-           -> ((CompanyId -> CompanyName) -> cols)
+           -> (Map CompanyId Company -> 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 $ 15 * diffMinute) ("CompanyDictionary"::Text) $ do
+  cmpMap <- memcachedBy (Just . Right $ 5 * 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)
@@ -384,8 +380,15 @@ 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 = dbtProjId
+    dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr, qUsrBlock) -> do
-    dbtColonnade = cols getCompanyName
+      -- cmps <- E.select . E.from $ \(usrComp `E.InnerJoin` comp) -> do
+      --   E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
+      --   E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val (entityKey usr)
+      --   E.orderBy [E.asc (comp E.^. CompanyName)]
+      --   return (comp E.^. CompanyName, comp E.^. CompanyAvsId, usrComp E.^. UserCompanySupervisor)
+      cmpUsr <- selectList [UserCompanyUser ==. entityKey usr] [Desc UserCompanyPriority, Asc UserCompanyCompany, LimitTo 1]
+      return (qualUsr, usr, lmsUsr, qUsrBlock, cmpUsr)
+    dbtColonnade = cols cmpMap
     dbtSorting = mconcat
       [ single $ sortUserNameLink   queryUser
       , single $ sortUserEmail      queryUser
@@ -468,7 +471,8 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
         doEncode' = QualificationTableCsv
           <$>  view    (resultUser     . _entityVal . _userDisplayName)
           <*>  view    (resultUser     . _entityVal . _userDisplayEmail)
-          <*>  preview (resultCompanyId . to getCompanyName . _CI)
+          <*> (view     resultCompanyUser >>= getCompanies)
+          <*> (view     resultCompanyUser >>= getCompanyNos)
           <*>  view    (resultQualUser . _entityVal . _qualificationUserValidUntil)
           <*>  view    (resultQualUser . _entityVal . _qualificationUserLastRefresh)
           <*>  preview (resultQualBlock. _entityVal . _qualificationUserBlockUnblock . _not)
@@ -476,6 +480,10 @@ 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
@@ -543,7 +551,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 9
+          Ex.limit 7
           pure (qblock Ex.^. QualificationUserBlockReason)
         mkOption :: Ex.Value Text -> Option Text
         mkOption (Ex.unValue -> t) = Option{ optionDisplay = t, optionInternalValue = t, optionExternalValue = toPathPiece t }
@@ -577,12 +585,16 @@ postQualificationR sid qsh = do
           ] isAdmin
         linkLmsUser     = toMaybe isAdmin (LmsUserR sid qsh)
         linkUserName    = bool ForProfileR ForProfileDataR isAdmin
-        colChoices getCompanyName = mconcat
+        colChoices cmpMap = mconcat
           [ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
           , colUserNameModalHdr MsgLmsUser linkUserName
           , colUserEmail
-          , sortable (Just "user-company") (i18nCell MsgTablePrimeCompany) $ \(preview resultCompanyId -> mcid) ->
+          , sortable (Just "user-company") (i18nCell MsgTableCompany) $ \( view resultCompanyUser -> cmps) ->
-              maybeEmpty mcid $ \cid -> companyCell (unCompanyKey cid) (getCompanyName cid) False
+              let cs =  [ companyCell (unCompanyKey cmpId) cmpName cmpSpr
+                        | Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps
+                        , let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap
+                        ]
+              in intercalate spacerCell cs
           , 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,19 +191,18 @@ 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'                     (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip)                (Just False)
+            <*> apopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just True)
             <*> 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'                     (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip)                (Just False)
+            <*> apopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just True)
             <*> aopt  (textField & cfStrip & addDatalist superReasons) (fslI MsgUserSupervisorReason & setTooltip MsgUserSupervisorReasonTooltip) Nothing
         , singletonMap UserRemoveSupervisor $ pure UserRemoveSupervisorData
         , singletonMap UserRemoveSubordinates $ pure UserRemoveSubordinatesData
@@ -425,8 +424,7 @@ postUsersR = do
 
   formResult allUsersRes $ \case
     AllUsersLdapSync -> do
-      -- runDBJobs . runConduit $ selectSource [] [] .| C.mapM_ (queueDBJob . JobSynchroniseLdapUser . entityKey) -- to slow to execute directly
+      runDBJobs . runConduit $ selectSource [] [] .| C.mapM_ (queueDBJob . JobSynchroniseLdapUser . entityKey)
-      queueJob' JobSynchroniseLdapAll
       addMessageI Success MsgSynchroniseLdapAllUsersQueued
       redirect UsersR
     AllUsersAvsSync -> do

src/Handler/Utils.hs

@@ -163,23 +163,19 @@ 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}
+adminProblemCell AdminProblemCompanySuperiorChange{adminProblemUserOld=Nothing}
-  = i18nCell MsgAdminProblemCompanySuperiorChange <> previousSuperior adminProblemUserOld
+  = i18nCell MsgAdminProblemCompanySuperiorChange
-adminProblemCell AdminProblemCompanySuperiorNotFound{..}
+adminProblemCell AdminProblemCompanySuperiorChange{adminProblemUserOld=Just uid}
-  = i18nCell (MsgAdminProblemCompanySuperiorNotFound (fromMaybe "???" adminProblemEmail)) <> previousSuperior adminProblemUserOld
+  = i18nCell MsgAdminProblemCompanySuperiorChange <> spacerCell <> i18nCell MsgAdminProblemCompanySuperiorPrevious <> anchorCellM (AdminUserR <$> encrypt uid) (userIdWidget uid)
 adminProblemCell AdminProblemNewlyUnsupervised{adminProblemCompanyNew}
   = i18nCell MsgAdminProblemNewlyUnsupervised <> companyIdCell adminProblemCompanyNew
 adminProblemCell AdminProblemUnknown{adminProblemText}
@@ -188,42 +184,6 @@ 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]
@@ -233,10 +193,8 @@ 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 catchAll2log'
+catchAll2log  = voidMaybe $ catchAVShandler True True False Nothing
 
-catchAll2log' :: (MonadHandler m, MonadCatch m, RenderMessage (HandlerSite m) AvsException) => m (Maybe a) -> m (Maybe a)
+-- catchAll2log' :: (MonadHandler m, MonadCatch m, RenderMessage (HandlerSite m) AvsException, Monoid a) => m a -> m ()
-catchAll2log' = catchAVShandler True True False Nothing
+-- catchAll2log' = voidMaybe $ catchAVShandler True True False mempty
 
 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,8 +329,6 @@ 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
@@ -382,73 +380,71 @@ updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAv
                       , UserAvsLastCardNo     =. newAvsCardNo
                       ]
 
-        usr_up2 <- guardMonoidM (oldAvsFirmInfo /= Just newAvsFirmInfo) $ do
+        -- update company association & supervision
-          -- update company association & supervision
+        Entity{entityKey=newCompanyId} <- upsertAvsCompany newAvsFirmInfo oldAvsFirmInfo
-          newCompanyEnt@Entity{entityKey=newCompanyId} <- upsertAvsCompany newAvsFirmInfo oldAvsFirmInfo
+        oldCompanyEnt <- getAvsCompany `traverseJoin` oldAvsFirmInfo
-          upsertCompanySuperior newCompanyEnt newAvsFirmInfo oldAvsFirmInfo usrId   -- ensure firmInfo superior is supervisor for this user
+        primaryCompanyId <- userCompanyCompany <<$>> getUserPrimaryCompany usrId
-          oldCompanyEnt <- getAvsCompany `traverseJoin` oldAvsFirmInfo
+        let oldCompanyId = entityKey <$> oldCompanyEnt
-          primaryCompanyId <- userCompanyCompany <<$>> getUserPrimaryCompany usrId
+            -- oldCompanyMb = entityVal <$> oldCompanyEnt
-          let oldCompanyId = entityKey <$> oldCompanyEnt
+            -- pst_up  = if
-              -- oldCompanyMb = entityVal <$> oldCompanyEnt
+            --           -- | isNothing oldCompanyMb || oldCompanyId == primaryCompanyId                                              -- refactor could replace next 4 lines
-              -- pst_up  = if
+            --           --   -> mkUpdate'      usr newCompany oldCompanyMb $ CheckUpdate UserPrefersPostal _companyPrefersPostal  -- always update if company association is fresh (case should not occur in practice though)
-              --           -- | isNothing oldCompanyMb || oldCompanyId == primaryCompanyId                                              -- refactor could replace next 4 lines
+            --           | isNothing oldCompanyMb
-              --           --   -> mkUpdate'      usr newCompany oldCompanyMb $ CheckUpdate UserPrefersPostal _companyPrefersPostal  -- always update if company association is fresh (case should not occur in practice though)
+            --             -> mkUpdateDirect usr newCompany              $ CheckUpdate UserPrefersPostal _companyPrefersPostal  -- always update if company association is fresh (case should not occur in practice though)
-              --           | isNothing oldCompanyMb
+            --           | oldCompanyId == primaryCompanyId -- && isJust oldCompanyId -- is ensured by previous line
-              --             -> 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  -- possibly change postal preference
-              --           | oldCompanyId == primaryCompanyId -- && isJust oldCompanyId -- is ensured by previous line
+            --           | otherwise
-              --             -> mkUpdate       usr newCompany oldCompanyMb $ CheckUpdate UserPrefersPostal _companyPrefersPostal  -- possibly change postal preference
+            --             -> Nothing
-              --           | otherwise
+            superReasonComDef = tshow SupervisorReasonCompanyDefault
-              --             -> Nothing
+            newUserComp = UserCompany usrId newCompanyId False False 1 True Nothing -- default value for new company insertion, if no update can be done
-              superReasonComDef = tshow SupervisorReasonCompanyDefault
-              newUserComp = UserCompany usrId newCompanyId False False 1 True Nothing -- default value for new company insertion, if no update can be done
 
-          case oldAvsFirmInfo of
+        usr_up2 <- 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
@@ -497,12 +493,13 @@ 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 <- runDB $ do
+        oldUsr <- runDBRead $ do
-          mbUid <- firstJustM $ return muid : maybe [] (\ipn ->
+          mbUid <- if isJust muid
-                [ getKeyByFilter [UserCompanyPersonalNumber ==. Just ipn] -- must ensure filter isnt ==. Nothing
+              then return muid
-                , catchAll2log' (Just . entityKey <$> ldapLookupAndUpsert ipn) -- attempt to insert by LDAP first
+              else firstJustM $ catMaybes
+                [ 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
@@ -566,8 +563,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))
@@ -588,18 +585,16 @@ 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 mbOldAvsFirmInfo} new #{tshow newAvsFirmInfo} ent-new #{tshow mbFirmEnt}|]
+    $logInfoS "AVS" [st|upsertAvsCompany: old #{tshow mbFirmEnt} new #{tshow newAvsFirmInfo}|]
-    case mbFirmEnt of
+    cmpEnt <- case (mbFirmEnt, mbOldAvsFirmInfo) 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 produced through firmInfo2company below for consistency
+            dmy = Company                                                                                 -- mostly dummy, values are actually prodcued through firmInfo2company below for consistency
                   { companyName           = newAvsFirmInfo ^. _avsFirmFirm          . from _CI
                   , companyShorthand      = newAvsFirmInfo ^. _avsFirmAbbreviation  . from _CI
                   , companyAvsId          = afn
@@ -611,12 +606,11 @@ 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}) -> do                                          -- possibly update existing company, if isJust oldAvsFirmInfo and identical AvsFirmNo and changes occurred
+      (Just Entity{entityKey=firmid, entityVal=firm}, oldAvsFirmInfo) -> do                               -- possibly update existing company, if isJust oldAvsFirmInfo and changed occurred
-        let oldHasSameFirmNo = Just (newAvsFirmInfo ^. _avsFirmFirmNo) == (mbOldAvsFirmInfo ^? _Just . _avsFirmFirmNo)
+        let cmp_ups = mapMaybe  (mkUpdate'            firm newAvsFirmInfo oldAvsFirmInfo) firmInfo2company
-            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}|]
@@ -635,8 +629,10 @@ 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" [st|Update company #{companyShorthand firm} completed.|]
+        $logInfoS "AVS" "Update company 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
@@ -649,73 +645,94 @@ 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
 
--- | adjust superiors, assumes that CompanyUser exists for all usrs for given company; does not work otherwise
+    deleteOldSuperior oldSup oldCid =
-upsertCompanySuperior :: Entity Company -> AvsFirmInfo -> Maybe AvsFirmInfo -> UserId -> DB () -- may return superior (Maybe UserId), but currently not needed
+      deleteWhere [ UserSupervisorSupervisor ==. oldSup
-upsertCompanySuperior Entity{entityKey=cid, entityVal=Company{}} newAfi oldAfi usrId =
+                  , UserSupervisorCompany ==. Just oldCid
-  let reasonSuperior = Just $ tshow SupervisorReasonAvsSuperior
+                  , UserSupervisorReason ==. reasonSuperior
-      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)
@@ -886,32 +903,30 @@ avsLicenceDifferences2personLicences AvsLicenceDifferences{..} =
   <> Set.map (AvsPersonLicence AvsLicenceRollfeld) avsLicenceDiffGrantRollfeld
 
 computeDifferingLicences :: AvsResponseGetLicences -> Handler (Set AvsPersonLicence)
-computeDifferingLicences = fmap (avsLicenceDifferences2personLicences . fst) . getDifferingLicences
+computeDifferingLicences = fmap avsLicenceDifferences2personLicences . getDifferingLicences
 
 type AvsPersonIdMapPersonCard = Map AvsPersonId (Set AvsDataPersonCard)
 
 avsResponseStatusMap :: AvsResponseStatus -> AvsPersonIdMapPersonCard
 avsResponseStatusMap (AvsResponseStatus status) = Map.fromDistinctAscList [(avsStatusPersonID,avsStatusPersonCardStatus) | AvsStatusPerson{..}<- Set.toAscList status]
 
-retrieveDifferingLicences :: Handler (AvsLicenceDifferences, Set AvsPersonId)
+retrieveDifferingLicences :: Handler AvsLicenceDifferences
 retrieveDifferingLicences = fst <$> retrieveDifferingLicences' False
 
-retrieveDifferingLicencesStatus :: Handler ((AvsLicenceDifferences, Set AvsPersonId), AvsPersonIdMapPersonCard)
+retrieveDifferingLicencesStatus :: Handler (AvsLicenceDifferences, AvsPersonIdMapPersonCard)
 retrieveDifferingLicencesStatus = retrieveDifferingLicences' True
 
-retrieveDifferingLicences' :: Bool -> Handler ((AvsLicenceDifferences, Set AvsPersonId),  AvsPersonIdMapPersonCard)
+retrieveDifferingLicences' :: Bool -> Handler (AvsLicenceDifferences, AvsPersonIdMapPersonCard)
 retrieveDifferingLicences' getStatus = do
 #ifdef DEVELOPMENT
-  avsUsrs <- runDBRead $ selectList [] [LimitTo 444]
+  avsUsrs <- runDB $ 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 (bool AvsLicenceRollfeld AvsLicenceVorfeld $ even $ avsPersonId avsid) avsid
+        ] ++ [AvsPersonLicence AvsLicenceVorfeld avsid | Entity _ UserAvs{userAvsPersonId = avsid} <- avsUsrs]
-             | Entity _ UserAvs{userAvsPersonId = avsid} <- avsUsrs
-             ]
 #else
   allLicences  <- avsQueryNoCache AvsQueryGetAllLicences
 #endif
@@ -927,7 +942,7 @@ retrieveDifferingLicences' getStatus = do
               ] <>
               [ AvsStatusPerson  avsid $ Set.singleton $ mkAdpc (even $ avsPersonId avsid) AvsCardColorGelb | Entity _ UserAvs{userAvsPersonId = avsid} <- avsUsrs ]
 #else
-  let statQry = avsLicenceDifferences2LicenceIds $ fst lDiff
+  let statQry = avsLicenceDifferences2LicenceIds lDiff
   lStat <- if getStatus && notNull statQry
             then avsQueryNoCache (AvsQueryStatus statQry)
               -- `catch` handler
@@ -939,7 +954,7 @@ retrieveDifferingLicences' getStatus = do
   return (lDiff, avsResponseStatusMap lStat)
 
 
-getDifferingLicences :: AvsResponseGetLicences -> Handler (AvsLicenceDifferences, Set AvsPersonId)
+getDifferingLicences :: AvsResponseGetLicences -> Handler AvsLicenceDifferences
 getDifferingLicences (AvsResponseGetLicences licences) = do
   now <- liftIO getCurrentTime
   --let (vorfeld, nonvorfeld) = Set.partition (`avsPersonLicenceIs` AvsLicenceVorfeld)  licences
@@ -950,7 +965,7 @@ getDifferingLicences (AvsResponseGetLicences licences) = do
       vorORrollfeld  = Set.map avsLicencePersonID vorORrollfeld'
       rollfeld       = Set.map avsLicencePersonID rollfeld'
 
-      antijoinAvsLicences :: AvsLicence -> Set AvsPersonId -> DBRead (Set AvsPersonId,Set AvsPersonId)
+      antijoinAvsLicences :: AvsLicence -> Set AvsPersonId -> DB (Set AvsPersonId,Set AvsPersonId)
       antijoinAvsLicences lic avsLics = fmap unwrapIds $
        E.select $ do
         ((_qauli :& _qualUser :& usrAvs) :& excl) <-
@@ -976,21 +991,19 @@ 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)) <- runDBRead $ (,)
+  ((vorfGrant, vorfRevoke), (rollGrant, rollRevoke)) <- runDB $ (,)
     <$> 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
-      rsChanged   = rollfeld `Set.intersection` Set.unions [vorfRevoke, rollRevoke, setTo1up] -- maneuvering driving licences to downgrade in AVS
+  return AvsLicenceDifferences
-      alds = AvsLicenceDifferences
+    { avsLicenceDiffRevokeAll      = setTo0
-              { avsLicenceDiffRevokeAll      = setTo0
+    , avsLicenceDiffGrantVorfeld   = setTo1up
-              , avsLicenceDiffGrantVorfeld   = setTo1up
+    , avsLicenceDiffRevokeRollfeld = setTo1down
-              , avsLicenceDiffRevokeRollfeld = setTo1down
+    , avsLicenceDiffGrantRollfeld  = setTo2
-              , 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,10 +169,6 @@ 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
@@ -184,7 +180,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{userCompanyPriority = succ oldPrio}
+            void $ upsertBy (UniqueUserCompany uid newCompanyId) newUserComp
               [UserCompanyPriority =. succ oldPrio, UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False, UserCompanyUseCompanyAddress =. True, UserCompanyReason =. Nothing]
             -- supervised by uid
             supervisees :: [(Entity UserSupervisor, E.Value Bool)] <- E.select $ do
@@ -217,13 +213,15 @@ 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 SupervisorReasonAvsSuperior   )]
+--  ||. [UserSupervisorReason <-. [Just $ tshow r | r <- [SupervisorReasonCompanyDefault, 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
@@ -233,11 +231,10 @@ deleteDefaultSupervisorsForUsers cids sprs usrs =
       $ bcons (notNull sprs) (UserSupervisorSupervisor  <-.  sprs)
       $ (UserSupervisorUser <-. toList usrs) : defaultSupervisorReasonFilter
 
--- | retrieve maximum company user priority fo a user
+-- | deletes user company association and all company related supervision
-getCompanyUserMaxPrio :: UserId -> DB Int
+-- WARNING: does not check for admin problems!
-getCompanyUserMaxPrio uid = do
+deleteCompanyUser :: CompanyId -> [UserId] -> DB (Int64, Int64, Int64)
-  mbMaxPrio <- E.selectOne $ do
+deleteCompanyUser cid uids = (,,)
-    usrCmp <- E.from $ E.table @UserCompany
+    <$> deleteWhereCount  [UserCompanyCompany    ==.      cid,  UserCompanyUser          <-. uids]
-    E.where_ $ usrCmp E.^. UserCompanyUser E.==. E.val uid
+    <*> deleteWhereCount ((UserSupervisorCompany ==. Just cid):(UserSupervisorSupervisor <-. uids) : defaultSupervisorReasonFilter)
-    return . E.max_ $ usrCmp E.^. UserCompanyPriority
+    <*> deleteWhereCount ((UserSupervisorCompany ==. Just cid):(UserSupervisorUser       <-. uids) : defaultSupervisorReasonFilter)
-  return $ maybe 1 (fromMaybe 1 . E.unValue) mbMaxPrio

src/Handler/Utils/DateTime.hs

@@ -10,8 +10,7 @@ module Handler.Utils.DateTime
   , toTimeOfDay
   , toMidnight, beforeMidnight, toMidday, toMorning
   , toFullHour, roundDownToMinutes, addHours
-  , formatDiffDays, formatDiffHours
+  , formatDiffDays, formatCalendarDiffDays
-  , formatCalendarDiffDays
   , formatTime'
   , formatTime, formatTimeUser, formatTimeW, formatTimeMail
   , formatTimeRange, formatTimeRangeW, formatTimeRangeMail
@@ -145,8 +144,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
@@ -161,7 +160,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
@@ -264,21 +263,18 @@ 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
@@ -314,10 +310,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
@@ -397,7 +393,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,20 +71,6 @@ 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,7 +32,6 @@ 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,23 +173,6 @@ 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,41 +396,28 @@ 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)) ()
@@ -468,7 +455,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
-      whenIsJust (qualificationRefreshReminder quali) $ \remindPeriod -> do
+      ifNothingM (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,40 +91,33 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act
                   , jNotification = NotificationQualificationRenewal { nQualification = qid, nReminder = True }
                   }
           _ -> return ()
-      -- send initial reminders
+
-      whenIsJust (qualificationRefreshWithin quali) $ \renewalPeriod -> do  -- no refreshWithin, no first reminders
+      ifNothingM (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 -> Maybe Job
+          let usr_job :: Entity QualificationUser -> 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
-                  unf = quser ^. _entityVal . _qualificationUserLastNotified
+                in if qualificationElearningStart quali
-                  nfy_cutoff = addGregorianDurationClip renewalPeriod $ utctDay unf
+                    then JobLmsEnqueueUser { jQualification = qid, jUser = uid  }
-                  do_notify  = uex > nfy_cutoff || (uex == nfy_cutoff && utctDayTime now >= utctDayTime unf)
+                    else JobUserNotification { jRecipient = uid, jNotification =
-              in if
+                              NotificationQualificationExpiry { nQualification = qid, nExpiry = uex }
-                  | qualificationElearningStart quali     -- repetition avoided since LmsUser does not exist
+                         }
-                    -> Just $ JobLmsEnqueueUser { jQualification = qid, jUser = uid }
+          forM_ renewalUsers (queueDBJob . usr_job)
-                  | do_notify                             -- repetition avoided by QualificationUserLastNotified
+          logInterface "LMS" (qshort <> "-enq") True (Just $ length renewalUsers) ""
-                    -> 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-24 Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
+-- SPDX-FileCopyrightText: 2022-23 Steffen Jost <jost@tcs.ifi.lmu.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -22,22 +22,24 @@ import Text.Hamlet
 
 
 dispatchNotificationQualificationExpiry :: QualificationId -> Day -> UserId -> Handler ()
-dispatchNotificationQualificationExpiry nQualification dExpiry jRecipient = do
+dispatchNotificationQualificationExpiry nQualification dExpiry jRecipient = userMailT jRecipient $ do
-  now <- liftIO getCurrentTime
+  (recipient@User{..}, Qualification{..}) <- liftHandler . runDB $ (,)
-  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
-  userMailT jRecipient $ do
+  expiryDate <- formatTimeUser SelFormatDate dExpiry $ Just entRecipient
-    expiryDate <- formatTimeUser SelFormatDate dExpiry $ Just entRecipient
+
-    replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
+  $logDebugS "LMS" $ "Notify " <> tshow encRecipient <> " about expiry of qualification " <> qname
-    setSubjectI $ MsgMailSubjectQualificationExpiry qname
+
-    editNotifications <- mkEditNotifications jRecipient
+  replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
-    addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/qualificationExpiry.hamlet")
+  setSubjectI $ MsgMailSubjectQualificationExpiry qname
-  runDB $ updateBy (UniqueQualificationUser nQualification jRecipient) [QualificationUserLastNotified =. now]
+
-  $logDebugS "LMS" $ "Notified " <> tshow encRecipient <> " about soonish expiry of qualification " <> qname
+  editNotifications <- mkEditNotifications jRecipient
+
+  addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/qualificationExpiry.hamlet")
 
 
 dispatchNotificationQualificationExpired :: QualificationId -> UserId -> Handler ()
@@ -79,7 +81,7 @@ dispatchNotificationQualificationExpired nQualification jRecipient = do
               $logInfoS  "LMS" $ "Notified " <> tshow encRecipient <> " about expired qualification " <> qname
             else
               $logErrorS "LMS" $ "Failed to notify " <> tshow encRecipient <> " about expired qualification " <> qname
-        else  $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
+        else  $logInfoS  "LMS" $ "Suppressed repeated notification " <> tshow encRecipient <> " about expired qualification " <> qname
     _ ->  $logErrorS "LMS" $ "Failed to notify " <> tshow encRecipient <> " about expired qualification " <> tshow nQualification
 
 

src/Jobs/Handler/SynchroniseAvs.hs

@@ -7,14 +7,11 @@ 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 ((:&)(..))
@@ -26,7 +23,6 @@ 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
@@ -122,66 +118,13 @@ 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 start for #{length linked} AVS linked users and #{length unlinked} unlinked users|]
+    $logInfoS "SynchronisAvs" [st|AVS synch performing 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 end for #{length linked} AVS linked users and #{length unlinked} unlinked users|]
+    $logInfoS "SynchronisAvs" [st|AVS synch performed 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,9 +3,7 @@
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
 module Jobs.Handler.SynchroniseLdap
-  ( dispatchJobSynchroniseLdap
+  ( dispatchJobSynchroniseLdap, dispatchJobSynchroniseLdapUser
-  , dispatchJobSynchroniseLdapUser
-  , dispatchJobSynchroniseLdapAll
   , SynchroniseLdapException(..)
   ) where
 
@@ -51,7 +49,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
@@ -64,6 +62,3 @@ 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,7 +97,6 @@ data Job
                               , jIteration :: Natural
                               }
   | JobSynchroniseLdapUser    { jUser :: UserId }
-  | JobSynchroniseLdapAll
   | JobSynchroniseAvs         { jNumIterations
                               , jEpoch
                               , jIteration :: Natural
@@ -110,7 +109,6 @@ data Job
   --                             , jSynchAfter :: Maybe Day
   --                             }
   | JobSynchroniseAvsQueue
-  | JobSynchroniseAvsLicences
   | JobChangeUserDisplayEmail { jUser :: UserId
                               , jDisplayEmail :: UserEmail
                               }
@@ -351,7 +349,6 @@ 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,12 +501,6 @@ 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    = "Vorgesetzter"
+  show SupervisorReasonAvsSuperior    = "Vorgesetzer"
   show SupervisorReasonUnknown        = "Unbekannt"
 
 

src/Settings.hs

@@ -102,8 +102,6 @@ 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
@@ -250,11 +248,11 @@ data AppSettings = AppSettings
 
     , appCommunicationAttachmentsMaxSize :: Maybe Natural
     , appCommunicationGlobalCC :: Maybe UserEmail
-
+    
     , appFileChunkingParams     :: FastCDCParameters
 
     , appLegalExternal          :: Set LegalExternal
-
+    
     } deriving Show
 
 
@@ -337,21 +335,6 @@ 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
@@ -440,11 +423,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
@@ -540,7 +523,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{..}
@@ -557,17 +540,7 @@ 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
@@ -638,7 +611,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"
@@ -667,7 +640,6 @@ 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,19 +813,6 @@ 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,7 +320,6 @@ 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,7 +222,6 @@ iconText = \case
     -- IconMagic                   -> "wand-magic"
     IconReroute                 -> "directions"
     IconTop                     -> "arrow-to-top"
-    IconWildcard                -> "asterisk"
 nullaryPathPiece ''Icon $ camelToPathPiece' 1
 deriveLift ''Icon
 
@@ -332,10 +331,6 @@ 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,7 +316,6 @@ makeLenses_ ''AuthorshipStatementDefinition
 makeLenses_ ''PrintJob
 
 makeLenses_ ''InterfaceLog
-makeLenses_ ''InterfaceHealth
 makeLenses_ ''AdminProblem
 makeLenses_ ''ProblemLog
 

src/Utils/Message.hs

@@ -228,5 +228,3 @@ 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,21 +17,13 @@ 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)
 
-htmlToPlainText :: Html -> Either P.PandocError Text
+plaintextToHtml :: Text -> Html
-htmlToPlainText html = P.runPure $ P.writePlain htmlWriterOptions =<< P.readHtml     markdownReaderOptions (toStrict $ renderHtml html)
+plaintextToHtml text = fromRight (toMarkup text) $ P.runPure $
-
-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-24 Steffen Jost <s.jost@fraport.de>
+$# SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
 $#
 $# SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -62,9 +62,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
       $else
         _{MsgInterfacesOk}
     ^{interfaceTable}
-    <p>
+
-      <a href=@{ConfigInterfacesR}>
-        _{MsgConfigInterfacesHeading}
 <section>
   <h2>
     _{MsgProblemsHeadingMisc}

templates/avs.hamlet

@@ -35,9 +35,6 @@ $# 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 und Fahrberechtigung Vorfeld gültig in FRADrive
+    Fahrbrechtigung Rollfeld ungültig in FRADrive, aber im AVS vorhanden
   <p>
     ^{tb1down}
   <h3>
@@ -43,41 +43,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
   <p>
     ^{tb1up}
   <h3>
-    Keine gültige Fahrberechtigung in FRADrive, aber im AVS vorhanden (Roll- oder Vorfeld)
+    Keine gültige Fahrberechtigung in FRADrive, aber im AVS vorhanden
   <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 and having a valid 'F' in FRADrive
+    Maneuvering area driving licence 'R' invalid in FRADrive, but valid in AVS
   <p>
     ^{tb1down}
   <h3>
@@ -43,40 +43,6 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
   <p>
     ^{tb1up}
   <h3>
-    No valid driving licence in FRADrive, but having any driving licence in AVS (maneuvering or apron)
+    No valid driving licence in FRADrive, but having a driving licence in AVS
   <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

@@ -1,42 +0,0 @@
-$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

@@ -1,38 +0,0 @@
-$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,15 +5,10 @@ $#
 $# SPDX-License-Identifier: AGPL-3.0-or-later
 
 <section>
-  <p>
+  Bitte beachten, dass Ansprechpartner-Beziehung unabhängig von Firmenzugehörigkeit zwischen Einzelpersonen bestehen.
-    Bitte beachten: Ansprechpartner-Beziehung bestehen unabhängig von Firmenzugehörigkeit zwischen Einzelpersonen! #
+  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, 
-  <p>
+  dass dann <em>x</em> als firmenfremd in der Liste der Ansprechpartner von Firma <em>b</em> angezeigt wird.
-    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,12 +5,9 @@ $#
 $# SPDX-License-Identifier: AGPL-3.0-or-later
 
 <section>
-  <p>
+  Note that supervision is company independent. 
-    Note that supervisionship is company independent! #
+  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>, 
-  <p>
+  then <em>x</em> will be listed as a foreign supervisor for company <em>b</em>.
-    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 = Just "1234.5"
+    , userPinPassword = Nothing
     , 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 = False
+    , userPrefersPostal = True
     , userExamOfficeGetSynced = userDefaultExamOfficeGetSynced
     , userExamOfficeGetLabels = userDefaultExamOfficeGetLabels
     }
@@ -202,7 +202,7 @@ fillDb = do
     , userPinPassword = Nothing
     , userPostAddress = Nothing
     , userPostLastUpdate = Nothing
-    , userPrefersPostal = False
+    , userPrefersPostal = True
     , 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 $ tshow SupervisorReasonAvsSuperior
+  void . insert' $ UserCompany jost    fraportAg    True   True  0 False $ Just "Vorgesetzter"
-  void . insert' $ UserCompany svaupel nice         True   False 2 False $ Just $ tshow SupervisorReasonAvsSuperior
+  void . insert' $ UserCompany svaupel nice         True   False 2 False $ Just "Vorgesetzter"
   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 $ tshow SupervisorReasonAvsSuperior
+  void . insert' $ UserCompany gkleen  bpol         False  True  1 False $ Just "Irgendwas"
   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 $ tshow SupervisorReasonAvsSuperior)
+  let supvs = [ UserSupervisor jost gkleen            True  (Just fraportAg)  (Just "Staff")
-              , UserSupervisor jost svaupel           False (Just fraportAg)  (Just $ tshow SupervisorReasonAvsSuperior)
+              , UserSupervisor jost svaupel           False (Just fraportAg)  (Just "Staff")
               , 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 $ tshow SupervisorReasonAvsSuperior)
+              , UserSupervisor sbarth tinaTester      True  (Just nice)       (Just "Staff")
               , 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 10) (n_day $ -40) (n_day $ -120) True  (n_day' $ -20)
+  qfkleen <- insert' $ QualificationUser gkleen qid_f  (n_day 33) (n_day $ -4) (n_day $ -20) True  (n_day' $ -9)
   void . insert  $ QualificationUserBlock qfkleen False (n_day' 1) "Future block"   (Just svaupel)
   void . insert' $ QualificationUser maxMuster  qid_f (n_day    0) (n_day $ -2) (n_day $  -8) False (n_day' $ -1)
   qfvaupel <- insert' $ QualificationUser svaupel    qid_f (n_day    2) (n_day $ -1) (n_day $  -2) True  (n_day' $ -9)