Compare commits
No commits in common. "master" and "v27.4.76" have entirely different histories.
37
CHANGELOG.md
37
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)
|
||||
|
||||
|
||||
|
||||
@ -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);
|
||||
|
||||
|
||||
@ -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.
|
||||
AdminProblemCompanySuperiorNotFound t@Text: Neuer unbekannter firmenweiter Vorgesetzter mit E-Mail #{t}, keine Ansprechpartnerbeziehungen eingerichtet.
|
||||
AdminProblemCompanySuperiorPrevious: Ehemaliger Vorgesetzter:
|
||||
AdminProblemCompanySuperiorChange: Neuer firmenweiter Vorgesetzer.
|
||||
AdminProblemCompanySuperiorPrevious: Ehemaliger Vorgesetzer:
|
||||
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
|
||||
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
|
||||
InterfaceFreshness: Prüfungszeitraum (h)
|
||||
@ -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
|
||||
ProblemAvsUsrHadR: Currenlt R valid in AVS
|
||||
ProblemsInterfaceSince: Only considering successes and errors since
|
||||
|
||||
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
|
||||
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
|
||||
InterfaceFreshness: Check hours
|
||||
@ -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.
|
||||
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.
|
||||
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.")}
|
||||
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
|
||||
|
||||
@ -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.
|
||||
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.
|
||||
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.")}
|
||||
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
|
||||
|
||||
@ -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")}
|
||||
|
||||
@ -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")}
|
||||
|
||||
@ -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!
|
||||
SynchroniseAvsAllUsersQueued n@Int64: AVS-Synchronisation von allen #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} angestoßen, welche heute noch nicht synchronisiert wurden, die Ausführung wird eine Weile brauchen!
|
||||
SynchroniseLdapUserQueued n@Int: LDAP-Synchronisation von #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} angestoßen, die Ausführung wird mehrere Minuten benötigen!
|
||||
SynchroniseLdapAllUsersQueued: LDAP-Synchronisation von allen Benutzer:innen angestoßen, die Ausführung kann eine Weile brauchen!
|
||||
SynchroniseAvsUserQueued n@Int: AVS-Synchronisation von #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} zwingend angestoßen
|
||||
SynchroniseAvsAllUsersQueued n@Int64: AVS-Synchronisation von allen #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} angestoßen, welche heute noch nicht synchronisiert wurden
|
||||
SynchroniseLdapUserQueued n@Int: LDAP-Synchronisation von #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} angestoßen
|
||||
SynchroniseLdapAllUsersQueued: LDAP-Synchronisation von allen Benutzer:innen angestoßen
|
||||
UserListTitle: Komprehensive Benutzerliste
|
||||
AccessRightsSaved: Berechtigungen erfolgreich verändert
|
||||
AccessRightsNotChanged: Berechtigungen wurden nicht verändert
|
||||
|
||||
@ -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.
|
||||
SynchroniseAvsAllUsersQueued n: Triggered AVS synchronisation of all #{n} #{pluralEN n "user" "users"} that were not already synchronised today, which may take quite a while to complete.
|
||||
SynchroniseLdapUserQueued n: Triggered LDAP synchronisation of #{n} #{pluralEN n "user" "users"}, which may take several minutes to complete.
|
||||
SynchroniseLdapAllUsersQueued: Triggered LDAP synchronisation of all users, which may take quite a while to complete.
|
||||
SynchroniseAvsUserQueued n: Triggered forced AVS synchronisation of #{n} #{pluralEN n "user" "users"}
|
||||
SynchroniseAvsAllUsersQueued n: Triggered AVS synchronisation of all #{n} #{pluralEN n "user" "users"} that were not already synchronised today
|
||||
SynchroniseLdapUserQueued n: Triggered LDAP synchronisation of #{n} #{pluralEN n "user" "users"}
|
||||
SynchroniseLdapAllUsersQueued: Triggered LDAP synchronisation of all users
|
||||
UserListTitle: Comprehensive list of users
|
||||
AccessRightsSaved: Successfully updated permissions
|
||||
AccessRightsNotChanged: Permissions left unchanged
|
||||
|
||||
@ -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"}
|
||||
|
||||
@ -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"}
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -153,7 +153,6 @@ MenuCommCenter: Notifications
|
||||
MenuMailCenter: Email
|
||||
MenuMailHtml: Html
|
||||
MenuMailPlain: Text
|
||||
MenuMailAttachment: Attachment
|
||||
|
||||
MenuApiDocs: API documentation
|
||||
MenuSwagger: OpenAPI 2.0 (Swagger)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -1,3 +1,3 @@
|
||||
{
|
||||
"version": "27.4.79"
|
||||
"version": "27.4.76"
|
||||
}
|
||||
|
||||
2
package-lock.json
generated
2
package-lock.json
generated
@ -1,6 +1,6 @@
|
||||
{
|
||||
"name": "uni2work",
|
||||
"version": "27.4.79",
|
||||
"version": "27.4.76",
|
||||
"lockfileVersion": 1,
|
||||
"requires": true,
|
||||
"dependencies": {
|
||||
|
||||
@ -1,6 +1,6 @@
|
||||
{
|
||||
"name": "uni2work",
|
||||
"version": "27.4.79",
|
||||
"version": "27.4.76",
|
||||
"description": "",
|
||||
"keywords": [],
|
||||
"author": "",
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: uniworx
|
||||
version: 27.4.79
|
||||
version: 27.4.76
|
||||
dependencies:
|
||||
- base
|
||||
- yesod
|
||||
|
||||
4
routes
4
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
|
||||
|
||||
25
src/Audit.hs
25
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
|
||||
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{..}
|
||||
insert_ ProblemLog{..}
|
||||
$logWarnS "Problem" $ Text.filter (/= '\n') $ tshow problem -- <> " - " <> pack (prettyCallStack callStack)
|
||||
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -9,9 +9,8 @@ module Handler.Admin
|
||||
import Import
|
||||
|
||||
-- import Data.Either
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
-- 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 = postProblemUnreachableR
|
||||
postProblemUnreachableR = do
|
||||
getProblemUnreachableR :: Handler Html
|
||||
getProblemUnreachableR = 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
|
||||
-- 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{..}
|
||||
mkProblemLogTable = 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)
|
||||
]
|
||||
|
||||
@ -266,128 +266,33 @@ postAdminAvsR = do
|
||||
|
||||
|
||||
(qryLicForm, qryLicRes) <- runButtonForm FIDAvsQueryLicenceDiffs
|
||||
(mbQryLic :: Maybe Widget, mbAutoDiffs :: Maybe Html) <- case qryLicRes of
|
||||
Nothing -> return mempty
|
||||
mbQryLic <- case qryLicRes of
|
||||
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 chgs = Set.filter ((l ==) . avsLicenceRampLicence) diffs
|
||||
in if Set.null chgs
|
||||
then ("[ ]", 0)
|
||||
else (Text.intercalate ", " (tshow . avsLicencePersonID <$> Set.toList chgs), Set.size chgs)
|
||||
(r_grant, rg_size) = showLics AvsLicenceRollfeld
|
||||
(f_set , fs_size) = showLics AvsLicenceVorfeld
|
||||
(revoke , rv_size) = showLics AvsNoLicence
|
||||
let showLics l = Text.intercalate ", " $ fmap (tshow . avsLicencePersonID) $ Set.toList $ Set.filter ((l ==) . avsLicenceRampLicence) diffs
|
||||
r_grant = showLics AvsLicenceRollfeld
|
||||
f_set = showLics AvsLicenceVorfeld
|
||||
revoke = showLics AvsNoLicence
|
||||
return $ Just [whamlet|
|
||||
<h2>Licence check AVS-ID differences:
|
||||
<dl .deflist>
|
||||
<dt .deflist__dt>Grant R (#{rg_size}):
|
||||
<dd .deflist__dd>#{r_grant}
|
||||
|
||||
<dt .deflist__dt>Set to F (#{fs_size}):
|
||||
<dd .deflist__dd>#{f_set}
|
||||
|
||||
<dt .deflist__dt>Revoke licence (#{rv_size}):
|
||||
<dd .deflist__dd>#{revoke}
|
||||
<h2>Licence check differences:
|
||||
<h3>Grant R:
|
||||
<p>
|
||||
#{r_grant}
|
||||
<h3>Set to F:
|
||||
<p>
|
||||
#{f_set}
|
||||
<h3>Revoke licence:
|
||||
<p>
|
||||
#{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
|
||||
let mkLicTbl = mkLicenceTable apidStatus rsChanged
|
||||
(AvsLicenceDifferences{..}, apidStatus) <- catchAllAvs' AdminR retrieveDifferingLicencesStatus
|
||||
|
||||
--
|
||||
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
|
||||
<*> mkLicTbl "avsLicDiffGrantVorfeld" AvsNoLicence avsLicenceDiffGrantVorfeld
|
||||
<*> mkLicTbl "avsLicDiffRevokeRollfeld" AvsLicenceRollfeld avsLicenceDiffRevokeRollfeld -- downgrade to Vorfeld
|
||||
<*> mkLicTbl "avsLicDiffGrantRollfeld" AvsNoLicence avsLicenceDiffGrantRollfeld
|
||||
<$> mkLicenceTable apidStatus "avsLicDiffRevokeVorfeld" AvsLicenceVorfeld avsLicenceDiffRevokeAll
|
||||
<*> mkLicenceTable apidStatus "avsLicDiffGrantVorfeld" AvsNoLicence avsLicenceDiffGrantVorfeld
|
||||
<*> mkLicenceTable apidStatus "avsLicDiffRevokeRollfeld" AvsLicenceRollfeld avsLicenceDiffRevokeRollfeld
|
||||
<*> 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 apidStatus rsChanged dbtIdent aLic apids = do
|
||||
(currentRoute, usrHasAvsRerr) <- liftHandler $ (,)
|
||||
<$> (fromMaybe (error "mkLicenceTable called from 404-handler") <$> liftHandler getCurrentRoute)
|
||||
<*> (messageTooltip <$> messageI Error MsgProblemAvsUsrHadR)
|
||||
mkLicenceTable :: AvsPersonIdMapPersonCard -> Text -> AvsLicence -> Set AvsPersonId -> DB (FormResult (LicenceTableActionData, Set AvsPersonId), Widget)
|
||||
mkLicenceTable apidStatus dbtIdent aLic apids = do
|
||||
currentRoute <- fromMaybe (error "mkLicenceTable called from 404-handler") <$> liftHandler getCurrentRoute
|
||||
avsQualifications <- selectList [QualificationAvsLicence !=. Nothing] [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) $
|
||||
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 "qualification") (i18nCell MsgTableQualifications) $ \(preview resultQualification -> q) -> cellMaybe lmsShortCell q
|
||||
, sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \(preview $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> cellMaybe dayCell d
|
||||
, sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \(preview $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> cellMaybe dayCell d
|
||||
-- , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \(preview $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> cellMaybe dayCell d
|
||||
|
||||
@ -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)}
|
||||
|]
|
||||
|
||||
|
||||
|
||||
|
||||
@ -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-address") mPrev $ aopt textField (fslI MsgFirmAddress)
|
||||
, prismAForm (singletonFilter "company-postal" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterFirmExtern)
|
||||
, 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)
|
||||
, firmUserActSetSuperIds :: Maybe [UserId]
|
||||
, firmUserActSetSuperReason :: Maybe Text
|
||||
, firmUserActSetSuperReroute :: Bool
|
||||
, firmUserActResetSupers :: Maybe Bool
|
||||
{ firmUserActSetSuperNames :: Maybe (Set Text)
|
||||
, firmUserActSetSuperIds :: Maybe [UserId]
|
||||
, firmUserActSetSuperReason :: Maybe Text
|
||||
, firmUserActSetSuperReroute :: Bool
|
||||
, firmUserActSetSuperKeep :: Bool
|
||||
}
|
||||
| FirmUserActMkSuperData
|
||||
{ firmUserActMkSuperReroute :: Maybe Bool }
|
||||
{ firmUserActMkSuperReroute :: Maybe Bool }
|
||||
| FirmUserActChangeDetailsData
|
||||
{ firmUserActDetailPriority :: Maybe Int
|
||||
, firmUserActDetailReason :: Maybe Text
|
||||
{ firmUserActDetailPriority :: Maybe Int
|
||||
, firmUserActDetailReason :: Maybe Text
|
||||
}
|
||||
| FirmUserActChangeContactData
|
||||
{ firmUserActPostalAddr :: Maybe StoredMarkup
|
||||
, firmUserActUseCompanyPostal :: Maybe Bool
|
||||
, firmUserActPostalPref :: Maybe Bool
|
||||
{ firmUserActPostalAddr :: Maybe StoredMarkup
|
||||
, firmUserActUseCompanyPostal :: 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, E.Value mbmbReason) = do
|
||||
mkSprOption (E.Value uid, E.Value udn, E.Value mbSpr) = 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 , False) <- procSupers])
|
||||
, (mr MsgFirmSuperIrregular, [opt | (opt, Just False, False) <- procSupers])
|
||||
, (mr MsgFirmSuperForeign , [opt | (opt, Nothing , False) <- procSupers])
|
||||
[ (mr MsgFirmSuperDefault , [opt | (opt, Just True ) <- procSupers])
|
||||
, (mr MsgFirmSuperIrregular, [opt | (opt, Just False) <- procSupers])
|
||||
, (mr MsgFirmSuperForeign , [opt | (opt, Nothing ) <- 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
|
||||
<*> areq boolField' (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just False)
|
||||
<*> aopt (boolFieldCustom (SomeMessage MsgFirmActResetSupersRemoveAll) (SomeMessage MsgFirmActResetSupersRemoveAps) $ Just $ SomeMessage MsgFirmActResetSupersKeepAll) (fslI MsgFirmActResetSuperKeep) (Just $ Just False)
|
||||
<*> aopt (textField & cfStrip & addDatalist superReasons) (fslI MsgUserSupervisorReason & setTooltip MsgUserSupervisorReasonTooltip) Nothing
|
||||
<*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (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
|
||||
let optRemove = if firmUserActRemoveSupers then id else const $ return 0
|
||||
(nrUc, nrSuper, nrSubs) <- runDB $ (,,)
|
||||
<$> deleteWhereCount [UserCompanyCompany ==. cid, UserCompanyUser <-. uids]
|
||||
<*> optRemove (deleteWhereCount [UserSupervisorCompany ==. Just cid, UserSupervisorSupervisor <-. uids])
|
||||
<*> optRemove (deleteWhereCount [UserSupervisorCompany ==. Just cid, UserSupervisorUser <-. uids])
|
||||
(FirmUserActRemoveData{}, Set.toList -> uids) -> do
|
||||
(nrUc, nrSuper, nrSubs) <- runDB $ deleteCompanyUser cid uids
|
||||
let total = fromIntegral $ length uids
|
||||
allok = bool Warning Success $ total == nrUc
|
||||
addMessageI allok $ someMessages [MsgFirmUserActRemoveResult nrUc, MsgFirmRemoveSupervision nrSuper nrSubs]
|
||||
allok = bool Warning Success $ nrUc == total
|
||||
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)
|
||||
-- let uc_reason = E.joinV (usrCmp E.?. UserCompanyReason)
|
||||
E.where_ $ E.isTrue (usrCmp E.?. UserCompanySupervisor)
|
||||
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.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)
|
||||
, E.exists (firmQuerySupervisedBy cid (Just (\usrSpr -> usrSpr E.^. UserSupervisorReason E.==. E.val 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
|
||||
Nothing -> iconCell IconSupervisorForeign
|
||||
(Just True ) -> iconCell IconSupervisor
|
||||
(Just False) -> iconSpacerCell
|
||||
, sortable Nothing (i18nCell MsgTableSuperior) $ view resultSuperCompanySuperior >>> flip ifIconCell IconSuperior
|
||||
-- , sortable (Just "def-super") (i18nCell MsgTableIsDefaultSupervisor) $ \(view resultSuperCompanyDefaultSuper -> mb) -> case mb of { Nothing -> iconCell IconSupervisorForeign; Just True -> iconCell IconSupervisor; Just False -> iconSpacerCell }
|
||||
, sortable (Just "def-super") (i18nCell MsgTableIsDefaultSupervisor) $ \row ->
|
||||
let mb = row ^. resultSuperCompanyDefaultSuper
|
||||
sp = row ^. resultSuperCompanySuperior
|
||||
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' (fslI MsgTableIsDefaultReroute) Nothing
|
||||
<$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableIsDefaultSupervisor) (Just $ Just True)
|
||||
<*> 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,nrRmSupers,nrRmSubs) <- runDB $ (,,)
|
||||
(nrRmSuper,nrRmActual) <- runDB $ (,)
|
||||
<$> updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False]
|
||||
<*> optRemove (deleteWhereCount [UserSupervisorCompany ==. Just cid, UserSupervisorSupervisor <-. uids])
|
||||
<*> optRemove (deleteWhereCount [UserSupervisorCompany ==. Just cid, UserSupervisorUser <-. uids])
|
||||
let total = fromIntegral $ length uids
|
||||
allok = bool Warning Success $ total == nrRmSuper
|
||||
addMessageI allok $ someMessages [MsgRemoveSupervisors nrRmSuper, MsgFirmRemoveSupervision nrRmSupers nrRmSubs]
|
||||
<*> if firmSuperActRMSuperActive /= Just True
|
||||
then return 0
|
||||
else E.deleteCount $ do
|
||||
spr <- E.from $ E.table @UserSupervisor
|
||||
E.where_ $ spr E.^. UserSupervisorSupervisor `E.in_` E.vals uids
|
||||
E.&&. E.exists (do
|
||||
usr <- E.from $ E.table @UserCompany
|
||||
E.where_ $ usr E.^. UserCompanyCompany E.==. E.val cid
|
||||
E.&&. usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser
|
||||
)
|
||||
addMessageI Info $ MsgRemoveSupervisors nrRmSuper nrRmActual
|
||||
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")
|
||||
|
||||
@ -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
|
||||
diffTime t =
|
||||
let tdiff = diffUTCTime currtime t
|
||||
in if 64 > abs tdiff
|
||||
then tshow tdiff
|
||||
else pack . iso8601Show . calendarTimeTime . fromIntegral $ truncate tdiff
|
||||
|
||||
withUrlRenderer
|
||||
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>
|
||||
#{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>
|
||||
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
|
||||
-- vnr_full :: Text = $(embedStringFile "nix/docker/version.json") -- nix/ files not accessible during container construction
|
||||
where
|
||||
-- vnr_full :: Text = $(embedStringFile "nix/docker/version.json") -- nix/ files not accessible during container construction
|
||||
cTime :: UTCTime
|
||||
cTime = $compileTime
|
||||
cTime = $compileTime
|
||||
|
||||
ddays :: UTCTime -> UTCTime -> Double
|
||||
ddays tstart tstop = (/100) $ fromIntegral $ round $ diffUTCTime tstop tstart / (36 * 24)
|
||||
|
||||
@ -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.Map as Map
|
||||
-- import qualified Data.Set as Set
|
||||
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 interfs@(reqIfs, banIfs) = do
|
||||
mkInterfaceLogTable :: (Bool -> Widget) -> ReqBanInterfaceHealth -> DB ([(Text,Bool)], Widget)
|
||||
mkInterfaceLogTable flagError interfs@(reqIfs, banIfs) = do
|
||||
-- $logWarnS "DEBUG" $ tshow ([ihDebugShow x | x<- reqIfs], [ihDebugShow x | x<- banIfs])
|
||||
flagError <- liftHandler $ do
|
||||
void $ timeoutHandler 42000001 $ runDB $ runInterfaceChecks interfs -- ensure interface checkc are up to date
|
||||
mkErrorFlag
|
||||
void $ liftHandler $ timeoutHandler 42000001 $ runDB $ runInterfaceChecks interfs
|
||||
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)
|
||||
in tellCell [(iface,status)] $ wgtCell $ flagError $ toMaybe (success || not status) status
|
||||
status = success && (hours < 0 || now <= addHours hours logtime)
|
||||
in tellCell [(iface,status)] $
|
||||
wgtCell $ flagError status
|
||||
, sortable (Just "interface") (i18nCell MsgInterfaceName ) $ \(view (resultILog . _interfaceLogInterface) -> n) -> textCell n
|
||||
, sortable (Just "subtype") (i18nCell MsgInterfaceSubtype ) $ textCell . view (resultILog . _interfaceLogSubtype)
|
||||
, sortable (Just "write") (i18nCell MsgInterfaceWrite ) $ (`ifIconCell` IconEdit) . view (resultILog . _interfaceLogWrite)
|
||||
, sortable (Just "time") (i18nCell MsgInterfaceLastSynch ) $ dateTimeCell . view (resultILog . _interfaceLogTime)
|
||||
, sortable (Just "hours") (i18nCell MsgInterfaceFreshness & cellTooltips [SomeMessage MsgInterfaceFreshnessTooltip, SomeMessage MsgTableDiffDaysTooltip]
|
||||
) $ warnIntervalCell . view resultHours
|
||||
, sortable Nothing (i18nCell MsgInterfaceFreshness ) $ numCell . view resultHours
|
||||
, sortable (Just "rows") (i18nCell MsgTableRows ) $ cellMaybe numCell . view (resultILog . _interfaceLogRows)
|
||||
, sortable (Just "success") (i18nCell MsgInterfaceSuccess ) $ \(view (resultILog . _interfaceLogSuccess) -> s) -> iconBoolCell s
|
||||
, sortable Nothing (i18nCell MsgInterfaceInfo ) $ \(view resultILog -> ilt) -> case ilt of
|
||||
@ -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")
|
||||
@ -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
|
||||
resultCompanyId = _dbrOutput . _6 . _unValue . _Just
|
||||
resultCompanyUser :: Lens' LmsTableData [Entity UserCompany]
|
||||
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.&&. ((lmsUser E.^. LmsUserIdent) E.=?. (pj E.^. PrintJobLmsUser))
|
||||
let pjOrder = [E.desc $ pj E.^. PrintJobCreated, E.desc $ pj E.^. PrintJobAcknowledged] -- latest created comes first! This is assumed to be the case later on!
|
||||
pure $ --(E.arrayAggWith E.AggModeAll (pj E.^. PrintJobCreated ) pjOrder, -- return two aggregates only works with select, the restricted type of subSelect does not seem to support this!
|
||||
E.arrayAggWith E.AggModeAll (pj E.^. PrintJobAcknowledged) pjOrder
|
||||
primeComp = E.subSelect . E.from $ \uc -> do
|
||||
E.where_ $ user E.^. UserId E.==. uc E.^. UserCompanyUser
|
||||
E.orderBy [E.desc $ uc E.^. UserCompanyPriority, E.asc $ uc E.^. UserCompanyCompany]
|
||||
return (uc E.^. UserCompanyCompany)
|
||||
return (qualUser, user, lmsUser, qualBlock, printAcknowledged, primeComp, validQualification now qualUser)
|
||||
E.where_ $ E.isJust (pj E.^. PrintJobLmsUser)
|
||||
E.&&. ((lmsUser E.^. LmsUserIdent) E.=?. (pj E.^. PrintJobLmsUser))
|
||||
let pjOrder = [E.desc $ pj E.^. PrintJobCreated, E.desc $ pj E.^. PrintJobAcknowledged] -- latest created comes first! This is assumed to be the case later on!
|
||||
pure $ --(E.arrayAggWith E.AggModeAll (pj E.^. PrintJobCreated ) pjOrder, -- return two aggregates only works with select, the restricted type of subSelect does not seem to support this!
|
||||
E.arrayAggWith E.AggModeAll (pj E.^. PrintJobAcknowledged) pjOrder
|
||||
return (qualUser, user, lmsUser, qualBlock, printAcknowledged, validQualification now qualUser)
|
||||
|
||||
|
||||
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
|
||||
dbtColonnade = cols getCompanyName
|
||||
dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr, qUsrBlock, printAcks, validQ) -> do
|
||||
cmpUsr <- selectList [UserCompanyUser ==. entityKey usr] [Desc UserCompanyPriority, Asc UserCompanyCompany, LimitTo 1]
|
||||
return (qualUsr, usr, lmsUsr, qUsrBlock, printAcks, cmpUsr, validQ)
|
||||
dbtColonnade = cols cmpMap
|
||||
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 (resultQualUser . _entityVal . _qualificationUserValidUntil)
|
||||
<*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh)
|
||||
<*> view (resultQualUser . _entityVal . _qualificationUserFirstHeld)
|
||||
<*> (view resultCompanyUser >>= getCompanies)
|
||||
<*> (view resultCompanyUser >>= getCompanyNos)
|
||||
<*> view (resultQualUser . _entityVal . _qualificationUserValidUntil)
|
||||
<*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh)
|
||||
<*> view (resultQualUser . _entityVal . _qualificationUserFirstHeld)
|
||||
<*> preview (resultQualBlock . _entityVal . _qualificationUserBlockUnblock . _not)
|
||||
<*> preview (resultQualBlock . _entityVal . _qualificationUserBlockFrom)
|
||||
<*> view (resultLmsUser . _entityVal . _lmsUserIdent)
|
||||
<*> view (resultLmsUser . _entityVal . _lmsUserStatus)
|
||||
<*> view (resultLmsUser . _entityVal . _lmsUserStatusDay)
|
||||
<*> view (resultLmsUser . _entityVal . _lmsUserStarted)
|
||||
<*> view (resultLmsUser . _entityVal . _lmsUserDatePin)
|
||||
<*> view (resultLmsUser . _entityVal . _lmsUserReceived)
|
||||
<*> view (resultLmsUser . _entityVal . _lmsUserNotified) -- TODO: only exports last email date / print job sending date, not print acknowledge
|
||||
<*> view (resultLmsUser . _entityVal . _lmsUserEnded)
|
||||
<*> view (resultLmsUser . _entityVal . _lmsUserIdent)
|
||||
<*> view (resultLmsUser . _entityVal . _lmsUserStatus)
|
||||
<*> view (resultLmsUser . _entityVal . _lmsUserStatusDay)
|
||||
<*> view (resultLmsUser . _entityVal . _lmsUserStarted)
|
||||
<*> view (resultLmsUser . _entityVal . _lmsUserDatePin)
|
||||
<*> view (resultLmsUser . _entityVal . _lmsUserReceived)
|
||||
<*> view (resultLmsUser . _entityVal . _lmsUserNotified) -- TODO: only exports last email date / print job sending date, not print acknowledge
|
||||
<*> view (resultLmsUser . _entityVal . _lmsUserEnded)
|
||||
getCompanies cmps = case mapMaybe (flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) cmps of
|
||||
[] -> pure Nothing
|
||||
somecmps -> pure $ Just $ intercalate ", " $ fmap (view (_companyName . _CI)) somecmps
|
||||
getCompanyNos = pure . CsvSemicolonList . mapMaybe (preview (_Just . _companyAvsId) . flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany))
|
||||
|
||||
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) ->
|
||||
maybeEmpty mcid $ \cid -> companyCell (unCompanyKey cid) (getCompanyName cid) False
|
||||
, sortable (Just "user-company") (i18nCell MsgTableCompany) $ \( view resultCompanyUser -> cmps) ->
|
||||
let cs = [ companyCell (unCompanyKey cmpId) cmpName cmpSpr
|
||||
| Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps
|
||||
, let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap
|
||||
]
|
||||
in intercalate spacerCell cs
|
||||
, colUserMatriclenr isAdmin
|
||||
-- , sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser)
|
||||
, sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d
|
||||
|
||||
@ -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 ("regex" , FilterColumn . E.mkRegExFilterWith id $ views (to queryMail) (E.str2text . (E.^. SentMailHeaders)))
|
||||
, single ("subject" , FilterColumn . E.mkContainsFilter $ 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
|
||||
^{part2widget cusm pt}
|
||||
$forall mc <- mcontent
|
||||
$maybe pt <- selectAlternative prefTypes mc
|
||||
<p>
|
||||
^{part2widget pt}
|
||||
|]
|
||||
-- Include for Debugging:
|
||||
-- <section>
|
||||
-- <h2>Debugging
|
||||
-- <p>
|
||||
-- ^{jsonWidget (sm ^. _sentMailHeaders)}
|
||||
-- <p>
|
||||
-- ^{jsonWidget (sentMailContentContent cn)} -- content fields needs decoding of base64 to make sense here
|
||||
-- Include for Debugging:
|
||||
-- ^{jsonWidget (sm ^. _sentMailHeaders)}
|
||||
-- ^{jsonWidget (sentMailContentContent cn)}
|
||||
|
||||
|
||||
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 (InlineDisposition n) = [whamlet|<h3>_{MsgMenuMailAttachment} #{n}|]
|
||||
disposition2widget (AttachmentDisposition n) = [whamlet|<h3>Attachment #{n}|]
|
||||
disposition2widget (InlineDisposition n) = [whamlet|<h3>#{n}|]
|
||||
disposition2widget DefaultDisposition = mempty
|
||||
|
||||
part2widget :: CryptoUUIDSentMail -> Part -> Widget
|
||||
part2widget cusm Part{partContent=NestedParts ps} =
|
||||
part2widget :: Part -> Widget
|
||||
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 typeHtml = toWidget $ preEscapedToHtml $ plainHtmlToHtml $ decodeUtf8 pc -- preEscapedToHtml :: ToMarkup a => a -> Html
|
||||
| pt == decodeUtf8 typePlain = toWidget $ preEscapedToHtml $ plaintextToHtml $ decodeUtf8 pc
|
||||
| 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
|
||||
, 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
|
||||
| otherwise = [whamlet|part2widget cannot decode parts of type #{pt} yet.|]
|
||||
|
||||
|
||||
------------------------------
|
||||
-- Decode MIME Encoded Word
|
||||
|
||||
@ -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
|
||||
spr <- E.from $ E.table @UserSupervisor
|
||||
E.where_ $ spr E.^. UserSupervisorSupervisor E.==. E.val uid
|
||||
return (E.countRows, E.count (spr E.^. UserSupervisorId) `E.filterWhere` (spr E.^. UserSupervisorRerouteNotifications))
|
||||
countSupervisors <- E.select $ do
|
||||
spr <- E.from $ E.table @UserSupervisor
|
||||
E.where_ $ spr E.^. UserSupervisorUser E.==. E.val uid
|
||||
return (E.countRows, E.count (spr E.^. UserSupervisorId) `E.filterWhere` (spr E.^. UserSupervisorRerouteNotifications))
|
||||
let errorCount ((E.Value x, E.Value y):_) = (x,y)
|
||||
errorCount _ = (-1,-1)
|
||||
supervisorsWgt :: Widget =
|
||||
let (nrSupers, nrSupersReroute) = errorCount countSupervisors
|
||||
in maybeTable' (MsgProfileSupervisor nrSupers nrSupersReroute) (Just MsgProfileNoSupervisor)
|
||||
(toMaybe (nrSupersReroute > 0) $ msg2widget $ MsgProfileSupervisorRemark nrSupers nrSupersReroute 0) (nrSupers > 0, supervisorsTable)
|
||||
let supervisorsWgt :: Widget =
|
||||
let ((getSum -> nrSupers, getSum -> nrReroute, getSum -> nrLetter), tWgt) = supervisorsTable
|
||||
in maybeTable' (MsgProfileSupervisor nrSupers nrReroute) (Just MsgProfileNoSupervisor)
|
||||
(toMaybe (nrReroute > 0) $ msg2widget $ MsgProfileSupervisorRemark nrSupers nrReroute nrLetter) (nrSupers > 0, tWgt)
|
||||
superviseesWgt :: Widget =
|
||||
let (nrUnderlings, nrUndersReroute) = errorCount countUnderlings
|
||||
in maybeTable' (MsgProfileSupervisee nrUnderlings nrUndersReroute) (Just MsgProfileNoSupervisee)
|
||||
(toMaybe (nrUndersReroute > 0) $ msg2widget $ MsgProfileSuperviseeRemark nrUnderlings nrUndersReroute) (nrUnderlings > 0, superviseesTable)
|
||||
let ((getSum -> nrSubs, getSum -> nrReroute), tWgt) = superviseesTable
|
||||
in maybeTable' (MsgProfileSupervisee nrSubs nrReroute) (Just MsgProfileNoSupervisee)
|
||||
(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 uid = dbTableWidget' validator DBTable{..}
|
||||
mkSupervisorsTable :: UserId -> DB ((Sum Int, Sum Int, Sum Int), Widget)
|
||||
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 userPrefersPostal uid = dbTableWidget' validator DBTable{..}
|
||||
mkSuperviseesTable ::Bool -> UserId -> DB ((Sum Int, Sum Int), Widget)
|
||||
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
|
||||
]
|
||||
|
||||
@ -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
|
||||
resultCompanyId = _dbrOutput . _5 . _unValue . _Just
|
||||
resultCompanyUser :: Lens' QualificationTableData [Entity UserCompany]
|
||||
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
|
||||
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)
|
||||
return (qualUser, user, lmsUser, qualBlock)
|
||||
|
||||
|
||||
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
|
||||
dbtColonnade = cols getCompanyName
|
||||
dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr, qUsrBlock) -> do
|
||||
-- cmps <- E.select . E.from $ \(usrComp `E.InnerJoin` comp) -> do
|
||||
-- E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
|
||||
-- E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val (entityKey usr)
|
||||
-- E.orderBy [E.asc (comp E.^. CompanyName)]
|
||||
-- return (comp E.^. CompanyName, comp E.^. CompanyAvsId, usrComp E.^. UserCompanySupervisor)
|
||||
cmpUsr <- selectList [UserCompanyUser ==. entityKey usr] [Desc UserCompanyPriority, Asc UserCompanyCompany, LimitTo 1]
|
||||
return (qualUsr, usr, lmsUsr, qUsrBlock, cmpUsr)
|
||||
dbtColonnade = cols cmpMap
|
||||
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) ->
|
||||
maybeEmpty mcid $ \cid -> companyCell (unCompanyKey cid) (getCompanyName cid) False
|
||||
, sortable (Just "user-company") (i18nCell MsgTableCompany) $ \( view resultCompanyUser -> cmps) ->
|
||||
let cs = [ companyCell (unCompanyKey cmpId) cmpName cmpSpr
|
||||
| Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps
|
||||
, let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap
|
||||
]
|
||||
in intercalate spacerCell cs
|
||||
, 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
|
||||
|
||||
@ -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 boolField' (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just False)
|
||||
<$> apopt (textField & cfAnySeparatedSet) (fslI MsgTableSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing
|
||||
<*> 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 boolField' (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just False)
|
||||
<$> apopt (textField & cfAnySeparatedSet) (fslI MsgTableSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing
|
||||
<*> 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
|
||||
queueJob' JobSynchroniseLdapAll
|
||||
runDBJobs . runConduit $ selectSource [] [] .| C.mapM_ (queueDBJob . JobSynchroniseLdapUser . entityKey)
|
||||
addMessageI Success MsgSynchroniseLdapAllUsersQueued
|
||||
redirect UsersR
|
||||
AllUsersAvsSync -> do
|
||||
|
||||
@ -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}
|
||||
= i18nCell MsgAdminProblemCompanySuperiorChange <> previousSuperior adminProblemUserOld
|
||||
adminProblemCell AdminProblemCompanySuperiorNotFound{..}
|
||||
= i18nCell (MsgAdminProblemCompanySuperiorNotFound (fromMaybe "???" adminProblemEmail)) <> previousSuperior adminProblemUserOld
|
||||
adminProblemCell AdminProblemCompanySuperiorChange{adminProblemUserOld=Nothing}
|
||||
= i18nCell MsgAdminProblemCompanySuperiorChange
|
||||
adminProblemCell AdminProblemCompanySuperiorChange{adminProblemUserOld=Just uid}
|
||||
= 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]
|
||||
|
||||
|
||||
@ -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' = catchAVShandler True True False Nothing
|
||||
-- catchAll2log' :: (MonadHandler m, MonadCatch m, RenderMessage (HandlerSite m) AvsException, Monoid a) => m a -> m ()
|
||||
-- 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
|
||||
newCompanyEnt@Entity{entityKey=newCompanyId} <- upsertAvsCompany newAvsFirmInfo oldAvsFirmInfo
|
||||
upsertCompanySuperior newCompanyEnt newAvsFirmInfo oldAvsFirmInfo usrId -- ensure firmInfo superior is supervisor for this user
|
||||
oldCompanyEnt <- getAvsCompany `traverseJoin` oldAvsFirmInfo
|
||||
primaryCompanyId <- userCompanyCompany <<$>> getUserPrimaryCompany usrId
|
||||
let oldCompanyId = entityKey <$> oldCompanyEnt
|
||||
-- oldCompanyMb = entityVal <$> oldCompanyEnt
|
||||
-- pst_up = if
|
||||
-- -- | isNothing oldCompanyMb || oldCompanyId == primaryCompanyId -- refactor could replace next 4 lines
|
||||
-- -- -> mkUpdate' usr newCompany oldCompanyMb $ CheckUpdate UserPrefersPostal _companyPrefersPostal -- always update if company association is fresh (case should not occur in practice though)
|
||||
-- | isNothing oldCompanyMb
|
||||
-- -> mkUpdateDirect usr newCompany $ CheckUpdate UserPrefersPostal _companyPrefersPostal -- always update if company association is fresh (case should not occur in practice though)
|
||||
-- | oldCompanyId == primaryCompanyId -- && isJust oldCompanyId -- is ensured by previous line
|
||||
-- -> mkUpdate usr newCompany oldCompanyMb $ CheckUpdate UserPrefersPostal _companyPrefersPostal -- possibly change postal preference
|
||||
-- | otherwise
|
||||
-- -> Nothing
|
||||
superReasonComDef = tshow SupervisorReasonCompanyDefault
|
||||
newUserComp = UserCompany usrId newCompanyId False False 1 True Nothing -- default value for new company insertion, if no update can be done
|
||||
-- update company association & supervision
|
||||
Entity{entityKey=newCompanyId} <- upsertAvsCompany newAvsFirmInfo oldAvsFirmInfo
|
||||
oldCompanyEnt <- getAvsCompany `traverseJoin` oldAvsFirmInfo
|
||||
primaryCompanyId <- userCompanyCompany <<$>> getUserPrimaryCompany usrId
|
||||
let oldCompanyId = entityKey <$> oldCompanyEnt
|
||||
-- oldCompanyMb = entityVal <$> oldCompanyEnt
|
||||
-- pst_up = if
|
||||
-- -- | isNothing oldCompanyMb || oldCompanyId == primaryCompanyId -- refactor could replace next 4 lines
|
||||
-- -- -> mkUpdate' usr newCompany oldCompanyMb $ CheckUpdate UserPrefersPostal _companyPrefersPostal -- always update if company association is fresh (case should not occur in practice though)
|
||||
-- | isNothing oldCompanyMb
|
||||
-- -> mkUpdateDirect usr newCompany $ CheckUpdate UserPrefersPostal _companyPrefersPostal -- always update if company association is fresh (case should not occur in practice though)
|
||||
-- | oldCompanyId == primaryCompanyId -- && isJust oldCompanyId -- is ensured by previous line
|
||||
-- -> mkUpdate usr newCompany oldCompanyMb $ CheckUpdate UserPrefersPostal _companyPrefersPostal -- possibly change postal preference
|
||||
-- | otherwise
|
||||
-- -> Nothing
|
||||
superReasonComDef = tshow SupervisorReasonCompanyDefault
|
||||
newUserComp = UserCompany usrId newCompanyId False False 1 True Nothing -- default value for new company insertion, if no update can be done
|
||||
|
||||
case oldAvsFirmInfo of
|
||||
_ | Just newCompanyId == oldCompanyId -- company unchanged entirely
|
||||
-> return mempty -- => do nothing
|
||||
(Just oafi) | isJust (view _avsFirmPostAddressSimple oafi)
|
||||
&& ((==) `on` view _avsFirmPostAddressSimple) oafi newAvsFirmInfo -- non-empty company address unchanged OR
|
||||
|| isJust (view _avsFirmPrimaryEmail oafi)
|
||||
&& ((==) `on` view _avsFirmPrimaryEmail) oafi newAvsFirmInfo -- non-empty company primary email unchanged
|
||||
-> do -- => just update user company association, keeping supervision privileges
|
||||
case oldCompanyId of
|
||||
Nothing -> void $ insertUnique newUserComp -- it's ok if this already exists
|
||||
Just ocid -> do
|
||||
void $ upsertBySafe (UniqueUserCompany usrId ocid) newUserComp (_userCompanyCompany .~ newCompanyId) -- keep default supervisor settings
|
||||
void $ updateWhere [ UserSupervisorSupervisor ==. usrId -- update company-related supervisions
|
||||
, UserSupervisorCompany ==. Just ocid -- to new company, regardless of
|
||||
, UserSupervisorReason ==. Just superReasonComDef] -- user
|
||||
[ UserSupervisorCompany =. Just newCompanyId]
|
||||
return mempty
|
||||
_ | Just newCompanyId == primaryCompanyId -- old primaryCompany is now also AVS-company
|
||||
-> do
|
||||
whenIsJust oldCompanyId $ \oldCid -> do
|
||||
deleteBy $ UniqueUserCompany usrId oldCid
|
||||
deleteWhere $ (UserSupervisorUser ==. usrId):(UserSupervisorCompany ==. oldCompanyId):(UserSupervisorReason ~=. superReasonComDef)
|
||||
return mempty
|
||||
_ -- company changed completely
|
||||
-> do
|
||||
(pst_up, problems) <- switchAvsUserCompany False False usrId newCompanyId
|
||||
mapM_ reportAdminProblem problems
|
||||
-- Following line does not type, hence additional parameter needed
|
||||
-- return [ u | u@Update{updateField=f} <- pst_up, f /= UserPostAddress ] -- already computed in frm_up above, duplicate update must be prevented (version above accounts for legacy updates)
|
||||
return pst_up
|
||||
-- SPECIALISED CODE, PROBABLY DEPRECATED
|
||||
-- switch user company, keeping old priority
|
||||
-- (getBy . UniqueUserCompany usrId) `traverseJoin` oldCompanyId >>= \case
|
||||
-- Nothing ->
|
||||
-- void $ insertUnique newUserComp
|
||||
-- Just Entity{entityKey=ucidOld, entityVal=UserCompany{userCompanyCompany, userCompanySupervisor, userCompanySupervisorReroute, userCompanyPriority}} -> do
|
||||
-- when userCompanySupervisor $ reportAdminProblem $ AdminProblemSupervisorNewCompany usrId userCompanyCompany newCompanyId userCompanySupervisorReroute
|
||||
-- delete ucidOld
|
||||
-- void $ insertUnique newUserComp{userCompanyPriority} -- keep priority, if insert succeeds
|
||||
-- -- adjust supervison
|
||||
-- let oldCompDefSuperFltr = mconcat [UserSupervisorCompany ~~. oldCompanyId, UserSupervisorReason ~=. superReasonComDef]
|
||||
-- deleteWhere $ (UserSupervisorSupervisor ==. usrId) : oldCompDefSuperFltr
|
||||
-- oldAPs <- deleteWhereCount $ (UserSupervisorUser ==. usrId) : oldCompDefSuperFltr
|
||||
-- addDefaultSupervisors' newCompanyId $ singleton usrId
|
||||
-- newAPs <- count $ (UserSupervisorUser ==. usrId) : (UserSupervisorCompany ==. Just newCompanyId) : (UserSupervisorReason ~=. superReasonComDef)
|
||||
-- when (oldAPs > 0 && newAPs <= 0) $ reportAdminProblem $ AdminProblemNewlyUnsupervised usrId oldCompanyId newCompanyId
|
||||
-- return pst_up
|
||||
usr_up2 <- case oldAvsFirmInfo of
|
||||
_ | Just newCompanyId == oldCompanyId -- company unchanged entirely
|
||||
-> return mempty -- => do nothing
|
||||
(Just oafi) | isJust (view _avsFirmPostAddressSimple oafi)
|
||||
&& ((==) `on` view _avsFirmPostAddressSimple) oafi newAvsFirmInfo -- non-empty company address unchanged OR
|
||||
|| isJust (view _avsFirmPrimaryEmail oafi)
|
||||
&& ((==) `on` view _avsFirmPrimaryEmail) oafi newAvsFirmInfo -- non-empty company primary email unchanged
|
||||
-> do -- => just update user company association, keeping supervision privileges
|
||||
case oldCompanyId of
|
||||
Nothing -> void $ insertUnique newUserComp -- it's ok if this already exists
|
||||
Just ocid -> do
|
||||
void $ upsertBySafe (UniqueUserCompany usrId ocid) newUserComp (_userCompanyCompany .~ newCompanyId) -- keep default supervisor settings
|
||||
void $ updateWhere [ UserSupervisorSupervisor ==. usrId -- update company-related supervisions
|
||||
, UserSupervisorCompany ==. Just ocid -- to new company, regardless of
|
||||
, UserSupervisorReason ==. Just superReasonComDef] -- user
|
||||
[ UserSupervisorCompany =. Just newCompanyId]
|
||||
return mempty
|
||||
_ | Just newCompanyId == primaryCompanyId -- old primaryCompany is now also AVS-company
|
||||
-> do
|
||||
whenIsJust oldCompanyId $ \oldCid -> do
|
||||
deleteBy $ UniqueUserCompany usrId oldCid
|
||||
deleteWhere $ (UserSupervisorUser ==. usrId):(UserSupervisorCompany ==. oldCompanyId):(UserSupervisorReason ~=. superReasonComDef)
|
||||
return mempty
|
||||
_ -- company changed completely
|
||||
-> do
|
||||
(pst_up, problems) <- switchAvsUserCompany False False usrId newCompanyId
|
||||
mapM_ reportAdminProblem problems
|
||||
-- Following line does not type, hence additional parameter needed
|
||||
-- return [ u | u@Update{updateField=f} <- pst_up, f /= UserPostAddress ] -- already computed in frm_up above, duplicate update must be prevented (version above accounts for legacy updates)
|
||||
return pst_up
|
||||
-- SPECIALISED CODE, PROBABLY DEPRECATED
|
||||
-- switch user company, keeping old priority
|
||||
-- (getBy . UniqueUserCompany usrId) `traverseJoin` oldCompanyId >>= \case
|
||||
-- Nothing ->
|
||||
-- void $ insertUnique newUserComp
|
||||
-- Just Entity{entityKey=ucidOld, entityVal=UserCompany{userCompanyCompany, userCompanySupervisor, userCompanySupervisorReroute, userCompanyPriority}} -> do
|
||||
-- when userCompanySupervisor $ reportAdminProblem $ AdminProblemSupervisorNewCompany usrId userCompanyCompany newCompanyId userCompanySupervisorReroute
|
||||
-- delete ucidOld
|
||||
-- void $ insertUnique newUserComp{userCompanyPriority} -- keep priority, if insert succeeds
|
||||
-- -- adjust supervison
|
||||
-- let oldCompDefSuperFltr = mconcat [UserSupervisorCompany ~~. oldCompanyId, UserSupervisorReason ~=. superReasonComDef]
|
||||
-- deleteWhere $ (UserSupervisorSupervisor ==. usrId) : oldCompDefSuperFltr
|
||||
-- oldAPs <- deleteWhereCount $ (UserSupervisorUser ==. usrId) : oldCompDefSuperFltr
|
||||
-- addDefaultSupervisors' newCompanyId $ singleton usrId
|
||||
-- newAPs <- count $ (UserSupervisorUser ==. usrId) : (UserSupervisorCompany ==. Just newCompanyId) : (UserSupervisorReason ~=. superReasonComDef)
|
||||
-- when (oldAPs > 0 && newAPs <= 0) $ reportAdminProblem $ AdminProblemNewlyUnsupervised usrId oldCompanyId newCompanyId
|
||||
-- return pst_up
|
||||
update usrId usr_up2 -- update user by company switch first (due to possible conflicts with usr_up2)
|
||||
update usrId usr_up1 -- update user eventually
|
||||
update uaId avs_ups -- update stored avsinfo for future updates
|
||||
@ -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
|
||||
mbUid <- firstJustM $ return muid : maybe [] (\ipn ->
|
||||
[ getKeyByFilter [UserCompanyPersonalNumber ==. Just ipn] -- must ensure filter isnt ==. Nothing
|
||||
, catchAll2log' (Just . entityKey <$> ldapLookupAndUpsert ipn) -- attempt to insert by LDAP first
|
||||
oldUsr <- runDBRead $ do
|
||||
mbUid <- if isJust muid
|
||||
then return muid
|
||||
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 = fmap (fmap entityKey) . getAvsCompany
|
||||
getAvsCompanyId :: AvsFirmInfo -> DB (Maybe CompanyId)
|
||||
getAvsCompanyId = fmap (fmap entityKey) . getAvsCompany
|
||||
|
||||
-- | Query DB from given AvsFirmInfo. Guarantees that all Uniqueness-Constraints are checked. Highly unlikely that Nothing is returned, since all AvsResponseContact always contains an AvsFirmInfo
|
||||
getAvsCompany :: AvsFirmInfo -> DB (Maybe (Entity Company))
|
||||
@ -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}|]
|
||||
case mbFirmEnt of
|
||||
Nothing -> do -- insert new company, neither AvsId nor Shorthand exist in DB
|
||||
$logInfoS "AVS" [st|upsertAvsCompany: old #{tshow mbFirmEnt} new #{tshow newAvsFirmInfo}|]
|
||||
cmpEnt <- case (mbFirmEnt, mbOldAvsFirmInfo) of
|
||||
(Nothing, _) -> do -- insert new company, neither AvsId nor Shorthand exist in DB
|
||||
afn <- if 0 < newAvsFirmInfo ^. _avsFirmFirmNo
|
||||
then return $ newAvsFirmInfo ^. _avsFirmFirmNo
|
||||
else maybe (-1) (pred . companyAvsId . entityVal) <$> selectMaybe [CompanyAvsId <. 0] [Asc CompanyAvsId]
|
||||
let upd = flip updateRecord newAvsFirmInfo
|
||||
dmy = Company -- mostly dummy, values are actually 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
|
||||
let oldHasSameFirmNo = Just (newAvsFirmInfo ^. _avsFirmFirmNo) == (mbOldAvsFirmInfo ^? _Just . _avsFirmFirmNo)
|
||||
oldAvsFirmInfo = guardOnM oldHasSameFirmNo mbOldAvsFirmInfo
|
||||
cmp_ups = mapMaybe (mkUpdate' firm newAvsFirmInfo oldAvsFirmInfo) firmInfo2company
|
||||
(Just Entity{entityKey=firmid, entityVal=firm}, oldAvsFirmInfo) -> do -- possibly update existing company, if isJust oldAvsFirmInfo and changed occurred
|
||||
let cmp_ups = mapMaybe (mkUpdate' firm newAvsFirmInfo oldAvsFirmInfo) firmInfo2company
|
||||
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
|
||||
upsertCompanySuperior :: Entity Company -> AvsFirmInfo -> Maybe AvsFirmInfo -> UserId -> DB () -- may return superior (Maybe UserId), but currently not needed
|
||||
upsertCompanySuperior Entity{entityKey=cid, entityVal=Company{}} newAfi oldAfi usrId =
|
||||
let reasonSuperior = Just $ tshow SupervisorReasonAvsSuperior
|
||||
getInsertUid eml = altM (guessUserByEmail $ stripCI eml) (catchAll2log' $ Just . entityKey <$> ldapLookupAndUpsert eml)
|
||||
newAvsNo = newAfi ^. _avsFirmFirmNo
|
||||
oldAvsNo = oldAfi ^? _Just . _avsFirmFirmNo
|
||||
mbSupEmail = newAfi ^. _avsFirmEMailSuperior
|
||||
mbOldEmail = oldAfi ^? _Just . _avsFirmEMailSuperior . _Just
|
||||
getSupId = getInsertUid `traverseJoin` mbSupEmail
|
||||
getOldId = (guessUserByEmail . stripCI) `traverseJoin` mbOldEmail
|
||||
getSupervision :: Maybe UserId -> DB (Maybe (Entity UserSupervisor))
|
||||
getSupervision = traverseJoin (getBy . flip UniqueUserSupervisor usrId)
|
||||
unchangedCompany = oldAvsNo == Just newAvsNo
|
||||
changedSuperior = mbSupEmail /= mbOldEmail -- beware we only have AvsFirmInfo for one user; also both could be Nothing
|
||||
-- 1. not unchangedCompany: do not delete, but ensure that superior supervision is set, since it could be a just a single user company change
|
||||
-- 2. unchangedCompany && not changedSuperior: superior must already been set, short-circuit
|
||||
-- 3. unchangedCompany && changedSuperior: update superior for all users
|
||||
in unless (unchangedCompany && not changedSuperior) $ do -- do nothing if (unchangedCompany && not changedSuperior).
|
||||
mbSupId <- getSupId
|
||||
mbUsrSup <- getSupervision mbSupId
|
||||
-- delete old superiors, if any
|
||||
when (unchangedCompany && changedSuperior) $
|
||||
deleteWhere $ mcons ((UserSupervisorSupervisor !=.) <$> mbSupId)
|
||||
[ UserSupervisorCompany ==. Just cid, UserSupervisorReason ==. reasonSuperior ]
|
||||
unless unchangedCompany $
|
||||
deleteWhere [ UserSupervisorReason ==. reasonSuperior, UserSupervisorUser ==. usrId ]
|
||||
-- ensure superior supervision
|
||||
case (mbSupId, mbUsrSup) of
|
||||
(_ , Just _) -> return () -- supId is already supervisor for uid for any reason
|
||||
(Just supId, Nothing) -> do
|
||||
-- ensure association between company and superior at equal-to-top priority
|
||||
prio <- getCompanyUserMaxPrio supId
|
||||
void $ insertUnique (UserCompany supId cid False False prio True reasonSuperior) -- superior is not a supervisor, do not change existing user company associations
|
||||
deleteOldSuperior oldSup oldCid =
|
||||
deleteWhere [ UserSupervisorSupervisor ==. oldSup
|
||||
, UserSupervisorCompany ==. Just oldCid
|
||||
, UserSupervisorReason ==. reasonSuperior
|
||||
]
|
||||
|
||||
-- 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
|
||||
| Entity _ UserAvs{userAvsPersonId = avsid} <- avsUsrs
|
||||
]
|
||||
] ++ [AvsPersonLicence AvsLicenceVorfeld avsid | 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
|
||||
alds = AvsLicenceDifferences
|
||||
{ avsLicenceDiffRevokeAll = setTo0
|
||||
, avsLicenceDiffGrantVorfeld = setTo1up
|
||||
, avsLicenceDiffRevokeRollfeld = setTo1down
|
||||
, avsLicenceDiffGrantRollfeld = setTo2
|
||||
}
|
||||
return (alds, rsChanged)
|
||||
return AvsLicenceDifferences
|
||||
{ avsLicenceDiffRevokeAll = setTo0
|
||||
, avsLicenceDiffGrantVorfeld = setTo1up
|
||||
, avsLicenceDiffRevokeRollfeld = setTo1down
|
||||
, avsLicenceDiffGrantRollfeld = setTo2
|
||||
}
|
||||
{- 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
|
||||
|
||||
@ -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")
|
||||
|
||||
@ -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 <-. Nothing : [Just $ tshow r | r <- [SupervisorReasonCompanyDefault, SupervisorReasonAvsSuperior]]] -- Does <-. work with Nothing?
|
||||
-- ||. [UserSupervisorReason <-. [Just $ tshow r | r <- [SupervisorReasonCompanyDefault, SupervisorReasonAvsSuperior]]]
|
||||
|
||||
-- | 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
|
||||
getCompanyUserMaxPrio :: UserId -> DB Int
|
||||
getCompanyUserMaxPrio uid = do
|
||||
mbMaxPrio <- E.selectOne $ do
|
||||
usrCmp <- E.from $ E.table @UserCompany
|
||||
E.where_ $ usrCmp E.^. UserCompanyUser E.==. E.val uid
|
||||
return . E.max_ $ usrCmp E.^. UserCompanyPriority
|
||||
return $ maybe 1 (fromMaybe 1 . E.unValue) mbMaxPrio
|
||||
-- | deletes user company association and all company related supervision
|
||||
-- WARNING: does not check for admin problems!
|
||||
deleteCompanyUser :: CompanyId -> [UserId] -> DB (Int64, Int64, Int64)
|
||||
deleteCompanyUser cid uids = (,,)
|
||||
<$> deleteWhereCount [UserCompanyCompany ==. cid, UserCompanyUser <-. uids]
|
||||
<*> deleteWhereCount ((UserSupervisorCompany ==. Just cid):(UserSupervisorSupervisor <-. uids) : defaultSupervisorReasonFilter)
|
||||
<*> deleteWhereCount ((UserSupervisorCompany ==. Just cid):(UserSupervisorUser <-. uids) : defaultSupervisorReasonFilter)
|
||||
|
||||
@ -10,8 +10,7 @@ module Handler.Utils.DateTime
|
||||
, toTimeOfDay
|
||||
, toMidnight, beforeMidnight, toMidday, toMorning
|
||||
, toFullHour, roundDownToMinutes, addHours
|
||||
, formatDiffDays, formatDiffHours
|
||||
, formatCalendarDiffDays
|
||||
, formatDiffDays, 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' SelFormatTime usr = usr & userTimeFormat
|
||||
getDateTimeFormatUser' SelFormatDate usr = usr & userDateFormat
|
||||
getDateTimeFormatUser' SelFormatTime usr = usr & userTimeFormat
|
||||
|
||||
getDateTimeFormatter :: (MonadHandler m, HandlerSite m ~ UniWorX, YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId) => m DateTimeFormatter
|
||||
getDateTimeFormatter = do
|
||||
@ -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
|
||||
(y,_,_) = toGregorian date
|
||||
where
|
||||
(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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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 --
|
||||
----------
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
let renewalDate = addGregorianDurationClip renewalPeriod nowaday
|
||||
renewalUsers <- E.select $ do
|
||||
quser <- E.from $ E.table @QualificationUser
|
||||
E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid
|
||||
E.&&. quser E.^. QualificationUserScheduleRenewal
|
||||
E.&&. quser E.^. QualificationUserValidUntil E.<=. E.val renewalDate
|
||||
E.&&. (quser `qualificationValid` now)
|
||||
E.&&. E.notExists (do
|
||||
luser <- E.from $ E.table @LmsUser
|
||||
E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid
|
||||
E.&&. luser E.^. LmsUserUser E.==. quser E.^. QualificationUserUser
|
||||
E.&&. E.isNothing (luser E.^. LmsUserEnded)
|
||||
)
|
||||
pure quser
|
||||
let usr_job :: Entity QualificationUser -> Maybe Job
|
||||
usr_job quser =
|
||||
let uid = quser ^. _entityVal . _qualificationUserUser
|
||||
uex = quser ^. _entityVal . _qualificationUserValidUntil
|
||||
unf = quser ^. _entityVal . _qualificationUserLastNotified
|
||||
nfy_cutoff = addGregorianDurationClip renewalPeriod $ utctDay unf
|
||||
do_notify = uex > nfy_cutoff || (uex == nfy_cutoff && utctDayTime now >= utctDayTime unf)
|
||||
in if
|
||||
| qualificationElearningStart quali -- repetition avoided since LmsUser does not exist
|
||||
-> Just $ JobLmsEnqueueUser { jQualification = qid, jUser = uid }
|
||||
| do_notify -- repetition avoided by QualificationUserLastNotified
|
||||
-> Just $ JobUserNotification
|
||||
{ jRecipient = uid
|
||||
, jNotification = NotificationQualificationExpiry { nQualification = qid, nExpiry = uex }
|
||||
}
|
||||
| otherwise -> Nothing
|
||||
forM_ renewalUsers (flip whenIsJust queueDBJob . usr_job)
|
||||
logInterface "LMS" (qshort <> "-enq") True (Just $ length renewalUsers) ""
|
||||
|
||||
ifNothingM (qualificationRefreshWithin quali) () $ \renewalPeriod -> do -- no refreshWithin, no first reminders
|
||||
let renewalDate = addGregorianDurationClip renewalPeriod nowaday
|
||||
renewalUsers <- E.select $ do
|
||||
quser <- E.from $ E.table @QualificationUser
|
||||
E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid
|
||||
E.&&. quser E.^. QualificationUserScheduleRenewal
|
||||
E.&&. quser E.^. QualificationUserValidUntil E.<=. E.val renewalDate
|
||||
E.&&. (quser `qualificationValid` now)
|
||||
E.&&. E.notExists (do
|
||||
luser <- E.from $ E.table @LmsUser
|
||||
E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid
|
||||
E.&&. luser E.^. LmsUserUser E.==. quser E.^. QualificationUserUser
|
||||
E.&&. E.isNothing (luser E.^. LmsUserEnded)
|
||||
)
|
||||
pure quser
|
||||
let usr_job :: Entity QualificationUser -> Job
|
||||
usr_job quser =
|
||||
let uid = quser ^. _entityVal . _qualificationUserUser
|
||||
uex = quser ^. _entityVal . _qualificationUserValidUntil
|
||||
in if qualificationElearningStart quali
|
||||
then JobLmsEnqueueUser { jQualification = qid, jUser = uid }
|
||||
else JobUserNotification { jRecipient = uid, jNotification =
|
||||
NotificationQualificationExpiry { nQualification = qid, nExpiry = uex }
|
||||
}
|
||||
forM_ renewalUsers (queueDBJob . usr_job)
|
||||
logInterface "LMS" (qshort <> "-enq") True (Just $ length renewalUsers) ""
|
||||
|
||||
dispatchJobLmsEnqueueUser :: QualificationId -> UserId -> JobHandler UniWorX
|
||||
dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act
|
||||
|
||||
@ -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
|
||||
now <- liftIO getCurrentTime
|
||||
encRecipient :: CryptoUUIDUser <- liftHandler $ encrypt jRecipient
|
||||
(recipient@User{..}, Qualification{..}) <- runDB $ (,)
|
||||
dispatchNotificationQualificationExpiry nQualification dExpiry jRecipient = userMailT jRecipient $ do
|
||||
(recipient@User{..}, Qualification{..}) <- liftHandler . 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
|
||||
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
|
||||
setSubjectI $ MsgMailSubjectQualificationExpiry qname
|
||||
editNotifications <- mkEditNotifications jRecipient
|
||||
addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/qualificationExpiry.hamlet")
|
||||
runDB $ updateBy (UniqueQualificationUser nQualification jRecipient) [QualificationUserLastNotified =. now]
|
||||
$logDebugS "LMS" $ "Notified " <> tshow encRecipient <> " about soonish expiry of qualification " <> qname
|
||||
expiryDate <- formatTimeUser SelFormatDate dExpiry $ Just entRecipient
|
||||
|
||||
$logDebugS "LMS" $ "Notify " <> tshow encRecipient <> " about expiry of qualification " <> qname
|
||||
|
||||
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
|
||||
setSubjectI $ MsgMailSubjectQualificationExpiry qname
|
||||
|
||||
editNotifications <- mkEditNotifications jRecipient
|
||||
|
||||
addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/qualificationExpiry.hamlet")
|
||||
|
||||
|
||||
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
|
||||
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -3,9 +3,7 @@
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
module Jobs.Handler.SynchroniseLdap
|
||||
( dispatchJobSynchroniseLdap
|
||||
, dispatchJobSynchroniseLdapUser
|
||||
, dispatchJobSynchroniseLdapAll
|
||||
( dispatchJobSynchroniseLdap, dispatchJobSynchroniseLdapUser
|
||||
, 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)
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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"
|
||||
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
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
|
||||
makeLenses_ ''AvsConf
|
||||
|
||||
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
|
||||
|
||||
13
src/Utils.hs
13
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 --
|
||||
----------
|
||||
|
||||
@ -320,7 +320,6 @@ data FormIdentifier
|
||||
| FIDAddSupervisor
|
||||
| FIDFirmUserChangeRequest
|
||||
| FIDFirmAction
|
||||
| FIDUnreachableUsersAction
|
||||
deriving (Eq, Ord, Read, Show)
|
||||
|
||||
instance PathPiece FormIdentifier where
|
||||
|
||||
@ -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:
|
||||
|
||||
@ -316,7 +316,6 @@ makeLenses_ ''AuthorshipStatementDefinition
|
||||
makeLenses_ ''PrintJob
|
||||
|
||||
makeLenses_ ''InterfaceLog
|
||||
makeLenses_ ''InterfaceHealth
|
||||
makeLenses_ ''AdminProblem
|
||||
makeLenses_ ''ProblemLog
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
htmlToPlainText html = P.runPure $ P.writePlain htmlWriterOptions =<< P.readHtml markdownReaderOptions (toStrict $ renderHtml html)
|
||||
|
||||
plainTextToHtml :: Text -> 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]]
|
||||
|
||||
plainHtmlToHtml :: Text -> Html
|
||||
plainHtmlToHtml text = fromRight (toMarkup text) $ P.runPure $
|
||||
P.writeHtml5 htmlWriterOptions =<< P.readHtml markdownReaderOptions text
|
||||
|
||||
-- where pandoc = P.Pandoc mempty [P.Plain [P.Str text]]
|
||||
|
||||
|
||||
htmlReaderOptions, markdownReaderOptions :: P.ReaderOptions
|
||||
|
||||
@ -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}
|
||||
|
||||
@ -35,9 +35,6 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
$maybe answer <- mbQryLic
|
||||
<p>
|
||||
^{answer}
|
||||
$maybe autodiffs <- mbAutoDiffs
|
||||
<p>
|
||||
#{autodiffs}
|
||||
|
||||
<section>
|
||||
<p>
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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}
|
||||
|
||||
@ -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}
|
||||
|
||||
|
||||
@ -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}
|
||||
|
||||
|
||||
@ -5,15 +5,10 @@ $#
|
||||
$# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
<section>
|
||||
<p>
|
||||
Bitte beachten: Ansprechpartner-Beziehung bestehen unabhängig von Firmenzugehörigkeit zwischen Einzelpersonen! #
|
||||
|
||||
<p>
|
||||
Daraus folgt zum Beispiel, dass wenn <em>x</em> ein Standard-Ansprechpartner für Firma <em>a</em> ist #
|
||||
und wenn <em>y</em> sowohl Firma <em>a</em> als auch <em>b</em> angehört, #
|
||||
dass <em>x</em> als firmenfremd in der Liste der Ansprechpartner von Firma <em>b</em> angezeigt wird. #
|
||||
Dies kann hier mit der Aktion "Firmenansprechpartner entfernen" nicht geändert werden, #
|
||||
da die Ansprechpartnerbeziehung ja über eine andere Firma weiter existiert.
|
||||
Bitte beachten, dass Ansprechpartner-Beziehung unabhängig von Firmenzugehörigkeit zwischen Einzelpersonen bestehen.
|
||||
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 dann <em>x</em> als firmenfremd in der Liste der Ansprechpartner von Firma <em>b</em> angezeigt wird.
|
||||
|
||||
^{firmContactInfo}
|
||||
|
||||
|
||||
@ -5,12 +5,9 @@ $#
|
||||
$# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
<section>
|
||||
<p>
|
||||
Note that supervisionship is company independent! #
|
||||
<p>
|
||||
For example, if <em>x</em> is a regular supervisor for company <em>a</em> and <em>y</em> belongs to companies <em>a</em> and <em>b</em>, #
|
||||
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.
|
||||
Note that supervision 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>,
|
||||
then <em>x</em> will be listed as a foreign supervisor for company <em>b</em>.
|
||||
|
||||
^{firmContactInfo}
|
||||
|
||||
|
||||
@ -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 svaupel nice True False 2 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 "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)
|
||||
, UserSupervisor jost svaupel False (Just fraportAg) (Just $ tshow SupervisorReasonAvsSuperior)
|
||||
let supvs = [ UserSupervisor jost gkleen True (Just fraportAg) (Just "Staff")
|
||||
, 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)
|
||||
|
||||
Reference in New Issue
Block a user