Compare commits
101 Commits
| Author | SHA1 | Date | |
|---|---|---|---|
| 3b0029ba04 | |||
| e554048f5a | |||
| e59fff352f | |||
| e9d4174b83 | |||
| 90613faf72 | |||
| 6a070a6775 | |||
| ea113cf57a | |||
| 6ffc49ae0e | |||
| ab8b17229a | |||
| 74f7633837 | |||
| d92d23bc99 | |||
| 4959736c90 | |||
| ade27e6479 | |||
| cbadef0a73 | |||
| 2a27a1efa6 | |||
| 620e3e4700 | |||
| f0798e8836 | |||
| 3c5edb1b97 | |||
| 4f7855b9ee | |||
| 547f34d2ec | |||
| 08788427a8 | |||
| 1e896da4a3 | |||
| 7e5c256b4c | |||
| 43319fbcca | |||
| f946e99da3 | |||
| cfe2318f81 | |||
| 64ff002ffb | |||
| 8397c468a0 | |||
| 81721b0794 | |||
| 40dadd5876 | |||
| b7e5b8f111 | |||
| 8ec2875590 | |||
| 6d1b177ce9 | |||
| 9c82558d71 | |||
| e8f9c21b7c | |||
| e1a02879d6 | |||
| 109e845db6 | |||
| 53abdb7cc3 | |||
| 97446aa9ef | |||
| 407ba543a1 | |||
| f61c35cfe7 | |||
| b0972bb154 | |||
| 8bc3663ee2 | |||
| 776e6b6736 | |||
| be5e609b1f | |||
| cc5da9a2a9 | |||
| e551fadd29 | |||
| 2ed626ea4a | |||
| f4823aaf28 | |||
| 760b102d52 | |||
| 000d8100db | |||
| d209a110e8 | |||
| 0af8598d6d | |||
| c3d27c25b5 | |||
| 1e6547e903 | |||
| e4abf915ee | |||
| 6299612adc | |||
| 8f54ea1051 | |||
| c1dbd61c14 | |||
| e35a5e99a6 | |||
| ab00a4f665 | |||
| f929e03129 | |||
| 21d32fd4cf | |||
| 4df8bd2fa5 | |||
| d1fa01fcc5 | |||
| ec02767552 | |||
| cfd25348ad | |||
| e1419766f3 | |||
| 5b6e4e60e7 | |||
| bc47387c91 | |||
| 0fde59c19a | |||
| 507a7e02fc | |||
| 43f5c5f485 | |||
| b9f70c7796 | |||
| 6ccbb3b7ff | |||
| 8b0466e74e | |||
| 689e6347da | |||
| 11fdcf0d44 | |||
| 58152beb03 | |||
| 803e8bfedb | |||
| d853e8559b | |||
| e6f0454e78 | |||
| 8c8ffa5183 | |||
| fee14edf36 | |||
| 0bbb679a43 | |||
| 6063eb24a2 | |||
| 28e2739e51 | |||
| c17c18f924 | |||
| d65fb2f4cd | |||
| ab28c8c243 | |||
| 6e2d545772 | |||
| fa0541aa4e | |||
| b5215cc7e8 | |||
| a1668f891a | |||
| c813c665ed | |||
| 9a0e8988fa | |||
| 9d3198f49b | |||
| 2caa5aec5b | |||
| 3def8ca916 | |||
| a97c3a5c9d | |||
| 468af9de9d |
71
CHANGELOG.md
71
CHANGELOG.md
@ -2,6 +2,77 @@
|
||||
|
||||
All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines.
|
||||
|
||||
## [27.4.79](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.78...v27.4.79) (2024-09-10)
|
||||
|
||||
|
||||
### Bug Fixes
|
||||
|
||||
* **notifications:** fix [#180](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/180) qualification expiry notification are sent only once ([74f7633](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/74f7633837870448f7cab1013719f42ab49941fe))
|
||||
* **supervision:** fix [#181](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/181) by unifying deletion of supervision ([6a070a6](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/6a070a67756bd4ef4b9b5efc176f34c7ed183f1a))
|
||||
|
||||
## [27.4.78](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.77...v27.4.78) (2024-09-05)
|
||||
|
||||
|
||||
### Bug Fixes
|
||||
|
||||
* **avs:** acs auto synch had inverted success/failure ([4f7855b](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/4f7855b9ee7133c5ee7e2ca63d63e5d9f060d62f))
|
||||
* **avs:** fix [#124](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/124) avs auto synch filter working ([2a27a1e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/2a27a1efa673a4245a7e8667bd30c79ac1891b9c))
|
||||
* **avs:** fix [#178](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/178) by deleting old superiors for individual users ([ade27e6](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ade27e647913ffe4432b41d585b3e00d1c68d4a0))
|
||||
* **avs:** typo in superior remark, towards [#178](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/178) ([3c5edb1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/3c5edb1b970c8c154d9957837007815b29e23964))
|
||||
* **mail:** fix [#179](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/179) by adding download links for PDF attachments ([620e3e4](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/620e3e470080831826ccc960dd876e7bb4fcea03))
|
||||
|
||||
## [27.4.77](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.76...v27.4.77) (2024-09-02)
|
||||
|
||||
|
||||
### Bug Fixes
|
||||
|
||||
* **avs:** attempt LDAP upsert before creating avs users ([cfe2318](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/cfe2318f81c951a7f7310e8bcd9ec25d79417587))
|
||||
* **avs:** company superiors are now irregular supervisors and old ones are deleted ([7e5c256](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/7e5c256b4c15a15f7218dd7c1490d5e7add4b1c1))
|
||||
* **avs:** fix [#124](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/124) implement automatic avs driving licence synchronisation ([cc5da9a](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/cc5da9a2a9bfc8a29f6fe19260bd6dc5412ad4a1))
|
||||
* **avs:** switch company did not always increase priority ([8ec2875](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/8ec2875590718f28c3bab8c10141065e11f1405c))
|
||||
* **build:** minor linter fix ([be5e609](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/be5e609b1fe879428784d78fa62a559d0764a85a))
|
||||
* **firm:** fix [#174](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/174) by adding address search filter to all company view ([40dadd5](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/40dadd58762156005b5889b93a56ffdc044b4460))
|
||||
* **firm:** fix [#175](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/175) by separating superiors in firm tables and selections ([8397c46](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/8397c468a04af42ba3baee2f84a0051adbc74374))
|
||||
* **ldap:** no more timeout for ldap synch all button ([f946e99](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/f946e99da3bc37514a4e3621438ac133cdc16732))
|
||||
* **linter:** minor bug in exam-correct.hs ([8bc3663](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/8bc3663ee2e4ded19091ebe350de82cd693093fc))
|
||||
* **mail:** display html emails no longer distorts page ([b0972bb](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/b0972bb154f453edd545fb4f658d9f5ff79966eb)), closes [#2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/2)
|
||||
* **model:** flip erroneous boolean SQL default for CompanyPostalAddress ([b7e5b8f](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/b7e5b8f111b5115d816d984c6ef2f12edfcef5bb))
|
||||
* **user:** fix pagination and count for supervision tables ([9c82558](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/9c82558d71a032dad27e892c489c7004d091e088))
|
||||
|
||||
## [27.4.76](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.75...v27.4.76) (2024-08-08)
|
||||
|
||||
|
||||
### Bug Fixes
|
||||
|
||||
* **ap:** disambiguate action message ([8b0466e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/8b0466e74e36e1d0d07518fd317d46b00ab53eff))
|
||||
* **avs:** fix [#173](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/173) by not using firm superior email as display email ([43f5c5f](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/43f5c5f4854d1ab2af27b479e72a58e2818a5696))
|
||||
* **avs:** towards [#117](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/117) update if current value is Nothing even if oldval == newval ([d1fa01f](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/d1fa01fcc5125c4adee8849f9c944884926f78ad))
|
||||
* **avs:** using firm superior as UserEmail is a no-go due to uniqueness constraints ([507a7e0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/507a7e02fc68476d01031dc9f9ee1a669a453ed1))
|
||||
* **build:** linter likes it ([f929e03](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/f929e03129378e08c8a08ed4bd6f8e8716401813))
|
||||
* **course:** fix [#150](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/150) course edit for associated qualifications requires school admin or lecturer rights ([5b6e4e6](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/5b6e4e60e7d2957fbce93ee2e2d6d3464b4e3db7))
|
||||
* **course:** fix [#148](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/148) course qualification ordering ([cfd2534](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/cfd25348ad3b63ac6bc5031467a3c4ead2e07eed)), closes [#150](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/150)
|
||||
* **course:** fix [#149](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/149) course cloning proposes associated qualifications ([e141976](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/e1419766f3a06f702abad0ea42f6552305504ba0))
|
||||
* **course:** fix [#150](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/150) no longer allow duplicated associated qualifications and orders due to editing existing ([ec02767](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ec027675525b30198378745ed281f60a42471807))
|
||||
* **course:** WIP course cloning should propose same associated qualifications, towards [#149](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/149) ([bc47387](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/bc47387c91dda60a2f12e52dba28ea7b079316f0))
|
||||
* **lms:** max e-learning tries default removed and info added to lms overview ([11fdcf0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/11fdcf0d445b8cfe97c3a3c26513a9229937c536))
|
||||
* **user:** format userDisplayNames having umlaut substitutes with respect to userSurname correctly ([e35a5e9](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/e35a5e99a6cea0976fd1c28f919e7d0ac0338503))
|
||||
|
||||
## [27.4.75](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.74...v27.4.75) (2024-07-12)
|
||||
|
||||
|
||||
### Bug Fixes
|
||||
|
||||
* **build:** make linter happy again ([c17c18f](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/c17c18f9247ef322bc051602a3cb4a52cd50affa))
|
||||
* **build:** minor ([ab28c8c](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ab28c8c2437680023d80e6ab43113d4328b3a151))
|
||||
* **firm:** fix [#157](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/157) by removing redundant duplicated code in firm user and supervision handling ([28e2739](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/28e2739e515700d15c75647c0efe2fe9a9cf15b1))
|
||||
* **job:** change some queueJob' to queueJob instead ([fa0541a](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/fa0541aa4eaf10f98535a0959593b148b8346109))
|
||||
* **lms:** allow 2nd reminders to be independent of renewal period ([d853e85](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/d853e8559b753865ee818bf24764f5c8d2e2303f))
|
||||
* **lms:** move lms reuse info from QualificationR to LmsR ([468af9d](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/468af9de9da44a8ad685ca4bb6890a3e630b58be))
|
||||
* **lms:** send second reminder indepentently from renewal period ([a97c3a5](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/a97c3a5c9d3cb9dddf90f561712f0845400893bd))
|
||||
* **nix:** workaround parsing port numbers failed in nix-shell ([b5215cc](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/b5215cc7e8df3a7ad636271c8e6950979b2b8e42))
|
||||
* **users:** nameHtml no longer complains about differing case for surname and displayname ([a1668f8](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/a1668f891a36b887439afb098f016ef22535af42))
|
||||
* **users:** remove users with company post address from list of unreachable users ([c813c66](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/c813c665ed306135b7813d91d23310341c689f41))
|
||||
|
||||
## [27.4.74](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.73...v27.4.74) (2024-07-04)
|
||||
|
||||
|
||||
|
||||
@ -301,7 +301,7 @@ export class ExamCorrect {
|
||||
users: [user],
|
||||
status: STATUS.LOADING,
|
||||
};
|
||||
if (results && results !== {}) rowInfo.results = results;
|
||||
if (results && Object.keys(results).length > 0) rowInfo.results = results;
|
||||
if (result !== undefined) rowInfo.result = result;
|
||||
this._addRow(rowInfo);
|
||||
|
||||
|
||||
@ -114,6 +114,7 @@ ProblemsNoStalePrintJobs n@Integer: Alle Briefversandaufträge #{pluralDE n "des
|
||||
ProblemsNoBadAPCIds: Alle kürzlich empfangenen Druckauftragsbestätigungen waren gültig
|
||||
ProblemsUnreachableHeading: Unerreichbare Benutzer
|
||||
ProblemsUnreachableBody: Benutzer ohne E-Mail oder Postadresse, welche z.B. bei ablaufenden Berechtigungen nicht benachrichtigt werden können:
|
||||
ProblemsUnreachableButtons: Synchronisation für Unerreichbare starten
|
||||
ProblemsRWithoutFHeading: Fahrer mit R ohne F
|
||||
ProblemsRWithoutFBody: Diese Fahrer sind wegen einer ungültigen Vorfeld-Fahrberechtigung komplett gesperrt, obwohl eine gültige Rollfeld-Fahrberechtigung besteht:
|
||||
ProblemsNoAvsIdHeading: Fahrer ohne AVS-Id
|
||||
@ -121,19 +122,20 @@ ProblemsNoAvsIdBody: Fahrer mit gültiger Fahrberechtigung in FRADrive, welche t
|
||||
ProblemsAvsSynchHeading: Synchronisation AVS Fahrberechtigungen
|
||||
ProblemsAvsErrorHeading: Fehlermeldungen
|
||||
ProblemsInterfaceSince: Berücksichtigt werden nur Erfolge und Fehler seit
|
||||
ProblemAvsUsrHadR: Momentan gültiges R im AVS
|
||||
|
||||
AdminProblemSolved: Erledigt
|
||||
AdminProblemSolver: Bearbeitet von
|
||||
AdminProblemCreated: Erkannt
|
||||
AdminProblemInfo: Problembeschreibung
|
||||
AdminProblemInfoTooltip: Nur Teile der folgenden englische Begriffe sind derzeit möglich: new-company, supervisor-new-company, supervisor-left-company, superior-change, newly-unsupervised und unknown
|
||||
AdminProblemsSolved n@Int: #{pluralDEeN n "Admin Problem"} als erledigt markiert
|
||||
AdminProblemsReopened n@Int: #{pluralDEeN n "Admin Problem"} erneut eröffnet
|
||||
AdminProblemNewCompany: Neue Firma über AVS automatisch erstellt; prüfen und ggf. Standardansprechpartner eintragen
|
||||
AdminProblemSupervisorNewCompany b@Bool: Standardansprechpartner #{boolText mempty "mit Standardumleitung" b} wechselte zu neuer Firma
|
||||
AdminProblemSupervisorLeftCompany b@Bool: Einziger Standardansprechpartner #{boolText mempty "mit Standardumleitung" b} dieses Fahrers wechselte zu neuer Firma
|
||||
AdminProblemCompanySuperiorChange: Neuer firmenweiter Vorgesetzer.
|
||||
AdminProblemCompanySuperiorPrevious: Ehemaliger Vorgesetzer:
|
||||
AdminProblemCompanySuperiorChange: Neuer firmenweiter Vorgesetzter.
|
||||
AdminProblemCompanySuperiorNotFound t@Text: Neuer unbekannter firmenweiter Vorgesetzter mit E-Mail #{t}, keine Ansprechpartnerbeziehungen eingerichtet.
|
||||
AdminProblemCompanySuperiorPrevious: Ehemaliger Vorgesetzter:
|
||||
AdminProblemNewlyUnsupervised: Fahrer hat keinen Firmenansprechpartner mehr nach AVS Firmenwechsel zu Firma
|
||||
AdminProblemUser: Betroffener
|
||||
ProblemTableMarkSolved: Als erledigt markieren
|
||||
@ -148,4 +150,13 @@ InterfaceSubtype: Betreffend
|
||||
InterfaceWrite: Schreibend
|
||||
InterfaceSuccess: Rückmeldung
|
||||
InterfaceInfo: Nachricht
|
||||
InterfaceFreshness: Prüfungszeitraum (h)
|
||||
InterfaceFreshness: Maximale Zugriffsfrist
|
||||
InterfaceFreshnessTooltip: Zeitspanne innerhalb der ein erneuter erfolgreicher Schnittstellenzugriff erfolgen muss, ohne Warnungen auszulösen
|
||||
ConfigInterfacesHeading: Konfiguration Zugriffsfristen
|
||||
|
||||
IWTActAdd: Hinzufügen/Ändern
|
||||
IWTActDelete: Entfernen
|
||||
InterfaceWarningAdded: Schnittstellenwarnungszeit hinzugefügt oder geändert
|
||||
InterfaceWarningDeleted n@Int: #{pluralDEeN n "Schnittstellenwarnungszeit"} gelöscht
|
||||
InterfaceWarningDisabledEntirely: Alle Fehler ignorieren
|
||||
InterfaceWarningDisabledInterval: Keine Zugriffsfrist
|
||||
@ -114,25 +114,27 @@ ProblemsNoStalePrintJobs n: All requests for letter mailing within the last #{pl
|
||||
ProblemsNoBadAPCIds: All recently received print job ids from Airport Print Center were legit
|
||||
ProblemsUnreachableHeading: Unreachable Users
|
||||
ProblemsUnreachableBody: Users without Email nor postal address, who thus cannot be notified about expiring qualifications:
|
||||
ProblemsUnreachableButtons: Start synchronisation for unreachable users only
|
||||
ProblemsRWithoutFHeading: Drivers having 'R' but not 'F'
|
||||
ProblemsRWithoutFBody: Drivers without apron driving licence are prohibited from driving, even if they own a valid maneuvering driving licence:
|
||||
ProblemsNoAvsIdHeading: Drivers without AVS id
|
||||
ProblemsNoAvsIdBody: Drivers having a valid apron driving licence within FRADrive only, but who may not drive since a missing AVS id prevents communication of the driving licence to AVS:
|
||||
ProblemsAvsSynchHeading: Synchronisation AVS Driving Licences
|
||||
ProblemsAvsErrorHeading: Error Log
|
||||
ProblemsInterfaceSince: Only considering successes and errors since
|
||||
ProblemsInterfaceSince: Only considering successes and errors since
|
||||
ProblemAvsUsrHadR: Currenlt R valid in AVS
|
||||
|
||||
AdminProblemSolved: Done
|
||||
AdminProblemSolver: Solved by
|
||||
AdminProblemCreated: Recognized
|
||||
AdminProblemInfo: Problem
|
||||
AdminProblemInfoTooltip: Only parts of the following keys currently work here: new-company, supervisor-new-company, supervisor-left-company, superior-change, newly-unsupervised und unknown
|
||||
AdminProblemsSolved n: #{pluralENsN n "admin problem"} marked as solved
|
||||
AdminProblemsReopened n: #{pluralENsN n "admin problem"} reopened
|
||||
AdminProblemNewCompany: New company from AVS; verify and add default supervisors
|
||||
AdminProblemSupervisorNewCompany b: Default company supervisor #{boolText mempty "with reroute" b} changed to new company
|
||||
AdminProblemSupervisorLeftCompany b: Only default company supervisor #{boolText mempty "with reroute" b} for this user changed to new company
|
||||
AdminProblemCompanySuperiorChange: New company wide superior.
|
||||
AdminProblemCompanySuperiorNotFound t: Unable to set supervision for new unknown company wide superior having Email #{t}.
|
||||
AdminProblemCompanySuperiorPrevious: Previous superior:
|
||||
AdminProblemNewlyUnsupervised: Driver has no longer a company default supervisor after AVS update at new company
|
||||
AdminProblemUser: Affected
|
||||
@ -148,4 +150,13 @@ InterfaceSubtype: Affecting
|
||||
InterfaceWrite: Write
|
||||
InterfaceSuccess: Returned
|
||||
InterfaceInfo: Message
|
||||
InterfaceFreshness: Check hours
|
||||
InterfaceFreshness: Maximum usage period
|
||||
InterfaceFreshnessTooltip: Time period within which the next successful interface access must occur to avoid a warning
|
||||
ConfigInterfacesHeading: Configure interface usage warnings
|
||||
|
||||
IWTActAdd: Add/Edit
|
||||
IWTActDelete: Delete
|
||||
InterfaceWarningAdded: Interface warning time added/changed
|
||||
InterfaceWarningDeleted n: #{pluralENsN n "interface warning time"} deleted
|
||||
InterfaceWarningDisabledEntirely: Ignore all errors
|
||||
InterfaceWarningDisabledInterval: No maximum usage period
|
||||
@ -70,6 +70,10 @@ CourseInvalidInput: Eingaben bitte korrigieren.
|
||||
CourseEditTitle: Kursart editieren/anlegen
|
||||
CourseEditOk tid@TermId ssh@SchoolId csh@CourseShorthand: Kursart #{tid}-#{ssh}-#{csh} wurde erfolgreich geändert.
|
||||
CourseEditDupShort tid@TermId ssh@SchoolId csh@CourseShorthand: Kursart #{tid}-#{ssh}-#{csh} konnte nicht geändert werden: Es gibt bereits einen andere Kursart mit dem selben Kürzel oder Titel in diesem Jahr und Bereich.
|
||||
CourseEditQualificationFail: Eine Qualifikation konnte uas unbekanntem Grund nicht mit diesem Kurs assoziert werden.
|
||||
CourseEditQualificationFailRights qsh@QualificationShorthand ssh@SchoolId: Qualifikation #{qsh} konnte nicht mit diesem Kurs assoziert werden, da Ihre Berechtigungen für Bereich #{ssh} dazu nicht ausreichen.
|
||||
CourseEditQualificationFailExists: Diese Qualifikation ist bereits assoziert
|
||||
CourseEditQualificationFailOrder: Diese Sortierpriorität existiert bereits
|
||||
CourseLecturer: Kursverwalter:in
|
||||
MailSubjectParticipantInvitation tid@TermId ssh@SchoolId csh@CourseShorthand: [#{tid}-#{ssh}-#{csh}] Einladung zur Kursartteilnahme
|
||||
CourseParticipantInviteHeading courseName@Text: Einladung zum Kursartteilnahmer für #{courseName}
|
||||
|
||||
@ -70,8 +70,12 @@ CourseInvalidInput: Invalid input
|
||||
CourseEditTitle: Edit/Create course
|
||||
CourseEditOk tid ssh csh: Successfully edited course type #{tid}-#{ssh}-#{csh}
|
||||
CourseEditDupShort tid ssh csh: Could not edit course type #{tid}-#{ssh}-#{csh}. Another course type with the same shorthand or title already exists for the given year and school.
|
||||
CourseEditQualificationFail: A qualifikation could not be associated with this course for unknown reasons.
|
||||
CourseEditQualificationFailRights qsh ssh: Qualification #{qsh} could not be associated with this course, due to your insufficient rights for department #{ssh}.
|
||||
CourseEditQualificationFailExists: This qualification is already associated
|
||||
CourseEditQualificationFailOrder: This sort order priority is used already
|
||||
CourseLecturer: Course administrator
|
||||
MailSubjectParticipantInvitation tid@TermId ssh@SchoolId csh@CourseShorthand: [#{tid}-#{ssh}-#{csh}] Invitaion to join the course
|
||||
MailSubjectParticipantInvitation tid ssh csh: [#{tid}-#{ssh}-#{csh}] Invitaion to join the course
|
||||
CourseParticipantInviteHeading courseName: Invitation to enrol for #{courseName}
|
||||
CourseParticipantInviteExplanation: You were invited to be a participant of a course.
|
||||
CourseParticipantInviteField: Email addresses to invite
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
# SPDX-FileCopyrightText: 2023 Steffen Jost <s.jost@fraport.de>
|
||||
# SPDX-FileCopyrightText: 2023-24 Steffen Jost <s.jost@fraport.de>
|
||||
#
|
||||
# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
@ -15,11 +15,15 @@ FirmActionInfo: Betrifft alle Firmenangehörigen unter Ihrer Aufsicht.
|
||||
FirmActNotify: Mitteilung versenden
|
||||
FirmActResetSupervision: Ansprechpartner für alle Firmenangehörigen zurücksetzen
|
||||
FirmActResetSuperKeep: Bisherige Ansprechpartner der Firmenangehörigen zusätzlich beibehalten?
|
||||
FirmActRemoveSupers: Alle rein firmenbezogenen Ansprechpartnerbeziehungen für diese Personen entfernen?
|
||||
FirmActResetMutualSupervision: Ansprechpartner beaufsichtigen sich gegenseitig
|
||||
FirmActAddSupersvisors: Ansprechpartner hinzufügen
|
||||
FirmActResetSupersKeepAll: Alle behalten
|
||||
FirmActResetSupersRemoveAps: Nur Standardansprechpartner entfernen
|
||||
FirmActResetSupersRemoveAll: Alle entfernen
|
||||
FirmActAddSupervisors: Ansprechpartner hinzufügen
|
||||
FirmActAddSupersEmpty: Es konnten keine Ansprechpartner hinzugefügt werden
|
||||
FirmActAddSupersSet n@Int64 postal@(Maybe Bool): #{n} Standardansprechpartner geändert #{maybeBoolMessage postal "" "und auf Briefversand geschaltet" "und Benachrichtigungen per Email gesetzt"}, aber nicht nicht aktiviert.
|
||||
RemoveSupervisors ndef@Int64 nact@Int64: #{ndef} Standard Ansprechpartner entfernt#{bool ", aber noch nicht deaktiviert" (", " <> tshow nact <> " aktive Ansprechpartnerbeziehungen gelöscht") (nact > 0)}
|
||||
RemoveSupervisors ndef@Int64: #{ndef} Standardansprechpartner entfernt.
|
||||
FirmActChangeContactUser: Kontaktinformationen von allen Firmenangehörigen ändern
|
||||
FirmActChangeContactFirm: Kontaktinformationen der Firma ändern
|
||||
FirmActChangeContactFirmInfo: Firmenkontaktinformationen werden nur für neue Firmenangehörige verwendet, für die sonst keine Kontaktinformationen vorliegen.
|
||||
@ -27,17 +31,23 @@ FirmActChangeContactFirmResult: Firmenkontaktinformationen geändert. Betrifft n
|
||||
FirmUserActNotify: Mitteilung versenden
|
||||
FirmUserActResetSupervision: Ansprechpartner auf Firmenstandard zurücksetzen
|
||||
FirmUserActSetSupervisor: Ansprechpartner ändern
|
||||
FirmUserActChangeContact: Kontaktinformationen für ausgewählte Firmenangehörige ändern
|
||||
FirmUserActChangeDetails: Firmenassoziation bearbeiten
|
||||
FirmUserActRemove: Firmenassoziation entfernen
|
||||
FirmUserActMkSuper: Zum Firmenansprechpartner ernennen
|
||||
FirmUserActChangeDetailsResult n@Int64 t@Int64: Firmenassoziation von #{n}/#{t} #{pluralDE n "Firmenangehörigen" "Firmenangehörige"} wurden aktualisiert
|
||||
FirmUserActChangeResult n@Int64 t@Int64: Benachrichtigungseinstellung für #{n}/#{t} #{pluralDE n "Firmenangehörigen" "Firmenangehörige"} wurden geändert
|
||||
FirmUserActRemoveResult uc@Int64: #{uc} #{pluralDE uc "Firmenassoziation" "Firmenassoziationen"} entfernt.
|
||||
FirmRemoveSupervision sup@Int64 sub@Int64: #{noneMoreDE sup "" (tshow sup <> " Ansprechpartnerbeziehungen wegen entferntem Ansprechpartner gelöscht. ")} #{noneOneMoreDE sub "Keine Ansprechpartnerbeziehung" "Eine Ansprechpartnerbeziehung" (tshow sup <> " Ansprechpartnerbeziehungen")} wegen entferntem Angesprochenem gelöscht.
|
||||
FirmNewSupervisor: Neue individuelle Ansprechpartner hinzufügen
|
||||
FirmSetSupervisor: Existierende Ansprechpartner hinzufügen
|
||||
FirmSetSupersReport nusr@Int64 nspr@Int64 nrem@Int64: Für #{nusr} Firmenangehörige wurden #{nspr} individuelle Ansprechpartner eingetragen#{bool "." (" und " <> tshow nrem <> " individuelle Ansprechpartnerbeziehungen gelöscht.") (nrem >0)}
|
||||
FirmUserActMkSuper: Zum Firmenansprechpartner ernennen
|
||||
FirmUserActChangeContact: Kontaktinformationen für ausgewählte Firmenangehörige ändern
|
||||
FirmResetSupervision rem@Int64 set@Int64: #{tshow set} Ansprechpartner gesetzt#{bool mempty (", " <> tshow rem <> " zuvor gelöscht") (rem > 0)}
|
||||
FirmSuperActNotify: Mitteilung versenden
|
||||
FirmSuperActSwitchSuper: Standard Firmenansprechpartner abändern
|
||||
FirmSuperActSwitchSuperInfo: Betrifft keine firmenfremden Ansprechpartner und ändert keine aktiven individuellen Ansprechpartnerbeziehungen. Gegebenfalls im Anschluss die Funktion "Ansprechpartner auf Firmenstandard zurücksetzen" nutzen.
|
||||
FirmSuperActRMSuperDef: Firmenansprechpartner entfernen
|
||||
FirmSuperActRMSuperActive: Auch aktive Ansprechpartnerbeziehungen innerhalb dieser Firma beenden
|
||||
FirmSuperActRMSuperActive: Aktive Ansprechpartnerbeziehungen innerhalb dieser Firma beenden?
|
||||
FirmsNotification: Firmen E-Mail versenden
|
||||
FirmNotification fsh@CompanyShorthand: E-Mail an #{fsh} senden
|
||||
FirmsNotificationTitle: Firmen benachrichtigen
|
||||
@ -46,7 +56,9 @@ FilterSupervisor: Hat aktiven Ansprechpartner
|
||||
FilterSupervisorCompany fsh@CompanyShorthand: Hat aktiven Ansprechpartner, #{fsh} der angehört
|
||||
FilterSupervisorForeign fsh@CompanyShorthand: Hat aktiven Ansprechpartner, der selbst nicht #{fsh} angehört
|
||||
FilterForeignSupervisor: Hat firmenfremde Ansprechpartner
|
||||
FilterIsForeignSupervisee: Ist Ansprechpartner für Firmenfremde
|
||||
FilterFirmExtern: Externe Firma
|
||||
FilterFirmExternTooltip: Hat die Firma eine Postanschrift im AVS?
|
||||
FilterFirmPrimary: Ist primäre Firma in FRADrive
|
||||
FilterHasQualification: Hat Firmenangehörige mit aktuell gültiger Qualifikation
|
||||
FirmSupervisorOf fsh@CompanyShorthand: Ansprechpartner #{fsh} angehörig
|
||||
@ -54,8 +66,13 @@ FirmSupervisorIndependent: Ansprechpartner ohne jegliche Firmenzugehörigkeit
|
||||
FirmEmployeeOf fsh@CompanyShorthand: Firmenangehörige #{fsh}
|
||||
NoCompanySelected: Bitte wählen Sie mindestens eine Firma aus.
|
||||
TableIsDefaultSupervisor: Standardansprechpartner
|
||||
TableSuperior: Vorgesetzter
|
||||
TableIsDefaultReroute: Standardumleitung
|
||||
FormFieldPostal: Benachrichtigungseinstellung
|
||||
FormFieldPostalTip: Gilt für alle Benachrichtigungen an diese Person, nicht nur für Umleitungen an diesen Ansprechpartner
|
||||
FirmUserChanges n@Int64: Benachrichtigungseinstellung für #{n} Firmenangehörige wurden geändert
|
||||
FirmSupervisionKeyData: Kennzahlen Ansprechpartner
|
||||
FirmSupervisionKeyData: Kennzahlen Ansprechpartner
|
||||
CompanyUserPriority: Firmenpriorität
|
||||
CompanyUserPriorityTip: Firmenpriorität ist lediglich relativ zu anderen Firmenassoziation der Person
|
||||
CompanyUserUseCompanyAddress: Verwendet Firmenkontaktaddresse
|
||||
CompanyUserUseCompanyAddressTip: sofern im Benutzer keine Postanschrift hinterlegt ist
|
||||
CompanyUserUseCompanyPostalError: Postalische Adresse muss leer bleiben, damit die Firmenanschrift genutzt wird!
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
# SPDX-FileCopyrightText: 2023 Steffen Jost <s.jost@fraport.de>
|
||||
# SPDX-FileCopyrightText: 2023-24 Steffen Jost <s.jost@fraport.de>
|
||||
#
|
||||
# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
@ -15,11 +15,15 @@ FirmActionInfo: Affects alle company associates under your supervision.
|
||||
FirmActNotify: Send message
|
||||
FirmActResetSupervision: Reset supervisors for all company associates
|
||||
FirmActResetSuperKeep: Additionally keep existing supervisors of company associates?
|
||||
FirmActRemoveSupers: Terminate all company related supervisonships?
|
||||
FirmActResetMutualSupervision: Supervisors supervise each other
|
||||
FirmActAddSupersvisors: Add supervisors
|
||||
FirmActResetSupersKeepAll: Keep all
|
||||
FirmActResetSupersRemoveAps: Remove default supervisors only
|
||||
FirmActResetSupersRemoveAll: Remove all
|
||||
FirmActAddSupervisors: Add supervisors
|
||||
FirmActAddSupersEmpty: No supervisors added
|
||||
FirmActAddSupersSet n postal: #{n} default company supervisors changed #{maybeBoolMessage postal "" "and switched to postal notifications" "and switched to email notifications"}, but not yet activated.
|
||||
RemoveSupervisors ndef nact: #{ndef} default supervisors removed#{bool ", but not yet deactivated" (" and " <> tshow nact <> " active supervisions terminated") (nact > 0)}
|
||||
RemoveSupervisors ndef: #{ndef} default supervisors removed.
|
||||
FirmActChangeContactUser: Change contact data for all company associates
|
||||
FirmActChangeContactFirm: Change company contact data
|
||||
FirmActChangeContactFirmInfo: The company contact data is only used for new company associates that would habe no contact information of their own otherwise.
|
||||
@ -27,17 +31,23 @@ FirmActChangeContactFirmResult: Company contact data changed, affecting future c
|
||||
FirmUserActNotify: Send message
|
||||
FirmUserActResetSupervision: Reset supervisors to company default
|
||||
FirmUserActSetSupervisor: Change supervision
|
||||
FirmUserActChangeContact: Change contact data for selected company associates
|
||||
FirmUserActChangeDetails: Edit company association
|
||||
FirmUserActRemove: Delete company association
|
||||
FirmUserActMkSuper: Mark as company supervisor
|
||||
FirmUserActChangeDetailsResult n t: #{n}/#{t} #{pluralENs n "company association"} updated
|
||||
FirmUserActChangeResult n t: Notification settings changed for #{n}/#{t} company #{pluralENs n "associate"}
|
||||
FirmUserActRemoveResult uc: #{pluralENsN uc "Company association"} deleted.
|
||||
FirmRemoveSupervision sup sub: #{noneMoreEN sup "" ((pluralENsN sup "supervision") <> " removed due to eliminated supervisors.")} #{noneMoreEN sub "No supervision" (pluralENsN sub "supervision")} removed due to eliminated supervisees.
|
||||
FirmNewSupervisor: Appoint new individual supervisors
|
||||
FirmSetSupervisor: Add existing supervisors
|
||||
FirmSetSupersReport nusr@Int64 nspr@Int64 nrem@Int64: #{nspr} individal supervisors set for #{nusr} company associates#{bool "." (" and " <> tshow nrem <> " other individual supervisions terminated.") (nrem >0)}
|
||||
FirmSetSupersReport nusr nspr nrem: #{nspr} individual supervisors set for #{nusr} company associates#{bool "." (" and " <> tshow nrem <> " other individual supervisions terminated.") (nrem >0)}
|
||||
FirmResetSupervision rem set: #{tshow set} supervisors set#{bool mempty (", " <> tshow rem <> " deleted before") (rem > 0)}
|
||||
FirmUserActChangeContact: Change contact data for selected company associates
|
||||
FirmUserActMkSuper: Mark as company supervisor
|
||||
FirmSuperActNotify: Send message
|
||||
FirmSuperActSwitchSuper: Change default company supervisor
|
||||
FirmSuperActSwitchSuperInfo: Does not affect company-external supervisors and does not change any active individal supervisions. Additionally use reset action, if desired.
|
||||
FirmSuperActSwitchSuperInfo: Does not affect company-external supervisors and does not change any active individual supervisions. Additionally use reset action, if desired.
|
||||
FirmSuperActRMSuperDef: Remove default supervisor
|
||||
FirmSuperActRMSuperActive: Also remove active supervisions within this company
|
||||
FirmSuperActRMSuperActive: Terminate active supervisions within this company?
|
||||
FirmsNotification: Send company notification e-mail
|
||||
FirmNotification fsh: Send e-mail to #{fsh}
|
||||
FirmsNotificationTitle: Company notification
|
||||
@ -46,7 +56,9 @@ FilterSupervisor: Has active supervisor
|
||||
FilterSupervisorCompany fsh: Has active company supervisor belonging to #{fsh}
|
||||
FilterSupervisorForeign fsh: Has active supervisor not belonging to #{fsh}
|
||||
FilterForeignSupervisor: Has company-external supervisors
|
||||
FilterIsForeignSupervisee: Supervisor for company external users
|
||||
FilterFirmExtern: External company
|
||||
FilterFirmExternTooltip: i.e. is a postal address registered within AVS?
|
||||
FilterFirmPrimary: Is primary company in FRADrive
|
||||
FilterHasQualification: Has company associates with currently valid qualification
|
||||
FirmSupervisorOf fsh@CompanyShorthand: Supervisors belonging to #{fsh}
|
||||
@ -54,8 +66,13 @@ FirmSupervisorIndependent: Independent supervisors
|
||||
FirmEmployeeOf fsh@CompanyShorthand: #{fsh} associated users
|
||||
NoCompanySelected: Select at least one company, please.
|
||||
TableIsDefaultSupervisor: Default supervisor
|
||||
TableSuperior: Superior
|
||||
TableIsDefaultReroute: Default reroute
|
||||
FormFieldPostal: Notification type
|
||||
FormFieldPostalTip: Affects all notifications to this person, not just reroutes to this supervisor
|
||||
FirmUserChanges n: Notification settings changed for #{n} company associates
|
||||
FirmSupervisionKeyData: Supervision key data
|
||||
FirmSupervisionKeyData: Supervision key data
|
||||
CompanyUserPriority: Company priority
|
||||
CompanyUserPriorityTip: Company priority is relative to other company associations for a user
|
||||
CompanyUserUseCompanyAddress: Use company postal address
|
||||
CompanyUserUseCompanyAddressTip: if and only if the postal address of the user is empty
|
||||
CompanyUserUseCompanyPostalError: Individual postal address must left empty for the company address to be used!
|
||||
|
||||
@ -26,4 +26,7 @@ PrintPDF !ident-ok: PDF
|
||||
PrintManualRenewal: Vorfeldführerschein Renewal-Brief testweise versenden
|
||||
PrintLmsUser: E‑Learning Id
|
||||
PrintJobs: Druckaufräge
|
||||
PrintLetterType: Brieftypkürzel
|
||||
PrintLetterType: Brieftypkürzel
|
||||
|
||||
MCActDummy: Platzhalter
|
||||
CCActDummy: Platzhalter
|
||||
@ -26,4 +26,7 @@ PrintPDF: PDF
|
||||
PrintManualRenewal: Manual sending of an apron driver's licence renewal letter
|
||||
PrintLmsUser: E‑learning id
|
||||
PrintJobs: Print jobs
|
||||
PrintLetterType: Letter type shorthand
|
||||
PrintLetterType: Letter type shorthand
|
||||
|
||||
MCActDummy: Placeholder
|
||||
CCActDummy: Placeholder
|
||||
@ -11,11 +11,14 @@ QualificationAuditDuration: Aufbewahrung Audit Log
|
||||
QualificationAuditDurationTooltip n@Int: Optionaler Zeitraum zur Löschung von E‑Learning Daten. Hinweis: Der E‑Learning Server kann seine anonymisierten Daten schon früher löschen, aber spätestens #{n} Tage nach Abschluss.
|
||||
QualificationAuditDurationReuseError: Diese Qualifikation nutzt das E‑Learning einer anderen Qualifikation, für die derzeit keinen Löschzeitraum konfiguriert wurde.
|
||||
QualificationRefreshWithin: Erneurerungszeitraum
|
||||
QualificationRefreshWithinTooltip: Optionaler Zeitraum vor Ablauf für automatischen Start des E‑Learnings und Versand einer Benachrichtigung per Brief oder Email.
|
||||
QualificationRefreshReminder: 2. Erinnerung
|
||||
QualificationRefreshReminderTooltip: Optionaler Zeitraum vor Ablauf zur Versendung einer zweiten Erinnerung per Brief oder Email mit identischen Zugangsdaten, sofern in diesem Zeitraum vor Ablauf noch keine Ablaufbenachrichtigung versendet wurde.
|
||||
QualificationRefreshWithinTooltip: Optionaler Zeitraum vor Ablauf für eine Benachrichtigung per Email. Bei aktiviertem automatischem E‑Learning wird dieses gestartet und die Benachrichtigung erfolgt per Brief oder Email.
|
||||
QualificationRefreshReminder: Zweite Erinnerung
|
||||
QualificationRefreshReminderTooltip: Optionaler Zeitraum vor Ablauf zur Versendung einer zweiten Erinnerung per Brief oder Email mit identischen E‑Learning Zugangsdaten, sofern die Qualifikation noch gültig und das E‑Learning noch offen ist.
|
||||
QualificationElearningStart: Wird das E‑Learning automatisch gestartet?
|
||||
QualificationElearningRenew: Verlängert ein erfolgreiches E‑Learning die Qualifikation automatisch um die reguläre Gültigkeitsdauer?
|
||||
QualificationElearningLimit: Ist die Anzahl der E‑Learning Versuche limitiert?
|
||||
QualificationElearningLimitMax n@Int: Maximal #{n} Versuche
|
||||
QualificationElearningNoLimit: Nicht limitiert
|
||||
QualificationExpiryNotification: Ungültigkeitsbenachrichtigung?
|
||||
QualificationExpiryNotificationTooltip: Nutzer werden benachrichtigt, wenn die Qualifikation ungültig wird, sofern der jeweilige Nutzer in seinen Benutzereinstellungen diese Art Benachrichtigung aktiviert hat.
|
||||
TableQualificationCountActive: Aktive
|
||||
@ -54,6 +57,7 @@ TableLmsEmail: E‑Mail
|
||||
TableLmsIdent: E‑Learning Benutzer
|
||||
TableLmsElearning: E‑Learning
|
||||
TableLmsElearningRenews: Automatische Verlängerung
|
||||
TableLmsElearningLimit: Maximale Versuche
|
||||
TableLmsPin: E‑Learning Passwort
|
||||
TableLmsResetPin: E‑Learning Passwort zurücksetzen?
|
||||
TableLmsDatePin: E‑Learning Passwort erstellt
|
||||
@ -119,7 +123,7 @@ QualificationStatusBlock l@QualificationShorthand n@Int m@Int: #{n}/#{m} #{l}
|
||||
QualificationStatusUnblock l@QualificationShorthand n@Int m@Int: #{n}/#{m} #{l} reaktiviert
|
||||
LmsInactive: Aktuell kein E‑Learning aktiv
|
||||
LmsRenewalInstructions: Weitere Anweisungen zur Verlängerung finden Sie im angehängten PDF. Um Missbrauch zu verhindern wurde das PDF mit dem im FRADrive hinterlegten PDF-Passwort des Prüflings verschlüsselt. Falls kein PDF-Passwort manuell hinterlegt wurde, ist das PDF-Passwort die Flughafen Ausweisnummer, inklusive Punkt und der Ziffer danach.
|
||||
LmsNoRenewal: Leider kann diese Qualifikation nicht alleine durch E‑Learning verlängert werden.
|
||||
LmsNoRenewal: Leider kann diese Qualifikation nicht alleine durch E‑Learning verlängert werden. Bitte setzen Sie sich mit uns in Verbindung, wenn Sie die Qualifikation verlängern möchten und noch nicht wissen, wie Sie das tun können. Ignorieren Sie diese automatisch generierte Erinnerung, falls Sie sich bereits um die Verlängerung gekümmert haben
|
||||
LmsRenewalReminder: Erinnerung
|
||||
LmsActNotify: Benachrichtigung E‑Learning erneut per Post oder E-Mail versenden
|
||||
LmsActRenewPin: Neues zufällige E‑Learning Passwort zuweisen
|
||||
|
||||
@ -11,11 +11,14 @@ QualificationAuditDuration: Audit log retention period
|
||||
QualificationAuditDurationTooltip n@Int: Optional period for deletion of e‑learning data. Note that the e‑learning server may delete its anonymised data earlier, at most #{n} days after closing.
|
||||
QualificationAuditDurationReuseError: This qualification reuses the e‑learning from another qualification, which has no audit duration configured.
|
||||
QualificationRefreshWithin: Refresh within
|
||||
QualificationRefreshWithinTooltip: Optional period before expiry to start e‑learning and send a notification by post or email.
|
||||
QualificationRefreshReminder: 2. Reminder
|
||||
QualificationRefreshReminderTooltip: Optional period before expiry to send a second notification by post or email once more, provided that no renewal notification was sent in this period before expiry.
|
||||
QualificationRefreshWithinTooltip: Optional period before expiry to send a notification by email. If e‑learning is set to start automatically, it will be started and e‑learning credentials are send with this notification by post or email.
|
||||
QualificationRefreshReminder: Second reminder
|
||||
QualificationRefreshReminderTooltip: Optional period before expiry to send a second notification by post or email once more, including the existing credentials, provided that the e‑learning is still undecided and the qualification has not yet expired.
|
||||
QualificationElearningStart: Is e‑learning automatically started?
|
||||
QualificationElearningRenew: Does successful e‑learning automatically extend a qualification by the default validity period?
|
||||
QualificationElearningLimit: Is the number of e‑learning attempts limited?
|
||||
QualificationElearningLimitMax n: #{n} attempts maximum
|
||||
QualificationElearningNoLimit: No limit
|
||||
QualificationExpiryNotification: Invalidity notification?
|
||||
QualificationExpiryNotificationTooltip: Qualification holder are notfied upon invalidity, provided they have activated such notification in their user settings.
|
||||
TableQualificationCountActive: Active
|
||||
@ -55,6 +58,7 @@ TableLmsIdent: E‑learning user
|
||||
TableLmsPin: E‑learning password
|
||||
TableLmsElearning: E‑learning
|
||||
TableLmsElearningRenews: Automatic renewal
|
||||
TableLmsElearningLimit: Max attempts
|
||||
TableLmsResetPin: Reset E‑learning password?
|
||||
TableLmsDatePin: E‑learning password created
|
||||
TableLmsDate: Date
|
||||
@ -119,7 +123,7 @@ QualificationStatusBlock l n m: #{n}/#{m} #{l} revoked
|
||||
QualificationStatusUnblock l n m: #{n}/#{m} #{l} reactivated
|
||||
LmsInactive: Currently no active e‑learning
|
||||
LmsRenewalInstructions: Instruction on how to accomplish the renewal are enclosed in the attached PDF. In order to avoid misuse, the PDF is encrypted with the FRADrive PDF-password of the examinee. If no PDF-password had been chosen yet, then the password is the Fraport id card number of the examinee, including the punctuation mark and the digit thereafter.
|
||||
LmsNoRenewal: Unfortunately, this particular qualification cannot be renewed through e‑learning only.
|
||||
LmsNoRenewal: Unfortunately, this particular qualification cannot be renewed through e‑learning only. Please contact us, if you do not yet know how to renew this qualification. Ignore this automatically generated reminder email, if you have made arrangements for the renewal of this qualification already.
|
||||
LmsRenewalReminder: Reminder
|
||||
LmsActNotify: Resend e‑learning notification by post or email
|
||||
LmsActRenewPin: Randomly replace e‑learning password
|
||||
|
||||
@ -29,7 +29,7 @@ Remarks: Hinweis:
|
||||
|
||||
ProfileNoSupervisor: Keine übergeordneten Ansprechpartner vorhanden
|
||||
ProfileSupervisor n@Int m@Int: #{n} #{pluralDE n "übergeordneter" "übergeordnete"} Ansprechpartner#{noneMoreDE m "" (", davon " <> tshow m <> " mit Benachrichtigungsumleitung")}
|
||||
ProfileSupervisorRemark n@Int m@Int l@Int: #{m}/#{n} #{pluralDE m "übergeordneter" "übergeordnete"} Ansprechpartner mit Benachrichtigungsumleitung#{noneMoreDE l "" (", davon " <> tshow l <> " mit postalischer Benachrichtigung")}
|
||||
ProfileSupervisorRemark n@Int m@Int l@Int: #{m} von #{n} #{pluralDE m "übergeordneter" "übergeordnete"} Ansprechpartner mit Benachrichtigungsumleitung#{noneMoreDE l "" (", davon " <> tshow l <> " mit postalischer Benachrichtigung")}
|
||||
ProfileNoSupervisee: Ist kein Ansprechpartner für irgendjemand
|
||||
ProfileSupervisee n@Int m@Int: Ist Ansprechpartner für #{n} #{pluralDE n "Person" "Personen"}#{noneMoreDE m "" (", davon " <> tshow m <> " mit Benachrichtigungsumleitung")}
|
||||
ProfileSuperviseeRemark n@Int m@Int: Dieser Nutzer ist Ansprechpartner für #{n} #{pluralDE n "Person" "Personen"}#{noneMoreDE m "" (", davon " <> tshow m <> " mit Benachrichtigungsumleitung")}
|
||||
|
||||
@ -29,7 +29,7 @@ Remarks: Remark:
|
||||
|
||||
ProfileNoSupervisor: Is not supervised by anynone
|
||||
ProfileSupervisor n m: #{pluralENsN n "supervisor"} #{noneMoreEN m "" ("with " <> tshow m <> " active notification rerouting")}
|
||||
ProfileSupervisorRemark n@Int m@Int l@Int: #{m}/#{n} #{pluralENs m "supervisor"} with active notification rerouting#{noneMoreEN l "" (", and " <> tshow l <> "of these prefer postal notifications")}
|
||||
ProfileSupervisorRemark n@Int m@Int l@Int: #{m} of #{n} #{pluralENs m "supervisor"} with active notification rerouting#{noneMoreEN l "" (", and " <> tshow l <> "of these prefer postal notifications")}
|
||||
ProfileNoSupervisee: Does not supervise anynone
|
||||
ProfileSupervisee n m: Supervises #{pluralENsN n "person"} #{noneMoreEN m "" ("with " <> tshow m <> " active notification rerouting")}
|
||||
ProfileSuperviseeRemark n m: This person supervises #{pluralENsN n "person"}#{noneMoreEN m "" (" with " <> tshow m <> " having active notifications rerouting to this user")}
|
||||
|
||||
@ -22,6 +22,7 @@ AdminUserPostAddress: Postalische Anschrift
|
||||
AdminUserPrefersPostal: Briefe anstatt Email bevorzugt
|
||||
AdminUserPinPassword: Passwort zur Verschlüsselung von PDF Anhängen in Emails
|
||||
AdminUserNoPassword: Kein Passwort gesetzt
|
||||
AdminUserPinPassNotIncluded: Hinweis: Das Passwort wird hier zur Bequemlichkeit zusätzlich angezeigt und ist selbstverständlich nicht im originalem Inhalt enthalten.
|
||||
AdminUserAssimilate: Diesen Benutzer assimilieren von
|
||||
UserAdded: Benutzer erfolgreich angelegt
|
||||
UserCollision: Benutzer konnte wegen Eindeutigkeit nicht angelegt werden
|
||||
@ -37,10 +38,10 @@ AuthPWHashAlreadyConfigured: Nutzer:in meldet sich bereits mit FRADrive spezifis
|
||||
AuthPWHashConfigured: Nutzer:in meldet sich nun mit FRADrive spezifischer Kennung an
|
||||
UsersCourseSchool: Bereich
|
||||
ActionNoUsersSelected: Keine Benutzer:innen ausgewählt
|
||||
SynchroniseAvsUserQueued n@Int: AVS-Synchronisation von #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} zwingend angestoßen
|
||||
SynchroniseAvsAllUsersQueued n@Int64: AVS-Synchronisation von allen #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} angestoßen, welche heute noch nicht synchronisiert wurden
|
||||
SynchroniseLdapUserQueued n@Int: LDAP-Synchronisation von #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} angestoßen
|
||||
SynchroniseLdapAllUsersQueued: LDAP-Synchronisation von allen Benutzer:innen angestoßen
|
||||
SynchroniseAvsUserQueued n@Int: AVS-Synchronisation von #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} zwingend angestoßen, die Ausführung wird mehrere Minuten benötigen!
|
||||
SynchroniseAvsAllUsersQueued n@Int64: AVS-Synchronisation von allen #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} angestoßen, welche heute noch nicht synchronisiert wurden, die Ausführung wird eine Weile brauchen!
|
||||
SynchroniseLdapUserQueued n@Int: LDAP-Synchronisation von #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} angestoßen, die Ausführung wird mehrere Minuten benötigen!
|
||||
SynchroniseLdapAllUsersQueued: LDAP-Synchronisation von allen Benutzer:innen angestoßen, die Ausführung kann eine Weile brauchen!
|
||||
UserListTitle: Komprehensive Benutzerliste
|
||||
AccessRightsSaved: Berechtigungen erfolgreich verändert
|
||||
AccessRightsNotChanged: Berechtigungen wurden nicht verändert
|
||||
@ -111,4 +112,8 @@ UsersChangeSupervisorsSuccess usr@Int spr@Int: #{tshow spr} Ansprechpartner für
|
||||
UsersChangeSupervisorsWarning usr@Int spr@Int bad@Int: Nur _{MsgUsersChangeSupervisorsSuccess usr spr} #{tshow bad} Ansprechpartner #{pluralDE bad "wurde" "wurden"} nicht gefunden!
|
||||
UsersRemoveSupervisors usr@Int: Alle Ansprechpartner für #{tshow usr} Benutzer gelöscht.
|
||||
UsersRemoveSubordinates usr@Int: Alle Ansprechpartnerbeziehungen für #{tshow usr} #{pluralDE usr "ehemaligen" "ehemalige"} Ansprechpartner gelöscht.
|
||||
SupervisorReason: Begründung
|
||||
UserCompanyReason: Begründung der Firmenassoziation
|
||||
UserCompanyReasonTooltip: Optionale Notiz für besondere Fälle. Kann ggf. autmatische Entfernung bei AVS Firmenwechsel verhindern.
|
||||
UserSupervisorReason: Begründung Ansprechpartner
|
||||
UserSupervisorReasonTooltip: Optionale Notiz für besondere Fälle. Kann ggf. autmatische Entfernung bei AVS Firmenwechsel verhindern.
|
||||
AdminUserAllNotifications: Alle Benachrichtigungen and diesen Benutzer
|
||||
@ -22,6 +22,7 @@ AdminUserPostAddress: Postal Address
|
||||
AdminUserPrefersPostal: Prefers postal letters over email
|
||||
AdminUserPinPassword: Password used for PDF attachments to emails
|
||||
AdminUserNoPassword: No password set
|
||||
AdminUserPinPassNotIncluded: Note: the password is shown here only for convenience, but is not contained in the original content, of course.
|
||||
AdminUserAssimilate: Assimilate user by another user
|
||||
UserAdded: Successfully added user
|
||||
UserCollision: Could not create user due to uniqueness constraint
|
||||
@ -37,10 +38,10 @@ AuthPWHashAlreadyConfigured: User already logs in using their FRADrive specific
|
||||
AuthPWHashConfigured: User now logs in using their FRADrive specific account
|
||||
UsersCourseSchool: Department
|
||||
ActionNoUsersSelected: No users selected
|
||||
SynchroniseAvsUserQueued n: Triggered forced AVS synchronisation of #{n} #{pluralEN n "user" "users"}
|
||||
SynchroniseAvsAllUsersQueued n: Triggered AVS synchronisation of all #{n} #{pluralEN n "user" "users"} that were not already synchronised today
|
||||
SynchroniseLdapUserQueued n: Triggered LDAP synchronisation of #{n} #{pluralEN n "user" "users"}
|
||||
SynchroniseLdapAllUsersQueued: Triggered LDAP synchronisation of all users
|
||||
SynchroniseAvsUserQueued n: Triggered forced AVS synchronisation of #{n} #{pluralEN n "user" "users"}, which may take several minutes to complete.
|
||||
SynchroniseAvsAllUsersQueued n: Triggered AVS synchronisation of all #{n} #{pluralEN n "user" "users"} that were not already synchronised today, which may take quite a while to complete.
|
||||
SynchroniseLdapUserQueued n: Triggered LDAP synchronisation of #{n} #{pluralEN n "user" "users"}, which may take several minutes to complete.
|
||||
SynchroniseLdapAllUsersQueued: Triggered LDAP synchronisation of all users, which may take quite a while to complete.
|
||||
UserListTitle: Comprehensive list of users
|
||||
AccessRightsSaved: Successfully updated permissions
|
||||
AccessRightsNotChanged: Permissions left unchanged
|
||||
@ -111,4 +112,8 @@ UsersChangeSupervisorsSuccess usr spr: #{pluralENsN spr "supervisor"} for #{plur
|
||||
UsersChangeSupervisorsWarning usr spr bad: Only _{MsgUsersChangeSupervisorsSuccess usr spr} #{pluralENsN bad "supervisors"} could not be identified!
|
||||
UsersRemoveSupervisors usr: Removed all supervisors for #{pluralENsN usr "user"}.
|
||||
UsersRemoveSubordinates usr: Removed all subordinates for #{pluralENsN usr "previous supervisor"}.
|
||||
SupervisorReason: Reason
|
||||
UserCompanyReason: Reason for company association
|
||||
UserCompanyReasonTooltip: Optional note for special cases. In some case this may prevent automatic removel upon AVS user company changes.
|
||||
UserSupervisorReason: Reason for supervision
|
||||
UserSupervisorReasonTooltip: Optional note for special cases. In some case this may prevent automatic removel upon AVS user company changes.
|
||||
AdminUserAllNotifications: All notification sent to this user
|
||||
@ -12,10 +12,12 @@ FieldSecondary: Nebenfach
|
||||
MultiEmailFieldTip: Es sind mehrere, Komma-separierte, E-Mail-Adressen möglich
|
||||
MultiSelectTip: Mehrfachauswahl und Abwählen mit Strg-Klick
|
||||
WeekDay: Wochentag
|
||||
Hours: Stunden
|
||||
LdapIdentificationOrEmail: Fraport AG-Kennung / E-Mail-Adresse
|
||||
Months num@Int64: #{num} #{pluralDE num "Monat" "Monate"}
|
||||
Days num@Int64: #{num} #{pluralDE num "Tag" "Tage"}
|
||||
NoAutomaticUpdateTip: Dieser Wert wurde manuell editiert und wird daher nicht mehr automatisch durch as AVS aktualisiert.
|
||||
AddressIsLinkedTip: Verlinkte Postaddresse: Für diesen Benutzer ist keine individuelle Postadresse gespeichert, die Adresse wurde stattdessen aus der Firmenzugehörigkeit abgeleitet.
|
||||
|
||||
ClusterVolatileQuickActionsEnabled: Schnellzugriffsmenü aktiv
|
||||
|
||||
@ -26,4 +28,7 @@ AvsNoLicenceGuest: Keine Fahrberechtigung (Gast, Fahrberechtigungserwerb nicht m
|
||||
|
||||
PaginationSize: Einträge pro Seite
|
||||
PaginationPage: Angzeigte Seite
|
||||
PaginationError: Paginierung Parameter dürfen nicht negativ sein
|
||||
PaginationError: Paginierung Parameter dürfen nicht negativ sein
|
||||
|
||||
NullDeletes: Zum Löschen NULL eingeben.
|
||||
SortPriority: Sortierungspriorität
|
||||
@ -12,10 +12,12 @@ FieldSecondary: Minor
|
||||
MultiEmailFieldTip: Multiple emails addresses may be specified (comma-separated)
|
||||
MultiSelectTip: Multiple selection and desection via Ctrl-Click
|
||||
WeekDay: Day of the week
|
||||
Hours: Hours
|
||||
LdapIdentificationOrEmail: Fraport AG-Kennung / email address
|
||||
Months num: #{num} #{pluralEN num "Month" "Months"}
|
||||
Days num: #{num} #{pluralEN num "Day" "Days"}
|
||||
NoAutomaticUpdateTip: This particular value receives no automatic AVS updates, since it has been edited manually.
|
||||
AddressIsLinkedTip: Linked postal address: No individual postal address is stored for this user, instead a postal address was inferred from the user's company association.
|
||||
|
||||
ClusterVolatileQuickActionsEnabled: Quick actions enabled
|
||||
|
||||
@ -26,4 +28,7 @@ AvsNoLicenceGuest: No driving licence (Guest account, cannot acquire a diriving
|
||||
|
||||
PaginationSize: Rows per Page
|
||||
PaginationPage: Page to show
|
||||
PaginationError: Pagination parameter must not be negative
|
||||
PaginationError: Pagination parameter must not be negative
|
||||
|
||||
NullDeletes: Enter NULL to delete.
|
||||
SortPriority: Sort order priority
|
||||
@ -143,12 +143,18 @@ MenuSap: SAP Schnittstelle
|
||||
MenuAvs: AVS Schnittstelle
|
||||
MenuAvsSynchError: AVS Problemübersicht
|
||||
MenuLdap: LDAP Schnittstelle
|
||||
MenuApc: Druckerei
|
||||
MenuApc: Druck
|
||||
MenuPrintSend: Manueller Briefversand
|
||||
MenuPrintDownload: Brief herunterladen
|
||||
MenuPrintLog: LPR Schnittstelle
|
||||
MenuPrintAck: Druckbestätigung
|
||||
|
||||
MenuCommCenter: Benachrichtigungen
|
||||
MenuMailCenter: E‑Mails
|
||||
MenuMailHtml !ident-ok: Html
|
||||
MenuMailPlain !ident-ok: Text
|
||||
MenuMailAttachment: Anhang
|
||||
|
||||
MenuApiDocs: API-Dokumentation (Englisch)
|
||||
MenuSwagger !ident-ok: OpenAPI 2.0 (Swagger)
|
||||
|
||||
|
||||
@ -143,12 +143,18 @@ MenuSap: SAP Interface
|
||||
MenuAvs: AVS Interface
|
||||
MenuAvsSynchError: AVS Problem Overview
|
||||
MenuLdap: LDAP Interface
|
||||
MenuApc: Printing
|
||||
MenuApc: Print
|
||||
MenuPrintSend: Send Letter
|
||||
MenuPrintDownload: Download Letter
|
||||
MenuPrintLog: LPR Interface
|
||||
MenuPrintAck: Acknowledge Printing
|
||||
|
||||
MenuCommCenter: Notifications
|
||||
MenuMailCenter: Email
|
||||
MenuMailHtml: Html
|
||||
MenuMailPlain: Text
|
||||
MenuMailAttachment: Attachment
|
||||
|
||||
MenuApiDocs: API documentation
|
||||
MenuSwagger: OpenAPI 2.0 (Swagger)
|
||||
|
||||
|
||||
@ -79,11 +79,13 @@ TableCompany: Firma
|
||||
TableCompanyFilter: Firma oder Nummer
|
||||
TableCompanyShort: Firmenkürzel
|
||||
TableCompanies: Firmen
|
||||
TablePrimeCompany: Primäre Firma
|
||||
TableCompanyNo: Firmennummer
|
||||
TableCompanyNos: Firmennummern
|
||||
TableCompanyUser: Firmenangehöriger
|
||||
TableCompanyNrUsers: Firmenangehörige
|
||||
TableCompanyNrSecondaryUsers: Sekundäre Firmenangehörige
|
||||
TableCompanyReason: Notiz
|
||||
TableCompanyNrSupers: Ansprechpartner
|
||||
TableCompanyNrEmpSupervised: Firmenangehörige mit Ansprechpartner
|
||||
TableCompanyNrEmpRerouted: Firmenangehörige mit Umleitung
|
||||
@ -97,6 +99,7 @@ TableRerouteActive: Umleitung
|
||||
TableCompanyPostalPreference: Benachrichtigungspräferenz neue Firmenangehörige
|
||||
TableSupervisor: Ansprechpartner
|
||||
TableSupervisee: Ansprechpartner für
|
||||
TableReason: Begründung
|
||||
TableCreationTime: Erstellungszeit
|
||||
TableJob !ident-ok: Job
|
||||
TableJobContent !ident-ok: Parameter
|
||||
|
||||
@ -79,11 +79,13 @@ TableCompany: Company
|
||||
TableCompanyFilter: Company/Nr
|
||||
TableCompanyShort: Company shorthand
|
||||
TableCompanies: Companies
|
||||
TablePrimeCompany: Primary company
|
||||
TableCompanyNo: Company number
|
||||
TableCompanyNos: Company numbers
|
||||
TableCompanyUser: Associate
|
||||
TableCompanyNrUsers: Associates
|
||||
TableCompanyNrSecondaryUsers: Secondary Associates
|
||||
TableCompanyReason: Note
|
||||
TableCompanyNrSupers: Supervisors
|
||||
TableCompanyNrEmpSupervised: Supervised employees
|
||||
TableCompanyNrEmpRerouted: Employees having reroute
|
||||
@ -97,6 +99,7 @@ TableRerouteActive: Reroute
|
||||
TableCompanyPostalPreference: Default notification preference
|
||||
TableSupervisor: Supervisor
|
||||
TableSupervisee: Supervisor for
|
||||
TableReason: Reason
|
||||
TableCreationTime: Creation
|
||||
TableJob !ident-ok: Job
|
||||
TableJobContent !ident-ok: Parameters
|
||||
|
||||
@ -25,6 +25,7 @@ RGTutorialParticipants tutn@TutorialName: Kursteilnehmer:innen (#{tutn})
|
||||
RGExamRegistered examn@ExamName: Angemeldet zur Prüfung „#{examn}“
|
||||
RGSheetSubmittor shn@SheetName: Abgebende für das Übungsblatt „#{shn}“
|
||||
CommSubject: Betreff
|
||||
CommContent: Inhalt
|
||||
CommAttachments: Anhänge
|
||||
CommAttachmentsTip: Im Allgemeinen ist es vorzuziehen Dateien, die Sie mit den Empfängern teilen möchten, als Material hochzuladen (und ggf. in der Nachricht zu verlinken). So ist die Datei für die Empfänger dauerhaft abrufbar und auch Personen, die sich z.B. erst später zur Kursart anmelden, haben Zugriff auf die Datei.
|
||||
CommSuccess n@Int: Nachricht wurde an #{n} Empfänger versandt
|
||||
@ -82,6 +83,7 @@ MultiUserFieldInvitationExplanationAlways: Es wird an alle Adressen, die Sie hie
|
||||
AmbiguousEmail: E-Mail-Adresse nicht eindeutig
|
||||
InvalidEmailAddress: E-Mail-Adresse ist ungültig
|
||||
InvalidEmailAddressWith e@Text: E-Mail-Adresse #{show e} ist ungültig
|
||||
MailFileAttachment: Dateianhang
|
||||
UtilExamResultGrade: Note
|
||||
UtilExamResultPass: Bestanden/Nicht Bestanden
|
||||
UtilExamResultNoShow: Nicht erschienen
|
||||
@ -96,6 +98,7 @@ RoomReferenceLinkLink !ident-ok: Link
|
||||
RoomReferenceLinkLinkPlaceholder !ident-ok: URL
|
||||
RoomReferenceLinkInstructions: Anweisungen
|
||||
RoomReferenceLinkInstructionsPlaceholder: Anweisungen
|
||||
UtilNoneSet: Keine angegeben
|
||||
UtilEmptyChoice: Auswahl war leer
|
||||
UtilEmptyNoChangeTip: Eine leere Eingabe belässt den vorherigen Wert unverändert.
|
||||
MultiNoSelection: Keine Auswahl
|
||||
|
||||
@ -25,6 +25,7 @@ RGTutorialParticipants tutn: Course participants (#{tutn})
|
||||
RGExamRegistered examn: Registered for exam “#{examn}”
|
||||
RGSheetSubmittor shn: Submitted for exercise sheet “#{shn}”
|
||||
CommSubject: Subject
|
||||
CommContent: Content
|
||||
CommAttachments: Attachments
|
||||
CommAttachmentsTip: In general it is preferable to upload files as course type material instead of sending them as attachments. You can then link to the material from the message. The file is then permanently accessable to the recipients and to persons that, for example, register for the Course type at a later date.
|
||||
CommSuccess n: Message was sent to #{n} #{pluralEN n "recipient" "recipients"}
|
||||
@ -82,6 +83,7 @@ MultiUserFieldInvitationExplanationAlways: An invitation will be sent via email
|
||||
AmbiguousEmail: Email address is ambiguous
|
||||
InvalidEmailAddress: Email address is invalid
|
||||
InvalidEmailAddressWith e: Email asdress #{show e} is invalid
|
||||
MailFileAttachment: Attached file
|
||||
UtilExamResultGrade: Grade
|
||||
UtilExamResultPass: Passed/Failed
|
||||
UtilExamResultNoShow: Not present
|
||||
@ -96,6 +98,7 @@ RoomReferenceLinkLink: Link
|
||||
RoomReferenceLinkLinkPlaceholder: URL
|
||||
RoomReferenceLinkInstructions: Instructions
|
||||
RoomReferenceLinkInstructionsPlaceholder: Instructions
|
||||
UtilNoneSet: None set
|
||||
UtilEmptyChoice: Empty selection
|
||||
UtilEmptyNoChangeTip: Existing values remain unchanged if this field is left empty.
|
||||
MultiNoSelection: No selection
|
||||
|
||||
@ -26,7 +26,7 @@ InterfaceHealth
|
||||
interface Text
|
||||
subtype Text Maybe
|
||||
write Bool Maybe
|
||||
hours Int
|
||||
hours Int -- negative number: never expires, i.e. if the last entry is a success, this remains indefinitely
|
||||
UniqueInterfaceHealth interface subtype write !force -- Note that nullable fields must be either empty or unique
|
||||
deriving Eq Read Show Generic
|
||||
|
||||
|
||||
@ -8,7 +8,7 @@ Company
|
||||
name CompanyName -- == (CI Text) -- NOTE: Fraport department name may carry additional information; use the Shorthand with respect to UserCompanyDepartment
|
||||
shorthand CompanyShorthand -- == (CI Text) and CompanyKey :: CompanyShorthand -> CompanyId A change to AvsId as primary key is too much work and not strictly necessary due to Uniqueness
|
||||
avsId Int default=0 -- primary key from avs, use negative numbers for non-AVS companies
|
||||
prefersPostal Bool default=false -- new company users prefers letters by post instead of email
|
||||
prefersPostal Bool default=true -- new company users prefers letters by post instead of email
|
||||
postAddress StoredMarkup Maybe -- default company postal address, including company name
|
||||
email UserEmail Maybe -- Case-insensitive generic company eMail address
|
||||
-- UniqueCompanyName name -- Should be Unique in AVS, but we do not yet need to enforce it
|
||||
|
||||
@ -13,7 +13,8 @@ Qualification
|
||||
refreshWithin CalendarDiffDays Maybe -- notify users about renewal within this number of month/days before expiry; to be used with addGregorianDurationClip
|
||||
refreshReminder CalendarDiffDays Maybe -- send a second notification about renewal within this number of month/days before expiry
|
||||
elearningStart Bool -- automatically schedule e-refresher
|
||||
elearningRenews Bool default=true -- successful E-learing automatically increases validity automatically by validDuration
|
||||
elearningRenews Bool default=true -- successful e-learing automatically increases validity automatically by validDuration
|
||||
elearningLimit Int Maybe -- limit of e-learning attempts, currently only for informative purposes, as it is enforced by LMS only
|
||||
lmsReuses QualificationId Maybe -- if set, lms is also included within the given qualification's lms, but only for direct routes. AuditDuration is used from this Qualification instead.
|
||||
expiryNotification Bool default=true -- should expiryNotification be generated for this qualification?
|
||||
avsLicence AvsLicence Maybe -- if set, valid QualificationUsers are synchronized to AVS as a driving licence
|
||||
|
||||
@ -93,6 +93,7 @@ UserCompany
|
||||
supervisorReroute Bool default=false -- if supervisor is true, should this supervisor receive email for _new_ company users?
|
||||
priority Int default=0 -- higher number, higher priority; default=1 for Haskell-Code
|
||||
useCompanyAddress Bool default=true -- if true, CompanyPostalAddress and CompanyEmail are used if UserPostalAddress/UserDisplayEmail are Nothing, respects priority
|
||||
reason Text Maybe -- miscellaneous note, e.g. Superior
|
||||
UniqueUserCompany user company -- a user may belong to multiple companies, but to each one only once
|
||||
deriving Generic Show
|
||||
UserSupervisor
|
||||
|
||||
@ -1,3 +1,3 @@
|
||||
{
|
||||
"version": "27.4.74"
|
||||
"version": "27.4.79"
|
||||
}
|
||||
|
||||
2
package-lock.json
generated
2
package-lock.json
generated
@ -1,6 +1,6 @@
|
||||
{
|
||||
"name": "uni2work",
|
||||
"version": "27.4.74",
|
||||
"version": "27.4.79",
|
||||
"lockfileVersion": 1,
|
||||
"requires": true,
|
||||
"dependencies": {
|
||||
|
||||
@ -1,6 +1,6 @@
|
||||
{
|
||||
"name": "uni2work",
|
||||
"version": "27.4.74",
|
||||
"version": "27.4.79",
|
||||
"description": "",
|
||||
"keywords": [],
|
||||
"author": "",
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: uniworx
|
||||
version: 27.4.74
|
||||
version: 27.4.79
|
||||
dependencies:
|
||||
- base
|
||||
- yesod
|
||||
|
||||
9
routes
9
routes
@ -71,11 +71,18 @@
|
||||
/admin/avs/#CryptoUUIDUser AdminAvsUserR GET POST
|
||||
/admin/ldap AdminLdapR GET POST
|
||||
/admin/problems AdminProblemsR GET POST
|
||||
/admin/problems/no-contact ProblemUnreachableR GET
|
||||
/admin/problems/no-contact ProblemUnreachableR GET POST
|
||||
/admin/problems/no-avs-id ProblemWithoutAvsId GET
|
||||
/admin/problems/r-without-f ProblemFbutNoR GET
|
||||
/admin/problems/avs ProblemAvsSynchR GET POST
|
||||
/admin/problems/avs/errors ProblemAvsErrorR GET
|
||||
/admin/config/interfaces ConfigInterfacesR GET POST
|
||||
|
||||
/comm CommCenterR GET
|
||||
/comm/email MailCenterR GET POST
|
||||
/comm/email/html/#CryptoUUIDSentMail MailHtmlR GET
|
||||
/comm/email/plain/#CryptoUUIDSentMail MailPlainR GET
|
||||
/comm/email/attachment/#CryptoUUIDSentMail/#Text MailAttachmentR GET
|
||||
|
||||
/print PrintCenterR GET POST !system-printer
|
||||
/print/acknowledge/#Day/#Int/#Int PrintAckR GET POST !system-printer
|
||||
|
||||
@ -197,9 +197,9 @@ let
|
||||
UPLOAD_S3_KEY_ID=''${MINIO_ACCESS_KEY}
|
||||
UPLOAD_S3_KEY=''${MINIO_SECRET_KEY}
|
||||
|
||||
SMTPHOST=''${SMTPHOST}
|
||||
SMTPPORT=''${SMTPPORT}
|
||||
SMTPSSL=''${SMTPSSL}
|
||||
# SMTPHOST=''${SMTPHOST}
|
||||
# SMTPPORT=''${SMTPPORT}
|
||||
# SMTPSSL=''${SMTPSSL}
|
||||
EOF
|
||||
|
||||
set +xe
|
||||
|
||||
@ -157,6 +157,8 @@ import Handler.Upload
|
||||
import Handler.Qualification
|
||||
import Handler.LMS
|
||||
import Handler.SAP
|
||||
import Handler.CommCenter
|
||||
import Handler.MailCenter
|
||||
import Handler.PrintCenter
|
||||
import Handler.ApiDocs
|
||||
import Handler.Swagger
|
||||
@ -352,15 +354,15 @@ makeFoundation appSettings''@AppSettings{..} = do
|
||||
handleIf isBucketExists (const $ return ()) $ Minio.makeBucket appUploadTmpBucket Nothing
|
||||
return conn
|
||||
|
||||
appAvsQuery <- case appAvsConf of
|
||||
appAvsQuery <- case appAvsConf of
|
||||
Nothing -> do
|
||||
$logErrorS "avsPrepare" "appAvsConfig is empty, i.e. invalid AVS configuration settings."
|
||||
return Nothing
|
||||
-- error "AvsConfig is empty, i.e. invalid AVS configuration settings."
|
||||
|
||||
Just avsConf -> do
|
||||
-- error "AvsConfig is empty, i.e. invalid AVS configuration settings."
|
||||
|
||||
Just avsConf -> do
|
||||
manager <- newManagerSettings $ mkManagerSettings (def { settingDisableCertificateValidation = True }) Nothing
|
||||
let avsServer = BaseUrl
|
||||
let avsServer = BaseUrl
|
||||
{ baseUrlScheme = Https
|
||||
, baseUrlHost = avsHost avsConf
|
||||
, baseUrlPort = avsPort avsConf
|
||||
@ -657,7 +659,7 @@ appMain = runResourceT $ do
|
||||
notifyWatchdog = forever' Nothing $ \pResults -> do
|
||||
let delay = floor $ wInterval % 4
|
||||
d <- liftIO $ newDelay delay
|
||||
|
||||
|
||||
$logDebugS "Notify" $ "Waiting up to " <> tshow delay <> "µs..."
|
||||
mResults <- atomically $ asum
|
||||
[ pResults <$ waitDelay d
|
||||
|
||||
25
src/Audit.hs
25
src/Audit.hs
@ -1,7 +1,9 @@
|
||||
-- SPDX-FileCopyrightText: 2023 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
|
||||
-- SPDX-FileCopyrightText: 2023-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
|
||||
--
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
module Audit
|
||||
( module Audit.Types
|
||||
, AuditException(..)
|
||||
@ -17,6 +19,8 @@ import Import.NoModel
|
||||
import Settings
|
||||
import Model
|
||||
import Database.Persist.Sql
|
||||
import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
import Audit.Types
|
||||
|
||||
import qualified Data.Text as Text
|
||||
@ -129,7 +133,7 @@ logInterface :: ( AuthId (HandlerSite m) ~ Key User
|
||||
-> Text -- ^ Any additional information
|
||||
-> ReaderT (YesodPersistBackend (HandlerSite m)) m ()
|
||||
-- ^ Log a transaction using information available from `HandlerT`, also calls `audit`
|
||||
logInterface interfaceLogInterface interfaceLogSubtype interfaceLogSuccess interfaceLogRows interfaceLogInfo = do
|
||||
logInterface interfaceLogInterface interfaceLogSubtype interfaceLogSuccess interfaceLogRows interfaceLogInfo = do
|
||||
interfaceLogWrite <- (methodGet /=) . Wai.requestMethod . reqWaiRequest <$> getRequest
|
||||
logInterface' interfaceLogInterface interfaceLogSubtype interfaceLogWrite interfaceLogSuccess interfaceLogRows interfaceLogInfo
|
||||
|
||||
@ -173,20 +177,25 @@ logInterface' (Text.strip -> interfaceLogInterface) (Text.strip -> interfaceLogS
|
||||
|
||||
reportAdminProblem :: ( IsSqlBackend (YesodPersistBackend (HandlerSite m))
|
||||
, SqlBackendCanWrite (YesodPersistBackend (HandlerSite m))
|
||||
, MonadHandler m
|
||||
, MonadHandler m
|
||||
-- , HasCallStack
|
||||
)
|
||||
=> AdminProblem -- ^ Problem to record
|
||||
=> AdminProblem -- ^ Problem to record
|
||||
-> ReaderT (YesodPersistBackend (HandlerSite m)) m ()
|
||||
-- ^ Log a problem that needs interventions by admins
|
||||
-- ^ Log a problem that needs interventions by admins, provided this problem has not already been reported and is still unsolved
|
||||
--
|
||||
-- - `problemLogTime` is now
|
||||
-- - `problemSolver` is Nothing, we do not record the person who caused it
|
||||
reportAdminProblem problem@(toJSON -> problemLogInfo) = do
|
||||
problemLogTime <- liftIO getCurrentTime
|
||||
reportAdminProblem problem = do
|
||||
let problemLogSolved = Nothing
|
||||
problemLogSolver = Nothing
|
||||
insert_ ProblemLog{..}
|
||||
problemLogInfo = toJSON problem
|
||||
problemLogTime <- liftIO getCurrentTime
|
||||
isKnown <- E.selectExists $ do
|
||||
pl <- E.from $ E.table @ProblemLog
|
||||
E.where_ $ E.isNothing (pl E.^. ProblemLogSolved)
|
||||
E.&&. E.val problemLogInfo E.==. pl E.^. ProblemLogInfo
|
||||
unless isKnown $ insert_ ProblemLog{..}
|
||||
$logWarnS "Problem" $ Text.filter (/= '\n') $ tshow problem -- <> " - " <> pack (prettyCallStack callStack)
|
||||
|
||||
|
||||
|
||||
@ -282,6 +282,11 @@ data AdminProblem
|
||||
, adminProblemCompany :: CompanyId -- affected company
|
||||
, adminProblemUserOld :: Maybe UserId -- previous superior
|
||||
}
|
||||
| AdminProblemCompanySuperiorNotFound -- a company received a new superior user through AVS, but user could not be created from email
|
||||
{ adminProblemEmail :: Maybe Text -- new superior user's email, not found in LDAP
|
||||
, adminProblemCompany :: CompanyId -- affected company
|
||||
, adminProblemUserOld :: Maybe UserId -- previous superior
|
||||
}
|
||||
| AdminProblemNewlyUnsupervised
|
||||
{ adminProblemUser :: UserId -- user who had a supervisor but no longer has, due to user company change
|
||||
, adminProblemCompanyOld :: Maybe CompanyId -- old company
|
||||
|
||||
@ -34,7 +34,7 @@ dummyForm = do
|
||||
mr <- getMessageRender
|
||||
wreq (ciField & addDatalist userList) (fslpI MsgDummyIdent (mr MsgDummyIdentPlaceholder) & addAttr "autocomplete" "username" & addName PostLoginDummy) Nothing
|
||||
where
|
||||
userList = fmap mkOptionList . runDB $ withReaderT projectBackend (map toOption <$> selectList [] [Asc UserIdent] :: ReaderT SqlBackend _ [Option UserIdent])
|
||||
userList = fmap mkOptionList . runDB $ withReaderT projectBackend (map toOption <$> selectList [UserId <=. UserKey 12] [Asc UserIdent] :: ReaderT SqlBackend _ [Option UserIdent])
|
||||
toOption (Entity _ User{..}) = Option userDisplayName userIdent (CI.original userIdent)
|
||||
|
||||
apDummy :: Text
|
||||
|
||||
@ -59,6 +59,7 @@ decCryptoIDs [ ''SubmissionId
|
||||
, ''MaterialFileId
|
||||
, ''PrintJobId
|
||||
, ''QualificationId
|
||||
, ''SentMailId
|
||||
]
|
||||
|
||||
decCryptoIDKeySize
|
||||
|
||||
@ -15,6 +15,7 @@ module Database.Esqueleto.Utils
|
||||
, (=?.), (?=.)
|
||||
, (=~.), (~=.)
|
||||
, (>~.), (<~.)
|
||||
, (~.), (~*.), (!~.), (!~*.)
|
||||
, or, and
|
||||
, any, all
|
||||
, not__, parens
|
||||
@ -26,6 +27,7 @@ module Database.Esqueleto.Utils
|
||||
, mkContainsFilterWithSet, mkContainsFilterWithComma, mkContainsFilterWithCommaPlus
|
||||
, mkDayFilter, mkDayFilterFrom, mkDayFilterTo
|
||||
, mkExistsFilter, mkExistsFilterWithComma
|
||||
-- , mkRegExFilterWith
|
||||
, anyFilter, allFilter
|
||||
, ascNullsFirst, descNullsLast
|
||||
, orderByList
|
||||
@ -48,10 +50,12 @@ module Database.Esqueleto.Utils
|
||||
, subSelectCountDistinct
|
||||
, selectCountRows, selectCountDistinct
|
||||
, selectMaybe
|
||||
, str2text, str2text'
|
||||
, num2text --, text2num
|
||||
, day, day', dayMaybe, interval, diffDays, diffTimes
|
||||
, exprLift
|
||||
, explicitUnsafeCoerceSqlExprValue
|
||||
, psqlVersion_
|
||||
, truncateTable
|
||||
, module Database.Esqueleto.Utils.TH
|
||||
) where
|
||||
@ -162,6 +166,24 @@ infixl 4 <~.
|
||||
(<~.) :: PersistField typ => E.SqlExpr (E.Value typ) -> E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value Bool)
|
||||
(<~.) a b = E.isNothing b E.||. (E.just a E.<. b)
|
||||
|
||||
infixr 2 ~., ~*., !~., !~*.
|
||||
|
||||
-- | PostgreSQL regular expression match, case sensitive. Works, but may throw SQL error for unblanced parenthesis, etc. Not suitable for dbTable filters
|
||||
(~.) :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value Bool)
|
||||
(~.) = E.unsafeSqlBinOp " ~ "
|
||||
|
||||
-- | PostgreSQL regular expression match, case insensitive. Works, but may throw SQL errors
|
||||
(~*.) :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value Bool)
|
||||
(~*.) = E.unsafeSqlBinOp " ~* "
|
||||
|
||||
-- | PostgreSQL regular expression does not match, case sensitive. Works, but may throw SQL error for unblanced parenthesis, etc. Not suitable for dbTable filters
|
||||
(!~.) :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value Bool)
|
||||
(!~.) = E.unsafeSqlBinOp " !~ "
|
||||
|
||||
-- | PostgreSQL regular expression does not match, case insensitive. Works, but may throw SQL errors
|
||||
(!~*.) :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value Bool)
|
||||
(!~*.) = E.unsafeSqlBinOp " !~* "
|
||||
|
||||
|
||||
-- | Negation of `isNothing` which is missing
|
||||
isJust :: PersistField typ => E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value Bool)
|
||||
@ -328,7 +350,7 @@ mkExactFilterLastWith :: (PersistField b)
|
||||
-> Last a -- ^ needle
|
||||
-> E.SqlExpr (E.Value Bool)
|
||||
mkExactFilterLastWith cast lenslike row criterias
|
||||
| Last (Just crit) <- criterias = lenslike row E.==. E.val (cast crit)
|
||||
| Last (Just crit) <- criterias = lenslike row E.==. E.val (cast crit)
|
||||
| otherwise = true
|
||||
|
||||
-- | like `mkExactFilterLast` but deals with Nothing being a filter criterion as well
|
||||
@ -409,11 +431,23 @@ mkContainsFilterWithCommaPlus cast lenslike row (foldMap commaSeparatedText -> c
|
||||
| Set.null compulsories = cond_optional
|
||||
| Set.null alternatives = cond_compulsory
|
||||
| otherwise = cond_compulsory E.&&. cond_optional
|
||||
where
|
||||
where
|
||||
(Set.mapMonotonic (Text.stripStart . Text.drop 1) -> compulsories, alternatives) = Set.partition (Text.isPrefixOf "+") criterias
|
||||
cond_compulsory = all (hasInfix (lenslike row) . E.val . cast) compulsories
|
||||
cond_optional = any (hasInfix (lenslike row) . E.val . cast) alternatives
|
||||
|
||||
-- like `mkContainsFilterWith` but allows regular expression criterias
|
||||
-- This works, but throws SQL errors for unbalanced parenthesis and similar invalid regex expressions
|
||||
-- mkRegExFilterWith :: (E.SqlString b, Ord a)
|
||||
-- => (a -> b)
|
||||
-- -> (t -> E.SqlExpr (E.Value b)) -- ^ getter from query to searched element
|
||||
-- -> t -- ^ query row
|
||||
-- -> Set.Set a -- ^ needle collection
|
||||
-- -> E.SqlExpr (E.Value Bool)
|
||||
-- mkRegExFilterWith cast lenslike row criterias
|
||||
-- | Set.null criterias = true
|
||||
-- | otherwise = any ((~.) (lenslike row) . E.val . cast) criterias
|
||||
|
||||
mkDayFilter :: (t -> E.SqlExpr (E.Value UTCTime)) -- ^ getter from query to searched element
|
||||
-> t -- ^ query row
|
||||
-> Last Day -- ^ a day to filter for
|
||||
@ -516,7 +550,7 @@ selectExists query = do
|
||||
_other -> error "SELECT EXISTS ... returned zero or more than one rows"
|
||||
selectNotExists = fmap not . selectExists
|
||||
|
||||
filterExists :: (MonadIO m, PersistEntity val, MonoFoldable mono, PersistField (Element mono))
|
||||
filterExists :: (MonadIO m, PersistEntity val, MonoFoldable mono, PersistField (Element mono))
|
||||
=> EntityField val (Element mono) -> mono -> E.SqlReadT m [Element mono]
|
||||
filterExists prj vs = fmap (fmap Ex.unValue) <$> Ex.select $ do
|
||||
ent <- Ex.from Ex.table
|
||||
@ -655,7 +689,8 @@ infixl 8 ->.
|
||||
|
||||
infixl 8 ->>.
|
||||
|
||||
(->>.) :: E.SqlExpr (E.Value a) -> Text -> E.SqlExpr (E.Value Text)
|
||||
-- Unsafe variant, see Database.Esqueleto.PostgreSQL.JSON for a safe version!
|
||||
(->>.) :: E.SqlExpr (E.Value a) -> Text -> E.SqlExpr (E.Value Text)
|
||||
(->>.) expr t = E.unsafeSqlBinOp "->>" expr $ E.val t
|
||||
|
||||
infixl 8 ->>>.
|
||||
@ -682,7 +717,7 @@ unKey = E.veryUnsafeCoerceSqlExprValue
|
||||
-- | distinct version of `Database.Esqueleto.subSelectCount`
|
||||
subSelectCountDistinct :: (Num a, PersistField a) => Ex.SqlQuery (Ex.SqlExpr (Ex.Value typ)) -> Ex.SqlExpr (Ex.Value a)
|
||||
subSelectCountDistinct query = Ex.subSelectUnsafe (Ex.countDistinct <$> query)
|
||||
|
||||
|
||||
-- PersistField a => SqlQuery (SqlExpr (Value a)) -> SqlExpr (Value a)
|
||||
-- countDistinct :: Num a => SqlExpr (Value typ) -> SqlExpr (Value a)
|
||||
|
||||
@ -707,6 +742,13 @@ selectCountDistinct q = do
|
||||
selectMaybe :: (E.SqlSelect a r, MonadIO m) => E.SqlQuery a -> E.SqlReadT m (Maybe r)
|
||||
selectMaybe = fmap listToMaybe . E.select . (<* E.limit 1)
|
||||
|
||||
-- | convert something that is like a text to text
|
||||
str2text :: E.SqlString a => E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value Text)
|
||||
str2text = E.unsafeSqlCastAs "text"
|
||||
|
||||
str2text' :: E.SqlString a => E.SqlExpr (E.Value (Maybe a)) -> E.SqlExpr (E.Value (Maybe Text))
|
||||
str2text' = E.unsafeSqlCastAs "text"
|
||||
|
||||
-- | cast numeric type to text, which is safe and allows for an inefficient but safe comparison of numbers stored as text and numbers
|
||||
num2text :: Num n => E.SqlExpr (E.Value n) -> E.SqlExpr (E.Value Text)
|
||||
num2text = E.unsafeSqlCastAs "text"
|
||||
@ -726,9 +768,9 @@ dayMaybe :: E.SqlExpr (E.Value (Maybe UTCTime)) -> E.SqlExpr (E.Value (Maybe Day
|
||||
dayMaybe = E.unsafeSqlCastAs "date"
|
||||
|
||||
interval :: CalendarDiffDays -> E.SqlExpr (E.Value Day) -- E.+=. requires both types to be the same, so we use Day
|
||||
-- interval _ = E.unsafeSqlCastAs "interval" $ E.unsafeSqlValue "'P2Y'" -- tested working example
|
||||
-- interval _ = E.unsafeSqlCastAs "interval" $ E.unsafeSqlValue "'P2Y'" -- tested working example
|
||||
interval = E.unsafeSqlCastAs "interval". E.unsafeSqlValue . wrapSqlString . Text.Builder.fromString . iso8601Show
|
||||
where
|
||||
where
|
||||
singleQuote = Text.Builder.singleton '\''
|
||||
wrapSqlString b = singleQuote <> b <> singleQuote
|
||||
|
||||
@ -773,14 +815,16 @@ instance (PersistField a1, PersistField a2, PersistField b, Finite a1, Finite a2
|
||||
]
|
||||
(E.else_ $ E.else_ $ E.veryUnsafeCoerceSqlExprValue (E.nothing :: E.SqlExpr (E.Value (Maybe ()))))
|
||||
|
||||
psqlVersion_ :: E.SqlExpr (E.Value Text)
|
||||
psqlVersion_ = E.unsafeSqlFunction "VERSION" ()
|
||||
|
||||
-- Suspected to cause trouble. Needs more testing!
|
||||
-- truncateTable :: (MonadIO m, BackendCompatible SqlBackend backend, PersistEntity record)
|
||||
-- truncateTable :: (MonadIO m, BackendCompatible SqlBackend backend, PersistEntity record)
|
||||
-- => record -> ReaderT backend m ()
|
||||
-- truncateTable tbl = E.rawExecute ("TRUNCATE TABLE " <> P.tableName tbl <> " RESTART IDENTITY") []
|
||||
|
||||
truncateTable :: (MonadIO m, BackendCompatible SqlBackend backend, PersistEntity record) -- TODO: test this code
|
||||
=> proxy record -> ReaderT backend m ()
|
||||
truncateTable tbl =
|
||||
truncateTable tbl =
|
||||
let tblName :: Text = P.unEntityNameDB $ P.entityDB $ P.entityDef tbl
|
||||
in E.rawExecute ("TRUNCATE TABLE " <> tblName <> " RESTART IDENTITY") []
|
||||
@ -122,6 +122,7 @@ breadcrumb ProblemWithoutAvsId = i18nCrumb MsgProblemsNoAvsIdHeading $ Just
|
||||
breadcrumb ProblemFbutNoR = i18nCrumb MsgProblemsRWithoutFHeading $ Just AdminProblemsR
|
||||
breadcrumb ProblemAvsSynchR = i18nCrumb MsgProblemsAvsSynchHeading $ Just AdminProblemsR
|
||||
breadcrumb ProblemAvsErrorR = i18nCrumb MsgProblemsAvsErrorHeading $ Just AdminProblemsR
|
||||
breadcrumb ConfigInterfacesR = i18nCrumb MsgConfigInterfacesHeading $ Just AdminProblemsR
|
||||
|
||||
breadcrumb FirmAllR = i18nCrumb MsgMenuFirms Nothing
|
||||
breadcrumb FirmsCommR{} = i18nCrumb MsgMenuFirmsComm $ Just FirmAllR
|
||||
@ -129,7 +130,13 @@ breadcrumb FirmUsersR{} = i18nCrumb MsgMenuFirmUsers $ Just FirmAll
|
||||
breadcrumb (FirmSupersR fsh)= i18nCrumb MsgMenuFirmSupervisors $ Just $ FirmUsersR fsh
|
||||
breadcrumb (FirmCommR fsh)= i18nCrumb MsgMenuFirmsComm $ Just $ FirmUsersR fsh
|
||||
|
||||
breadcrumb PrintCenterR = i18nCrumb MsgMenuApc Nothing
|
||||
breadcrumb CommCenterR = i18nCrumb MsgMenuCommCenter Nothing
|
||||
breadcrumb MailCenterR = i18nCrumb MsgMenuMailCenter $ Just CommCenterR
|
||||
breadcrumb MailHtmlR{} = i18nCrumb MsgMenuMailHtml $ Just MailCenterR
|
||||
breadcrumb MailPlainR{} = i18nCrumb MsgMenuMailPlain $ Just MailCenterR
|
||||
breadcrumb (MailAttachmentR mid _) = i18nCrumb MsgMenuMailAttachment $ Just $ MailHtmlR mid
|
||||
|
||||
breadcrumb PrintCenterR = i18nCrumb MsgMenuApc $ Just CommCenterR
|
||||
breadcrumb PrintSendR = i18nCrumb MsgMenuPrintSend $ Just PrintCenterR
|
||||
breadcrumb PrintDownloadR{} = i18nCrumb MsgMenuPrintDownload $ Just PrintCenterR
|
||||
breadcrumb PrintAckR{} = i18nCrumb MsgMenuPrintSend $ Just PrintCenterR -- never displayed
|
||||
@ -1225,7 +1232,7 @@ pageActions (AdminUserR cID) = return
|
||||
, NavPageActionPrimary
|
||||
{ navLink = defNavLink MsgMenuUserEdit $ ForProfileR cID
|
||||
, navChildren = []
|
||||
}
|
||||
}
|
||||
, NavPageActionPrimary
|
||||
{ navLink = defNavLinkModal MsgUserHijack $ AdminHijackUserR cID
|
||||
, navChildren = []
|
||||
@ -1461,7 +1468,7 @@ pageActions (ForProfileDataR cID) = return
|
||||
[ NavPageActionPrimary
|
||||
{ navLink = defNavLink MsgAdminUserHeading $ AdminUserR cID
|
||||
, navChildren = []
|
||||
}
|
||||
}
|
||||
]
|
||||
pageActions TermShowR = do
|
||||
participantsSecondary <- pageQuickActions NavQuickViewPageActionSecondary ParticipantsListR
|
||||
@ -2477,6 +2484,50 @@ pageActions PrintCenterR = do
|
||||
dayLinks <- mapM toDayAck $ Map.toAscList dayMap
|
||||
return $ manualSend : printLog : printAck : take 9 dayLinks
|
||||
|
||||
pageActions CommCenterR = return
|
||||
[ NavPageActionPrimary
|
||||
{ navLink = defNavLink MsgMenuMailCenter MailCenterR
|
||||
, navChildren = []
|
||||
}
|
||||
, NavPageActionPrimary
|
||||
{ navLink = defNavLink MsgMenuApc PrintCenterR
|
||||
, navChildren = []
|
||||
}
|
||||
]
|
||||
|
||||
pageActions (MailHtmlR smid) = do
|
||||
sid <- decrypt smid
|
||||
usrNotiSettings <- useRunDB $ runMaybeT $ do
|
||||
sm <- MaybeT $ get sid
|
||||
uid <- hoistMaybe $ sentMailRecipient sm
|
||||
User{userDisplayName} <- MaybeT $ get uid
|
||||
uuid <- liftHandler $ encrypt uid
|
||||
return NavPageActionPrimary
|
||||
{ navLink = defNavLink (MsgNotificationSettingsHeading userDisplayName) $ UserNotificationR uuid
|
||||
, navChildren = []
|
||||
}
|
||||
let linkPlain = NavPageActionPrimary
|
||||
{ navLink = defNavLink MsgMenuMailPlain $ MailPlainR smid
|
||||
, navChildren = []
|
||||
}
|
||||
return $ msnoc [linkPlain] usrNotiSettings
|
||||
pageActions (MailPlainR smid) = do
|
||||
sid <- decrypt smid
|
||||
usrNotiSettings <- useRunDB $ runMaybeT $ do
|
||||
sm <- MaybeT $ get sid
|
||||
uid <- hoistMaybe $ sentMailRecipient sm
|
||||
User{userDisplayName} <- MaybeT $ get uid
|
||||
uuid <- liftHandler $ encrypt uid
|
||||
return NavPageActionPrimary
|
||||
{ navLink = defNavLink (MsgNotificationSettingsHeading userDisplayName) $ UserNotificationR uuid
|
||||
, navChildren = []
|
||||
}
|
||||
let linkHtml = NavPageActionPrimary
|
||||
{ navLink = defNavLink MsgMenuMailHtml $ MailHtmlR smid
|
||||
, navChildren = []
|
||||
}
|
||||
return $ msnoc [linkHtml] usrNotiSettings
|
||||
|
||||
pageActions AdminCrontabR = return
|
||||
[ NavPageActionPrimary
|
||||
{ navLink = defNavLink MsgMenuAdminJobs AdminJobsR
|
||||
@ -2484,6 +2535,20 @@ pageActions AdminCrontabR = return
|
||||
}
|
||||
]
|
||||
|
||||
pageActions AdminProblemsR = return
|
||||
[ NavPageActionPrimary
|
||||
{ navLink = defNavLink MsgConfigInterfacesHeading ConfigInterfacesR
|
||||
, navChildren = []
|
||||
}
|
||||
, NavPageActionPrimary
|
||||
{ navLink = defNavLink MsgProblemsAvsSynchHeading ProblemAvsSynchR
|
||||
, navChildren = []
|
||||
}
|
||||
, NavPageActionSecondary
|
||||
{ navLink = defNavLink MsgProblemsAvsErrorHeading ProblemAvsErrorR
|
||||
}
|
||||
]
|
||||
|
||||
pageActions _ = return []
|
||||
|
||||
submissionList :: ( MonadIO m
|
||||
|
||||
@ -15,7 +15,7 @@ module Foundation.Type
|
||||
, _memcachedLocalARC
|
||||
, SMTPPool
|
||||
, _appSettings', _appStatic, _appConnPool, _appSmtpPool, _appLdapPool, _appWidgetMemcached, _appHttpManager, _appLogger, _appLogSettings, _appCryptoIDKey, _appClusterID, _appInstanceID, _appJobState, _appSessionStore, _appSecretBoxKey, _appJSONWebKeySet, _appHealthReport, _appMemcached, _appUploadCache, _appVerpSecret, _appAuthKey, _appPersonalisedSheetFilesSeedKey, _appVolatileClusterSettingsCache, _appAvsQuery
|
||||
, DB, Form, MsgRenderer, MailM, DBFile
|
||||
, DB, DBRead, Form, MsgRenderer, MailM, DBFile
|
||||
) where
|
||||
|
||||
import Import.NoFoundation
|
||||
@ -123,8 +123,9 @@ instance HasCookieSettings RegisteredCookie UniWorX where
|
||||
instance (MonadHandler m, HandlerSite m ~ UniWorX) => ReadLogSettings m where
|
||||
readLogSettings = liftIO . readTVarIO =<< getsYesod (view _appLogSettings)
|
||||
|
||||
|
||||
|
||||
type DB = YesodDB UniWorX
|
||||
type DBRead = ReaderT SqlReadBackend (HandlerFor UniWorX)
|
||||
type Form x = Html -> MForm (HandlerFor UniWorX) (FormResult x, WidgetFor UniWorX ())
|
||||
type MsgRenderer = MsgRendererS UniWorX -- see Utils
|
||||
type MailM a = MailT (HandlerFor UniWorX) a
|
||||
|
||||
@ -107,7 +107,7 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend
|
||||
| not isDummy -> res <$ update uid [ UserLastAuthentication =. Just now ]
|
||||
_other -> return res
|
||||
|
||||
$logDebugS "auth" $ tshow Creds{..}
|
||||
$logDebugS "auth" $ tshow Creds{..}
|
||||
ldapPool' <- getsYesod $ view _appLdapPool
|
||||
|
||||
flip catches excHandlers $ case ldapPool' of
|
||||
@ -153,9 +153,9 @@ _upsertCampusUserMode mMode cs@Creds{..}
|
||||
|
||||
defaultOther = apHash
|
||||
|
||||
ldapLookupAndUpsert :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX, MonadMask m, MonadUnliftIO m) => Text -> SqlPersistT m (Entity User)
|
||||
ldapLookupAndUpsert ident =
|
||||
getsYesod (view _appLdapPool) >>= \case
|
||||
ldapLookupAndUpsert :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX, MonadMask m, MonadUnliftIO m) => Text -> SqlPersistT m (Entity User)
|
||||
ldapLookupAndUpsert ident =
|
||||
getsYesod (view _appLdapPool) >>= \case
|
||||
Nothing -> throwM $ CampusUserLdapError $ LdapHostNotResolved "No LDAP configuration in Foundation."
|
||||
Just ldapPool ->
|
||||
campusUser'' ldapPool campusUserFailoverMode ident >>= \case
|
||||
@ -188,15 +188,15 @@ upsertCampusUser upsertMode ldapData = do
|
||||
user@(Entity userId userRec) <- case oldUsers of
|
||||
Just [oldUserId] -> updateGetEntity oldUserId userUpdate
|
||||
_other -> upsertBy (UniqueAuthentication (newUser ^. _userIdent)) newUser userUpdate
|
||||
unless (validDisplayName (newUser ^. _userTitle)
|
||||
unless (validDisplayName (newUser ^. _userTitle)
|
||||
(newUser ^. _userFirstName)
|
||||
(newUser ^. _userSurname)
|
||||
(newUser ^. _userSurname)
|
||||
(userRec ^. _userDisplayName)) $
|
||||
update userId [ UserDisplayName =. (newUser ^. _userDisplayName) ]
|
||||
when (validEmail' (userRec ^. _userEmail)) $ do
|
||||
update userId [ UserDisplayName =. (newUser ^. _userDisplayName) ] -- update invalid display names only
|
||||
when (validEmail' (userRec ^. _userEmail)) $ do -- RECALL: userRec already contains basic updates
|
||||
let emUps = [ UserDisplayEmail =. (newUser ^. _userEmail) | not (validEmail' (userRec ^. _userDisplayEmail)) ]
|
||||
++ [ UserAuthentication =. AuthLDAP | is _AuthNoLogin (userRec ^. _userAuthentication) ]
|
||||
unless (null emUps) $ update userId emUps
|
||||
update userId emUps -- update already checks whether list is empty
|
||||
-- Attempt to update ident, too:
|
||||
unless (validEmail' (userRec ^. _userIdent)) $
|
||||
void $ maybeCatchAll (update userId [ UserIdent =. (newUser ^. _userEmail) ] >> return (Just ()))
|
||||
@ -227,7 +227,7 @@ decodeUserTest mbIdent ldapData = do
|
||||
|
||||
|
||||
decodeUser :: (MonadThrow m) => UTCTime -> UserDefaultConf -> UpsertCampusUserMode -> Ldap.AttrList [] -> m (User,_)
|
||||
decodeUser now UserDefaultConf{..} upsertMode ldapData = do
|
||||
decodeUser now UserDefaultConf{..} upsertMode ldapData = do
|
||||
let
|
||||
userTelephone = decodeLdap ldapUserTelephone <&> canonicalPhone
|
||||
userMobile = decodeLdap ldapUserMobile <&> canonicalPhone
|
||||
@ -266,7 +266,7 @@ decodeUser now UserDefaultConf{..} upsertMode ldapData = do
|
||||
-- -> return $ CI.mk userEmail
|
||||
| otherwise
|
||||
-> throwM CampusUserInvalidEmail
|
||||
|
||||
|
||||
userLdapPrimaryKey <- if
|
||||
| [bs] <- ldapMap !!! ldapPrimaryKey
|
||||
, Right userLdapPrimaryKey'' <- Text.decodeUtf8' bs
|
||||
@ -305,13 +305,13 @@ decodeUser now UserDefaultConf{..} upsertMode ldapData = do
|
||||
, userPrefersPostal = userDefaultPrefersPostal
|
||||
, ..
|
||||
}
|
||||
userUpdate =
|
||||
userUpdate =
|
||||
[ UserLastAuthentication =. Just now | isLogin ] ++
|
||||
[ UserEmail =. userEmail | validEmail' userEmail ] ++
|
||||
[
|
||||
-- UserDisplayName =. userDisplayName -- not updated here, since users are allowed to change their DisplayName; see line 272
|
||||
-- UserDisplayName =. userDisplayName -- not updated here, since users are allowed to change their DisplayName; see line 191
|
||||
UserFirstName =. userFirstName
|
||||
, UserSurname =. userSurname
|
||||
, UserSurname =. userSurname
|
||||
, UserLastLdapSynchronisation =. Just now
|
||||
, UserLdapPrimaryKey =. userLdapPrimaryKey
|
||||
, UserMobile =. userMobile
|
||||
|
||||
@ -9,8 +9,9 @@ module Handler.Admin
|
||||
import Import
|
||||
|
||||
-- import Data.Either
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Text as Text
|
||||
-- import qualified Data.Text.Lazy.Encoding as LBS
|
||||
|
||||
-- import qualified Control.Monad.Catch as Catch
|
||||
@ -23,11 +24,13 @@ import qualified Database.Esqueleto.Experimental as E
|
||||
import qualified Database.Esqueleto.Legacy as EL (on) -- needed for dbTable
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
|
||||
import Jobs
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Avs
|
||||
import Handler.Utils.Users
|
||||
-- import Handler.Utils.Company
|
||||
import Handler.Health.Interface
|
||||
import Handler.Users (AllUsersAction(..))
|
||||
|
||||
import Handler.Admin.Test as Handler.Admin
|
||||
import Handler.Admin.ErrorMessage as Handler.Admin
|
||||
@ -86,14 +89,14 @@ handleAdminProblems mbProblemTable = do
|
||||
<*> allRDriversHaveFs now
|
||||
<*> (not <$> exists [PrintJobAcknowledged ==. Nothing, PrintJobCreated <. cutOffOldTime])
|
||||
<*> (not <$> exists [PrintAcknowledgeProcessed ==. False])
|
||||
<*> mkInterfaceLogTable flagError mempty
|
||||
<*> mkInterfaceLogTable mempty
|
||||
let interfacesBadNr = length $ filter (not . snd) interfaceOks
|
||||
-- interfacesOk = all snd interfaceOks
|
||||
|
||||
diffLics <- try retrieveDifferingLicences >>= \case
|
||||
-- (Left (UnsupportedContentType "text/html" resp)) -> Left $ text2widget "Html received"
|
||||
(Left e) -> return $ Left $ text2widget $ tshow (e :: SomeException)
|
||||
(Right AvsLicenceDifferences{..}) -> do
|
||||
(Right (AvsLicenceDifferences{..},_)) -> do
|
||||
let problemIds = avsLicenceDiffRevokeAll <> avsLicenceDiffGrantVorfeld <> avsLicenceDiffRevokeRollfeld <> avsLicenceDiffGrantRollfeld
|
||||
void $ runDB $ queueAvsUpdateByAID problemIds $ Just nowaday
|
||||
return $ Right
|
||||
@ -104,7 +107,7 @@ handleAdminProblems mbProblemTable = do
|
||||
)
|
||||
-- Attempt to format results in a nicer way failed, since rendering Html within a modal destroyed the page layout itself
|
||||
-- let procDiffLics (to0, to1, to2) = Right (Set.size to0, Set.size to1, Set.size to2)
|
||||
-- diffLics <- (procDiffLics <$> retrieveDifferingLicences) `catches`
|
||||
-- diffLics <- (procDiffLics . fst <$> retrieveDifferingLicences) `catches`
|
||||
-- [ Catch.Handler (\case (UnsupportedContentType "text/html;charset=utf-8" Response{responseBody})
|
||||
-- -> return $ Left $ toWidget $ preEscapedToHtml $ fromRight "Response UTF8-decoding error" $ LBS.decodeUtf8' responseBody
|
||||
-- ex -> return $ Left $ text2widget $ tshow ex)
|
||||
@ -139,12 +142,34 @@ postAdminProblemsR = do
|
||||
addMessageI mkind $ msg oks
|
||||
when (oks > 0) $ reloadKeepGetParams AdminProblemsR -- reload to update all tables
|
||||
|
||||
getProblemUnreachableR :: Handler Html
|
||||
getProblemUnreachableR = do
|
||||
getProblemUnreachableR, postProblemUnreachableR :: Handler Html
|
||||
getProblemUnreachableR = postProblemUnreachableR
|
||||
postProblemUnreachableR = do
|
||||
unreachables <- runDB retrieveUnreachableUsers
|
||||
|
||||
-- the following form is a nearly identicaly copy from Handler.Users:
|
||||
((noreachUsersRes, noreachUsersWgt'), noreachUsersEnctype) <- runFormPost . identifyForm FIDUnreachableUsersAction $ buttonForm
|
||||
let noreachUsersWgt = wrapForm noreachUsersWgt' def
|
||||
{ formSubmit = FormNoSubmit
|
||||
, formAction = Just $ SomeRoute ProblemUnreachableR
|
||||
, formEncoding = noreachUsersEnctype
|
||||
}
|
||||
formResult noreachUsersRes $ \case
|
||||
AllUsersLdapSync -> do
|
||||
forM_ unreachables $ \Entity{entityKey=uid} -> void . queueJob $ JobSynchroniseLdapUser uid
|
||||
addMessageI Success . MsgSynchroniseLdapUserQueued $ length unreachables
|
||||
redirect ProblemUnreachableR
|
||||
AllUsersAvsSync -> do
|
||||
n <- runDB $ queueAvsUpdateByUID (entityKey <$> unreachables) Nothing
|
||||
addMessageI Success . MsgSynchroniseAvsUserQueued $ fromIntegral n
|
||||
redirect ProblemUnreachableR
|
||||
|
||||
siteLayoutMsg MsgProblemsUnreachableHeading $ do
|
||||
setTitleI MsgProblemsUnreachableHeading
|
||||
[whamlet|
|
||||
<section>
|
||||
<h3>_{MsgProblemsUnreachableButtons}
|
||||
^{noreachUsersWgt}
|
||||
<section>
|
||||
#{length unreachables} _{MsgProblemsUnreachableBody}
|
||||
<ul>
|
||||
@ -195,8 +220,7 @@ mkUnreachableUsersTable = do
|
||||
-}
|
||||
|
||||
areAllUsersReachable :: DB Bool
|
||||
-- areAllUsersReachable = isNothing <$> E.selectOne retrieveUnreachableUsers'
|
||||
-- areAllUsersReachable = E.selectNotExists retrieveUnreachableUsers'
|
||||
-- areAllUsersReachable = E.selectNotExists retrieveUnreachableUsers' -- works and would be more efficient, but we cannot check proper email validity within DB alone
|
||||
areAllUsersReachable = null <$> retrieveUnreachableUsers
|
||||
|
||||
-- retrieveUnreachableUsers' :: E.SqlQuery (E.SqlExpr (Entity User))
|
||||
@ -214,8 +238,16 @@ retrieveUnreachableUsers = do
|
||||
user <- E.from $ E.table @User
|
||||
E.where_ $ E.isNothing (user E.^. UserPostAddress)
|
||||
E.&&. (E.isNothing (user E.^. UserCompanyDepartment) E.||. user E.^. UserCompanyPersonalNumber `E.ilike` E.justVal "E%")
|
||||
E.&&. E.notExists (do
|
||||
(cmp :& usrCmp) <- E.from $ E.table @Company `E.innerJoin` E.table @UserCompany
|
||||
`E.on` (\(cmp :& usrCmp) -> cmp E.^. CompanyId E.==. usrCmp E.^. UserCompanyCompany)
|
||||
E.where_ $ user E.^. UserId E.==. usrCmp E.^. UserCompanyUser
|
||||
E.&&. usrCmp E.^. UserCompanyUseCompanyAddress
|
||||
E.&&. E.isJust (cmp E.^. CompanyPostAddress)
|
||||
)
|
||||
return user
|
||||
filterM hasInvalidEmail emailOnlyUsers
|
||||
-- filterM hasInvalifPostal -- probably not worth it, since Utils.Postal.validPostAddress is pretty weak anyway
|
||||
where
|
||||
hasInvalidEmail = fmap isNothing . getUserEmail
|
||||
|
||||
@ -281,7 +313,7 @@ retrieveDriversRWithoutF now = do
|
||||
`E.on` (\(qual :& qualUsr) -> qual E.^. QualificationId E.==. qualUsr E.^. QualificationUserQualification))
|
||||
E.where_ $ (qual E.^. QualificationAvsLicence E.==. E.justVal lic) -- matches licence
|
||||
E.&&. (qualUsr E.^. QualificationUserUser E.==. usr E.^. UserId) -- matches user
|
||||
E.&&. (qualUsr & validQualification now) -- currently valid
|
||||
E.&&. (qualUsr & validQualification now) -- currently valid
|
||||
E.where_ $ E.exists (hasValidQual AvsLicenceRollfeld)
|
||||
E.&&. E.notExists (hasValidQual AvsLicenceVorfeld)
|
||||
return usr
|
||||
@ -309,7 +341,13 @@ resultUser :: Traversal' ProblemLogTableData (Entity User)
|
||||
resultUser = _dbrOutput . _3 . _Just
|
||||
|
||||
mkProblemLogTable :: DB (FormResult (ProblemTableActionData, Set ProblemLogId), Widget)
|
||||
mkProblemLogTable = over _1 postprocess <$> dbTable validator DBTable{..}
|
||||
mkProblemLogTable = do
|
||||
-- problem_types <- E.select $ do
|
||||
-- ap <- E.from $ E.table @ProblemLog
|
||||
-- let res = ap E.^. ProblemLogInfo E.->>. "problem"
|
||||
-- E.groupBy res
|
||||
-- return res
|
||||
over _1 postprocess <$> dbTable validator DBTable{..}
|
||||
where
|
||||
-- TODO: query to collect all occurring problem types to use as tooltip for the problem filter, so that these don't run out of synch
|
||||
dbtIdent = "problem-log" :: Text
|
||||
@ -319,7 +357,7 @@ mkProblemLogTable = over _1 postprocess <$> dbTable validator DBTable{..}
|
||||
EL.on (solver E.?. UserId E.==. problem E.^. ProblemLogSolver)
|
||||
return (problem, solver, usr)
|
||||
dbtRowKey = queryProblem >>> (E.^. ProblemLogId)
|
||||
dbtProj = dbtProjId
|
||||
dbtProj = dbtProjFilteredPostId
|
||||
dbtColonnade = formColonnade $ mconcat
|
||||
[ dbSelect (applying _2) id $ return . view (resultProblem . _entityKey)
|
||||
, sortable (Just "time") (i18nCell MsgAdminProblemCreated) $ \( view $ resultProblem . _entityVal . _problemLogTime -> t) -> dateTimeCell t
|
||||
@ -342,14 +380,20 @@ mkProblemLogTable = over _1 postprocess <$> dbTable validator DBTable{..}
|
||||
dbtFilter = mconcat
|
||||
[ single ("user" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to queryUser) (E.?. UserDisplayName))
|
||||
, single ("solver" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to querySolver) (E.?. UserDisplayName))
|
||||
, single ("problem" , FilterColumn . E.mkContainsFilter $ views (to queryProblem) ((E.->>. "problem").(E.^. ProblemLogInfo)))
|
||||
, single ("company" , FilterColumn . E.mkContainsFilter $ views (to queryProblem) ((E.->>. "company").(E.^. ProblemLogInfo)))
|
||||
, single ("solved" , FilterColumn . E.mkExactFilterLast $ views (to queryProblem) (E.isJust . (E.^. ProblemLogSolved)))
|
||||
-- , single ("problem" , FilterColumn . E.mkContainsFilter $ views (to queryProblem) ((E.->>. "problem").(E.^. ProblemLogInfo))) -- not stored in plaintext!
|
||||
, single ("problem" , mkFilterProjectedPost $ \(getLast -> criterion) dbr -> -- falls es nicht schnell genug ist: in dbtProj den Anzeigetext nur einmal berechnen
|
||||
ifNothingM criterion True $ \(crit::Text) -> do
|
||||
let problem = dbr ^. resultProblem . _entityVal . _problemLogAdminProblem
|
||||
protxt <- adminProblem2Text problem
|
||||
return $ crit `Text.isInfixOf` protxt
|
||||
)
|
||||
]
|
||||
dbtFilterUI mPrev = mconcat
|
||||
[ prismAForm (singletonFilter "user" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgAdminProblemUser & setTooltip MsgTableFilterCommaPlus)
|
||||
, prismAForm (singletonFilter "solver" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgAdminProblemSolver & setTooltip MsgTableFilterCommaPlusShort)
|
||||
, prismAForm (singletonFilter "problem" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgAdminProblemInfo & setTooltip MsgAdminProblemInfoTooltip)
|
||||
, prismAForm (singletonFilter "problem" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgAdminProblemInfo)
|
||||
, prismAForm (singletonFilter "company" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableCompanyShort)
|
||||
, prismAForm (singletonFilter "solved" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgAdminProblemSolved)
|
||||
]
|
||||
|
||||
@ -59,7 +59,7 @@ instance Finite ButtonAvsTest
|
||||
nullaryPathPiece ''ButtonAvsTest camelToPathPiece
|
||||
|
||||
instance Button UniWorX ButtonAvsTest where
|
||||
btnLabel BtnCheckLicences = "Check all licences" -- could be msg
|
||||
btnLabel BtnCheckLicences = "Show all licence difference to current AVS" -- could be msg
|
||||
-- btnLabel BtnSynchLicences = "Synchronize all licences" -- could be msg
|
||||
btnClasses BtnCheckLicences = [BCIsButton, BCPrimary]
|
||||
-- btnClasses BtnSynchLicences = [BCIsButton, BCDanger]
|
||||
@ -266,33 +266,128 @@ postAdminAvsR = do
|
||||
|
||||
|
||||
(qryLicForm, qryLicRes) <- runButtonForm FIDAvsQueryLicenceDiffs
|
||||
mbQryLic <- case qryLicRes of
|
||||
Nothing -> return Nothing
|
||||
(mbQryLic :: Maybe Widget, mbAutoDiffs :: Maybe Html) <- case qryLicRes of
|
||||
Nothing -> return mempty
|
||||
(Just BtnCheckLicences) -> do
|
||||
res <- try $ do
|
||||
allLicences <- avsQuery AvsQueryGetAllLicences
|
||||
allLicences <- avsQueryNoCache AvsQueryGetAllLicences
|
||||
computeDifferingLicences allLicences
|
||||
case res of
|
||||
basediffs <- case res of
|
||||
(Right diffs) -> do
|
||||
let showLics l = Text.intercalate ", " $ fmap (tshow . avsLicencePersonID) $ Set.toList $ Set.filter ((l ==) . avsLicenceRampLicence) diffs
|
||||
r_grant = showLics AvsLicenceRollfeld
|
||||
f_set = showLics AvsLicenceVorfeld
|
||||
revoke = showLics AvsNoLicence
|
||||
let showLics l =
|
||||
let chgs = Set.filter ((l ==) . avsLicenceRampLicence) diffs
|
||||
in if Set.null chgs
|
||||
then ("[ ]", 0)
|
||||
else (Text.intercalate ", " (tshow . avsLicencePersonID <$> Set.toList chgs), Set.size chgs)
|
||||
(r_grant, rg_size) = showLics AvsLicenceRollfeld
|
||||
(f_set , fs_size) = showLics AvsLicenceVorfeld
|
||||
(revoke , rv_size) = showLics AvsNoLicence
|
||||
return $ Just [whamlet|
|
||||
<h2>Licence check differences:
|
||||
<h3>Grant R:
|
||||
<p>
|
||||
#{r_grant}
|
||||
<h3>Set to F:
|
||||
<p>
|
||||
#{f_set}
|
||||
<h3>Revoke licence:
|
||||
<p>
|
||||
#{revoke}
|
||||
<h2>Licence check AVS-ID differences:
|
||||
<dl .deflist>
|
||||
<dt .deflist__dt>Grant R (#{rg_size}):
|
||||
<dd .deflist__dd>#{r_grant}
|
||||
|
||||
<dt .deflist__dt>Set to F (#{fs_size}):
|
||||
<dd .deflist__dd>#{f_set}
|
||||
|
||||
<dt .deflist__dt>Revoke licence (#{rv_size}):
|
||||
<dd .deflist__dd>#{revoke}
|
||||
|]
|
||||
(Left e) -> do
|
||||
let msg = tshow (e :: SomeException)
|
||||
return $ Just [whamlet|<h2>Licence check error:</h2> #{msg}|]
|
||||
autoDiffs <- do
|
||||
-- what follows is copy of the code from Jobs.Handler.SynchroniseAvs.dispatchJobSynchroniseAvsLicences modified to not do anything actually
|
||||
AvsLicenceSynchConf
|
||||
{ avsLicenceSynchLevel = synchLevel -- SynchLevel corresponds to tables of ProblemAvsSynchR: 4=top grant R, 3= reduce R->F, 2= grant F, 1= revoke F
|
||||
, avsLicenceSynchReasonFilter = reasonFilter
|
||||
, avsLicenceSynchMaxChanges = maxChanges
|
||||
} <- getsYesod $ view _appAvsLicenceSynchConf
|
||||
guardMonoidM (synchLevel > 0) $ do
|
||||
let showApids apids
|
||||
| null apids = "[ ]"
|
||||
| otherwise = Text.intercalate ", " (tshow <$> Set.toList apids)
|
||||
procLic :: (Ord a, Show a) => AvsLicence -> Bool -> Set a -> Html
|
||||
procLic aLic up apids
|
||||
| n <- Set.size apids, n > 0 =
|
||||
let subtype = Text.cons (bool '↧' '↥' up) $ Text.singleton $ licence2char aLic
|
||||
in if NTop (Just n) <= NTop maxChanges
|
||||
then
|
||||
[shamlet|
|
||||
<dt .deflist__dt>#{subtype} (#{n}):
|
||||
<dd .deflist__dd>#{showApids apids}
|
||||
|]
|
||||
else
|
||||
[shamlet|
|
||||
<dt .deflist__dt>#{subtype} (#{n}):
|
||||
<dd .deflist__dd>Too many changes at once. Consider increasing avs-licence-synch-max-changes #{tshow maxChanges}
|
||||
|]
|
||||
| otherwise = mempty
|
||||
|
||||
(AvsLicenceDifferences{..}, rsChanged) <- retrieveDifferingLicences
|
||||
-- prevent automatic changes to users blocked with certain reasons and with currently being associated with multiple companies
|
||||
reasonFltrdIds <- ifNothingM reasonFilter mempty $ \reasons -> do
|
||||
now <- liftIO getCurrentTime
|
||||
firmBlocks <- runDBRead $ E.select $ do
|
||||
(uavs :& _qualUser :& qblock) <- X.from $ E.table @UserAvs
|
||||
`E.innerJoin` E.table @QualificationUser `X.on` (\( uavs :& qualUser) -> uavs E.^. UserAvsUser E.==. qualUser E.^. QualificationUserUser)
|
||||
`E.innerJoin` E.table @QualificationUserBlock `X.on` (\(_uavs :& qualUser :& qblock) ->
|
||||
qualUser E.^. QualificationUserId E.==. qblock E.^. QualificationUserBlockQualificationUser
|
||||
E.&&. qblock `isLatestBlockBefore'` E.val now)
|
||||
E.where_ $ (qblock E.^. QualificationUserBlockReason E.~*. E.val reasons)
|
||||
E.&&. uavs E.^. UserAvsPersonId `E.in_` E.vals (Set.unions [avsLicenceDiffRevokeAll, avsLicenceDiffRevokeRollfeld, avsLicenceDiffGrantVorfeld, avsLicenceDiffGrantRollfeld])
|
||||
return $ uavs E.^. UserAvsPersonId
|
||||
return $ Set.fromList $ map E.unValue firmBlocks
|
||||
|
||||
let fltrIds
|
||||
| synchLevel >= 5 = id
|
||||
| synchLevel >= 3 = flip Set.difference reasonFltrdIds
|
||||
| otherwise = flip Set.difference $ reasonFltrdIds `Set.union` rsChanged
|
||||
|
||||
l1 = guardMonoid (synchLevel >= 1) $ procLic AvsNoLicence False $ fltrIds avsLicenceDiffRevokeAll --revoke Vorfeld and maybe also Rollfeld
|
||||
l2 = guardMonoid (synchLevel >= 2) $ procLic AvsLicenceVorfeld True $ fltrIds avsLicenceDiffGrantVorfeld --grant Vorfeld
|
||||
l3 = guardMonoid (synchLevel >= 3) $ procLic AvsLicenceVorfeld False $ fltrIds avsLicenceDiffRevokeRollfeld --downgrade Rollfeld -> Vorfeld
|
||||
l4 = guardMonoid (synchLevel >= 4) $ procLic AvsLicenceRollfeld True $ fltrIds avsLicenceDiffGrantRollfeld --grant Rollfeld
|
||||
avsIdChanges = [shamlet|
|
||||
<h3>
|
||||
Next automatic AVS-ID licence synchronisation:
|
||||
<dl .deflist>
|
||||
^{l4}
|
||||
^{l3}
|
||||
^{l2}
|
||||
^{l1}
|
||||
$maybe reason <- reasonFilter
|
||||
<dt .deflist__dt>Filtered "#{reason}" (#{Set.size reasonFltrdIds}):
|
||||
<dd .deflist__dd>#{showApids reasonFltrdIds}
|
||||
|]
|
||||
----------------------------------------------------
|
||||
-- translate AVS-IDs to AVS-NOs for convenience only
|
||||
avsidnos <- runDBRead $ E.select $ do
|
||||
ua <- X.from $ E.table @UserAvs
|
||||
E.where_ $ ua E.^. UserAvsPersonId `E.in_` E.vals (Set.unions [avsLicenceDiffRevokeAll, avsLicenceDiffRevokeRollfeld, avsLicenceDiffGrantVorfeld, avsLicenceDiffGrantRollfeld]) -- , reasonFltrdIds])
|
||||
return (ua E.^. UserAvsPersonId, ua E.^. UserAvsNoPerson)
|
||||
let id2no = Map.fromList $ $(E.unValueN 2) <$> avsidnos
|
||||
translate = setMapMaybe (`Map.lookup` id2no)
|
||||
l1' = guardMonoid (synchLevel >= 1) $ procLic AvsNoLicence False $ translate $ fltrIds avsLicenceDiffRevokeAll --revoke Vorfeld and maybe also Rollfeld
|
||||
l2' = guardMonoid (synchLevel >= 2) $ procLic AvsLicenceVorfeld True $ translate $ fltrIds avsLicenceDiffGrantVorfeld --grant Vorfeld
|
||||
l3' = guardMonoid (synchLevel >= 3) $ procLic AvsLicenceVorfeld False $ translate $ fltrIds avsLicenceDiffRevokeRollfeld --downgrade Rollfeld -> Vorfeld
|
||||
l4' = guardMonoid (synchLevel >= 4) $ procLic AvsLicenceRollfeld True $ translate $ fltrIds avsLicenceDiffGrantRollfeld --grant Rollfeld
|
||||
autoNoDiffs = [shamlet|
|
||||
<h3>
|
||||
Next automatic licence changes translated to human readable AVS-Numbers, if known:
|
||||
<dl .deflist>
|
||||
^{l4'}
|
||||
^{l3'}
|
||||
^{l2'}
|
||||
^{l1'}
|
||||
$maybe reason <- reasonFilter
|
||||
<dt .deflist__dt>Filtered "#{reason}" (#{Set.size reasonFltrdIds}):
|
||||
<dd .deflist__dd>#{showApids $ translate reasonFltrdIds}
|
||||
|]
|
||||
return $ Just $ avsIdChanges <> autoNoDiffs
|
||||
return (basediffs, autoDiffs)
|
||||
|
||||
-- (Just BtnSynchLicences) -> do
|
||||
-- res <- try synchAvsLicences
|
||||
-- case res of
|
||||
@ -378,8 +473,8 @@ postProblemAvsSynchR = getProblemAvsSynchR
|
||||
getProblemAvsSynchR = do
|
||||
let catchAllAvs' r = flip catch (\err -> addMessageModal Error (i18n MsgAvsCommunicationError) (Right (text2widget $ tshow (err :: SomeException))) >> redirect r)
|
||||
catchAllAvs = catchAllAvs' ProblemAvsSynchR -- == current route; use only in conditions that are not repeated upon reload; do not call redirect within catchAllAvs actions!
|
||||
(AvsLicenceDifferences{..}, apidStatus) <- catchAllAvs' AdminR retrieveDifferingLicencesStatus
|
||||
|
||||
((AvsLicenceDifferences{..}, rsChanged), apidStatus) <- catchAllAvs' AdminR retrieveDifferingLicencesStatus
|
||||
let mkLicTbl = mkLicenceTable apidStatus rsChanged
|
||||
--
|
||||
unknownLicenceOwners' <- whenNonEmpty avsLicenceDiffRevokeAll $ \neZeros ->
|
||||
runDB $ E.select $ do
|
||||
@ -434,10 +529,10 @@ getProblemAvsSynchR = do
|
||||
|
||||
-- licence differences
|
||||
((tres0,tb0),(tres1up,tb1up),(tres1down,tb1down),(tres2,tb2)) <- runDB $ (,,,)
|
||||
<$> mkLicenceTable apidStatus "avsLicDiffRevokeVorfeld" AvsLicenceVorfeld avsLicenceDiffRevokeAll
|
||||
<*> mkLicenceTable apidStatus "avsLicDiffGrantVorfeld" AvsNoLicence avsLicenceDiffGrantVorfeld
|
||||
<*> mkLicenceTable apidStatus "avsLicDiffRevokeRollfeld" AvsLicenceRollfeld avsLicenceDiffRevokeRollfeld
|
||||
<*> mkLicenceTable apidStatus "avsLicDiffGrantRollfeld" AvsNoLicence avsLicenceDiffGrantRollfeld
|
||||
<$> mkLicTbl "avsLicDiffRevokeVorfeld" AvsLicenceVorfeld avsLicenceDiffRevokeAll
|
||||
<*> mkLicTbl "avsLicDiffGrantVorfeld" AvsNoLicence avsLicenceDiffGrantVorfeld
|
||||
<*> mkLicTbl "avsLicDiffRevokeRollfeld" AvsLicenceRollfeld avsLicenceDiffRevokeRollfeld -- downgrade to Vorfeld
|
||||
<*> mkLicTbl "avsLicDiffGrantRollfeld" AvsNoLicence avsLicenceDiffGrantRollfeld
|
||||
|
||||
now <- liftIO getCurrentTime
|
||||
let procRes :: AvsLicence -> (LicenceTableActionData, Set AvsPersonId) -> Handler ()
|
||||
@ -476,6 +571,7 @@ getProblemAvsSynchR = do
|
||||
formResult tres1up $ procRes AvsLicenceVorfeld
|
||||
formResult tres0 $ procRes AvsNoLicence
|
||||
|
||||
AvsLicenceSynchConf{..} <- getsYesod $ view _appAvsLicenceSynchConf
|
||||
siteLayoutMsg MsgAvsTitleLicenceSynch $ do
|
||||
setTitleI MsgAvsTitleLicenceSynch
|
||||
$(i18nWidgetFile "avs-synchronisation")
|
||||
@ -528,14 +624,17 @@ instance HasUser LicenceTableData where
|
||||
-- instance HasQualificationUser LicenceTableData where -- Not possible, since not all rows have a QualificationUser
|
||||
-- hasQualificationUser = resultQualUser . _entityVal
|
||||
|
||||
mkLicenceTable :: AvsPersonIdMapPersonCard -> Text -> AvsLicence -> Set AvsPersonId -> DB (FormResult (LicenceTableActionData, Set AvsPersonId), Widget)
|
||||
mkLicenceTable apidStatus dbtIdent aLic apids = do
|
||||
currentRoute <- fromMaybe (error "mkLicenceTable called from 404-handler") <$> liftHandler getCurrentRoute
|
||||
avsQualifications <- selectList [QualificationAvsLicence !=. Nothing] []
|
||||
mkLicenceTable :: AvsPersonIdMapPersonCard -> Set AvsPersonId -> Text -> AvsLicence -> Set AvsPersonId -> DB (FormResult (LicenceTableActionData, Set AvsPersonId), Widget)
|
||||
mkLicenceTable apidStatus rsChanged dbtIdent aLic apids = do
|
||||
(currentRoute, usrHasAvsRerr) <- liftHandler $ (,)
|
||||
<$> (fromMaybe (error "mkLicenceTable called from 404-handler") <$> liftHandler getCurrentRoute)
|
||||
<*> (messageTooltip <$> messageI Error MsgProblemAvsUsrHadR)
|
||||
avsQualifications <- selectList [QualificationAvsLicence !=. Nothing] [Asc QualificationName]
|
||||
now <- liftIO getCurrentTime
|
||||
|
||||
let nowaday = utctDay now
|
||||
avsQids = entityKey <$> avsQualifications
|
||||
qualOpts = pure $ qualificationsOptionList avsQualifications
|
||||
-- fltrLic qual = if
|
||||
-- | aLic == AvsNoLicence -> E.isNothing (qual E.?. QualificationId) E.||. E.isJust (E.joinV $ qual E.?. QualificationAvsLicence) -- could be R, F, both or none at all, but has licence in AVS
|
||||
-- | otherwise -> E.isNothing (qual E.?. QualificationId) E.||. (E.val aLic E.=?. E.joinV (qual E.?. QualificationAvsLicence)) -- if we suggest granting that licence, this join should deliver a value too
|
||||
@ -570,7 +669,18 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do
|
||||
(\(E.Value cmpSh, E.Value cmpName, E.Value cmpSpr) -> simpleLink (citext2widget cmpName) (FirmUsersR cmpSh) <> bool mempty icnSuper cmpSpr) <$> companies'
|
||||
|
||||
pure $ intercalate (text2widget "; ") companies
|
||||
, sortable (Just "qualification") (i18nCell MsgTableQualifications) $ \(preview resultQualification -> q) -> cellMaybe lmsShortCell q
|
||||
, sortable (Just "qualification") (i18nCell MsgTableQualifications) $
|
||||
if aLic /= AvsLicenceVorfeld
|
||||
then
|
||||
\(preview resultQualification -> q) -> cellMaybe lmsShortCell q
|
||||
else
|
||||
\row ->
|
||||
let q = row ^? resultQualification
|
||||
apid = row ^. resultUserAvs . _userAvsPersonId
|
||||
warnCell c = if Set.member apid rsChanged
|
||||
then c <> spacerCell <> wgtCell usrHasAvsRerr -- expected to be effectively dead code in practice, but we never know
|
||||
else c
|
||||
in warnCell $ cellMaybe lmsShortCell q
|
||||
, sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \(preview $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> cellMaybe dayCell d
|
||||
, sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \(preview $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> cellMaybe dayCell d
|
||||
-- , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \(preview $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> cellMaybe dayCell d
|
||||
@ -614,14 +724,6 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do
|
||||
, prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany)
|
||||
]
|
||||
|
||||
qualOpt :: Entity Qualification -> Handler (Option QualificationId)
|
||||
qualOpt (Entity qualId qual) = do
|
||||
cQualId :: CryptoUUIDQualification <- encrypt qualId
|
||||
return $ Option
|
||||
{ optionDisplay = CI.original $ qualificationName qual
|
||||
, optionInternalValue = qualId
|
||||
, optionExternalValue = tshow cQualId
|
||||
}
|
||||
aLicQid = fmap entityKey . headMay $ filter ((== Just aLic) . qualificationAvsLicence . entityVal) avsQualifications
|
||||
|
||||
-- Block identical to Handler/Qualifications TODO: refactor
|
||||
@ -639,7 +741,7 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do
|
||||
mkOption :: E.Value Text -> Option Text
|
||||
mkOption (E.unValue -> t) = Option{ optionDisplay = t, optionInternalValue = t, optionExternalValue = toPathPiece t }
|
||||
suggestionsBlock :: HandlerFor UniWorX (OptionList Text)
|
||||
suggestionsBlock = mkOptionList . fmap mkOption <$> runDBRead (getBlockReasons E.not_)
|
||||
suggestionsBlock = mkOptionList . fmap mkOption <$> runDBRead (getBlockReasons E.not__)
|
||||
suggestionsUnblock = mkOptionList . fmap mkOption <$> runDBRead (getBlockReasons id)
|
||||
|
||||
acts :: Map LicenceTableAction (AForm Handler LicenceTableActionData)
|
||||
@ -647,12 +749,12 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do
|
||||
[ singletonMap LicenceTableChangeAvs $ pure LicenceTableChangeAvsData
|
||||
, if aLic == AvsNoLicence
|
||||
then singletonMap LicenceTableRevokeFDrive $ LicenceTableRevokeFDriveData
|
||||
<$> apreq (selectField . fmap mkOptionList $ mapM qualOpt avsQualifications) (fslI MsgQualificationName) aLicQid
|
||||
<$> apreq (selectField qualOpts) (fslI MsgQualificationName) aLicQid
|
||||
<*> apreq (textField & cfStrip & addDatalist suggestionsBlock) (fslI MsgQualificationBlockReason) Nothing
|
||||
<*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockNotify) (Just False)
|
||||
|
||||
else singletonMap LicenceTableGrantFDrive $ LicenceTableGrantFDriveData
|
||||
<$> apreq (selectField . fmap mkOptionList $ mapM qualOpt avsQualifications) (fslI MsgQualificationName) aLicQid
|
||||
<$> apreq (selectField qualOpts) (fslI MsgQualificationName) aLicQid
|
||||
<*> apreq (textField & cfStrip & addDatalist suggestionsUnblock) (fslI MsgQualificationGrantReason) Nothing
|
||||
<*> apreq dayField (fslI MsgLmsQualificationValidUntil) Nothing -- apreq?!
|
||||
<*> aopt (convertField not not (boolField . Just $ SomeMessage MsgBoolIrrelevant)) (fslI MsgQualificationUserNoRenewal) Nothing
|
||||
|
||||
@ -28,7 +28,9 @@ import Text.Hamlet
|
||||
-- import Handler.Utils.I18n
|
||||
|
||||
import Handler.Admin.Test.Download (testDownload)
|
||||
|
||||
import qualified Database.Esqueleto.Experimental as E (selectOne, unValue)
|
||||
import qualified Database.Esqueleto.PostgreSQL as E (now_)
|
||||
import qualified Database.Esqueleto.Utils as E (psqlVersion_)
|
||||
|
||||
-- BEGIN - Buttons needed only here
|
||||
data ButtonCreate = CreateMath | CreateInf | CrashApp -- Dummy for Example
|
||||
@ -226,6 +228,9 @@ postAdminTestR = do
|
||||
|
||||
UniWorX{ appSettings' = AppSettings{..} } <- getYesod
|
||||
|
||||
psqlVersion <- runDBRead $ E.selectOne $ return E.psqlVersion_
|
||||
dbTime <- runDBRead $ E.selectOne $ return E.now_
|
||||
|
||||
let locallyDefinedPageHeading = [whamlet|Admin TestPage for Uni2work|]
|
||||
siteLayout locallyDefinedPageHeading $ do
|
||||
-- defaultLayout $ do
|
||||
@ -327,6 +332,17 @@ postAdminTestR = do
|
||||
<dd .deflist__dd>#{tshow appSynchroniseAvsUsersWithin}
|
||||
|]
|
||||
|
||||
[whamlet|
|
||||
<section>
|
||||
<h2> PostgreSQL Information
|
||||
<dl .deflist>
|
||||
$maybe pver <- psqlVersion
|
||||
<dt .deflist__dt>DB Version
|
||||
<dd .deflist__dd>#{E.unValue pver}
|
||||
$maybe ptme <- dbTime
|
||||
<dt .deflist__dt>DB Time
|
||||
<dd .deflist__dd>#{tshow (E.unValue ptme)}
|
||||
|]
|
||||
|
||||
|
||||
|
||||
@ -352,6 +368,7 @@ getAdminTestPdfR = do
|
||||
, qualSchool = qual ^. _qualificationSchool
|
||||
, qualDuration = qual ^. _qualificationValidDuration
|
||||
, qualRenewAuto = qual ^. _qualificationElearningRenews
|
||||
, qualELimit = qual ^. _qualificationElearningLimit
|
||||
, isReminder = False
|
||||
}
|
||||
apcIdent <- letterApcIdent letter encRecipient now
|
||||
|
||||
152
src/Handler/CommCenter.hs
Normal file
152
src/Handler/CommCenter.hs
Normal file
@ -0,0 +1,152 @@
|
||||
-- SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
|
||||
--
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Handler.CommCenter
|
||||
( getCommCenterR
|
||||
) where
|
||||
|
||||
import Import
|
||||
import Handler.Utils
|
||||
|
||||
-- import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
-- import qualified Data.Text as Text
|
||||
import Data.Text.Lens (packed)
|
||||
|
||||
-- import Database.Persist.Sql (updateWhereCount)
|
||||
-- import Database.Esqueleto.Experimental ((:&)(..))
|
||||
import qualified Database.Esqueleto.Legacy as EL (on) -- only `on` and `from` are different, needed for dbTable using Esqueleto.Legacy
|
||||
import qualified Database.Esqueleto.Experimental as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
import qualified Database.Esqueleto.PostgreSQL as E
|
||||
import Database.Esqueleto.Utils.TH
|
||||
|
||||
|
||||
-- avoids repetition of local definitions
|
||||
single :: (k,a) -> Map k a
|
||||
single = uncurry Map.singleton
|
||||
|
||||
|
||||
data CCTableAction = CCActDummy -- just a dummy, since we don't now yet which actions we will be needing
|
||||
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
||||
|
||||
instance Universe CCTableAction
|
||||
instance Finite CCTableAction
|
||||
nullaryPathPiece ''CCTableAction $ camelToPathPiece' 2
|
||||
embedRenderMessage ''UniWorX ''CCTableAction id
|
||||
|
||||
data CCTableActionData = CCActDummyData
|
||||
deriving (Eq, Ord, Read, Show, Generic)
|
||||
|
||||
|
||||
-- SJ: I don't know how to use E.unionAll_ with dbTable, so we simulate it by a FullOuterJoin with constant False ON-clause instead
|
||||
type CCTableExpr =
|
||||
( (E.SqlExpr (Maybe (Entity User)) `E.InnerJoin` E.SqlExpr (Maybe (Entity SentMail)))
|
||||
`E.FullOuterJoin` (E.SqlExpr (Maybe (Entity User)) `E.InnerJoin` E.SqlExpr (Maybe (Entity PrintJob)))
|
||||
)
|
||||
|
||||
queryRecipientMail :: CCTableExpr -> E.SqlExpr (Maybe (Entity User))
|
||||
queryRecipientMail = $(sqlIJproj 2 1) . $(sqlFOJproj 2 1)
|
||||
|
||||
queryMail :: CCTableExpr -> E.SqlExpr (Maybe (Entity SentMail))
|
||||
queryMail = $(sqlIJproj 2 2) . $(sqlFOJproj 2 1)
|
||||
|
||||
queryRecipientPrint :: CCTableExpr -> E.SqlExpr (Maybe (Entity User))
|
||||
queryRecipientPrint = $(sqlIJproj 2 1) . $(sqlFOJproj 2 2)
|
||||
|
||||
queryPrint :: CCTableExpr -> E.SqlExpr (Maybe (Entity PrintJob))
|
||||
queryPrint = $(sqlIJproj 2 2) . $(sqlFOJproj 2 2)
|
||||
|
||||
type CCTableData = DBRow (Maybe (Entity User), Maybe (Entity SentMail), Maybe (Entity User), Maybe (Entity PrintJob))
|
||||
|
||||
resultRecipientMail :: Traversal' CCTableData (Entity User)
|
||||
resultRecipientMail = _dbrOutput . _1 . _Just
|
||||
|
||||
resultMail :: Traversal' CCTableData (Entity SentMail)
|
||||
resultMail = _dbrOutput . _2 . _Just
|
||||
|
||||
resultRecipientPrint :: Traversal' CCTableData (Entity User)
|
||||
resultRecipientPrint = _dbrOutput . _3 . _Just
|
||||
|
||||
resultPrint :: Traversal' CCTableData (Entity PrintJob)
|
||||
resultPrint = _dbrOutput . _4 . _Just
|
||||
|
||||
|
||||
mkCCTable :: DB (Any, Widget)
|
||||
mkCCTable = do
|
||||
let
|
||||
dbtSQLQuery :: CCTableExpr -> E.SqlQuery (E.SqlExpr (Maybe (Entity User)), E.SqlExpr (Maybe (Entity SentMail)), E.SqlExpr (Maybe (Entity User)), E.SqlExpr (Maybe (Entity PrintJob)))
|
||||
dbtSQLQuery ((recipientMail `E.InnerJoin` mail) `E.FullOuterJoin` (recipientPrint `E.InnerJoin` printJob)) = do
|
||||
EL.on $ recipientMail E.?. UserId E.==. E.joinV (mail E.?. SentMailRecipient)
|
||||
EL.on $ recipientPrint E.?. UserId E.==. E.joinV (printJob E.?. PrintJobRecipient)
|
||||
-- EL.on $ recipientMail E.?. UserId E.==. recipientPrint E.?. UserId E.&&. E.false -- simulating E.unionAll_ by a constant false full outer join, since it is unclear how dbTable could handle E.unionAll_
|
||||
EL.on E.false -- simulating E.unionAll_ by a constant false full outer join, since it is unclear how dbTable could handle E.unionAll_
|
||||
-- E.where_ $ E.isJust (recipientMail E.?. UserId) E.||. E.isJust (recipientPrint E.?. UserId) -- not needed for full outer join
|
||||
-- return (E.coalesce[recipientMail, recipientPrint], mail, print) -- coalesce only works on values, not entities
|
||||
return (recipientMail, mail, recipientPrint, printJob)
|
||||
-- dbtRowKey = (,) <$> views (to queryMail) (E.?. SentMailId) <*> views (to queryPrint) (E.?. PrintJobId)
|
||||
dbtRowKey ((_recipientMail `E.InnerJoin` mail) `E.FullOuterJoin` (_recipientPrint `E.InnerJoin` printJob)) = (mail E.?. SentMailId, printJob E.?. PrintJobId)
|
||||
|
||||
dbtProj = dbtProjId
|
||||
dbtColonnade = dbColonnade $ mconcat -- prefer print over email in the impossible case that both are Just
|
||||
[ sortable (Just "date") (i18nCell MsgPrintJobCreated) $ \row ->
|
||||
let tprint = row ^? resultPrint . _entityVal . _printJobCreated
|
||||
tmail = row ^? resultMail . _entityVal . _sentMailSentAt
|
||||
in maybeCell (tprint <|> tmail) dateTimeCell
|
||||
, sortable (Just "recipient") (i18nCell MsgPrintRecipient) $ \row ->
|
||||
let uprint = row ^? resultRecipientPrint
|
||||
umail = row ^? resultRecipientMail
|
||||
in maybeCell (uprint <|> umail) $ cellHasUserLink AdminUserR
|
||||
, sortable Nothing (i18nCell MsgCommBody) $ \row -> if
|
||||
| (Just k) <- row ^? resultPrint . _entityKey
|
||||
-> anchorCellM (PrintDownloadR <$> encrypt k) $ toWgt (iconLetterOrEmail True ) <> text2widget "-link"
|
||||
| (Just k) <- row ^? resultMail . _entityKey
|
||||
-> anchorCellM (MailHtmlR <$> encrypt k) $ toWgt (iconLetterOrEmail False) <> text2widget "-link"
|
||||
| otherwise
|
||||
-> mempty
|
||||
, sortable Nothing (i18nCell MsgCommSubject) $ \row ->
|
||||
let tsubject = row ^? resultPrint . _entityVal . _printJobFilename . packed
|
||||
msubject = row ^? resultMail . _entityVal . _sentMailHeaders . _mailHeaders' . _mailHeader' "Subject"
|
||||
in maybeCell (tsubject <|> msubject) textCell
|
||||
]
|
||||
dbtSorting = mconcat
|
||||
[ singletonMap "date" $ SortColumn $ \row -> E.coalesce [queryPrint row E.?. PrintJobCreated, queryMail row E.?. SentMailSentAt]
|
||||
, singletonMap "recipient" $ SortColumns $ \row ->
|
||||
[ SomeExprValue $ E.coalesce [queryRecipientPrint row E.?. UserSurname , queryRecipientMail row E.?. UserSurname ]
|
||||
, SomeExprValue $ E.coalesce [queryRecipientPrint row E.?. UserDisplayName, queryRecipientMail row E.?. UserDisplayName]
|
||||
]
|
||||
]
|
||||
dbtFilter = mconcat
|
||||
[ single ("sent" , FilterColumn . E.mkDayFilterTo
|
||||
$ \row -> E.coalesceDefault [queryPrint row E.?. PrintJobCreated, queryMail row E.?. SentMailSentAt] E.now_) -- either one is guaranteed to be non-null, default never used
|
||||
, single ("recipient" , FilterColumn . E.mkContainsFilterWithCommaPlus Just
|
||||
$ \row -> E.coalesce [queryRecipientPrint row E.?. UserDisplayName, queryRecipientMail row E.?. UserDisplayName])
|
||||
, single ("subject" , FilterColumn . E.mkContainsFilterWithCommaPlus Just
|
||||
$ \row -> E.coalesce [E.str2text' $ queryPrint row E.?. PrintJobFilename
|
||||
,E.str2text' $ queryMail row E.?. SentMailHeaders ])
|
||||
]
|
||||
dbtFilterUI mPrev = mconcat
|
||||
[ prismAForm (singletonFilter "date" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift dayField) (fslI MsgPrintJobCreated)
|
||||
, prismAForm (singletonFilter "recipient" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintRecipient & setTooltip MsgTableFilterCommaPlus)
|
||||
, prismAForm (singletonFilter "subject" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgCommSubject & setTooltip MsgTableFilterCommaPlusShort)
|
||||
]
|
||||
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout}
|
||||
dbtIdent :: Text
|
||||
dbtIdent = "comms"
|
||||
dbtCsvEncode = noCsvEncode
|
||||
dbtCsvDecode = Nothing
|
||||
dbtExtraReps = []
|
||||
dbtParams = def
|
||||
psValidator = def & defaultSorting [SortDescBy "date"]
|
||||
dbTable psValidator DBTable{..}
|
||||
|
||||
getCommCenterR :: Handler Html
|
||||
getCommCenterR = do
|
||||
(_, ccTable) <- runDB mkCCTable
|
||||
siteLayoutMsg MsgMenuCommCenter $ do
|
||||
setTitleI MsgMenuCommCenter
|
||||
$(widgetFile "comm-center")
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
|
||||
-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>,Winnie Ros <winnie.ros@campus.lmu.de>
|
||||
--
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
@ -46,12 +46,13 @@ data CourseForm = CourseForm
|
||||
, cfRegTo :: Maybe UTCTime
|
||||
, cfDeRegUntil :: Maybe UTCTime
|
||||
, cfLecturers :: [Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)]
|
||||
, cfQualis :: [(QualificationId, Int)]
|
||||
}
|
||||
|
||||
makeLenses_ ''CourseForm
|
||||
|
||||
courseToForm :: Entity Course -> [Lecturer] -> Map UserEmail (InvitationDBData Lecturer) -> CourseForm
|
||||
courseToForm (Entity cid Course{..}) lecs lecInvites = CourseForm
|
||||
courseToForm :: Entity Course -> [Lecturer] -> Map UserEmail (InvitationDBData Lecturer) -> [CourseQualification] -> CourseForm
|
||||
courseToForm (Entity cid Course{..}) lecs lecInvites qualis = CourseForm
|
||||
{ cfCourseId = Just cid
|
||||
, cfName = courseName
|
||||
, cfDesc = courseDescription
|
||||
@ -69,6 +70,9 @@ courseToForm (Entity cid Course{..}) lecs lecInvites = CourseForm
|
||||
, cfDeRegUntil = courseDeregisterUntil
|
||||
, cfLecturers = [Right (lecturerUser, lecturerType) | Lecturer{..} <- lecs]
|
||||
++ [Left (email, mType) | (email, InvDBDataLecturer mType) <- Map.toList lecInvites ]
|
||||
-- TODO: Filterung nach aktueller Schule, da ansonsten ein Sicherheitleck droht! Siehe #150
|
||||
, cfQualis = [ (courseQualificationQualification, courseQualificationSortOrder)
|
||||
| CourseQualification{..} <- qualis, courseQualificationCourse == cid ]
|
||||
}
|
||||
|
||||
|
||||
@ -81,17 +85,19 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
|
||||
uid <- liftHandler requireAuthId
|
||||
(lecturerSchools, adminSchools, oldSchool) <- liftHandler . runDB $ do
|
||||
lecturerSchools <- map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolLecturer]] []
|
||||
protoAdminSchools <- map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolAdmin]] []
|
||||
adminSchools <- filterM (hasWriteAccessTo . flip SchoolR SchoolEditR) protoAdminSchools
|
||||
(userSchools, elegibleQualifications) :: ([SchoolId], OptionList QualificationId) <- liftHandler . runDB $ do
|
||||
lecturerSchools <- map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolLecturer]] []
|
||||
protoAdminSchools <- map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolAdmin]] [] -- default rights
|
||||
adminSchools <- filterM (hasWriteAccessTo . flip SchoolR SchoolEditR) protoAdminSchools -- and user as admin rights active right now
|
||||
oldSchool <- forM (cfCourseId =<< template) $ fmap courseSchool . getJust
|
||||
return (lecturerSchools, adminSchools, oldSchool)
|
||||
let userSchools = nubOrd . maybe id (:) oldSchool $ lecturerSchools ++ adminSchools
|
||||
let elegibleSchools = Set.fromList $ lecturerSchools ++ adminSchools
|
||||
userSchools = Set.toList $ maybe id Set.insert oldSchool elegibleSchools
|
||||
elegibleQualifications <- selectList [QualificationSchool <-. Set.toList elegibleSchools] [Asc QualificationName, Asc QualificationSchool]
|
||||
return (userSchools, qualificationsOptionList elegibleQualifications)
|
||||
|
||||
(termsField, userTerms) <- liftHandler $ case template of
|
||||
-- Change of term is only allowed if user may delete the course (i.e. no participants) or admin
|
||||
(Just cform) | (Just cid) <- cfCourseId cform -> do -- edit existing course
|
||||
(Just cform) | (Just cid) <- cfCourseId cform -> do -- edit existing course& \c
|
||||
_courseOld@Course{..} <- runDB $ get404 cid
|
||||
mayEditTerm <- isAuthorized TermEditR True
|
||||
mayDelete <- isAuthorized (CourseR courseTerm courseSchool courseShorthand CDeleteR) True
|
||||
@ -102,51 +108,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
|
||||
-> return (termsSetField [cfTerm cform], [cfTerm cform])
|
||||
_allOtherCases -> (termsAllowedField, ) . Set.toList <$> runDB getActiveTerms
|
||||
|
||||
let miAdd :: ListPosition -> Natural -> ListLength -> (Text -> Text) -> FieldView UniWorX -> Maybe (Form (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId))))
|
||||
miAdd _ _ _ nudge btn = Just $ \csrf -> do
|
||||
(addRes, addView) <- mpreq (multiUserInvitationField $ MUILookupAnyUser Nothing) (fslI MsgCourseLecturerEmail & addName (nudge "email") & addPlaceholder (mr MsgLdapIdentificationOrEmail)) Nothing
|
||||
let addRes'' = addRes <&> \newDat oldDat -> if
|
||||
| existing <- newDat `Set.intersection` Set.fromList (Map.elems oldDat)
|
||||
, not $ Set.null existing
|
||||
-> FormFailure [mr MsgCourseLecturerAlreadyAdded]
|
||||
| otherwise
|
||||
-> FormSuccess . Map.fromList . zip [maybe 0 (succ . fst) $ Map.lookupMax oldDat ..] $ Set.toList newDat
|
||||
addView' = $(widgetFile "course/lecturerMassInput/add")
|
||||
return (addRes'', addView')
|
||||
|
||||
miCell :: ListPosition -> Either UserEmail UserId -> Maybe (Maybe LecturerType) -> (Text -> Text) -> Form (Maybe LecturerType)
|
||||
miCell _ (Right lid) defType nudge = \csrf -> do
|
||||
(lrwRes,lrwView) <- mreq (selectField optionsFinite) (fslI MsgCourseLecturerType & addName (nudge "lecturer-type")) (join defType)
|
||||
usr <- liftHandler . runDB $ get404 lid
|
||||
let lrwView' = $(widgetFile "course/lecturerMassInput/cellKnown")
|
||||
return (Just <$> lrwRes,lrwView')
|
||||
miCell _ (Left lEmail) defType nudge = \csrf -> do
|
||||
(lrwRes,lrwView) <- mopt (selectField optionsFinite) ("" & addName (nudge "lecturer-type")) defType
|
||||
invWarnMsg <- messageIconI Info IconEmail MsgEmailInvitationWarning
|
||||
let lrwView' = $(widgetFile "course/lecturerMassInput/cellInvitation")
|
||||
return (lrwRes,lrwView')
|
||||
|
||||
miDelete :: Map ListPosition (Either UserEmail UserId) -- ^ Current shape
|
||||
-> ListPosition -- ^ Coordinate to delete
|
||||
-> MaybeT (MForm (HandlerFor UniWorX)) (Map ListPosition ListPosition)
|
||||
miDelete = miDeleteList
|
||||
|
||||
miAddEmpty :: ListPosition -> Natural -> ListLength -> Set ListPosition
|
||||
miAddEmpty _ _ _ = Set.empty
|
||||
|
||||
miLayout :: ListLength
|
||||
-> Map ListPosition (Either UserEmail UserId, FormResult (Maybe LecturerType)) -- ^ massInput state
|
||||
-> Map ListPosition Widget -- ^ Cell widgets
|
||||
-> Map ListPosition (FieldView UniWorX) -- ^ Deletion buttons
|
||||
-> Map (Natural, ListPosition) Widget -- ^ Addition widgets
|
||||
-> Widget
|
||||
miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "course/lecturerMassInput/layout")
|
||||
|
||||
miIdent :: Text
|
||||
miIdent = "lecturers"
|
||||
|
||||
|
||||
lecturerForm :: AForm Handler [Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)]
|
||||
let lecturerForm :: AForm Handler [Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)]
|
||||
lecturerForm = formToAForm . over (mapped._2) pure . over (mapped._1.mapped) (map liftEither . Map.elems) $ massInput
|
||||
MassInput{..}
|
||||
(fslI MsgCourseLecturers & setTooltip MsgCourseLecturerRightsIdentical)
|
||||
@ -163,6 +125,79 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
|
||||
unliftEither (Right (lid , lType )) = (Right lid , Just lType)
|
||||
unliftEither (Left (lEmail, mLType)) = (Left lEmail, mLType )
|
||||
|
||||
miAdd :: ListPosition -> Natural -> ListLength -> (Text -> Text) -> FieldView UniWorX -> Maybe (Form (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId))))
|
||||
miAdd _ _ _ nudge btn = Just $ \csrf -> do
|
||||
(addRes, addView) <- mpreq (multiUserInvitationField $ MUILookupAnyUser Nothing) (fslI MsgCourseLecturerEmail & addName (nudge "email") & addPlaceholder (mr MsgLdapIdentificationOrEmail)) Nothing
|
||||
let addRes'' = addRes <&> \newDat oldDat -> if
|
||||
| existing <- newDat `Set.intersection` Set.fromList (Map.elems oldDat)
|
||||
, not $ Set.null existing
|
||||
-> FormFailure [mr MsgCourseLecturerAlreadyAdded]
|
||||
| otherwise
|
||||
-> FormSuccess . Map.fromList . zip [maybe 0 (succ . fst) $ Map.lookupMax oldDat ..] $ Set.toList newDat
|
||||
addView' = $(widgetFile "course/lecturerMassInput/add")
|
||||
return (addRes'', addView')
|
||||
|
||||
miCell :: ListPosition -> Either UserEmail UserId -> Maybe (Maybe LecturerType) -> (Text -> Text) -> Form (Maybe LecturerType)
|
||||
miCell _ (Right lid) defType nudge = \csrf -> do
|
||||
(lrwRes,lrwView) <- mreq (selectField optionsFinite) (fslI MsgCourseLecturerType & addName (nudge "lecturer-type")) (join defType)
|
||||
usr <- liftHandler . runDB $ get404 lid
|
||||
let lrwView' = $(widgetFile "course/lecturerMassInput/cellKnown")
|
||||
return (Just <$> lrwRes,lrwView')
|
||||
miCell _ (Left lEmail) defType nudge = \csrf -> do
|
||||
(lrwRes,lrwView) <- mopt (selectField optionsFinite) ("" & addName (nudge "lecturer-type")) defType
|
||||
invWarnMsg <- messageIconI Info IconEmail MsgEmailInvitationWarning
|
||||
let lrwView' = $(widgetFile "course/lecturerMassInput/cellInvitation")
|
||||
return (lrwRes,lrwView')
|
||||
|
||||
miDelete :: Map ListPosition (Either UserEmail UserId) -- ^ Current shape
|
||||
-> ListPosition -- ^ Coordinate to delete
|
||||
-> MaybeT (MForm (HandlerFor UniWorX)) (Map ListPosition ListPosition)
|
||||
miDelete = miDeleteList
|
||||
|
||||
miAddEmpty :: ListPosition -> Natural -> ListLength -> Set ListPosition
|
||||
miAddEmpty _ _ _ = Set.empty
|
||||
|
||||
miLayout :: ListLength
|
||||
-> Map ListPosition (Either UserEmail UserId, FormResult (Maybe LecturerType)) -- ^ massInput state
|
||||
-> Map ListPosition Widget -- ^ Cell widgets
|
||||
-> Map ListPosition (FieldView UniWorX) -- ^ Deletion buttons
|
||||
-> Map (Natural, ListPosition) Widget -- ^ Addition widgets
|
||||
-> Widget
|
||||
miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "course/lecturerMassInput/layout")
|
||||
|
||||
miIdent :: Text
|
||||
miIdent = "lecturers"
|
||||
|
||||
qualificationsForm :: Maybe [(QualificationId, Int)] -> AForm Handler [(QualificationId, Int)] -- filter by admin school done later through upsertCourseQualifications
|
||||
qualificationsForm = massInputAccumEditA miAdd miEdit miButtonAction miLayout miIdent (fslI $ MsgCourseQualifications 9) False
|
||||
where
|
||||
miIdent :: Text
|
||||
miIdent = "qualifications"
|
||||
|
||||
miAdd :: (Text -> Text) -> FieldView UniWorX -> Form ([(QualificationId,Int)] -> FormResult [(QualificationId,Int)])
|
||||
miAdd nudge submitView csrf = do
|
||||
(formRes, formView) <- aCourseQualiForm nudge Nothing csrf
|
||||
let addRes = formRes <&> \newDat@(newQid,oldOrd) (unzip -> (oldQids,oldOrds)) ->
|
||||
let qidBad = guardMonoid (newQid `elem` oldQids) [mr MsgCourseEditQualificationFailExists]
|
||||
ordBad = guardMonoid (oldOrd `elem` oldOrds) [mr MsgCourseEditQualificationFailOrder ]
|
||||
problems = qidBad ++ ordBad
|
||||
in if null problems
|
||||
then FormSuccess $ pure newDat
|
||||
else FormFailure problems
|
||||
return (addRes, $(widgetFile "widgets/massinput/courseQualifications/add"))
|
||||
|
||||
miEdit :: (Text -> Text) -> (QualificationId, Int) -> Form (QualificationId, Int)
|
||||
miEdit nudge = aCourseQualiForm nudge . Just
|
||||
|
||||
miLayout :: MassInputLayout ListLength (QualificationId,Int) (QualificationId, Int)
|
||||
miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/courseQualifications/layout")
|
||||
|
||||
aCourseQualiForm :: (Text -> Text) -> Maybe (QualificationId, Int) -> Form (QualificationId, Int)
|
||||
aCourseQualiForm nudge mTemplate csrf = do
|
||||
(cquRes, cquView) <- mpreq (selectField $ pure elegibleQualifications) ("" & addName (nudge "cquali")) (view _1 <$> mTemplate)
|
||||
(ordRes, ordView) <- mpreq intField ("" & addName (nudge "cqordr")) (view _2 <$> mTemplate)
|
||||
return ((,) <$> cquRes <*> ordRes, $(widgetFile "widgets/massinput/courseQualifications/form"))
|
||||
|
||||
(newVisFrom,newRegFrom,newRegTo,newDeRegUntil) <- case template of
|
||||
(Just cform) | (Just _cid) <- cfCourseId cform -> return (Nothing,Nothing,Nothing,Nothing)
|
||||
_allIOtherCases -> do
|
||||
@ -208,6 +243,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
|
||||
& setTooltip MsgCourseDeregisterUntilTip) (deepAlt (cfDeRegUntil <$> template) newDeRegUntil)
|
||||
<* aformSection MsgCourseFormSectionAdministration
|
||||
<*> lecturerForm
|
||||
<*> qualificationsForm (cfQualis <$> template)
|
||||
return (result, widget)
|
||||
|
||||
|
||||
@ -227,6 +263,10 @@ validateCourse = do
|
||||
unless userAdmin $ do
|
||||
guardValidation MsgCourseUserMustBeLecturer
|
||||
$ anyOf (traverse . _Right . _1) (== uid) cfLecturers
|
||||
guardValidation MsgCourseEditQualificationFailExists
|
||||
$ not $ hasDuplicates $ fst <$> cfQualis
|
||||
guardValidation MsgCourseEditQualificationFailOrder
|
||||
$ not $ hasDuplicates $ snd <$> cfQualis
|
||||
|
||||
warnValidation MsgCourseShorthandTooLong
|
||||
$ length (CI.original cfShort) <= 10
|
||||
@ -280,8 +320,11 @@ getCourseNewR = do
|
||||
E.limit 1
|
||||
return course
|
||||
template <- case oldCourses of
|
||||
(oldTemplate:_) ->
|
||||
let newTemplate = courseToForm oldTemplate mempty mempty in
|
||||
(oldTemplate:_) -> runDB $ do
|
||||
mbLecs <- oldTemplate & \course -> map entityVal <$> selectList [LecturerCourse ==. entityKey course] [Asc LecturerType]
|
||||
mbLecInvites <- oldTemplate & sourceInvitationsF . entityKey
|
||||
mbQualis <- oldTemplate & \course -> map entityVal <$> selectList [CourseQualificationCourse ==. entityKey course] [Asc CourseQualificationSortOrder]
|
||||
let newTemplate = courseToForm oldTemplate mbLecs mbLecInvites mbQualis
|
||||
return $ Just $ newTemplate
|
||||
{ cfCourseId = Nothing
|
||||
, cfTerm = TermKey $ termFromRational 0 -- invalid, will be ignored; undefined won't work due to strictness
|
||||
@ -314,10 +357,11 @@ pgCEditR tid ssh csh = do
|
||||
mbCourse <- getBy (TermSchoolCourseShort tid ssh csh)
|
||||
mbLecs <- for mbCourse $ \course -> map entityVal <$> selectList [LecturerCourse ==. entityKey course] [Asc LecturerType]
|
||||
mbLecInvites <- for mbCourse $ sourceInvitationsF . entityKey
|
||||
return $ (,,) <$> mbCourse <*> mbLecs <*> mbLecInvites
|
||||
mbQualis <- for mbCourse $ \course -> map entityVal <$> selectList [CourseQualificationCourse ==. entityKey course] [Asc CourseQualificationSortOrder]
|
||||
return $ (,,,) <$> mbCourse <*> mbLecs <*> mbLecInvites <*> mbQualis
|
||||
-- IMPORTANT: both GET and POST Handler must use the same template,
|
||||
-- since an Edit is identified via CourseID, which is not embedded in the received form data for security reasons.
|
||||
courseEditHandler (\p -> Just . SomeRoute $ CourseR tid ssh csh CEditR :#: p) $ $(uncurryN 3) courseToForm <$> courseData
|
||||
courseEditHandler (\p -> Just . SomeRoute $ CourseR tid ssh csh CEditR :#: p) $ $(uncurryN 4) courseToForm <$> courseData
|
||||
|
||||
|
||||
-- | Course Creation and Editing
|
||||
@ -357,6 +401,7 @@ courseEditHandler miButtonAction mbCourseForm = do
|
||||
let (invites, adds) = partitionEithers $ cfLecturers res
|
||||
insertMany_ $ map (\(lid, lty) -> Lecturer lid cid lty) adds
|
||||
sinkInvitationsF lecturerInvitationConfig $ map (\(lEmail, mLty) -> (lEmail, cid, (InvDBDataLecturer mLty, InvTokenDataLecturer))) invites
|
||||
void $ upsertCourseQualifications aid cid $ cfQualis res
|
||||
insert_ $ CourseEdit aid now cid
|
||||
memcachedByInvalidate AuthCacheLecturerList $ Proxy @(Set UserId)
|
||||
return insertOkay
|
||||
@ -405,11 +450,9 @@ courseEditHandler miButtonAction mbCourseForm = do
|
||||
let (invites, adds) = partitionEithers $ cfLecturers res
|
||||
insertMany_ $ map (\(lid, lty) -> Lecturer lid cid lty) adds
|
||||
sinkInvitationsF lecturerInvitationConfig $ map (\(lEmail, mLty) -> (lEmail, cid, (InvDBDataLecturer mLty, InvTokenDataLecturer))) invites
|
||||
|
||||
void $ upsertCourseQualifications aid cid $ cfQualis res
|
||||
insert_ $ CourseEdit aid now cid
|
||||
|
||||
memcachedByInvalidate AuthCacheLecturerList $ Proxy @(Set UserId)
|
||||
|
||||
addMessageI Success $ MsgCourseEditOk tid ssh csh
|
||||
return True
|
||||
when success $ redirect $ CourseR tid ssh csh CShowR
|
||||
@ -420,3 +463,35 @@ courseEditHandler miButtonAction mbCourseForm = do
|
||||
{ formAction = Just $ SomeRoute actionUrl
|
||||
, formEncoding = formEnctype
|
||||
}
|
||||
|
||||
-- upsertCourseQualifications :: forall m backend . (MonadIO m, PersistStoreWrite backend, PersistQueryRead backend) => UserId -> CourseId -> [(QualificationId, Int)] -> ReaderT backend m Bool
|
||||
upsertCourseQualifications :: UserId -> CourseId -> [(QualificationId, Int)] -> YesodJobDB UniWorX Bool -- could be generalized
|
||||
upsertCourseQualifications uid cid qualis = do
|
||||
let newQualis = Map.fromList qualis
|
||||
oldQualis <- Map.fromList . fmap (\Entity{entityKey=k, entityVal=CourseQualification{..}} -> (courseQualificationQualification, (k, courseQualificationSortOrder)))
|
||||
<$> selectList [CourseQualificationCourse ==. cid] [Asc CourseQualificationQualification]
|
||||
-- NOTE: CourseQualification allow the immediate assignment of these qualifications to any enrolled user. Hence SchoolAdmins must not be allowed to assign school-foreign qualifications, see #150
|
||||
okSchools <- Set.fromList . fmap (userFunctionSchool . entityVal)
|
||||
<$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolAdmin, SchoolLecturer]] [Asc UserFunctionSchool]
|
||||
{- Some debugging due to an error caused by using fromDistinctAscList with violated precondition:
|
||||
$logErrorS "CourseQuali" $ "OLD Course Qualifications:" <> tshow oldQualis
|
||||
$logErrorS "CourseQuali" $ "NEW Course Qualifications:" <> tshow newQualis
|
||||
$logErrorS "CourseQuali" $ "DIFF Course Qualifications:" <> tshow (newQualis Map.\\ oldQualis)
|
||||
-}
|
||||
foldWithKeyMapM oldQualis $ \qu (k, so_old) -> case Map.lookup qu newQualis of
|
||||
Just so_new | so_new /= so_old
|
||||
-> update k [CourseQualificationSortOrder =. so_new] -- existing CourseQualifications may be re-ordered, regardless of school association
|
||||
Nothing -> delete k -- existing CourseQualifications may be removed, regardless of school association
|
||||
_ -> return ()
|
||||
res <- foldWithKeyMapM (newQualis Map.\\ oldQualis) $ \qu so -> get qu >>= \case
|
||||
Just Qualification{qualificationSchool=ssh, qualificationShorthand=qsh}
|
||||
| Set.member ssh okSchools ->
|
||||
insert_ CourseQualification{courseQualificationQualification = qu, courseQualificationCourse = cid, courseQualificationSortOrder = so}
|
||||
$> All True
|
||||
| otherwise -> do
|
||||
addMessageI Warning $ MsgCourseEditQualificationFailRights qsh ssh
|
||||
pure $ All False
|
||||
_ -> do
|
||||
addMessageI Warning MsgCourseEditQualificationFail
|
||||
pure $ All False
|
||||
pure $ getAll res
|
||||
|
||||
@ -19,6 +19,7 @@ import Import
|
||||
|
||||
-- import Jobs
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Company
|
||||
import Handler.Utils.Communication
|
||||
import Handler.Utils.Avs (guessAvsUser)
|
||||
|
||||
@ -32,8 +33,8 @@ import qualified Data.CaseInsensitive as CI
|
||||
import Database.Persist.Postgresql
|
||||
import Database.Esqueleto.Experimental ((:&)(..))
|
||||
import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
|
||||
import qualified Database.Esqueleto.Legacy as EL (on)
|
||||
import qualified Database.Esqueleto.PostgreSQL as E
|
||||
import qualified Database.Esqueleto.Legacy as EL (on) -- needed for legacy join expected by dbTable
|
||||
-- import qualified Database.Esqueleto.PostgreSQL as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
import Database.Esqueleto.Utils.TH
|
||||
|
||||
@ -56,7 +57,7 @@ postalEmailField = boolFieldCustom (SomeMessage MsgUtilPostal) (SomeMessage MsgU
|
||||
|
||||
data FirmAction = FirmActNotify
|
||||
| FirmActResetSupervision
|
||||
| FirmActAddSupersvisors
|
||||
| FirmActAddSupervisors
|
||||
| FirmActChangeContactFirm
|
||||
| FirmActChangeContactUser
|
||||
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
||||
@ -70,10 +71,11 @@ data FirmActionData = FirmActNotifyData
|
||||
{ firmActResetKeepOldSupers :: Maybe Bool
|
||||
, firmActResetMutualSupervision :: Maybe Bool
|
||||
}
|
||||
| FirmActAddSupersvisorsData
|
||||
| FirmActAddSupervisorsData
|
||||
{ firmActAddSupervisorIds :: Set Text
|
||||
, firmActAddSupervisorReroute :: Bool
|
||||
, firmActAddSupervisorPostal :: Maybe Bool
|
||||
, firmActAddSupervisorReason :: Maybe Text
|
||||
}
|
||||
| FirmActChangeContactFirmData
|
||||
{ firmActCCFPostalAddr :: Maybe StoredMarkup
|
||||
@ -82,6 +84,7 @@ data FirmActionData = FirmActNotifyData
|
||||
}
|
||||
| FirmActChangeContactUserData
|
||||
{ firmActCCUPostalAddr :: Maybe StoredMarkup
|
||||
, firmActCCUUseCompanyPostal :: Maybe Bool
|
||||
, firmActCCUPostalPref :: Maybe Bool
|
||||
}
|
||||
deriving (Eq, Ord, Read, Show, Generic)
|
||||
@ -91,21 +94,31 @@ firmActionMap mr isAdmin acts = mconcat (mkAct isAdmin <$> acts)
|
||||
where
|
||||
mkAct True FirmActNotify = singletonMap FirmActNotify $ pure FirmActNotifyData
|
||||
mkAct _ FirmActResetSupervision = singletonMap FirmActResetSupervision $ FirmActResetSupervisionData
|
||||
<$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just $ Just False)
|
||||
<*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True )
|
||||
mkAct _ FirmActAddSupersvisors = singletonMap FirmActAddSupersvisors $ FirmActAddSupersvisorsData
|
||||
<$> areq (textField & cfAnySeparatedSet) (fslI MsgTableIsDefaultSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing
|
||||
<$> aopt boolField' (fslI MsgFirmActResetSuperKeep) (Just $ Just False)
|
||||
<*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True )
|
||||
mkAct _ FirmActAddSupervisors = singletonMap FirmActAddSupervisors $ FirmActAddSupervisorsData
|
||||
<$> areq (textField & cfAnySeparatedSet) (fslI MsgFirmSuperDefault & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing
|
||||
<*> areq checkBoxField (fslI MsgTableIsDefaultReroute) (Just True)
|
||||
<*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing
|
||||
<*> aopt (textField & cfStrip & addDatalist ucdefSuperReasons)
|
||||
(fslI MsgUserCompanyReason & setTooltip MsgUserCompanyReasonTooltip) Nothing
|
||||
mkAct _ FirmActChangeContactFirm = singletonMap FirmActChangeContactFirm $ FirmActChangeContactFirmData
|
||||
<$> aopt htmlField (fslI MsgPostAddress & setTooltip (SomeMessages [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing
|
||||
<*> aopt (emailField & cfStrip & cfCI) (fslI MsgUserDisplayEmail & setTooltip MsgUtilEmptyNoChangeTip) Nothing
|
||||
<*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing
|
||||
<*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFirmDefaultPreferenceInfo) Nothing
|
||||
<* aformMessage (Message Info (toHtml $ mr MsgFirmActChangeContactFirmInfo) (Just IconNotificationNonactive))
|
||||
mkAct _ FirmActChangeContactUser = singletonMap FirmActChangeContactUser $ FirmActChangeContactUserData
|
||||
<$> aopt htmlField (fslI MsgPostAddress & setTooltip (SomeMessages [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing
|
||||
<*> aopt boolField' (fslI MsgCompanyUserUseCompanyAddress & setTooltip MsgCompanyUserUseCompanyAddressTip) Nothing
|
||||
<*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing
|
||||
mkAct _ _ = mempty
|
||||
ucdefSuperReasons :: HandlerFor UniWorX (OptionList Text)
|
||||
ucdefSuperReasons = fmap (mkOptionList . map (\t -> Option t t t) . Set.toAscList) . runDB $
|
||||
fmap (setOf $ folded . _Value . _Just) . E.select . E.distinct $ do
|
||||
usrc <- E.from $ E.table @UserCompany
|
||||
E.where_ $ E.isJust $ usrc E.^. UserCompanyReason
|
||||
return $ usrc E.^. UserCompanyReason
|
||||
|
||||
|
||||
firmActionForm :: _ -> Bool -> [FirmAction] -> AForm Handler FirmActionData
|
||||
firmActionForm mr isAdmin acts = multiActionA (firmActionMap mr isAdmin acts) (fslI MsgTableAction) Nothing
|
||||
@ -136,17 +149,19 @@ firmActionHandler route isAdmin = flip formResult faHandler
|
||||
delSupers <- if firmActResetKeepOldSupers == Just False
|
||||
then E.deleteCount $ do
|
||||
spr <- E.from $ E.table @UserSupervisor
|
||||
E.where_ $ suprFltr spr E.&&. E.exists (do
|
||||
usr <- E.from $ E.table @UserCompany
|
||||
E.where_ $ usr E.^. UserCompanyCompany `E.in_` E.vals fids
|
||||
E.&&. usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser
|
||||
)
|
||||
E.where_ $ suprFltr spr
|
||||
E.&&. spr E.^. UserSupervisorReason E.~=. E.val (tshow SupervisorReasonCompanyDefault)
|
||||
E.&&. E.exists (do
|
||||
usr <- E.from $ E.table @UserCompany
|
||||
E.where_ $ usr E.^. UserCompanyCompany `E.in_` E.vals fids
|
||||
E.&&. usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser
|
||||
)
|
||||
else return 0
|
||||
newSupers <- addDefaultSupervisorsFor madId (firmActResetMutualSupervision /= Just False) fids
|
||||
newSupers <- addDefaultSupervisorsFor (Just $ tshow SupervisorReasonCompanyDefault) madId (firmActResetMutualSupervision /= Just False) fids
|
||||
addMessageI Success $ MsgFirmResetSupervision delSupers newSupers
|
||||
reloadKeepGetParams route -- reload to reflect changes
|
||||
|
||||
faHandler (FirmActAddSupersvisorsData{..}, Set.toList -> [cid]) = do
|
||||
faHandler (FirmActAddSupervisorsData{..}, Set.toList -> [cid]) = do
|
||||
avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser firmActAddSupervisorIds
|
||||
let (usersFound', usersNotFound) = partition (is _Just . view _2) $ Map.toList avsUsers
|
||||
usersFound = mapMaybe snd usersFound'
|
||||
@ -164,7 +179,7 @@ firmActionHandler route isAdmin = flip formResult faHandler
|
||||
runDB $ do
|
||||
-- putMany [UserCompany uid cid True firmActAddSupervisorReroute 0 False | uid <- usersFound] -- putMany always overwrites existing records, which would destroy priority and useCompanyAddress here
|
||||
-- upsertManyWhere [UserCompany uid cid True firmActAddSupervisorReroute 0 False | uid <- usersFound] [copyField UserCompanySupervisor, copyField UserCompanySupervisorReroute] [] [] -- overwrite Supervisor and SupervisorReroute, keep priority and useCompanyAddress
|
||||
upsertManyWhere [UserCompany uid cid True firmActAddSupervisorReroute 0 False | uid <- usersFound] [] [UserCompanySupervisor =. True, UserCompanySupervisorReroute =. firmActAddSupervisorReroute] [] -- identical to previous line, but perhaps more clear?
|
||||
upsertManyWhere [UserCompany uid cid True firmActAddSupervisorReroute 0 False firmActAddSupervisorReason| uid <- usersFound] [] [UserCompanySupervisor =. True, UserCompanySupervisorReroute =. firmActAddSupervisorReroute, UserCompanyReason =. firmActAddSupervisorReason] [] -- identical to previous line, but perhaps more clear?
|
||||
whenIsJust firmActAddSupervisorPostal $ \prefPostal ->
|
||||
updateWhere [UserId <-. usersFound] [UserPrefersPostal =. prefPostal]
|
||||
addMessageI Success $ MsgFirmActAddSupersSet (fromIntegral $ length usersFound) firmActAddSupervisorPostal
|
||||
@ -181,21 +196,30 @@ firmActionHandler route isAdmin = flip formResult faHandler
|
||||
addMessageI Success MsgFirmActChangeContactFirmResult
|
||||
reloadKeepGetParams route
|
||||
|
||||
faHandler (FirmActChangeContactUserData{..}, Set.toList -> [cid]) =
|
||||
let changes = catMaybes
|
||||
[ (UserPostAddress E.=.) . E.justVal <$> canonical firmActCCUPostalAddr -- note that Nothing means no change and not delete address!
|
||||
, (UserPrefersPostal E.=.) . E.val <$> firmActCCUPostalPref
|
||||
]
|
||||
in unless (null changes) $ do
|
||||
nrChanged <- runDB $ E.updateCount $ \usr -> do
|
||||
E.set usr changes
|
||||
E.where_ $ E.exists $ do
|
||||
usrCmpy <- E.from $ E.table @UserCompany
|
||||
E.where_ $ usrCmpy E.^. UserCompanyCompany E.==. E.val cid
|
||||
E.&&. usrCmpy E.^. UserCompanyUser E.==. usr E.^. UserId
|
||||
addMessageI Success $ MsgFirmUserChanges nrChanged
|
||||
reloadKeepGetParams route -- reload to reflect changes
|
||||
|
||||
faHandler (FirmActChangeContactUserData{..}, Set.toList -> [cid])
|
||||
| firmActCCUUseCompanyPostal == Just True, isJust firmActCCUPostalAddr =
|
||||
addMessageI Error MsgCompanyUserUseCompanyPostalError
|
||||
| otherwise = do
|
||||
let changes = catMaybes
|
||||
[ toMaybe (firmActCCUUseCompanyPostal == Just True) (UserPostAddress E.=. E.nothing) -- precondition ensures that only one update applies for UserPostAddress
|
||||
, (UserPostAddress E.=.) . E.justVal <$> canonical firmActCCUPostalAddr -- note that Nothing means no change and not delete address!
|
||||
, (UserPrefersPostal E.=.) . E.val <$> firmActCCUPostalPref
|
||||
]
|
||||
(total, nrChanged) <- runDB $ do
|
||||
nrUsrChange <- E.updateCount $ \usr -> do
|
||||
E.set usr changes
|
||||
E.where_ $ E.exists $ do
|
||||
usrCmpy <- E.from $ E.table @UserCompany
|
||||
E.where_ $ usrCmpy E.^. UserCompanyCompany E.==. E.val cid
|
||||
E.&&. usrCmpy E.^. UserCompanyUser E.==. usr E.^. UserId
|
||||
nrUseComp <- case firmActCCUUseCompanyPostal of
|
||||
Just x -> updateWhereCount [UserCompanyCompany ==. cid] [UserCompanyUseCompanyAddress =. x]
|
||||
Nothing -> return 0
|
||||
nrCid <- count [UserCompanyCompany ==. cid]
|
||||
return (fromIntegral nrCid, max nrUsrChange nrUseComp)
|
||||
let allok = bool Warning Success $ nrChanged == total
|
||||
addMessageI allok $ MsgFirmUserActChangeResult nrChanged total
|
||||
reloadKeepGetParams route -- reload to reflect changes
|
||||
faHandler _ = addMessageI Error MsgErrorUnknownFormAction
|
||||
|
||||
|
||||
@ -230,99 +254,6 @@ runFirmActionFormPost cid route isAdmin acts = do
|
||||
-- Firm specific utilities
|
||||
-- for filters and counts also see before FirmAllR Handlers
|
||||
|
||||
|
||||
|
||||
-- | remove supervisors for given users; maybe restricted to those linked to a given companies
|
||||
deleteSupervisors :: NonEmpty UserId -> [CompanyId] -> DB Int64
|
||||
deleteSupervisors usrs cids = deleteWhereCount $ (UserSupervisorUser <-. toList usrs) : restrictByCompany
|
||||
where
|
||||
restrictByCompany = guardMonoid (notNull cids) [UserSupervisorCompany <-. (Just <$> cids)]
|
||||
|
||||
-- reset supervisors given employees of a company to default company supervision, deleting all previous company-related supervisors
|
||||
resetSupervisors :: CompanyId -> NonEmpty UserId -> DB Int64
|
||||
resetSupervisors cid employees = do
|
||||
nr_del <- deleteSupervisors employees [cid]
|
||||
nr_add <- addDefaultSupervisors cid employees
|
||||
return $ max nr_del nr_add
|
||||
|
||||
-- adds the default company supervisors as supervisor to a given set of users, which themselves may belong to any company
|
||||
addDefaultSupervisors :: CompanyId -> NonEmpty UserId -> DB Int64
|
||||
addDefaultSupervisors cid employees = do
|
||||
E.insertSelectWithConflictCount UniqueUserSupervisor
|
||||
(do
|
||||
(spr :& usr) <- E.from $ E.table @UserCompany `E.crossJoin` E.toValues employees
|
||||
E.where_ $ spr E.^. UserCompanyCompany E.==. E.val cid
|
||||
E.&&. spr E.^. UserCompanySupervisor
|
||||
E.distinct $ return $ UserSupervisor
|
||||
E.<# (spr E.^. UserCompanyUser)
|
||||
E.<&> usr
|
||||
E.<&> (spr E.^. UserCompanySupervisorReroute)
|
||||
E.<&> E.justVal cid
|
||||
E.<&> E.nothing
|
||||
)
|
||||
(\_old new ->
|
||||
[ UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications
|
||||
, UserSupervisorCompany E.=. E.justVal cid
|
||||
-- , UserSupervisorReason E.=. new E.^. UserSupervisorReason -- keep any existing reason
|
||||
])
|
||||
|
||||
-- like `addDefaultSupervisors`, but selects all employees of given companies from database, optionally filtered by being under supervision of a given individual
|
||||
addDefaultSupervisorsFor :: (CompanyId ~ Element mono, MonoFoldable mono) => Maybe UserId -> Bool -> mono -> DB Int64
|
||||
addDefaultSupervisorsFor mbSuperId mutualSupervision cids = do
|
||||
E.insertSelectWithConflictCount UniqueUserSupervisor
|
||||
(do
|
||||
(spr :& usr) <- E.from $ E.table @UserCompany `E.innerJoin` E.table @UserCompany `E.on` (\(spr :& usr) -> spr E.^. UserCompanyCompany E.==. usr E.^. UserCompanyCompany)
|
||||
E.where_ $ E.and $ guardMonoid (not mutualSupervision)
|
||||
[ E.not_ $ usr E.^. UserCompanySupervisor ]
|
||||
<> maybeEmpty mbSuperId (\sprId -> [E.exists $ do
|
||||
superv <- E.from $ E.table @UserSupervisor
|
||||
E.where_ $ superv E.^. UserSupervisorSupervisor E.==. E.val sprId
|
||||
E.&&. superv E.^. UserSupervisorUser E.==. usr E.^. UserCompanyUser
|
||||
])
|
||||
<> [ spr E.^. UserCompanySupervisor
|
||||
, spr E.^. UserCompanyCompany `E.in_` E.vals cids
|
||||
, usr E.^. UserCompanyCompany `E.in_` E.vals cids
|
||||
]
|
||||
E.distinct $ return $ UserSupervisor
|
||||
E.<# (spr E.^. UserCompanyUser)
|
||||
E.<&> (usr E.^. UserCompanyUser)
|
||||
E.<&> (spr E.^. UserCompanySupervisorReroute)
|
||||
E.<&> E.just (spr E.^. UserCompanyCompany)
|
||||
E.<&> E.nothing
|
||||
)
|
||||
(\_old new ->
|
||||
[ UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications
|
||||
, UserSupervisorCompany E.=. new E.^. UserSupervisorCompany
|
||||
-- , UserSupervisorReason E.=. new E.^. UserSupervisorReason -- keep any existing reaon
|
||||
] )
|
||||
|
||||
-- like `addDefaultSupervisors`, but selects all employees of given companies from database
|
||||
addDefaultSupervisorsAll :: (CompanyId ~ Element mono, MonoFoldable mono) => Bool -> mono -> DB Int64
|
||||
addDefaultSupervisorsAll mutualSupervision cids = do
|
||||
E.insertSelectWithConflictCount UniqueUserSupervisor
|
||||
(do
|
||||
(spr :& usr) <- E.from $ E.table @UserCompany `E.innerJoin` E.table @UserCompany `E.on` (\(spr :& usr) -> spr E.^. UserCompanyCompany E.==. usr E.^. UserCompanyCompany)
|
||||
E.where_ $ E.and $ guardMonoid (not mutualSupervision)
|
||||
[ E.not_ $ usr E.^. UserCompanySupervisor ]
|
||||
<> [ spr E.^. UserCompanySupervisor
|
||||
, spr E.^. UserCompanyCompany `E.in_` E.vals cids
|
||||
, usr E.^. UserCompanyCompany `E.in_` E.vals cids
|
||||
]
|
||||
E.distinct $ return $ UserSupervisor
|
||||
E.<# (spr E.^. UserCompanyUser)
|
||||
E.<&> (usr E.^. UserCompanyUser)
|
||||
E.<&> (spr E.^. UserCompanySupervisorReroute)
|
||||
E.<&> E.just (spr E.^. UserCompanyCompany)
|
||||
E.<&> E.nothing
|
||||
)
|
||||
(\_old new ->
|
||||
[ UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications
|
||||
, UserSupervisorCompany E.=. new E.^. UserSupervisorCompany
|
||||
-- , UserSupervisorReason E.=. new E.^. UserSupervisorReason -- keep any existing reaon
|
||||
] )
|
||||
|
||||
|
||||
------------------------------
|
||||
-- repeatedly useful queries
|
||||
|
||||
usrPrimaryCompanies :: E.SqlExpr (Entity Company) -> E.SqlExpr (Entity UserCompany) -> E.SqlQuery ()
|
||||
@ -735,6 +666,8 @@ mkFirmAllTable isAdmin uid = do
|
||||
E.&&. qual E.^. QualificationShorthand E.==. E.val criterion
|
||||
E.&&. validQualification now usrQual
|
||||
)
|
||||
, single ("company-address", FilterColumn $ E.mkContainsFilterWithCommaPlus id $ views (to queryAllCompany) ((E.->>. "markup-input").(E.^. CompanyPostAddress))
|
||||
)
|
||||
]
|
||||
dbtFilterUI mPrev = mconcat
|
||||
[ fltrCompanyNameUI mPrev
|
||||
@ -744,7 +677,8 @@ mkFirmAllTable isAdmin uid = do
|
||||
, prismAForm (singletonFilter "is-supervisor") mPrev $ aopt textField (fslI MsgTableSupervisor)
|
||||
, prismAForm (singletonFilter "is-default-supervisor") mPrev $ aopt textField (fslI MsgFirmSuperDefault)
|
||||
, prismAForm (singletonFilter "foreign-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterForeignSupervisor)
|
||||
, prismAForm (singletonFilter "company-postal" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterFirmExtern)
|
||||
, prismAForm (singletonFilter "company-postal" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterFirmExtern & setTooltip MsgFilterFirmExternTooltip)
|
||||
, prismAForm (singletonFilter "company-address") mPrev $ aopt textField (fslI MsgFirmAddress)
|
||||
, fltrQualificationHdrUI MsgFilterHasQualification mPrev
|
||||
]
|
||||
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
||||
@ -797,7 +731,9 @@ data FirmUserAction = FirmUserActNotify
|
||||
| FirmUserActResetSupervision
|
||||
| FirmUserActSetSupervisor
|
||||
| FirmUserActMkSuper
|
||||
| FirmUserActChangeDetails
|
||||
| FirmUserActChangeContact
|
||||
| FirmUserActRemove
|
||||
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
||||
deriving anyclass (Universe, Finite)
|
||||
|
||||
@ -806,20 +742,28 @@ embedRenderMessage ''UniWorX ''FirmUserAction id
|
||||
|
||||
data FirmUserActionData = FirmUserActNotifyData
|
||||
| FirmUserActResetSupervisionData
|
||||
{ firmUserActResetKeepOldSupers :: Maybe Bool
|
||||
-- , firmUserActResetMutualSupervision :: Maybe Bool
|
||||
{ firmUserActResetSupers :: Maybe Bool
|
||||
}
|
||||
| FirmUserActSetSupervisorData
|
||||
{ firmUserActSetSuperNames :: Maybe (Set Text)
|
||||
, firmUserActSetSuperIds :: Maybe [UserId]
|
||||
, firmUserActSetSuperReroute :: Bool
|
||||
, firmUserActSetSuperKeep :: Bool
|
||||
{ firmUserActSetSuperNames :: Maybe (Set Text)
|
||||
, firmUserActSetSuperIds :: Maybe [UserId]
|
||||
, firmUserActSetSuperReason :: Maybe Text
|
||||
, firmUserActSetSuperReroute :: Bool
|
||||
, firmUserActResetSupers :: Maybe Bool
|
||||
}
|
||||
| FirmUserActMkSuperData
|
||||
{ firmUserActMkSuperReroute :: Maybe Bool }
|
||||
{ firmUserActMkSuperReroute :: Maybe Bool }
|
||||
| FirmUserActChangeDetailsData
|
||||
{ firmUserActDetailPriority :: Maybe Int
|
||||
, firmUserActDetailReason :: Maybe Text
|
||||
}
|
||||
| FirmUserActChangeContactData
|
||||
{ firmUserActPostalAddr :: Maybe StoredMarkup
|
||||
, firmUserActPostalPref :: Maybe Bool
|
||||
{ firmUserActPostalAddr :: Maybe StoredMarkup
|
||||
, firmUserActUseCompanyPostal :: Maybe Bool
|
||||
, firmUserActPostalPref :: Maybe Bool
|
||||
}
|
||||
| FirmUserActRemoveData
|
||||
{ firmUserActRemoveSupers :: Bool
|
||||
}
|
||||
deriving (Eq, Ord, Show, Generic)
|
||||
|
||||
@ -831,7 +775,7 @@ queryUserUser = $(sqlIJproj 2 1)
|
||||
queryUserUserCompany :: UserCompanyTableExpr -> E.SqlExpr (Entity UserCompany)
|
||||
queryUserUserCompany = $(sqlIJproj 2 2)
|
||||
|
||||
type UserCompanyTableData = DBRow (Entity User, Entity UserCompany, E.Value Word64, E.Value Word64) -- , E.Value Bool)
|
||||
type UserCompanyTableData = DBRow (Entity User, Entity UserCompany, E.Value Word64, E.Value Word64, E.Value Bool)
|
||||
|
||||
resultUserUser :: Lens' UserCompanyTableData (Entity User)
|
||||
resultUserUser = _dbrOutput . _1
|
||||
@ -845,8 +789,8 @@ resultUserCompanySupervisors = _dbrOutput . _3 . _unValue
|
||||
resultUserCompanyReroutes :: Lens' UserCompanyTableData Word64
|
||||
resultUserCompanyReroutes = _dbrOutput . _4 . _unValue
|
||||
|
||||
-- resultUserCompanyPrimary :: Lens' UserCompanyTableData Bool
|
||||
-- resultUserCompanyPrimary = _dbrOutput . _5 . _unValue
|
||||
resultUserCompanyPrimary :: Lens' UserCompanyTableData Bool
|
||||
resultUserCompanyPrimary = _dbrOutput . _5 . _unValue
|
||||
|
||||
instance HasEntity UserCompanyTableData User where
|
||||
hasEntity = resultUserUser
|
||||
@ -859,24 +803,27 @@ mkFirmUserTable :: Bool -> CompanyId -> DB (FormResult (FirmUserActionData, Set
|
||||
mkFirmUserTable isAdmin cid = do
|
||||
mr <- getMessageRender
|
||||
let
|
||||
mkSprOption (E.Value uid, E.Value udn, E.Value mbSpr) = do
|
||||
reasonSuperior = Just $ tshow SupervisorReasonAvsSuperior
|
||||
mkSprOption (E.Value uid, E.Value udn, E.Value mbSpr, E.Value mbmbReason) = do
|
||||
uuid <- toPathPiece <$> encryptUser uid
|
||||
return (Option{ optionDisplay = udn, optionInternalValue = uid, optionExternalValue = uuid }, mbSpr)
|
||||
return (Option{ optionDisplay = udn, optionInternalValue = uid, optionExternalValue = uuid }, mbSpr, mbmbReason == Just reasonSuperior)
|
||||
|
||||
procOptions rawSupers = do
|
||||
procSupers <- traverse mkSprOption rawSupers
|
||||
return $ mkOptionListGrouped $ filter (notNull . snd)
|
||||
[ (mr MsgFirmSuperDefault , [opt | (opt, Just True ) <- procSupers])
|
||||
, (mr MsgFirmSuperIrregular, [opt | (opt, Just False) <- procSupers])
|
||||
, (mr MsgFirmSuperForeign , [opt | (opt, Nothing ) <- procSupers])
|
||||
[ (mr MsgTableSuperior , [opt | (opt, _ , True ) <- procSupers])
|
||||
, (mr MsgFirmSuperDefault , [opt | (opt, Just True , False) <- procSupers])
|
||||
, (mr MsgFirmSuperIrregular, [opt | (opt, Just False, False) <- procSupers])
|
||||
, (mr MsgFirmSuperForeign , [opt | (opt, Nothing , False) <- procSupers])
|
||||
]
|
||||
|
||||
rawSupers <- E.select $ do
|
||||
(usr :& usrCmp) <- E.from $ E.table @User `E.leftJoin` E.table @UserCompany
|
||||
`E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.=?. usrCmp E.?. UserCompanyUser E.&&. usrCmp E.?. UserCompanyCompany E.==. E.justVal cid)
|
||||
E.where_ $ E.isTrue (usrCmp E.?. UserCompanySupervisor)
|
||||
E.||. (usrCmp E.?. UserCompanyReason E.?=. E.val reasonSuperior)
|
||||
E.||. E.exists (firmQuerySupervisedBy cid Nothing usr)
|
||||
return (usr E.^. UserId, usr E.^. UserDisplayName, usrCmp E.?. UserCompanySupervisor)
|
||||
return (usr E.^. UserId, usr E.^. UserDisplayName, usrCmp E.?. UserCompanySupervisor, usrCmp E.?. UserCompanyReason)
|
||||
let
|
||||
-- supervisorField :: Field Handler UserId
|
||||
-- supervisorField = selectField' (Just $ SomeMessage MsgMultiNoSelection) $ procOptions rawSupers
|
||||
@ -888,12 +835,12 @@ mkFirmUserTable isAdmin cid = do
|
||||
dbtSQLQuery = \(usr `E.InnerJoin` usrCmp) -> do
|
||||
EL.on $ usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser
|
||||
E.where_ $ usrCmp E.^. UserCompanyCompany E.==. E.val cid
|
||||
-- let isPrimary = E.notExists (do
|
||||
-- other <- E.from $ E.table @UserCompany
|
||||
-- E.where_ $ other E.^. UserCompanyUser E.==. usrCmp E.^. UserCompanyUser
|
||||
-- E.&&. other E.^. UserCompanyPriority E.>. usrCmp E.^. UserCompanyPriority
|
||||
-- )
|
||||
return (usr, usrCmp, firmCountUserSupervisors usrCmp, firmCountUserSupervisorsReroute usrCmp)
|
||||
let isPrimary = E.notExists (do
|
||||
other <- E.from $ E.table @UserCompany
|
||||
E.where_ $ other E.^. UserCompanyUser E.==. usrCmp E.^. UserCompanyUser
|
||||
E.&&. other E.^. UserCompanyPriority E.>. usrCmp E.^. UserCompanyPriority
|
||||
)
|
||||
return (usr, usrCmp, firmCountUserSupervisors usrCmp, firmCountUserSupervisorsReroute usrCmp, isPrimary)
|
||||
dbtRowKey = queryUserUser >>> (E.^. UserId)
|
||||
dbtProj = dbtProjId
|
||||
dbtColonnade = formColonnade $ mconcat
|
||||
@ -904,7 +851,16 @@ mkFirmUserTable isAdmin cid = do
|
||||
, sortable (Just "supervisors") (i18nCell MsgTableCompanyNrSupers ) $ \(view resultUserCompanySupervisors -> nr) -> wgtCell $ word2widget nr
|
||||
, sortable (Just "reroutes") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultUserCompanyReroutes -> nr) -> wgtCell $ word2widget nr
|
||||
, sortable (Just "postal-pref") (i18nCell MsgPrefersPostal) $ \(view $ resultUserUser . _userPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b
|
||||
, sortable Nothing (i18nCell MsgCompanyUserUseCompanyAddress) $ \row ->
|
||||
let noUsrAddr = isNothing $ row ^. resultUserUser . _userPostAddress
|
||||
useCompA = row ^. resultUserUserCompany . _entityVal . _userCompanyUseCompanyAddress
|
||||
in tickmarkCell $ noUsrAddr && useCompA
|
||||
, colUserEmail
|
||||
, sortable (Just "usr-reason") (i18nCell MsgTableCompanyReason) $ \(view $ resultUserUserCompany . _entityVal . _userCompanyReason -> r) -> cellMaybe textCell r
|
||||
, sortable (Just "priority") (i18nCell MsgCompanyUserPriority) $ \row ->
|
||||
let prio :: Int = row ^. resultUserUserCompany . _entityVal . _userCompanyPriority
|
||||
isPrime = row ^. resultUserCompanyPrimary
|
||||
in numCell prio <> spacerCell <> ifIconCell isPrime IconTop
|
||||
, sortable Nothing (i18nCell MsgTableUserEdit) $ \(view resultUserUser -> entUsr) -> cellEditUserModal entUsr
|
||||
]
|
||||
dbtSorting = mconcat
|
||||
@ -915,6 +871,8 @@ mkFirmUserTable isAdmin cid = do
|
||||
, singletonMap "personal-number" $ SortColumn $ queryUserUser >>> (E.^. UserCompanyPersonalNumber)
|
||||
, singletonMap "supervisors" $ SortColumn $ queryUserUserCompany >>> firmCountUserSupervisors
|
||||
, singletonMap "reroutes" $ SortColumn $ queryUserUserCompany >>> firmCountUserSupervisorsReroute
|
||||
, singletonMap "usr-reason" $ SortColumn $ queryUserUserCompany >>> (E.^. UserCompanyReason)
|
||||
, singletonMap "priority" $ SortColumn $ queryUserUserCompany >>> (E.^. UserCompanyPriority)
|
||||
]
|
||||
dbtFilter = mconcat
|
||||
[ single $ fltrUserNameEmail queryUserUser
|
||||
@ -991,22 +949,42 @@ mkFirmUserTable isAdmin cid = do
|
||||
, prismAForm (singletonFilter "is-primary-company" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterFirmPrimary)
|
||||
]
|
||||
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
||||
userReasons :: HandlerFor UniWorX (OptionList Text)
|
||||
userReasons = fmap (mkOptionList . map (\t -> Option t t t) . Set.toAscList) . runDB $
|
||||
fmap (setOf $ folded . _Value . _Just) . E.select . E.distinct $ do
|
||||
usrc <- E.from $ E.table @UserCompany
|
||||
E.where_ $ E.isJust (usrc E.^. UserCompanyReason)
|
||||
E.&&. usrc E.^. UserCompanyCompany E.==. E.val cid
|
||||
return $ usrc E.^. UserCompanyReason
|
||||
superReasons :: HandlerFor UniWorX (OptionList Text)
|
||||
superReasons = fmap (mkOptionList . map (\t -> Option t t t) . Set.toAscList) . runDB $
|
||||
fmap (setOf $ folded . _Value . _Just) . E.select . E.distinct $ do
|
||||
usrc <- E.from $ E.table @UserSupervisor
|
||||
E.where_ $ E.isJust (usrc E.^. UserSupervisorReason)
|
||||
E.&&. usrc E.^. UserSupervisorCompany E.~=. E.val cid
|
||||
return $ usrc E.^. UserSupervisorReason
|
||||
acts :: Map FirmUserAction (AForm Handler FirmUserActionData)
|
||||
acts = mconcat
|
||||
[ guardMonoid isAdmin $ singletonMap FirmUserActNotify $ pure FirmUserActNotifyData
|
||||
, singletonMap FirmUserActResetSupervision $ FirmUserActResetSupervisionData
|
||||
<$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just $ Just False)
|
||||
-- <*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True )
|
||||
<$> aopt (boolFieldCustom (SomeMessage MsgFirmActResetSupersRemoveAll) (SomeMessage MsgFirmActResetSupersRemoveAps) $ Just $ SomeMessage MsgFirmActResetSupersKeepAll) (fslI MsgFirmActResetSuperKeep) (Just $ Just False)
|
||||
, singletonMap FirmUserActSetSupervisor $ FirmUserActSetSupervisorData
|
||||
<$> aopt (textField & cfAnySeparatedSet) (fslI MsgFirmNewSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing
|
||||
<*> aopt supervisorsField (fslI MsgFirmSetSupervisor & setTooltip MsgMultiSelectTip) Nothing
|
||||
<*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just False)
|
||||
<*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just False)
|
||||
<*> aopt (textField & cfStrip & addDatalist superReasons) (fslI MsgUserSupervisorReason & setTooltip MsgUserSupervisorReasonTooltip) Nothing
|
||||
<*> areq boolField' (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just False)
|
||||
<*> aopt (boolFieldCustom (SomeMessage MsgFirmActResetSupersRemoveAll) (SomeMessage MsgFirmActResetSupersRemoveAps) $ Just $ SomeMessage MsgFirmActResetSupersKeepAll) (fslI MsgFirmActResetSuperKeep) (Just $ Just False)
|
||||
, singletonMap FirmUserActMkSuper $ FirmUserActMkSuperData
|
||||
<$> aopt checkBoxField (fslI MsgTableIsDefaultReroute) (Just $ Just True)
|
||||
, singletonMap FirmUserActChangeContact $ FirmUserActChangeContactData
|
||||
<$> aopt htmlField (fslI MsgPostAddress & setTooltip (SomeMessages [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing
|
||||
<*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing
|
||||
<$> aopt htmlField (fslI MsgPostAddress & setTooltip (SomeMessages [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing
|
||||
<*> aopt boolField' (fslI MsgCompanyUserUseCompanyAddress & setTooltip MsgCompanyUserUseCompanyAddressTip) Nothing
|
||||
<*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing
|
||||
, singletonMap FirmUserActChangeDetails $ FirmUserActChangeDetailsData
|
||||
<$> aopt intField (fslI MsgCompanyUserPriority & setTooltip MsgCompanyUserPriorityTip) Nothing
|
||||
<*> aopt (textField & cfStrip & addDatalist userReasons) (fslI MsgUserCompanyReason & setTooltip (SomeMessages [SomeMessage MsgUserCompanyReasonTooltip, SomeMessage MsgNullDeletes])) Nothing
|
||||
, singletonMap FirmUserActRemove $ FirmUserActRemoveData
|
||||
<$> areq boolField' (fslI MsgFirmActRemoveSupers) (Just True)
|
||||
]
|
||||
dbtParams = DBParamsForm
|
||||
{ dbParamsFormMethod = POST
|
||||
@ -1073,6 +1051,10 @@ postFirmUsersR fsh = do
|
||||
-- return usr
|
||||
<*> mkFirmUserTable isAdmin cid
|
||||
|
||||
let resetSupers :: Maybe Bool -> NonEmpty UserId -> DB Int64
|
||||
resetSupers Nothing _ = return 0
|
||||
resetSupers (Just False) uids = deleteDefaultSupervisorsForUsers [] [] uids
|
||||
resetSupers (Just True ) uids = deleteWhereCount [UserSupervisorUser <-. toList uids]
|
||||
formResult fusrRes $ \case
|
||||
(_, uids) | null uids -> addMessageI Error MsgUtilEmptyChoice
|
||||
(FirmUserActNotifyData , uids) -> do
|
||||
@ -1080,10 +1062,8 @@ postFirmUsersR fsh = do
|
||||
redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids])
|
||||
(FirmUserActResetSupervisionData{..}, set2NonEmpty (error "Unexpected empty user list in getFirmUserR action handler.") -> uids) -> do -- set guaranteed to be non-empty due to first case clause
|
||||
runDB $ do
|
||||
delSupers <- if firmUserActResetKeepOldSupers == Just False
|
||||
then deleteSupervisors uids []
|
||||
else return 0
|
||||
newSupers <- addDefaultSupervisors cid uids
|
||||
delSupers <- resetSupers firmUserActResetSupers uids
|
||||
newSupers <- addDefaultSupervisors Nothing cid uids
|
||||
addMessageI Info $ MsgFirmResetSupervision delSupers newSupers
|
||||
reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
|
||||
(FirmUserActSetSupervisorData{..}, set2NonEmpty (error "Unexpected empty user list in getFirmUserR action handler.") -> uids) -> do
|
||||
@ -1101,27 +1081,55 @@ postFirmUsersR fsh = do
|
||||
<li>#{usr}
|
||||
|]
|
||||
in addMessageModal Error (i18n . MsgCourseParticipantsRegisterNotFoundInAvs $ length usersNotFound) (Right msgContent)
|
||||
delSupers <- runDB
|
||||
$ bool (deleteSupervisors uids [cid]) (return 0) firmUserActSetSuperKeep
|
||||
<* putMany [UserSupervisor s u firmUserActSetSuperReroute (Just cid) Nothing | u <- toList uids, s <- newSupers]
|
||||
delSupers <- runDB $ resetSupers firmUserActResetSupers uids
|
||||
<* putMany [UserSupervisor s u firmUserActSetSuperReroute (Just cid) firmUserActSetSuperReason | u <- toList uids, s <- newSupers]
|
||||
addMessageI Success $ MsgFirmSetSupersReport nrUsers nrSupers delSupers
|
||||
reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
|
||||
|
||||
(FirmUserActMkSuperData{..}, Set.toList -> uids) -> do
|
||||
nrMkSuper <- runDB $ updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. True, UserCompanySupervisorReroute =. (firmUserActMkSuperReroute == Just True)]
|
||||
addMessageI Info $ MsgFirmActAddSupersSet nrMkSuper Nothing
|
||||
nrUpd <- runDB $ updateWhereCount [UserCompanyCompany ==. cid, UserCompanyUser <-. uids] [UserCompanySupervisor =. True, UserCompanySupervisorReroute =. (firmUserActMkSuperReroute == Just True)]
|
||||
addMessageI Success $ MsgFirmActAddSupersSet nrUpd Nothing
|
||||
reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
|
||||
(FirmUserActChangeContactData{..}, Set.toList -> uids) ->
|
||||
let changes = catMaybes
|
||||
[ (UserPostAddress =.) . Just <$> canonical firmUserActPostalAddr -- note that Nothing means no change and not delete address!
|
||||
, (UserPrefersPostal =.) <$> firmUserActPostalPref
|
||||
]
|
||||
in unless (null changes) $ do
|
||||
nrChanged <- runDB $ updateWhereCount [UserId <-. uids] changes
|
||||
addMessageI Success $ MsgFirmUserChanges nrChanged
|
||||
(FirmUserActChangeDetailsData{..}, Set.toList -> uids) -> do
|
||||
let upReason = case canonical firmUserActDetailReason of
|
||||
Nothing -> Nothing
|
||||
Just "NULL" -> Just $ UserCompanyReason =. Nothing
|
||||
other -> Just $ UserCompanyReason =. other
|
||||
nrUpd <- runDB $ updateWhereCount [UserCompanyCompany ==. cid, UserCompanyUser <-. uids] $ catMaybes [upReason, (UserCompanyPriority =.) <$> firmUserActDetailPriority]
|
||||
let total = fromIntegral $ length uids
|
||||
allok = bool Warning Success $ nrUpd == total
|
||||
addMessageI allok $ MsgFirmUserActChangeDetailsResult nrUpd total
|
||||
reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
|
||||
(FirmUserActChangeContactData{..}, Set.toList -> uids)
|
||||
| firmUserActUseCompanyPostal == Just True, isJust firmUserActPostalAddr ->
|
||||
addMessageI Error MsgCompanyUserUseCompanyPostalError
|
||||
| otherwise -> do
|
||||
let changes = catMaybes
|
||||
[ toMaybe (firmUserActUseCompanyPostal == Just True) (UserPostAddress =. Nothing) -- precondition ensures that only one update applies for UserPostAddress
|
||||
, (UserPostAddress =.) . Just <$> canonical firmUserActPostalAddr -- note that Nothing means no change and not delete address!
|
||||
, (UserPrefersPostal =.) <$> firmUserActPostalPref
|
||||
]
|
||||
nrChanged <- runDB $ do
|
||||
nrUsrChange <- updateWhereCount [UserId <-. uids] changes
|
||||
nrUseComp <- case firmUserActUseCompanyPostal of
|
||||
Just x -> updateWhereCount [UserCompanyCompany ==. cid, UserCompanyUser <-. uids] [UserCompanyUseCompanyAddress =. x]
|
||||
Nothing -> return 0
|
||||
return $ max nrUsrChange nrUseComp
|
||||
let total = fromIntegral $ length uids
|
||||
allok = bool Warning Success $ nrChanged == total
|
||||
addMessageI allok $ MsgFirmUserActChangeResult nrChanged total
|
||||
reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
|
||||
(FirmUserActRemoveData{..}, Set.toList -> uids) -> do
|
||||
let optRemove = if firmUserActRemoveSupers then id else const $ return 0
|
||||
(nrUc, nrSuper, nrSubs) <- runDB $ (,,)
|
||||
<$> deleteWhereCount [UserCompanyCompany ==. cid, UserCompanyUser <-. uids]
|
||||
<*> optRemove (deleteWhereCount [UserSupervisorCompany ==. Just cid, UserSupervisorSupervisor <-. uids])
|
||||
<*> optRemove (deleteWhereCount [UserSupervisorCompany ==. Just cid, UserSupervisorUser <-. uids])
|
||||
let total = fromIntegral $ length uids
|
||||
allok = bool Warning Success $ total == nrUc
|
||||
addMessageI allok $ someMessages [MsgFirmUserActRemoveResult nrUc, MsgFirmRemoveSupervision nrSuper nrSubs]
|
||||
reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
|
||||
|
||||
formFirmAction <- runFirmActionFormPost cid (FirmUsersR fsh) isAdmin [FirmActNotify, FirmActResetSupervision, FirmActAddSupersvisors, FirmActChangeContactFirm, FirmActChangeContactUser]
|
||||
formFirmAction <- runFirmActionFormPost cid (FirmUsersR fsh) isAdmin [FirmActNotify, FirmActResetSupervision, FirmActAddSupervisors, FirmActChangeContactFirm, FirmActChangeContactUser]
|
||||
|
||||
siteLayout (citext2widget companyName) $ do
|
||||
setTitle $ toHtml $ CI.original companyShorthand <> "-" <> tshow companyAvsId
|
||||
@ -1148,7 +1156,7 @@ data FirmSuperActionData = FirmSuperActNotifyData
|
||||
, firmSuperActSwitchReroute :: Maybe Bool
|
||||
}
|
||||
| FirmSuperActRMSuperDefData
|
||||
{ firmSuperActRMSuperActive :: Maybe Bool }
|
||||
{ firmSuperActRMSuperActive :: Bool }
|
||||
|
||||
deriving (Eq, Ord, Show, Generic)
|
||||
|
||||
@ -1199,20 +1207,22 @@ mkFirmSuperTable :: Bool -> CompanyId -> DB (FormResult (FirmSuperActionData, Se
|
||||
mkFirmSuperTable isAdmin cid = do
|
||||
msgSupervisorUnchanged <- messageI Info MsgFirmSuperActSwitchSuperInfo
|
||||
let
|
||||
reasonSuperior = Just $ tshow SupervisorReasonAvsSuperior
|
||||
reasonSuperior = tshow SupervisorReasonAvsSuperior
|
||||
-- fsh = unCompanyKey cid
|
||||
resultDBTable = DBTable{..}
|
||||
where
|
||||
dbtSQLQuery = \(usr `E.LeftOuterJoin` usrCmp) -> do
|
||||
EL.on $ usr E.^. UserId E.=?. usrCmp E.?. UserCompanyUser E.&&. usrCmp E.?. UserCompanyCompany E.?=. E.val cid
|
||||
E.where_ $ E.isTrue (usrCmp E.?. UserCompanySupervisor)
|
||||
E.||. E.exists (firmQuerySupervisedBy cid Nothing usr)
|
||||
E.where_ $ E.isTrue (usrCmp E.?. UserCompanySupervisor) E.||. E.exists (firmQuerySupervisedBy cid Nothing usr)
|
||||
-- let uc_reason = E.joinV (usrCmp E.?. UserCompanyReason)
|
||||
return ( usr
|
||||
, usr & firmCountForSupervisor cid Nothing
|
||||
, usr & firmCountForSupervisor cid (Just (E.^. UserSupervisorRerouteNotifications))
|
||||
, usrCmp E.?. UserCompanySupervisor
|
||||
, usrCmp E.?. UserCompanySupervisorReroute
|
||||
, E.exists (firmQuerySupervisedBy cid (Just (\usrSpr -> usrSpr E.^. UserSupervisorReason E.==. E.val reasonSuperior)) usr)
|
||||
-- , (E.isJust uc_reason E.&&. uc_reason E.==. E.justVal reasonSuperior) -- NOTE: this is problematic, as obvious approaches caused errors such as: Failed to parse Haskell type bool, received PersistNull, since the SQL comparison with NULL returns NULL
|
||||
, (E.coalesceDefault [E.joinV (usrCmp E.?. UserCompanyReason)] (E.val mempty) E.==. E.val reasonSuperior) -- works as well
|
||||
E.||. E.exists (firmQuerySupervisedBy cid (Just (\usrSpr -> usrSpr E.^. UserSupervisorReason E.==. E.justVal reasonSuperior)) usr)
|
||||
)
|
||||
dbtRowKey = querySuperUser >>> (E.^. UserId)
|
||||
dbtProj = dbtProjSimple $ \(usr, supervised, rerouted, supervisor, reroute, isSuperior) -> do
|
||||
@ -1233,15 +1243,11 @@ mkFirmSuperTable isAdmin cid = do
|
||||
, colUserEmail
|
||||
, sortable (Just "supervised") (i18nCell MsgTableCompanyNrEmpSupervised) $ \(view resultSuperCompanySupervised -> nr) -> wgtCell $ word2widget nr
|
||||
, sortable (Just "rerouted") (i18nCell MsgTableCompanyNrEmpRerouted ) $ \(view resultSuperCompanyReroutes -> nr) -> wgtCell $ word2widget nr
|
||||
-- , sortable (Just "def-super") (i18nCell MsgTableIsDefaultSupervisor) $ \(view resultSuperCompanyDefaultSuper -> mb) -> case mb of { Nothing -> iconCell IconSupervisorForeign; Just True -> iconCell IconSupervisor; Just False -> iconSpacerCell }
|
||||
, sortable (Just "def-super") (i18nCell MsgTableIsDefaultSupervisor) $ \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-super") (i18nCell MsgTableIsDefaultSupervisor) $ view resultSuperCompanyDefaultSuper >>> \case
|
||||
Nothing -> iconCell IconSupervisorForeign
|
||||
(Just True ) -> iconCell IconSupervisor
|
||||
(Just False) -> iconSpacerCell
|
||||
, sortable Nothing (i18nCell MsgTableSuperior) $ view resultSuperCompanySuperior >>> flip ifIconCell IconSuperior
|
||||
, sortable (Just "def-reroute") (i18nCell MsgTableIsDefaultReroute) $ \(view resultSuperCompanyDefaultReroute -> mb) -> tickmarkCell (mb == Just True)
|
||||
, sortable Nothing (i18nCell MsgTableUserEdit) $ \(view resultSuperUser -> entUsr) -> cellEditUserModal entUsr
|
||||
]
|
||||
@ -1264,20 +1270,40 @@ mkFirmSuperTable isAdmin cid = do
|
||||
]
|
||||
dbtFilter = mconcat
|
||||
[ single $ fltrUserNameEmail querySuperUser
|
||||
, singletonMap "is-foreign-supervisor" $ FilterColumn $ \(querySuperUserCompany -> suc) (getLast -> criterion) ->
|
||||
case criterion of
|
||||
Nothing -> E.true
|
||||
Just True -> E.isNothing $ suc E.?. UserCompanyUser
|
||||
Just False -> E.isJust $ suc E.?. UserCompanyUser
|
||||
, singletonMap "super-relation-foreign" $ FilterColumn $ \row (getLast -> criterion) ->
|
||||
let checkSuper = do
|
||||
usrSpr <- E.from $ E.table @UserSupervisor
|
||||
E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. querySuperUser row E.^. UserId
|
||||
E.&&. E.exists (do
|
||||
usr <- E.from $ E.table @UserCompany
|
||||
E.where_ $ usr E.^. UserCompanyCompany E.!=. E.val cid
|
||||
E.&&. usr E.^. UserCompanyUser E.==. usrSpr E.^. UserSupervisorUser
|
||||
)
|
||||
in case criterion of
|
||||
Nothing -> E.true
|
||||
Just True -> E.exists checkSuper
|
||||
Just False -> E.notExists checkSuper
|
||||
]
|
||||
dbtFilterUI mPrev = mconcat
|
||||
[ fltrUserNameEmailHdrUI MsgTableSupervisor mPrev
|
||||
, prismAForm (singletonFilter "is-foreign-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmSuperForeign)
|
||||
, prismAForm (singletonFilter "super-relation-foreign" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterIsForeignSupervisee)
|
||||
]
|
||||
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
||||
acts :: Map FirmSuperAction (AForm Handler FirmSuperActionData)
|
||||
acts = mconcat
|
||||
[ guardMonoid isAdmin $ singletonMap FirmSuperActNotify $ pure FirmSuperActNotifyData
|
||||
, singletonMap FirmSuperActSwitchSuper $ FirmSuperActSwitchSuperData
|
||||
<$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableIsDefaultSupervisor) (Just $ Just True)
|
||||
<*> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableIsDefaultReroute) Nothing
|
||||
<$> aopt boolField' (fslI MsgFirmSuperDefault) (Just $ Just True)
|
||||
<*> aopt boolField' (fslI MsgTableIsDefaultReroute) Nothing
|
||||
<* aformMessage msgSupervisorUnchanged
|
||||
, singletonMap FirmSuperActRMSuperDef $ FirmSuperActRMSuperDefData
|
||||
<$> aopt checkBoxField (fslI MsgFirmSuperActRMSuperActive) (Just $ Just True)
|
||||
<$> areq boolField' (fslI MsgFirmSuperActRMSuperActive) (Just True)
|
||||
]
|
||||
dbtParams = DBParamsForm
|
||||
{ dbParamsFormMethod = POST
|
||||
@ -1321,19 +1347,14 @@ postFirmSupersR fsh = do
|
||||
formResult fsprRes $ \case
|
||||
(_, uids) | null uids -> addMessageI Error MsgUtilEmptyChoice
|
||||
(FirmSuperActRMSuperDefData{..}, Set.toList -> uids) -> do
|
||||
(nrRmSuper,nrRmActual) <- runDB $ (,)
|
||||
let optRemove = if firmSuperActRMSuperActive then id else const $ return 0
|
||||
(nrRmSuper,nrRmSupers,nrRmSubs) <- runDB $ (,,)
|
||||
<$> updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False]
|
||||
<*> if firmSuperActRMSuperActive /= Just True
|
||||
then return 0
|
||||
else E.deleteCount $ do
|
||||
spr <- E.from $ E.table @UserSupervisor
|
||||
E.where_ $ spr E.^. UserSupervisorSupervisor `E.in_` E.vals uids
|
||||
E.&&. E.exists (do
|
||||
usr <- E.from $ E.table @UserCompany
|
||||
E.where_ $ usr E.^. UserCompanyCompany E.==. E.val cid
|
||||
E.&&. usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser
|
||||
)
|
||||
addMessageI Info $ MsgRemoveSupervisors nrRmSuper nrRmActual
|
||||
<*> optRemove (deleteWhereCount [UserSupervisorCompany ==. Just cid, UserSupervisorSupervisor <-. uids])
|
||||
<*> optRemove (deleteWhereCount [UserSupervisorCompany ==. Just cid, UserSupervisorUser <-. uids])
|
||||
let total = fromIntegral $ length uids
|
||||
allok = bool Warning Success $ total == nrRmSuper
|
||||
addMessageI allok $ someMessages [MsgRemoveSupervisors nrRmSuper, MsgFirmRemoveSupervision nrRmSupers nrRmSubs]
|
||||
reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
|
||||
(FirmSuperActSwitchSuperData{..}, Set.toList -> uids) -> do
|
||||
let (fltrSpr, changes) = case (firmSuperActSwitchSuper, firmSuperActSwitchReroute) of
|
||||
@ -1351,9 +1372,9 @@ postFirmSupersR fsh = do
|
||||
cuids <- traverse encrypt $ Set.toList uids :: Handler [CryptoUUIDUser]
|
||||
redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids])
|
||||
|
||||
formFirmAction <- runFirmActionFormPost cid (FirmSupersR fsh) isAdmin [FirmActAddSupersvisors, FirmActResetSupervision, FirmActChangeContactFirm]
|
||||
formFirmAction <- runFirmActionFormPost cid (FirmSupersR fsh) isAdmin [FirmActAddSupervisors, FirmActResetSupervision, FirmActChangeContactFirm]
|
||||
|
||||
siteLayout (citext2widget fsh) $ do
|
||||
siteLayout (citext2widget companyName) $ do
|
||||
setTitle $ citext2Html $ fsh <> " Supers"
|
||||
let firmContactInfo = $(widgetFile "firm-contact-info")
|
||||
$(i18nWidgetFile "firm-supervisors")
|
||||
|
||||
@ -6,6 +6,7 @@ module Handler.Health where
|
||||
|
||||
import Import
|
||||
|
||||
import Data.Time.Format.ISO8601 (iso8601Show)
|
||||
import Handler.Utils.DateTime (formatTimeW)
|
||||
|
||||
import qualified Data.Aeson.Encode.Pretty as Aeson
|
||||
@ -19,6 +20,9 @@ import Control.Concurrent.STM.Delay
|
||||
|
||||
import System.Environment (lookupEnv) -- while git version number is not working
|
||||
|
||||
import qualified Database.Esqueleto.Experimental as E
|
||||
import qualified Database.Esqueleto.PostgreSQL as E (now_)
|
||||
|
||||
-- import Data.FileEmbed (embedStringFile)
|
||||
|
||||
getHealthR :: Handler TypedContent
|
||||
@ -77,12 +81,12 @@ getHealthR = do
|
||||
#{boolSymbol (healthOk hcstatus)} #
|
||||
$case report
|
||||
$of HealthLDAPAdmins (Just found)
|
||||
#{textPercent found 1}
|
||||
#{textPercent found 1}
|
||||
$of HealthActiveJobExecutors (Just active)
|
||||
#{textPercent active 1}
|
||||
$of _
|
||||
<div>
|
||||
^{formatTimeW SelFormatDateTime lUp}
|
||||
^{formatTimeW SelFormatDateTime lUp}
|
||||
|]
|
||||
provideJson healthReports
|
||||
provideRep . return . Builder.toLazyText $ Aeson.encodePrettyToTextBuilder healthReports
|
||||
@ -113,34 +117,44 @@ getInstanceR = do
|
||||
getStatusR :: Handler Html
|
||||
getStatusR = do
|
||||
starttime <- getsYesod appStartTime
|
||||
(currtime, env_version) <- liftIO $ (,) <$> getCurrentTime <*> lookupEnv "VERSION_NR"
|
||||
dbTime <- runDBRead $ E.selectOne $ return E.now_
|
||||
(currtime,env_version) <- liftIO $ (,) <$> getCurrentTime <*> lookupEnv "VERSION_NR"
|
||||
-- ft <- formatTime' "%Y-%m-%d %H:%M:%S" currtime
|
||||
withUrlRenderer
|
||||
let diffTime :: UTCTime -> Text
|
||||
diffTime t =
|
||||
let tdiff = diffUTCTime currtime t
|
||||
in if 64 > abs tdiff
|
||||
then tshow tdiff
|
||||
else pack . iso8601Show . calendarTimeTime . fromIntegral $ truncate tdiff
|
||||
|
||||
withUrlRenderer
|
||||
[hamlet|
|
||||
$doctype 5
|
||||
<html lang=en>
|
||||
<head>
|
||||
<head>
|
||||
<title>Status
|
||||
<body>
|
||||
$maybe env_ver <- env_version
|
||||
<p>
|
||||
Environment version #{env_ver}
|
||||
<p>
|
||||
Current Time <br>
|
||||
#{show currtime} <br>
|
||||
<p>
|
||||
Instance Start <br>
|
||||
Current Application Time <br>
|
||||
#{show currtime} <br>
|
||||
$maybe dbtval <- dbTime
|
||||
$with dbt <- E.unValue dbtval
|
||||
Current Database Time <br>
|
||||
#{show dbt} #
|
||||
Difference: #{diffTime dbt} <br>
|
||||
<p>
|
||||
Instance Start <br>
|
||||
#{show starttime} #
|
||||
Uptime: #{show $ ddays starttime currtime} days.
|
||||
Uptime: #{diffTime starttime}
|
||||
<p>
|
||||
Compile Time <br>
|
||||
#{show cTime} #
|
||||
Build age: #{show $ ddays cTime currtime} days.
|
||||
Build age: #{diffTime cTime}
|
||||
|]
|
||||
where
|
||||
-- vnr_full :: Text = $(embedStringFile "nix/docker/version.json") -- nix/ files not accessible during container construction
|
||||
where
|
||||
-- vnr_full :: Text = $(embedStringFile "nix/docker/version.json") -- nix/ files not accessible during container construction
|
||||
cTime :: UTCTime
|
||||
cTime = $compileTime
|
||||
|
||||
ddays :: UTCTime -> UTCTime -> Double
|
||||
ddays tstart tstop = (/100) $ fromIntegral $ round $ diffUTCTime tstop tstart / (36 * 24)
|
||||
cTime = $compileTime
|
||||
@ -8,12 +8,14 @@ module Handler.Health.Interface
|
||||
getHealthInterfaceR
|
||||
, mkInterfaceLogTable
|
||||
, runInterfaceChecks
|
||||
, getConfigInterfacesR, postConfigInterfacesR
|
||||
)
|
||||
where
|
||||
|
||||
import Import
|
||||
|
||||
-- import qualified Data.Set as Set
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Text as Text
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Concurrent
|
||||
@ -24,6 +26,8 @@ import qualified Database.Esqueleto.Utils as E
|
||||
import qualified Database.Esqueleto.Legacy as EL (on)
|
||||
import qualified Database.Persist.Sql as E (deleteWhereCount)
|
||||
|
||||
defaultInterfaceWarnHours :: Int
|
||||
defaultInterfaceWarnHours = 3 * 24 -- if no warn time can be found, use 3 days instead
|
||||
|
||||
-- | identify a wildcard argument
|
||||
wc2null :: Text -> Maybe Text
|
||||
@ -33,6 +37,12 @@ wc2null "_" = Nothing
|
||||
wc2null "*" = Nothing
|
||||
wc2null o = Just o
|
||||
|
||||
warnIntervalCell :: (IsDBTable m b, Integral a) => a -> DBCell m b
|
||||
warnIntervalCell x
|
||||
| x >= 0 = textCell $ formatDiffHours x
|
||||
| x <= (-100) = i18nCell MsgInterfaceWarningDisabledEntirely
|
||||
| otherwise = i18nCell MsgInterfaceWarningDisabledInterval
|
||||
|
||||
-- | sloppily parse a boolean, also see Model.Types.Avs.SloppyBool
|
||||
pbool :: Text -> Maybe Bool
|
||||
pbool (Text.toLower . Text.strip -> w)
|
||||
@ -88,12 +98,7 @@ getHealthInterfaceR (dropWhile (=="force") -> ris) = do -- for bac
|
||||
|
||||
runInterfaceLogTable :: ReqBanInterfaceHealth -> Handler (Bool, Bool, [(Text,Bool)], Widget)
|
||||
runInterfaceLogTable interfs@(reqIfs,_) = do
|
||||
-- we abuse messageTooltip for colored icons here
|
||||
msgSuccessTooltip <- messageI Success MsgMessageSuccess
|
||||
-- msgWarningTooltip <- messageI Warning MsgMessageWarning
|
||||
msgErrorTooltip <- messageI Error MsgMessageError
|
||||
let flagError = messageTooltip . bool msgErrorTooltip msgSuccessTooltip
|
||||
(res, twgt) <- runDB $ mkInterfaceLogTable flagError interfs
|
||||
(res, twgt) <- runDB $ mkInterfaceLogTable interfs
|
||||
let missing = notNull [ifce | (UniqueInterfaceHealth ifce _subt _writ) <- reqIfs, ifce `notElem` (fst <$> res) ]
|
||||
allok = all snd res
|
||||
return (missing, allok, res, twgt)
|
||||
@ -101,12 +106,14 @@ runInterfaceLogTable interfs@(reqIfs,_) = do
|
||||
-- ihDebugShow :: Unique InterfaceHealth -> Text
|
||||
-- ihDebugShow (UniqueInterfaceHealth i s w) = "(" <> tshow i <> "," <> tshow s <> "," <> tshow w <> ")"
|
||||
|
||||
mkInterfaceLogTable :: (Bool -> Widget) -> ReqBanInterfaceHealth -> DB ([(Text,Bool)], Widget)
|
||||
mkInterfaceLogTable flagError interfs@(reqIfs, banIfs) = do
|
||||
mkInterfaceLogTable :: ReqBanInterfaceHealth -> DB ([(Text,Bool)], Widget)
|
||||
mkInterfaceLogTable interfs@(reqIfs, banIfs) = do
|
||||
-- $logWarnS "DEBUG" $ tshow ([ihDebugShow x | x<- reqIfs], [ihDebugShow x | x<- banIfs])
|
||||
void $ liftHandler $ timeoutHandler 42000001 $ runDB $ runInterfaceChecks interfs
|
||||
flagError <- liftHandler $ do
|
||||
void $ timeoutHandler 42000001 $ runDB $ runInterfaceChecks interfs -- ensure interface checkc are up to date
|
||||
mkErrorFlag
|
||||
now <- liftIO getCurrentTime
|
||||
dbTableDB ilvalidator DBTable{dbtColonnade=colonnade now, ..}
|
||||
dbTableDB ilvalidator DBTable{dbtColonnade=colonnade now flagError, ..}
|
||||
where
|
||||
sanitize = text2AlphaNumPlus ['+','-','_','Ä','Ö','Ü','ß','ä','ö','ü']
|
||||
dbtIdent = "interface-log" :: Text
|
||||
@ -115,7 +122,16 @@ mkInterfaceLogTable flagError interfs@(reqIfs, banIfs) = do
|
||||
EL.on ( ilog E.^. InterfaceLogInterface E.=?. ihealth E.?. InterfaceHealthInterface
|
||||
E.&&. ilog E.^. InterfaceLogSubtype E.=~. E.joinV (ihealth E.?. InterfaceHealthSubtype)
|
||||
E.&&. ilog E.^. InterfaceLogWrite E.=~. E.joinV (ihealth E.?. InterfaceHealthWrite )
|
||||
)
|
||||
E.&&. E.notExists (do -- a more specific match does not exist
|
||||
otherh <- E.from $ E.table @InterfaceHealth
|
||||
E.where_ $ ilog E.^. InterfaceLogInterface E.==. otherh E.^. InterfaceHealthInterface
|
||||
E.&&. ilog E.^. InterfaceLogSubtype E.=~. otherh E.^. InterfaceHealthSubtype
|
||||
E.&&. ilog E.^. InterfaceLogWrite E.=~. otherh E.^. InterfaceHealthWrite
|
||||
E.&&. ihealth E.?. InterfaceHealthHours E.!=. E.just (otherh E.^. InterfaceHealthHours)
|
||||
E.&&. (E.isNothing (E.joinV $ ihealth E.?. InterfaceHealthSubtype)
|
||||
E.||. E.isNothing (E.joinV $ ihealth E.?. InterfaceHealthWrite ))
|
||||
)
|
||||
)
|
||||
let matchUIH crits = E.or
|
||||
[ E.and $ catMaybes
|
||||
[ ilog E.^. InterfaceLogInterface E.==. E.val (sanitize ifce) & Just
|
||||
@ -139,32 +155,34 @@ mkInterfaceLogTable flagError interfs@(reqIfs, banIfs) = do
|
||||
-- E.where_ $ E.not_ (ilog E.^. InterfaceLogInterface E.==. E.val "LMS" E.&&. ilog E.^. InterfaceLogSubtype E.==. E.val (sanitize "F")) -- BAD All missing, except for "Printer" "F"
|
||||
-- E.where_ $ E.not_ $ E.parens (ilog E.^. InterfaceLogInterface E.==. E.val "LMS" E.&&. ilog E.^. InterfaceLogSubtype E.==. E.val (sanitize "F")) -- WORKS OKAY
|
||||
-- E.where_ $ ilog E.^. InterfaceLogInterface E.!=. E.val "LMS" E.||. ilog E.^. InterfaceLogSubtype E.!=. E.val (sanitize "F") -- WORKS OKAY
|
||||
let ihour = E.coalesceDefault [ihealth E.?. InterfaceHealthHours] (E.val $ 3 * 24) -- if no default time is set, use 3 days instead
|
||||
let ihour = E.coalesceDefault [ihealth E.?. InterfaceHealthHours] (E.val defaultInterfaceWarnHours) -- if no default time is set, use a default instead
|
||||
return (ilog, ihour)
|
||||
|
||||
queryILog :: (E.SqlExpr (Entity InterfaceLog) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity InterfaceHealth))) -> E.SqlExpr (Entity InterfaceLog)
|
||||
queryILog = $(E.sqlLOJproj 2 1)
|
||||
queryHealth :: (E.SqlExpr (Entity InterfaceLog) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity InterfaceHealth))) -> E.SqlExpr (Maybe (Entity InterfaceHealth))
|
||||
queryHealth = $(E.sqlLOJproj 2 2)
|
||||
resultILog :: Lens' (DBRow (Entity InterfaceLog, E.Value Int)) InterfaceLog
|
||||
resultILog = _dbrOutput . _1 . _entityVal
|
||||
resultHours :: Lens' (DBRow (Entity InterfaceLog, E.Value Int)) Int
|
||||
resultHours = _dbrOutput . _2 . E._unValue
|
||||
|
||||
dbtRowKey = queryILog >>> (E.^.InterfaceLogId)
|
||||
colonnade now = mconcat
|
||||
colonnade now flagError = mconcat
|
||||
[ sortable Nothing (i18nCell MsgInterfaceStatus) $ \row -> -- do
|
||||
let hours = row ^. resultHours
|
||||
-- defmsg = row ^? resultErrMsg
|
||||
logtime = row ^. resultILog . _interfaceLogTime
|
||||
success = row ^. resultILog . _interfaceLogSuccess
|
||||
iface = row ^. resultILog . _interfaceLogInterface
|
||||
status = success && now <= addHours hours logtime
|
||||
in tellCell [(iface,status)] $
|
||||
wgtCell $ flagError status
|
||||
status = (success || hours <= -100) && (hours < 0 || now <= addHours hours logtime)
|
||||
in tellCell [(iface,status)] $ wgtCell $ flagError $ toMaybe (success || not status) status
|
||||
, sortable (Just "interface") (i18nCell MsgInterfaceName ) $ \(view (resultILog . _interfaceLogInterface) -> n) -> textCell n
|
||||
, sortable (Just "subtype") (i18nCell MsgInterfaceSubtype ) $ textCell . view (resultILog . _interfaceLogSubtype)
|
||||
, sortable (Just "write") (i18nCell MsgInterfaceWrite ) $ (`ifIconCell` IconEdit) . view (resultILog . _interfaceLogWrite)
|
||||
, sortable (Just "time") (i18nCell MsgInterfaceLastSynch ) $ dateTimeCell . view (resultILog . _interfaceLogTime)
|
||||
, sortable Nothing (i18nCell MsgInterfaceFreshness ) $ numCell . view resultHours
|
||||
, sortable (Just "hours") (i18nCell MsgInterfaceFreshness & cellTooltips [SomeMessage MsgInterfaceFreshnessTooltip, SomeMessage MsgTableDiffDaysTooltip]
|
||||
) $ warnIntervalCell . view resultHours
|
||||
, sortable (Just "rows") (i18nCell MsgTableRows ) $ cellMaybe numCell . view (resultILog . _interfaceLogRows)
|
||||
, sortable (Just "success") (i18nCell MsgInterfaceSuccess ) $ \(view (resultILog . _interfaceLogSuccess) -> s) -> iconBoolCell s
|
||||
, sortable Nothing (i18nCell MsgInterfaceInfo ) $ \(view resultILog -> ilt) -> case ilt of
|
||||
@ -180,6 +198,7 @@ mkInterfaceLogTable flagError interfs@(reqIfs, banIfs) = do
|
||||
, singletonMap "time" $ SortColumn $ queryILog >>> (E.^. InterfaceLogTime)
|
||||
, singletonMap "rows" $ SortColumn $ queryILog >>> (E.^. InterfaceLogRows)
|
||||
, singletonMap "success" $ SortColumn $ queryILog >>> (E.^. InterfaceLogSuccess)
|
||||
, singletonMap "hours" $ SortColumn $ \r -> E.coalesceDefault [queryHealth r E.?. InterfaceHealthHours] (E.val defaultInterfaceWarnHours)
|
||||
]
|
||||
ilvalidator = def & defaultSorting [SortAscBy "interface", SortAscBy "subtype", SortAscBy "write"]
|
||||
dbtFilter = mempty
|
||||
@ -249,3 +268,135 @@ avsInterfaceCheck interfs = maybeRunCheck interfs (UniqueInterfaceHealth "AVS" (
|
||||
-- lastOk <- userAvsLastSynch . entityVal <<$>> selectFirst [UserAvsLastSynchError ==. Nothing] [Desc UserAvsLastSynch]
|
||||
writeAvsSynchStats Nothing =<< mkBadInfo badRows badTime
|
||||
_ -> return ()
|
||||
|
||||
|
||||
|
||||
data IWTableAction
|
||||
= IWTActAdd
|
||||
| IWTActDelete
|
||||
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
||||
|
||||
instance Universe IWTableAction
|
||||
instance Finite IWTableAction
|
||||
nullaryPathPiece ''IWTableAction $ camelToPathPiece' 2
|
||||
embedRenderMessage ''UniWorX ''IWTableAction id
|
||||
|
||||
data IWTableActionData
|
||||
= IWTActAddData
|
||||
{ iwtActInterface :: Text
|
||||
, iwtActSubtype :: Maybe Text
|
||||
, iwtActWrite :: Maybe Bool
|
||||
, iwtActHours :: Int
|
||||
}
|
||||
| IWTActDeleteData
|
||||
deriving (Eq, Ord, Read, Show, Generic)
|
||||
|
||||
type IWTableExpr = E.SqlExpr (Entity InterfaceHealth)
|
||||
|
||||
queryInterfaceHealth :: IWTableExpr -> E.SqlExpr (Entity InterfaceHealth)
|
||||
queryInterfaceHealth = id
|
||||
|
||||
type IWTableData = DBRow (Entity InterfaceHealth)
|
||||
|
||||
resultInterfaceHealth :: Lens' IWTableData (Entity InterfaceHealth)
|
||||
resultInterfaceHealth = _dbrOutput
|
||||
|
||||
wildcardCell :: IsDBTable m b => (a -> DBCell m b) -> Maybe a -> DBCell m b
|
||||
wildcardCell _ Nothing = iconFixedCell $ icon IconWildcard
|
||||
wildcardCell c (Just x) = c x
|
||||
|
||||
mkInterfaceWarnTable :: DB (FormResult (IWTableActionData, Set InterfaceHealthId), Widget)
|
||||
mkInterfaceWarnTable = do
|
||||
let
|
||||
mkOption :: E.Value Text -> Option Text
|
||||
mkOption (E.unValue -> t) = Option{ optionDisplay = t, optionInternalValue = t, optionExternalValue = toPathPiece t }
|
||||
getSuggestion pj = E.select $ E.distinct $ do
|
||||
il <- E.from $ E.table @InterfaceLog
|
||||
let res = il E.^. pj
|
||||
E.orderBy [E.asc res]
|
||||
pure res
|
||||
suggestionInterface :: HandlerFor UniWorX (OptionList Text)
|
||||
suggestionInterface = mkOptionList . fmap mkOption <$> runDB (getSuggestion InterfaceLogInterface)
|
||||
suggestionSubtype :: HandlerFor UniWorX (OptionList Text)
|
||||
suggestionSubtype = mkOptionList . fmap mkOption <$> runDB (getSuggestion InterfaceLogSubtype)
|
||||
dbtIdent = "interface-warnings" :: Text
|
||||
dbtSQLQuery :: IWTableExpr -> E.SqlQuery IWTableExpr
|
||||
dbtSQLQuery = return
|
||||
dbtRowKey = queryInterfaceHealth >>> (E.^. InterfaceHealthId)
|
||||
dbtProj = dbtProjId
|
||||
dbtColonnade = formColonnade $ mconcat
|
||||
[ dbSelect (applying _2) id (return . view (resultInterfaceHealth . _entityKey))
|
||||
, sortable (Just "interface") (i18nCell MsgInterfaceName ) $ \(view (resultInterfaceHealth . _entityVal . _interfaceHealthInterface) -> n) -> textCell n
|
||||
, sortable (Just "subtype") (i18nCell MsgInterfaceSubtype ) $ wildcardCell textCell . view (resultInterfaceHealth . _entityVal . _interfaceHealthSubtype )
|
||||
, sortable (Just "write") (i18nCell MsgInterfaceWrite ) $ wildcardCell (iconFixedCell . iconWriteReadOnly) . view (resultInterfaceHealth . _entityVal . _interfaceHealthWrite )
|
||||
-- , sortable (Just "hours") (i18nCell MsgInterfaceFreshness ) $ numCell . view (resultInterfaceHealth . _entityVal . _interfaceHealthHours )
|
||||
, sortable (Just "hours") (i18nCell MsgInterfaceFreshness
|
||||
& cellTooltip MsgTableDiffDaysTooltip ) $ warnIntervalCell . view (resultInterfaceHealth . _entityVal . _interfaceHealthHours )
|
||||
]
|
||||
dbtSorting = mconcat
|
||||
[ singletonMap "interface" $ SortColumn $ queryInterfaceHealth >>> (E.^. InterfaceHealthInterface)
|
||||
, singletonMap "subtype" $ SortColumn $ queryInterfaceHealth >>> (E.^. InterfaceHealthSubtype)
|
||||
, singletonMap "write" $ SortColumn $ queryInterfaceHealth >>> (E.^. InterfaceHealthWrite)
|
||||
, singletonMap "hours" $ SortColumn $ queryInterfaceHealth >>> (E.^. InterfaceHealthHours)
|
||||
]
|
||||
dbtFilter = mempty
|
||||
dbtFilterUI = mempty
|
||||
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
||||
dbtParams = DBParamsForm
|
||||
{ dbParamsFormMethod = POST
|
||||
, dbParamsFormAction = Nothing -- Just $ SomeRoute currentRoute
|
||||
, dbParamsFormAttrs = []
|
||||
, dbParamsFormSubmit = FormSubmit
|
||||
, dbParamsFormAdditional
|
||||
= let acts :: Map IWTableAction (AForm Handler IWTableActionData)
|
||||
acts = mconcat
|
||||
[ singletonMap IWTActAdd $ IWTActAddData
|
||||
<$> apreq (textField & cfStrip & addDatalist suggestionInterface) (fslI MsgInterfaceName) Nothing
|
||||
<*> aopt (textField & cfStrip & addDatalist suggestionSubtype) (fslI MsgInterfaceSubtype) Nothing
|
||||
<*> aopt boolField' (fslI MsgInterfaceWrite) Nothing
|
||||
<*> apreq intField (fslI MsgInterfaceFreshness & setTooltip MsgHours) Nothing
|
||||
, singletonMap IWTActDelete $ pure IWTActDeleteData
|
||||
]
|
||||
in renderAForm FormStandard
|
||||
$ (, mempty) . First . Just
|
||||
<$> multiActionA acts (fslI MsgTableAction) Nothing
|
||||
, dbParamsFormEvaluate = liftHandler . runFormPost
|
||||
, dbParamsFormResult = id
|
||||
, dbParamsFormIdent = def
|
||||
}
|
||||
dbtCsvEncode = noCsvEncode
|
||||
dbtCsvDecode = Nothing
|
||||
dbtExtraReps = []
|
||||
postprocess :: FormResult (First IWTableActionData, DBFormResult InterfaceHealthId Bool IWTableData)
|
||||
-> FormResult ( IWTableActionData, Set InterfaceHealthId)
|
||||
postprocess inp = do
|
||||
(First (Just act), jobMap) <- inp
|
||||
let jobSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) jobMap
|
||||
return (act, jobSet)
|
||||
psValidator = def & defaultSorting [SortAscBy "interface", SortAscBy "subtype", SortAscBy "write"]
|
||||
over _1 postprocess <$> dbTable psValidator DBTable{..}
|
||||
|
||||
getConfigInterfacesR, postConfigInterfacesR :: Handler Html
|
||||
getConfigInterfacesR = postConfigInterfacesR
|
||||
postConfigInterfacesR = do
|
||||
((interfaceOks, interfaceTable), (warnRes, configTable)) <- runDB $ (,)
|
||||
<$> mkInterfaceLogTable mempty
|
||||
<*> mkInterfaceWarnTable
|
||||
let interfacesBadNr = length $ filter (not . snd) interfaceOks
|
||||
formResult warnRes $ \case
|
||||
(IWTActAddData{..}, _) -> do
|
||||
void $ runDB $ upsertBy
|
||||
(UniqueInterfaceHealth iwtActInterface iwtActSubtype iwtActWrite)
|
||||
( InterfaceHealth iwtActInterface iwtActSubtype iwtActWrite iwtActHours)
|
||||
[InterfaceHealthHours =. iwtActHours]
|
||||
addMessageI Success MsgInterfaceWarningAdded
|
||||
reloadKeepGetParams ConfigInterfacesR
|
||||
(IWTActDeleteData, ihids) -> do
|
||||
runDB $ mapM_ delete ihids
|
||||
addMessageI Success $ MsgInterfaceWarningDeleted $ Set.size ihids
|
||||
reloadKeepGetParams ConfigInterfacesR
|
||||
|
||||
siteLayoutMsg MsgConfigInterfacesHeading $ do
|
||||
setTitleI MsgConfigInterfacesHeading
|
||||
let defWarnTime = formatDiffHours defaultInterfaceWarnHours
|
||||
$(i18nWidgetFile "config-interfaces")
|
||||
@ -1,4 +1,4 @@
|
||||
-- SPDX-FileCopyrightText: 2022-23 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
|
||||
-- SPDX-FileCopyrightText: 2022-24 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
|
||||
--
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
@ -149,12 +149,20 @@ mkLmsAllTable isAdmin lmsDeletionDays = do
|
||||
, sortable Nothing (i18nCell MsgQualificationRefreshWithin & cellTooltips [SomeMessage MsgQualificationRefreshWithinTooltip , SomeMessage MsgTableDiffDaysTooltip]) $
|
||||
foldMap (textCell . formatCalendarDiffDays ) . view (resultAllQualification . _qualificationRefreshWithin)
|
||||
-- , sortable Nothing (i18nCell MsgQualificationRefreshWithin) $ foldMap textCell . view (resultAllQualification . _qualificationRefreshWithin . to formatCalendarDiffDays) -- does not work, since there is a maybe in between
|
||||
, sortable (Just "qelearning") (i18nCell MsgTableLmsElearning & cellTooltip MsgQualificationElearningStart) $ \row ->
|
||||
let elearnstart = row ^. resultAllQualification . _qualificationElearningStart
|
||||
reminder = row ^. resultAllQualification . _qualificationRefreshReminder
|
||||
in tickmarkCell $ elearnstart && isJust reminder
|
||||
, sortable Nothing (i18nCell MsgQualificationRefreshReminder & cellTooltips [SomeMessage MsgQualificationRefreshReminderTooltip, SomeMessage MsgTableDiffDaysTooltip]) $
|
||||
foldMap (textCell . formatCalendarDiffDays ) . view (resultAllQualification . _qualificationRefreshReminder)
|
||||
, sortable Nothing (i18nCell MsgQualificationAuditDuration & cellTooltips [SomeMessage (MsgQualificationAuditDurationTooltip lmsDeletionDays), SomeMessage MsgTableDiffDaysTooltip]) $
|
||||
foldMap (textCell . formatCalendarDiffDays . fromMonths) . view (resultAllQualification . _qualificationAuditDuration)
|
||||
, sortable (Just "qelearning") (i18nCell MsgTableLmsElearning & cellTooltip MsgQualificationElearningStart)
|
||||
$ tickmarkCell . view (resultAllQualification . _qualificationElearningStart)
|
||||
, sortable (Just "qel-renew") (i18nCell MsgTableLmsElearningRenews & cellTooltip MsgQualificationElearningRenew)
|
||||
$ tickmarkCell . view (resultAllQualification . _qualificationElearningRenews)
|
||||
, sortable (Just "qel-limit") (i18nCell MsgTableLmsElearningLimit & cellTooltip MsgQualificationElearningLimit)
|
||||
$ cellMaybe numCell . view (resultAllQualification . _qualificationElearningLimit)
|
||||
, sortable (Just "qel-reuse") (i18nCell MsgTableQualificationLmsReuses & cellTooltip MsgTableQualificationLmsReusesTooltip)
|
||||
$ \(view (resultAllQualification . _qualificationLmsReuses) -> reuseQid) -> maybeCell reuseQid qualificationIdShortCell
|
||||
, sortable Nothing (i18nCell MsgTableQualificationIsAvsLicence & cellTooltip MsgTableQualificationIsAvsLicenceTooltip)
|
||||
$ \(view (resultAllQualification . _qualificationAvsLicence) -> licence) -> maybeCell licence $ textCell . T.singleton . licence2char
|
||||
, sortable Nothing (i18nCell MsgTableQualificationSapExport & cellTooltip MsgTableQualificationSapExportTooltip)
|
||||
@ -175,6 +183,9 @@ mkLmsAllTable isAdmin lmsDeletionDays = do
|
||||
, singletonMap "qshort" $ SortColumn (E.^. QualificationShorthand)
|
||||
, singletonMap "qname" $ SortColumn (E.^. QualificationName)
|
||||
, singletonMap "qelearning" $ SortColumn (E.^. QualificationElearningStart)
|
||||
, singletonMap "qel-renew" $ SortColumn (E.^. QualificationElearningRenews)
|
||||
, singletonMap "qel-limit" $ SortColumn (E.^. QualificationElearningLimit)
|
||||
, singletonMap "qel-reuse" $ SortColumn (E.^. QualificationLmsReuses)
|
||||
]
|
||||
dbtFilter = mconcat
|
||||
[
|
||||
@ -209,7 +220,6 @@ data LmsTableCsv = LmsTableCsv -- L..T..C.. -> ltc..
|
||||
{ ltcDisplayName :: UserDisplayName
|
||||
, ltcEmail :: UserEmail
|
||||
, ltcCompany :: Maybe Text
|
||||
, ltcCompanyNumbers :: CsvSemicolonList Int
|
||||
, ltcValidUntil :: Day
|
||||
, ltcLastRefresh :: Day
|
||||
, ltcFirstHeld :: Day
|
||||
@ -231,8 +241,7 @@ ltcExample :: LmsTableCsv
|
||||
ltcExample = LmsTableCsv
|
||||
{ ltcDisplayName = "Max Mustermann"
|
||||
, ltcEmail = "m.mustermann@example.com"
|
||||
, ltcCompany = Just "Example Brothers LLC, SecondaryJobs Inc"
|
||||
, ltcCompanyNumbers = CsvSemicolonList [27,69]
|
||||
, ltcCompany = Just "Example Brothers LLC"
|
||||
, ltcValidUntil = succ compDay
|
||||
, ltcLastRefresh = compDay
|
||||
, ltcFirstHeld = pred $ pred compDay
|
||||
@ -274,8 +283,7 @@ instance CsvColumnsExplained LmsTableCsv where
|
||||
csvColumnsExplanations = genericCsvColumnsExplanations ltcOptions $ Map.fromList
|
||||
[ ('ltcDisplayName , SomeMessage MsgLmsUser)
|
||||
, ('ltcEmail , SomeMessage MsgTableLmsEmail)
|
||||
, ('ltcCompany , SomeMessage MsgTableCompanies)
|
||||
, ('ltcCompanyNumbers , SomeMessage MsgTableCompanyNos)
|
||||
, ('ltcCompany , SomeMessage MsgTablePrimeCompany)
|
||||
, ('ltcValidUntil , SomeMessage MsgLmsQualificationValidUntil)
|
||||
, ('ltcLastRefresh , SomeMessage MsgTableQualificationLastRefresh)
|
||||
, ('ltcFirstHeld , SomeMessage MsgTableQualificationFirstHeld)
|
||||
@ -309,7 +317,7 @@ queryQualBlock :: LmsTableExpr -> E.SqlExpr (Maybe (Entity QualificationUserBloc
|
||||
queryQualBlock = $(sqlLOJproj 2 2)
|
||||
|
||||
|
||||
type LmsTableData = DBRow (Entity QualificationUser, Entity User, Entity LmsUser, Maybe (Entity QualificationUserBlock), E.Value (Maybe [Maybe UTCTime]), [Entity UserCompany], E.Value Bool)
|
||||
type LmsTableData = DBRow (Entity QualificationUser, Entity User, Entity LmsUser, Maybe (Entity QualificationUserBlock), E.Value (Maybe [Maybe UTCTime]), E.Value (Maybe CompanyId), E.Value Bool)
|
||||
|
||||
resultQualUser :: Lens' LmsTableData (Entity QualificationUser)
|
||||
resultQualUser = _dbrOutput . _1
|
||||
@ -326,8 +334,8 @@ resultQualBlock = _dbrOutput . _4 . _Just
|
||||
resultPrintAck :: Traversal' LmsTableData [Maybe UTCTime]
|
||||
resultPrintAck = _dbrOutput . _5 . _unValue . _Just
|
||||
|
||||
resultCompanyUser :: Lens' LmsTableData [Entity UserCompany]
|
||||
resultCompanyUser = _dbrOutput . _6
|
||||
resultCompanyId :: Traversal' LmsTableData CompanyId
|
||||
resultCompanyId = _dbrOutput . _6 . _unValue . _Just
|
||||
|
||||
resultValidQualification :: Lens' LmsTableData Bool
|
||||
resultValidQualification = _dbrOutput . _7 . _unValue
|
||||
@ -395,6 +403,7 @@ lmsTableQuery :: UTCTime -> QualificationId -> LmsTableExpr
|
||||
, E.SqlExpr (Entity LmsUser)
|
||||
, E.SqlExpr (Maybe (Entity QualificationUserBlock))
|
||||
, E.SqlExpr (E.Value (Maybe [Maybe UTCTime])) -- outer maybe indicates, whether a printJob exists, inner maybe indicates all acknowledged printJobs
|
||||
, E.SqlExpr (E.Value (Maybe CompanyId))
|
||||
, E.SqlExpr (E.Value Bool)
|
||||
)
|
||||
lmsTableQuery now qid (qualUser `E.InnerJoin` user `E.InnerJoin` lmsUser `E.LeftOuterJoin` qualBlock) = do
|
||||
@ -410,12 +419,16 @@ lmsTableQuery now qid (qualUser `E.InnerJoin` user `E.InnerJoin` lmsUser `E.Left
|
||||
E.where_ $ E.val qid E.==. qualUser E.^. QualificationUserQualification
|
||||
-- Letztes Datum anzeigen, wenn mehrere, dann diese in klickbaren Tooltip verstecken!
|
||||
let printAcknowledged = E.subSelectMaybe . E.from $ \pj -> do
|
||||
E.where_ $ E.isJust (pj E.^. PrintJobLmsUser)
|
||||
E.&&. ((lmsUser E.^. LmsUserIdent) E.=?. (pj E.^. PrintJobLmsUser))
|
||||
let pjOrder = [E.desc $ pj E.^. PrintJobCreated, E.desc $ pj E.^. PrintJobAcknowledged] -- latest created comes first! This is assumed to be the case later on!
|
||||
pure $ --(E.arrayAggWith E.AggModeAll (pj E.^. PrintJobCreated ) pjOrder, -- return two aggregates only works with select, the restricted type of subSelect does not seem to support this!
|
||||
E.arrayAggWith E.AggModeAll (pj E.^. PrintJobAcknowledged) pjOrder
|
||||
return (qualUser, user, lmsUser, qualBlock, printAcknowledged, validQualification now qualUser)
|
||||
E.where_ $ E.isJust (pj E.^. PrintJobLmsUser)
|
||||
E.&&. ((lmsUser E.^. LmsUserIdent) E.=?. (pj E.^. PrintJobLmsUser))
|
||||
let pjOrder = [E.desc $ pj E.^. PrintJobCreated, E.desc $ pj E.^. PrintJobAcknowledged] -- latest created comes first! This is assumed to be the case later on!
|
||||
pure $ --(E.arrayAggWith E.AggModeAll (pj E.^. PrintJobCreated ) pjOrder, -- return two aggregates only works with select, the restricted type of subSelect does not seem to support this!
|
||||
E.arrayAggWith E.AggModeAll (pj E.^. PrintJobAcknowledged) pjOrder
|
||||
primeComp = E.subSelect . E.from $ \uc -> do
|
||||
E.where_ $ user E.^. UserId E.==. uc E.^. UserCompanyUser
|
||||
E.orderBy [E.desc $ uc E.^. UserCompanyPriority, E.asc $ uc E.^. UserCompanyCompany]
|
||||
return (uc E.^. UserCompanyCompany)
|
||||
return (qualUser, user, lmsUser, qualBlock, printAcknowledged, primeComp, validQualification now qualUser)
|
||||
|
||||
|
||||
mkLmsTable :: ( Functor h, ToSortable h
|
||||
@ -424,25 +437,26 @@ mkLmsTable :: ( Functor h, ToSortable h
|
||||
=> Bool
|
||||
-> Entity Qualification
|
||||
-> Map LmsTableAction (AForm Handler LmsTableActionData)
|
||||
-> (Map CompanyId Company -> cols)
|
||||
-> ((CompanyId -> CompanyName) -> cols)
|
||||
-> PSValidator (MForm Handler) (FormResult (First LmsTableActionData, DBFormResult UserId Bool LmsTableData))
|
||||
-> DB (FormResult (LmsTableActionData, Set UserId), Widget)
|
||||
mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
|
||||
now <- liftIO getCurrentTime
|
||||
-- lookup all companies
|
||||
cmpMap <- memcachedBy (Just . Right $ 5 * diffMinute) ("CompanyDictionary"::Text) $ do
|
||||
cmpMap <- memcachedBy (Just . Right $ 15 * diffMinute) ("CompanyDictionary"::Text) $ do
|
||||
cmps <- selectList [] [] -- [Asc CompanyShorthand]
|
||||
return $ Map.fromList $ fmap (\Entity{..} -> (entityKey, entityVal)) cmps
|
||||
let
|
||||
getCompanyName :: CompanyId -> CompanyName
|
||||
getCompanyName cid = maybe (unCompanyKey cid) companyName $ Map.lookup cid cmpMap -- use shorthand in case of impossible failure
|
||||
|
||||
csvName = T.replace " " "-" $ ciOriginal (quali ^. _qualificationName)
|
||||
dbtIdent :: Text
|
||||
dbtIdent = "lms"
|
||||
dbtSQLQuery = lmsTableQuery now qid
|
||||
dbtRowKey = queryUser >>> (E.^. UserId)
|
||||
dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr, qUsrBlock, printAcks, validQ) -> do
|
||||
cmpUsr <- selectList [UserCompanyUser ==. entityKey usr] [Desc UserCompanyPriority, Asc UserCompanyCompany, LimitTo 1]
|
||||
return (qualUsr, usr, lmsUsr, qUsrBlock, printAcks, cmpUsr, validQ)
|
||||
dbtColonnade = cols cmpMap
|
||||
dbtProj = dbtProjId
|
||||
dbtColonnade = cols getCompanyName
|
||||
dbtSorting = mconcat
|
||||
[ single $ sortUserNameLink queryUser
|
||||
, single $ sortUserEmail queryUser
|
||||
@ -533,25 +547,20 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
|
||||
doEncode' = LmsTableCsv
|
||||
<$> view (resultUser . _entityVal . _userDisplayName)
|
||||
<*> view (resultUser . _entityVal . _userDisplayEmail)
|
||||
<*> (view resultCompanyUser >>= getCompanies)
|
||||
<*> (view resultCompanyUser >>= getCompanyNos)
|
||||
<*> view (resultQualUser . _entityVal . _qualificationUserValidUntil)
|
||||
<*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh)
|
||||
<*> view (resultQualUser . _entityVal . _qualificationUserFirstHeld)
|
||||
<*> preview (resultCompanyId . to getCompanyName . _CI)
|
||||
<*> view (resultQualUser . _entityVal . _qualificationUserValidUntil)
|
||||
<*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh)
|
||||
<*> view (resultQualUser . _entityVal . _qualificationUserFirstHeld)
|
||||
<*> preview (resultQualBlock . _entityVal . _qualificationUserBlockUnblock . _not)
|
||||
<*> preview (resultQualBlock . _entityVal . _qualificationUserBlockFrom)
|
||||
<*> view (resultLmsUser . _entityVal . _lmsUserIdent)
|
||||
<*> view (resultLmsUser . _entityVal . _lmsUserStatus)
|
||||
<*> view (resultLmsUser . _entityVal . _lmsUserStatusDay)
|
||||
<*> view (resultLmsUser . _entityVal . _lmsUserStarted)
|
||||
<*> view (resultLmsUser . _entityVal . _lmsUserDatePin)
|
||||
<*> view (resultLmsUser . _entityVal . _lmsUserReceived)
|
||||
<*> view (resultLmsUser . _entityVal . _lmsUserNotified) -- TODO: only exports last email date / print job sending date, not print acknowledge
|
||||
<*> view (resultLmsUser . _entityVal . _lmsUserEnded)
|
||||
getCompanies cmps = case mapMaybe (flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) cmps of
|
||||
[] -> pure Nothing
|
||||
somecmps -> pure $ Just $ intercalate ", " $ fmap (view (_companyName . _CI)) somecmps
|
||||
getCompanyNos = pure . CsvSemicolonList . mapMaybe (preview (_Just . _companyAvsId) . flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany))
|
||||
<*> view (resultLmsUser . _entityVal . _lmsUserIdent)
|
||||
<*> view (resultLmsUser . _entityVal . _lmsUserStatus)
|
||||
<*> view (resultLmsUser . _entityVal . _lmsUserStatusDay)
|
||||
<*> view (resultLmsUser . _entityVal . _lmsUserStarted)
|
||||
<*> view (resultLmsUser . _entityVal . _lmsUserDatePin)
|
||||
<*> view (resultLmsUser . _entityVal . _lmsUserReceived)
|
||||
<*> view (resultLmsUser . _entityVal . _lmsUserNotified) -- TODO: only exports last email date / print job sending date, not print acknowledge
|
||||
<*> view (resultLmsUser . _entityVal . _lmsUserEnded)
|
||||
|
||||
dbtCsvDecode = Nothing
|
||||
dbtExtraReps = []
|
||||
@ -596,8 +605,9 @@ postLmsR sid qsh = do
|
||||
msgResetInfo <- messageIconI Info IconNotificationNonactive MsgLmsActResetInfo
|
||||
msgRestartWarning <- messageIconI Warning IconWarning MsgLmsActRestartWarning
|
||||
|
||||
((lmsRes, lmsTable), Entity qid quali) <- runDB $ do
|
||||
qent <- getBy404 $ SchoolQualificationShort sid qsh
|
||||
((lmsRes, lmsTable), Entity qid quali, lmsQualiReused) <- runDB $ do
|
||||
qent@Entity{entityVal=Qualification{qualificationLmsReuses = reuseQuali}} <- getBy404 $ SchoolQualificationShort sid qsh
|
||||
lmsQualiReused <- traverseJoin get reuseQuali
|
||||
let acts :: Map LmsTableAction (AForm Handler LmsTableActionData)
|
||||
acts = mconcat
|
||||
[ singletonMap LmsActNotify $ pure LmsActNotifyData
|
||||
@ -615,16 +625,12 @@ postLmsR sid qsh = do
|
||||
-- <*> aopt (commentField MsgQualificationActBlockSupervisor) (fslI MsgMessageWarning) Nothing
|
||||
<* aformMessage msgRestartWarning
|
||||
]
|
||||
colChoices cmpMap = mconcat
|
||||
colChoices getCompanyName = mconcat
|
||||
[ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultUser . _entityKey))
|
||||
, colUserNameModalHdrAdmin MsgLmsUser AdminUserR
|
||||
, colUserEmail
|
||||
, sortable (Just "user-company") (i18nCell MsgTableCompany) $ \( view resultCompanyUser -> cmps) ->
|
||||
let cs = [ companyCell (unCompanyKey cmpId) cmpName cmpSpr
|
||||
| Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps
|
||||
, let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap
|
||||
]
|
||||
in intercalate spacerCell cs
|
||||
, sortable (Just "user-company") (i18nCell MsgTablePrimeCompany) $ \(preview resultCompanyId -> mcid) ->
|
||||
maybeEmpty mcid $ \cid -> companyCell (unCompanyKey cid) (getCompanyName cid) False
|
||||
, colUserMatriclenr isAdmin
|
||||
-- , sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser)
|
||||
, sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d
|
||||
@ -694,7 +700,7 @@ postLmsR sid qsh = do
|
||||
i18nLms msg = cell [whamlet|LMS #|] <> i18nCell msg
|
||||
psValidator = def & defaultSorting [SortDescBy "started", SortDescBy "status"]
|
||||
tbl <- mkLmsTable isAdmin qent acts colChoices psValidator
|
||||
return (tbl, qent)
|
||||
return (tbl, qent, lmsQualiReused)
|
||||
|
||||
formResult lmsRes $ \case
|
||||
_ | not isAdmin -> addMessageI Error MsgUnauthorized -- only admins can use the form on this page
|
||||
|
||||
375
src/Handler/MailCenter.hs
Normal file
375
src/Handler/MailCenter.hs
Normal file
@ -0,0 +1,375 @@
|
||||
-- SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
|
||||
--
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Handler.MailCenter
|
||||
( getMailCenterR, postMailCenterR
|
||||
, getMailHtmlR
|
||||
, getMailPlainR
|
||||
, getMailAttachmentR
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
-- import qualified Data.Aeson as Aeson
|
||||
-- import qualified Data.Text as Text
|
||||
|
||||
-- import Database.Persist.Sql (updateWhereCount)
|
||||
-- import Database.Esqueleto.Experimental ((:&)(..))
|
||||
import qualified Database.Esqueleto.Legacy as EL (on) -- only `on` and `from` are different, needed for dbTable using Esqueleto.Legacy
|
||||
import qualified Database.Esqueleto.Experimental as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
import Database.Esqueleto.Utils.TH
|
||||
|
||||
import qualified Data.Aeson as Aeson
|
||||
|
||||
import Text.Blaze.Html (preEscapedToHtml)
|
||||
-- import Text.Blaze.Html5 as H (html, body, pre, p, h1)
|
||||
-- import Text.Blaze.Html.Renderer.String (renderHtml)
|
||||
|
||||
import Numeric (readHex)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as TE
|
||||
import qualified Data.ByteString as S
|
||||
import qualified Data.ByteString.Lazy as LB
|
||||
|
||||
|
||||
import Handler.Utils
|
||||
|
||||
|
||||
|
||||
-- avoids repetition of local definitions
|
||||
single :: (k,a) -> Map k a
|
||||
single = uncurry Map.singleton
|
||||
|
||||
|
||||
data MCTableAction = MCActDummy -- just a dummy, since we don't now yet which actions we will be needing
|
||||
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
||||
|
||||
instance Universe MCTableAction
|
||||
instance Finite MCTableAction
|
||||
nullaryPathPiece ''MCTableAction $ camelToPathPiece' 2
|
||||
embedRenderMessage ''UniWorX ''MCTableAction id
|
||||
|
||||
data MCTableActionData = MCActDummyData
|
||||
deriving (Eq, Ord, Read, Show, Generic)
|
||||
|
||||
|
||||
type MCTableExpr =
|
||||
( E.SqlExpr (Entity SentMail)
|
||||
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
|
||||
)
|
||||
|
||||
queryMail :: MCTableExpr -> E.SqlExpr (Entity SentMail)
|
||||
queryMail = $(sqlLOJproj 2 1)
|
||||
|
||||
|
||||
queryRecipient :: MCTableExpr -> E.SqlExpr (Maybe (Entity User))
|
||||
queryRecipient = $(sqlLOJproj 2 2)
|
||||
|
||||
|
||||
type MCTableData = DBRow (Entity SentMail, Maybe (Entity User))
|
||||
|
||||
resultMail :: Lens' MCTableData (Entity SentMail)
|
||||
resultMail = _dbrOutput . _1
|
||||
|
||||
resultRecipient :: Traversal' MCTableData (Entity User)
|
||||
resultRecipient = _dbrOutput . _2 . _Just
|
||||
|
||||
|
||||
mkMCTable :: DB (FormResult (MCTableActionData, Set SentMailId), Widget)
|
||||
mkMCTable = do
|
||||
let
|
||||
dbtSQLQuery :: MCTableExpr -> E.SqlQuery (E.SqlExpr (Entity SentMail), E.SqlExpr (Maybe (Entity User)))
|
||||
dbtSQLQuery (mail `E.LeftOuterJoin` recipient) = do
|
||||
EL.on $ mail E.^. SentMailRecipient E.==. recipient E.?. UserId
|
||||
return (mail, recipient)
|
||||
dbtRowKey = queryMail >>> (E.^. SentMailId)
|
||||
dbtProj = dbtProjId
|
||||
dbtColonnade = mconcat
|
||||
[ -- dbSelect (applying _2) id (return . view (resultMail . _entityKey))
|
||||
sortable (Just "sent") (i18nCell MsgPrintJobCreated) $ \( view $ resultMail . _entityVal . _sentMailSentAt -> t) -> dateTimeCell t
|
||||
, sortable (Just "recipient") (i18nCell MsgPrintRecipient) $ \(preview resultRecipient -> u) -> maybeCell u $ cellHasUserLink AdminUserR
|
||||
, sortable Nothing (i18nCell MsgCommSubject) $ \(view resultMail -> Entity k v) ->
|
||||
let subject = v ^? _sentMailHeaders . _mailHeaders' . _mailHeader' "Subject"
|
||||
linkWgt = maybe (msg2widget MsgUtilEMail) text2widget subject
|
||||
in anchorCellM (MailHtmlR <$> encrypt k) linkWgt
|
||||
-- , sortable Nothing (i18nCell MsgCommContent) $ \(view $ resultMail . _entityKey -> k) -> anchorCellM (MailHtmlR <$> encrypt k) (text2widget "html")
|
||||
-- , sortable Nothing (i18nCell MsgCommSubject) $ \(preview $ resultMail . _entityVal . _sentMailHeaders . _mailHeaders' . _mailHeader' "Subject" -> h) -> cellMaybe textCell h
|
||||
]
|
||||
dbtSorting = mconcat
|
||||
[ single ("sent" , SortColumn $ queryMail >>> (E.^. SentMailSentAt))
|
||||
, single ("recipient" , sortUserNameBareM queryRecipient)
|
||||
]
|
||||
dbtFilter = mconcat
|
||||
[ single ("sent" , FilterColumn . E.mkDayFilterTo $ views (to queryMail) (E.^. SentMailSentAt))
|
||||
, single ("recipient" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to queryRecipient) (E.?. UserDisplayName))
|
||||
, single ("subject" , FilterColumn . E.mkContainsFilterWithCommaPlus id $ views (to queryMail) (E.str2text . (E.^. SentMailHeaders)))
|
||||
-- , single ("regex" , FilterColumn . E.mkRegExFilterWith id $ views (to queryMail) (E.str2text . (E.^. SentMailHeaders)))
|
||||
]
|
||||
dbtFilterUI mPrev = mconcat
|
||||
[ prismAForm (singletonFilter "sent" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift dayField) (fslI MsgPrintJobCreated)
|
||||
, prismAForm (singletonFilter "recipient" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintRecipient & setTooltip MsgTableFilterCommaPlus)
|
||||
, prismAForm (singletonFilter "subject" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgCommSubject & setTooltip MsgTableFilterCommaPlusShort)
|
||||
-- , prismAForm (singletonFilter "regex" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgCommSubject )
|
||||
]
|
||||
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout}
|
||||
dbtIdent :: Text
|
||||
dbtIdent = "sent-mail"
|
||||
dbtCsvEncode = noCsvEncode
|
||||
dbtCsvDecode = Nothing
|
||||
dbtExtraReps = []
|
||||
dbtParams = DBParamsForm
|
||||
{ dbParamsFormMethod = POST
|
||||
, dbParamsFormAction = Nothing -- Just $ SomeRoute currentRoute
|
||||
, dbParamsFormAttrs = []
|
||||
, dbParamsFormSubmit = FormNoSubmit
|
||||
, dbParamsFormAdditional = \_csrf -> return (FormMissing, mempty)
|
||||
-- , dbParamsFormSubmit = FormSubmit
|
||||
-- , dbParamsFormAdditional
|
||||
-- = let acts :: Map MCTableAction (AForm Handler MCTableActionData)
|
||||
-- acts = mconcat
|
||||
-- [ singletonMap MCActDummy $ pure MCActDummyData
|
||||
-- ]
|
||||
-- in renderAForm FormStandard
|
||||
-- $ (, mempty) . First . Just
|
||||
-- <$> multiActionA acts (fslI MsgTableAction) Nothing
|
||||
, dbParamsFormEvaluate = liftHandler . runFormPost
|
||||
, dbParamsFormResult = id
|
||||
, dbParamsFormIdent = def
|
||||
}
|
||||
postprocess :: FormResult (First MCTableActionData, DBFormResult SentMailId Bool MCTableData)
|
||||
-> FormResult ( MCTableActionData, Set SentMailId)
|
||||
postprocess inp = do
|
||||
(First (Just act), jobMap) <- inp
|
||||
let jobSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) jobMap
|
||||
return (act, jobSet)
|
||||
psValidator = def & defaultSorting [SortDescBy "sent"]
|
||||
over _1 postprocess <$> dbTable psValidator DBTable{..}
|
||||
|
||||
getMailCenterR, postMailCenterR :: Handler Html
|
||||
getMailCenterR = postMailCenterR
|
||||
postMailCenterR = do
|
||||
(mcRes, mcTable) <- runDB mkMCTable
|
||||
formResult mcRes $ \case
|
||||
(MCActDummyData, Set.toList -> _smIds) -> do
|
||||
addMessageI Success MsgBoolIrrelevant
|
||||
reloadKeepGetParams MailCenterR
|
||||
siteLayoutMsg MsgMenuMailCenter $ do
|
||||
setTitleI MsgMenuMailCenter
|
||||
$(widgetFile "mail-center")
|
||||
|
||||
|
||||
typePDF :: ContentType
|
||||
typePDF = "application/pdf"
|
||||
|
||||
getMailAttachmentR :: CryptoUUIDSentMail -> Text -> Handler TypedContent
|
||||
getMailAttachmentR cusm attdisp = do
|
||||
smid <- decrypt cusm
|
||||
(sm,cn) <- runDBRead $ do
|
||||
sm <- get404 smid
|
||||
cn <- get404 $ sm ^. _sentMailContentRef
|
||||
return (sm,cn)
|
||||
let mcontent = getMailContent (sentMailContentContent cn)
|
||||
getAttm alts = case selectAlternative [typePDF] alts of
|
||||
(Just Part{partContent=PartContent (LB.toStrict -> pc), partDisposition=AttachmentDisposition t}) -- partType=pt,
|
||||
| t == attdisp
|
||||
-> Just pc
|
||||
_ -> Nothing
|
||||
attm = firstJust getAttm mcontent
|
||||
case attm of
|
||||
(Just pc) -> sendByteStringAsFile (T.unpack attdisp) pc $ sm ^. _sentMailSentAt
|
||||
_ -> notFound
|
||||
|
||||
getMailHtmlR :: CryptoUUIDSentMail -> Handler Html
|
||||
getMailHtmlR = handleMailShow (SomeMessages [SomeMessage MsgUtilEMail, SomeMessage MsgMenuMailHtml]) [typeHtml,typePlain]
|
||||
|
||||
getMailPlainR :: CryptoUUIDSentMail -> Handler Html
|
||||
getMailPlainR = handleMailShow (SomeMessages [SomeMessage MsgUtilEMail, SomeMessage MsgMenuMailPlain]) [typePlain,typeHtml]
|
||||
|
||||
handleMailShow :: _ -> [ContentType] -> CryptoUUIDSentMail -> Handler Html
|
||||
handleMailShow hdr prefTypes cusm = do
|
||||
smid <- decrypt cusm
|
||||
(sm,cn) <- runDBRead $ do
|
||||
sm <- get404 smid
|
||||
cn <- get404 $ sm ^. _sentMailContentRef
|
||||
return (sm,cn)
|
||||
siteLayout' Nothing $ do
|
||||
setTitleI hdr
|
||||
let mcontent = getMailContent (sentMailContentContent cn)
|
||||
getHeader h = preview (_mailHeader' h) (sm ^. _sentMailHeaders . _mailHeaders')
|
||||
mparts = reorderParts $ mapMaybe (selectAlternative prefTypes) mcontent
|
||||
[whamlet|
|
||||
<section>
|
||||
<dl .deflist>
|
||||
<dt .deflist__dt>
|
||||
_{MsgPrintJobCreated}
|
||||
<dd .deflist__dd>
|
||||
^{formatTimeW SelFormatDateTime (sm ^. _sentMailSentAt)}
|
||||
$maybe usr <- sm ^. _sentMailRecipient
|
||||
<dt .deflist__dt>
|
||||
_{MsgPrintRecipient}
|
||||
<dd .deflist__dd>
|
||||
^{userIdWidget usr}
|
||||
$maybe r <- getHeader "To"
|
||||
<dt .deflist__dt>
|
||||
To
|
||||
<dd .deflist__dd>
|
||||
#{decodeEncodedWord r}
|
||||
$maybe r <- getHeader "Cc"
|
||||
<dt .deflist__dt>
|
||||
Cc
|
||||
<dd .deflist__dd>
|
||||
#{decodeEncodedWord r}
|
||||
$maybe r <- getHeader "From"
|
||||
<dt .deflist__dt>
|
||||
From
|
||||
<dd .deflist__dd>
|
||||
#{decodeEncodedWord r}
|
||||
$maybe r <- getHeader "Subject"
|
||||
<dt .deflist__dt>
|
||||
_{MsgCommSubject}
|
||||
<dd .deflist__dd>
|
||||
#{decodeEncodedWord r}
|
||||
|
||||
<section>
|
||||
$forall pt <- mparts
|
||||
^{part2widget cusm pt}
|
||||
|]
|
||||
-- Include for Debugging:
|
||||
-- <section>
|
||||
-- <h2>Debugging
|
||||
-- <p>
|
||||
-- ^{jsonWidget (sm ^. _sentMailHeaders)}
|
||||
-- <p>
|
||||
-- ^{jsonWidget (sentMailContentContent cn)} -- content fields needs decoding of base64 to make sense here
|
||||
|
||||
selectAlternative :: [ContentType] -> Alternatives -> Maybe Part
|
||||
selectAlternative (fmap decodeUtf8 -> prefTypes) allAlts = aux prefTypes allAlts
|
||||
where
|
||||
aux ts@(ct:_) (pt:ps)
|
||||
| ct == partType pt = Just pt
|
||||
| otherwise = aux ts ps
|
||||
aux (_:ts) [] = aux ts allAlts
|
||||
aux [] (pt:_) = Just pt
|
||||
aux _ [] = Nothing
|
||||
|
||||
reorderParts :: [Part] -> [Part]
|
||||
reorderParts = sortBy pOrder
|
||||
where
|
||||
pOrder Part{partDisposition=d1} Part{partDisposition=d2} = dispoOrder d1 d2
|
||||
|
||||
dispoOrder DefaultDisposition DefaultDisposition = EQ
|
||||
dispoOrder DefaultDisposition _ = LT
|
||||
dispoOrder _ DefaultDisposition = GT
|
||||
dispoOrder (InlineDisposition t1) (InlineDisposition t2) = compare t1 t2
|
||||
dispoOrder (InlineDisposition _) _ = LT
|
||||
dispoOrder _ (InlineDisposition _) = GT
|
||||
dispoOrder (AttachmentDisposition t1) (AttachmentDisposition t2) = compare t1 t2
|
||||
|
||||
disposition2widget :: Disposition -> Widget
|
||||
disposition2widget (AttachmentDisposition _) = [whamlet|<h3>_{MsgMailFileAttachment}|]
|
||||
disposition2widget (InlineDisposition n) = [whamlet|<h3>_{MsgMenuMailAttachment} #{n}|]
|
||||
disposition2widget DefaultDisposition = mempty
|
||||
|
||||
part2widget :: CryptoUUIDSentMail -> Part -> Widget
|
||||
part2widget cusm Part{partContent=NestedParts ps} =
|
||||
[whamlet|
|
||||
$forall p <- ps
|
||||
^{part2widget cusm p}
|
||||
|]
|
||||
part2widget cusm Part{partContent=PartContent (LB.toStrict -> pc), partType=pt, partDisposition=dispo} =
|
||||
[whamlet|
|
||||
<section>
|
||||
^{disposition2widget dispo}
|
||||
^{showBody}
|
||||
^{showPass}
|
||||
|]
|
||||
where
|
||||
showBody
|
||||
| pt == decodeUtf8 typePlain = toWidget $ preEscapedToHtml $ plainTextToHtml $ decodeUtf8 pc
|
||||
| pt == decodeUtf8 typeHtml = toWidget $ preEscapedToHtml $ plainHtmlToHtml $ decodeUtf8 pc -- preEscapedToHtml :: ToMarkup a => a -> Html
|
||||
| pt == decodeUtf8 typeJson =
|
||||
let jw :: Aeson.Value -> Widget = jsonWidget
|
||||
in either str2widget jw $ Aeson.eitherDecodeStrict' pc
|
||||
| pt == decodeUtf8 typePDF
|
||||
, AttachmentDisposition t <- dispo
|
||||
= [whamlet|<a href=@{MailAttachmentR cusm t}>#{t}|]
|
||||
| otherwise = [whamlet|FRADrive cannot decode email parts of type #{pt} yet.|]
|
||||
showPass
|
||||
| pt == decodeUtf8 typePlain
|
||||
, let cw = T.words $ decodeUtf8 pc
|
||||
, Just name <- listBracket ("Inhaber","Gültig") cw -- heursitic for dirving licence renewal letters only; improve
|
||||
<|> listBracket ("Licensee","Valid") cw
|
||||
= let sdn = T.filter (/= '*') (T.unwords $ dropWhile (":"==) name) in
|
||||
liftHandler (runDBRead $ getByFilter [UserDisplayName ==. sdn]) >>= \case
|
||||
Nothing -> mempty -- DEBUG: [whamlet|<h2>Not found: #{sdn}|]
|
||||
Just Entity{entityVal = u@User{userPinPassword=mbpw}} ->
|
||||
[whamlet|
|
||||
<section>
|
||||
$maybe pw <- mbpw
|
||||
<details>
|
||||
<summary>
|
||||
_{MsgAdminUserPinPassword}
|
||||
<p>
|
||||
<dl .deflist>
|
||||
<dt .deflist__dt>
|
||||
^{userWidget u}
|
||||
<dd .deflist__dd>
|
||||
<b>
|
||||
#{pw}
|
||||
<p>
|
||||
_{MsgAdminUserPinPassNotIncluded}
|
||||
$nothing
|
||||
_{MsgAdminUserNoPassword}
|
||||
|]
|
||||
| otherwise = mempty
|
||||
|
||||
------------------------------
|
||||
-- Decode MIME Encoded Word
|
||||
|
||||
-- | decode the MIME encoded-word format, which is used in email headers to encode non-ASCII text. This format is specified in RFC 2047.
|
||||
decodeEncodedWord :: Text -> Text
|
||||
decodeEncodedWord tinp
|
||||
| (pl, T.drop 2 -> cf) <- T.breakOn "=?" tinp
|
||||
, (cw, T.drop 2 -> rm) <- T.breakOn "?=" cf
|
||||
, notNull cw
|
||||
= pl <> decodeEncodedWordHeader cw <> decodeEncodedWord rm
|
||||
| otherwise
|
||||
= tinp
|
||||
|
||||
decodeEncodedWordHeader :: Text -> Text
|
||||
decodeEncodedWordHeader tinp
|
||||
| [enc, bin, cw] <- T.splitOn "?" tinp
|
||||
, "utf-8" == T.toLower enc
|
||||
, "Q" == T.toUpper bin -- Quoted Printable Text
|
||||
= decEncWrdUtf8Q cw
|
||||
-- TODO: add more decoders for other possible encodings here, but "=?utf-8?Q?..?=" is the only one used by Network.Mail.Mime at the moment
|
||||
| otherwise
|
||||
= tinp
|
||||
|
||||
decEncWrdUtf8Q :: Text -> Text
|
||||
decEncWrdUtf8Q tinp
|
||||
| Right ok <- TE.decodeUtf8' $ decWds tinp
|
||||
= ok
|
||||
| otherwise
|
||||
= tinp
|
||||
where
|
||||
decWds :: Text -> S.ByteString
|
||||
decWds t
|
||||
| (h:tl) <- T.splitOn "=" t
|
||||
= mconcat $ TE.encodeUtf8 h : map deco tl
|
||||
| otherwise
|
||||
= TE.encodeUtf8 t
|
||||
|
||||
deco :: Text -> S.ByteString
|
||||
deco w
|
||||
| (c,r) <- T.splitAt 2 w
|
||||
, [(v,"")] <- readHex $ T.unpack c
|
||||
= S.cons v $ TE.encodeUtf8 r
|
||||
| otherwise
|
||||
= TE.encodeUtf8 w
|
||||
@ -1,4 +1,4 @@
|
||||
-- SPDX-FileCopyrightText: 2022 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
|
||||
-- SPDX-FileCopyrightText: 2022-24 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
|
||||
--
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
@ -20,9 +20,9 @@ import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import Database.Persist.Sql (updateWhereCount)
|
||||
import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma
|
||||
import qualified Database.Esqueleto.Legacy as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma
|
||||
import qualified Database.Esqueleto.Legacy as E -- needed for dbTable using Esqueleto.Legacy
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
import Database.Esqueleto.Utils.TH
|
||||
|
||||
import Utils.Print
|
||||
@ -95,6 +95,7 @@ lrqf2letter LRQF{..}
|
||||
, qualSchool = lrqfQuali ^. _qualificationSchool
|
||||
, qualDuration = lrqfQuali ^. _qualificationValidDuration
|
||||
, qualRenewAuto = lrqfQuali ^. _qualificationElearningRenews
|
||||
, qualELimit = lrqfQuali ^. _qualificationElearningLimit
|
||||
, isReminder = lrqfReminder
|
||||
}
|
||||
return (fromMaybe usr rcvr, SomeLetter letter)
|
||||
@ -132,10 +133,10 @@ instance Finite PJTableAction
|
||||
nullaryPathPiece ''PJTableAction $ camelToPathPiece' 2
|
||||
embedRenderMessage ''UniWorX ''PJTableAction id
|
||||
|
||||
-- Not yet needed, since there is no additional data for now:
|
||||
data PJTableActionData = PJActAcknowledgeData | PJActReprintData { ignoreReroute :: Maybe Bool }
|
||||
deriving (Eq, Ord, Read, Show, Generic)
|
||||
|
||||
|
||||
type PJTableExpr = ( E.SqlExpr (Entity PrintJob)
|
||||
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
|
||||
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
|
||||
|
||||
@ -31,9 +31,12 @@ import Utils.Print (validCmdArgument)
|
||||
import Data.Map ((!))
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
import qualified Database.Esqueleto.Legacy as E
|
||||
import Database.Esqueleto.Experimental ((:&)(..))
|
||||
import qualified Database.Esqueleto.Experimental as E
|
||||
import qualified Database.Esqueleto.Legacy as EL (on,from)
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
-- import Database.Esqueleto ((^.))
|
||||
import qualified Database.Esqueleto.PostgreSQL as E
|
||||
|
||||
import qualified Data.Text as Text
|
||||
import Data.List (inits)
|
||||
|
||||
@ -44,6 +47,9 @@ import Jobs
|
||||
import Foundation.Yesod.Auth (updateUserLanguage)
|
||||
|
||||
|
||||
{-# ANN module ("HLint: ignore Functor law" :: String) #-}
|
||||
|
||||
|
||||
data ExamOfficeSettings
|
||||
= ExamOfficeSettings
|
||||
{ eosettingsGetSynced :: Bool
|
||||
@ -113,10 +119,11 @@ instance RenderMessage UniWorX NotificationTriggerKind where
|
||||
makeSettingForm :: Maybe SettingsForm -> Form SettingsForm
|
||||
makeSettingForm template html = do
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
-- isAdmin <- checkAdmin
|
||||
(result, widget) <- flip (renderAForm FormStandard) html $ SettingsForm
|
||||
<$ aformSection MsgFormPersonalAppearance
|
||||
<*> areq (textField & cfStrip) (fslI MsgUserDisplayName & setTooltip MsgUserDisplayNameRulesBelow) (stgDisplayName <$> template)
|
||||
<*> areq (emailField & cfStrip & cfCI) (fslI MsgUserDisplayEmail & setTooltip MsgUserDisplayEmailTip) (stgDisplayEmail <$> template)
|
||||
<*> areq (textField & cfStrip) (fslI MsgUserDisplayName & setTooltip MsgUserDisplayNameRulesBelow) (stgDisplayName <$> template)
|
||||
<*> areq (textField & cfStrip & cfCI) (fslI MsgUserDisplayEmail & setTooltip MsgUserDisplayEmailTip) (stgDisplayEmail <$> template)
|
||||
<* aformSection MsgFormCosmetics
|
||||
<*> areq (natFieldI MsgFavouritesNotNatural)
|
||||
(fslpI MsgFavourites (mr MsgFavouritesPlaceholder) & setTooltip MsgFavouritesTip) (stgMaxFavourites <$> template)
|
||||
@ -191,28 +198,28 @@ notificationForm template = wFormToAForm $ do
|
||||
-> return False
|
||||
NTKCourseParticipant
|
||||
| Just uid <- mbUid
|
||||
-> fmap not . E.selectExists . E.from $ \courseParticipant ->
|
||||
-> fmap not . E.selectExists . EL.from $ \courseParticipant ->
|
||||
E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val uid
|
||||
E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
|
||||
NTKSubmissionUser
|
||||
| Just uid <- mbUid
|
||||
-> fmap not . E.selectExists . E.from $ \submissionUser ->
|
||||
-> fmap not . E.selectExists . EL.from $ \submissionUser ->
|
||||
E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val uid
|
||||
NTKExamParticipant
|
||||
| Just uid <- mbUid
|
||||
-> fmap not . E.selectExists . E.from $ \examRegistration ->
|
||||
-> fmap not . E.selectExists . EL.from $ \examRegistration ->
|
||||
E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val uid
|
||||
NTKCorrector
|
||||
| Just uid <- mbUid
|
||||
-> fmap not . E.selectExists . E.from $ \sheetCorrector ->
|
||||
-> fmap not . E.selectExists . EL.from $ \sheetCorrector ->
|
||||
E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val uid
|
||||
NTKCourseLecturer
|
||||
| Just uid <- mbUid
|
||||
-> fmap not . E.selectExists . E.from $ \lecturer ->
|
||||
-> fmap not . E.selectExists . EL.from $ \lecturer ->
|
||||
E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid
|
||||
NTKFunctionary f
|
||||
| Just uid <- mbUid
|
||||
-> fmap not . E.selectExists . E.from $ \userFunction ->
|
||||
-> fmap not . E.selectExists . EL.from $ \userFunction ->
|
||||
E.where_ $ userFunction E.^. UserFunctionUser E.==. E.val uid
|
||||
E.&&. userFunction E.^. UserFunctionFunction E.==. E.val f
|
||||
_ | Nothing <- mbUid -> return False -- Show everything for not-logged-in users (e.g. if they presented a token)
|
||||
@ -370,7 +377,9 @@ validateSettings User{..} = do
|
||||
|
||||
userDisplayEmail' <- use _stgDisplayEmail
|
||||
guardValidation (MsgInvalidEmailAddressWith $ CI.original userDisplayEmail') $
|
||||
validEmail' userDisplayEmail'
|
||||
validEmail' userDisplayEmail' || -- valid
|
||||
userDisplayEmail' == userDisplayEmail || -- unchanged
|
||||
userDisplayEmail' == userEmail -- euqal to default, which is then ignored
|
||||
|
||||
userPostAddress' <- use _stgPostAddress
|
||||
let postalNotSet = isNothing userPostAddress' -- TODO $ canonical userPostAddress'
|
||||
@ -425,8 +434,8 @@ serveProfileR :: (UserId, User) -> Handler Html
|
||||
serveProfileR (uid, user@User{..}) = do
|
||||
currentRoute <- fromMaybe ProfileR <$> getCurrentRoute
|
||||
(userSchools, userExamOfficeLabels) <- runDB $ do
|
||||
userSchools <- fmap (setOf $ folded . _Value) . E.select . E.from $ \school -> do
|
||||
E.where_ . E.exists . E.from $ \userSchool ->
|
||||
userSchools <- fmap (setOf $ folded . _Value) . E.select . EL.from $ \school -> do
|
||||
E.where_ . E.exists . EL.from $ \userSchool ->
|
||||
E.where_ $ E.not_ (userSchool E.^. UserSchoolIsOptOut)
|
||||
E.&&. userSchool E.^. UserSchoolUser E.==. E.val uid
|
||||
E.&&. userSchool E.^. UserSchoolSchool E.==. school E.^. SchoolId
|
||||
@ -435,7 +444,7 @@ serveProfileR (uid, user@User{..}) = do
|
||||
return (userSchools, userExamOfficeLabels)
|
||||
let settingsTemplate = Just SettingsForm
|
||||
{ stgDisplayName = userDisplayName
|
||||
, stgDisplayEmail = userDisplayEmail
|
||||
, stgDisplayEmail = if userDisplayEmail == "" then userEmail else userDisplayEmail
|
||||
, stgMaxFavourites = userMaxFavourites
|
||||
, stgMaxFavouriteTerms = userMaxFavouriteTerms
|
||||
, stgTheme = userTheme
|
||||
@ -464,11 +473,12 @@ serveProfileR (uid, user@User{..}) = do
|
||||
now <- liftIO getCurrentTime
|
||||
isAdmin <- checkAdmin
|
||||
thisUser <- fromMaybe uid <$> maybeAuthId
|
||||
let changeEmailByUser = userDisplayEmail /= stgDisplayEmail && (not isAdmin || thisUser == uid)
|
||||
let changeEmailByUser = not isAdmin || thisUser == uid
|
||||
changeEmailProper = userDisplayEmail /= stgDisplayEmail && userEmail /= stgDisplayEmail
|
||||
runDBJobs $ do
|
||||
update uid $
|
||||
[ UserDisplayEmail =. stgDisplayEmail | not changeEmailByUser ] ++ -- DisplayEmail changes by Users must be confirmed, see 480 below
|
||||
[ UserPostLastUpdate =. Just now | userPostAddress /= stgPostAddress ] ++
|
||||
[ UserDisplayEmail =. stgDisplayEmail | not changeEmailByUser, changeEmailProper ] ++ -- DisplayEmail changes by Users must be confirmed, see 480 below
|
||||
[ UserPostLastUpdate =. Just now | userPostAddress /= stgPostAddress ] ++
|
||||
[ UserDisplayName =. stgDisplayName
|
||||
, UserMaxFavourites =. stgMaxFavourites
|
||||
, UserMaxFavouriteTerms =. stgMaxFavouriteTerms
|
||||
@ -489,7 +499,7 @@ serveProfileR (uid, user@User{..}) = do
|
||||
, UserExamOfficeGetLabels =. (stgExamOfficeSettings & eosettingsGetLabels)
|
||||
]
|
||||
updateFavourites Nothing
|
||||
when changeEmailByUser $ do
|
||||
when (changeEmailByUser && changeEmailProper) $ do
|
||||
queueDBJob $ JobChangeUserDisplayEmail uid stgDisplayEmail
|
||||
addMessageI Info $ MsgUserDisplayEmailChangeSent stgDisplayEmail
|
||||
let
|
||||
@ -515,8 +525,8 @@ serveProfileR (uid, user@User{..}) = do
|
||||
oldExamLabels = userExamOfficeLabels
|
||||
newExamLabels = stgExamOfficeSettings & eosettingsLabels
|
||||
forM_ oldExamLabels $ \(Entity eolid ExamOfficeLabel{..}) -> unless (Right eolid `Map.member` newExamLabels || Left examOfficeLabelName `Map.member` newExamLabels) $ do
|
||||
E.delete . E.from $ \examOfficeExternalExamLabel -> E.where_ $ examOfficeExternalExamLabel E.^. ExamOfficeExternalExamLabelLabel E.==. E.val eolid
|
||||
E.delete . E.from $ \examOfficeExamLabel -> E.where_ $ examOfficeExamLabel E.^. ExamOfficeExamLabelLabel E.==. E.val eolid
|
||||
E.delete . EL.from $ \examOfficeExternalExamLabel -> E.where_ $ examOfficeExternalExamLabel E.^. ExamOfficeExternalExamLabelLabel E.==. E.val eolid
|
||||
E.delete . EL.from $ \examOfficeExamLabel -> E.where_ $ examOfficeExamLabel E.^. ExamOfficeExamLabelLabel E.==. E.val eolid
|
||||
when (csvExportLabel userCsvOptions == Just examOfficeLabelName) $
|
||||
update uid [ UserCsvOptions =. userCsvOptions { csvExportLabel = Nothing } ]
|
||||
delete eolid
|
||||
@ -596,6 +606,7 @@ tableWidget :: TableHasData -> Widget
|
||||
tableWidget = snd
|
||||
-}
|
||||
|
||||
-- | Given a header message, a bool and widget; display widget and header only if the boolean is true
|
||||
maybeTable :: (RenderMessage UniWorX a)
|
||||
=> a -> (Bool, Widget) -> Widget
|
||||
maybeTable m = maybeTable' m Nothing Nothing
|
||||
@ -626,22 +637,22 @@ makeProfileData usrEnt@(Entity uid usrVal@User{..}) = do
|
||||
avsId <- entityVal <<$>> getBy (UniqueUserAvsUser uid)
|
||||
let usrAutomatic :: CU_UserAvs_User -> Widget
|
||||
usrAutomatic = updateAutomatic . mayUpdate usrVal avsId . mkCheckUpdate
|
||||
|
||||
addressLinkdIcon <- messageTooltip <$> messageIconI Info IconLink MsgAddressIsLinkedTip
|
||||
(actualPrefersPostal, (actualPostAddress, postalAutomatic), (actualDisplayEmail, emailAutomatic)) <- getPostalPreferenceAndAddress' usrEnt
|
||||
functions <- Map.fromListWith Set.union . map (\(Entity _ UserFunction{..}) -> (userFunctionFunction, Set.singleton userFunctionSchool)) <$> selectList [UserFunctionUser ==. uid] []
|
||||
lecture_corrector <- E.select $ E.distinct $ E.from $ \(sheet `E.InnerJoin` corrector `E.InnerJoin` course) -> do
|
||||
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
|
||||
E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet
|
||||
lecture_corrector <- E.select $ E.distinct $ EL.from $ \(sheet `E.InnerJoin` corrector `E.InnerJoin` course) -> do
|
||||
EL.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
|
||||
EL.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet
|
||||
E.where_ $ corrector E.^. SheetCorrectorUser E.==. E.val uid
|
||||
return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand)
|
||||
studies <- E.select $ E.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do
|
||||
E.on $ studyfeat E.^. StudyFeaturesField E.==. studyterms E.^. StudyTermsId
|
||||
E.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId
|
||||
studies <- E.select $ EL.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do
|
||||
EL.on $ studyfeat E.^. StudyFeaturesField E.==. studyterms E.^. StudyTermsId
|
||||
EL.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId
|
||||
E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid
|
||||
return (studyfeat, studydegree, studyterms)
|
||||
companies <- wgtCompanies uid
|
||||
-- supervisors' <- E.select $ E.from $ \(spvr `E.InnerJoin` usrSpvr) -> do
|
||||
-- E.on $ spvr E.^. UserSupervisorSupervisor E.==. usrSpvr E.^. UserId
|
||||
-- supervisors' <- E.select $ EL.from $ \(spvr `E.InnerJoin` usrSpvr) -> do
|
||||
-- EL.on $ spvr E.^. UserSupervisorSupervisor E.==. usrSpvr E.^. UserId
|
||||
-- E.where_ $ spvr E.^. UserSupervisorUser E.==. E.val uid
|
||||
-- E.orderBy [E.asc (usrSpvr E.^. UserDisplayName)]
|
||||
-- return (usrSpvr, spvr E.^. UserSupervisorRerouteNotifications)
|
||||
@ -649,8 +660,8 @@ makeProfileData usrEnt@(Entity uid usrVal@User{..}) = do
|
||||
-- supervisors = intersperse (text2widget ", ") $
|
||||
-- (\(usr, E.Value reroutCom) -> linkUserWidget ForProfileDataR usr <> bool mempty icnReroute reroutCom) <$> supervisors'
|
||||
-- icnReroute = text2widget " " <> toWgt (icon IconReroute)
|
||||
-- supervisees' <- E.select $ E.from $ \(spvr `E.InnerJoin` usrSpvr) -> do
|
||||
-- E.on $ spvr E.^. UserSupervisorUser E.==. usrSpvr E.^. UserId
|
||||
-- supervisees' <- E.select $ EL.from $ \(spvr `E.InnerJoin` usrSpvr) -> do
|
||||
-- EL.on $ spvr E.^. UserSupervisorUser E.==. usrSpvr E.^. UserId
|
||||
-- E.where_ $ spvr E.^. UserSupervisorSupervisor E.==. E.val uid
|
||||
-- return (usrSpvr, spvr E.^. UserSupervisorRerouteNotifications)
|
||||
-- let numSupervisees = length supervisees'
|
||||
@ -666,18 +677,28 @@ makeProfileData usrEnt@(Entity uid usrVal@User{..}) = do
|
||||
qualificationsTable <- mkQualificationsTable now uid -- Tabelle mit allen Qualifikationen
|
||||
supervisorsTable <- mkSupervisorsTable uid -- Tabelle mit allen Supervisors
|
||||
superviseesTable <- mkSuperviseesTable actualPrefersPostal uid -- Tabelle mit allen Supervisees
|
||||
let supervisorsWgt :: Widget =
|
||||
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)
|
||||
countUnderlings <- E.select $ do
|
||||
spr <- E.from $ E.table @UserSupervisor
|
||||
E.where_ $ spr E.^. UserSupervisorSupervisor E.==. E.val uid
|
||||
return (E.countRows, E.count (spr E.^. UserSupervisorId) `E.filterWhere` (spr E.^. UserSupervisorRerouteNotifications))
|
||||
countSupervisors <- E.select $ do
|
||||
spr <- E.from $ E.table @UserSupervisor
|
||||
E.where_ $ spr E.^. UserSupervisorUser E.==. E.val uid
|
||||
return (E.countRows, E.count (spr E.^. UserSupervisorId) `E.filterWhere` (spr E.^. UserSupervisorRerouteNotifications))
|
||||
let errorCount ((E.Value x, E.Value y):_) = (x,y)
|
||||
errorCount _ = (-1,-1)
|
||||
supervisorsWgt :: Widget =
|
||||
let (nrSupers, nrSupersReroute) = errorCount countSupervisors
|
||||
in maybeTable' (MsgProfileSupervisor nrSupers nrSupersReroute) (Just MsgProfileNoSupervisor)
|
||||
(toMaybe (nrSupersReroute > 0) $ msg2widget $ MsgProfileSupervisorRemark nrSupers nrSupersReroute 0) (nrSupers > 0, supervisorsTable)
|
||||
superviseesWgt :: Widget =
|
||||
let ((getSum -> nrSubs, getSum -> nrReroute), tWgt) = superviseesTable
|
||||
in maybeTable' (MsgProfileSupervisee nrSubs nrReroute) (Just MsgProfileNoSupervisee)
|
||||
(toMaybe (nrReroute > 0) $ msg2widget $ MsgProfileSuperviseeRemark nrSubs nrReroute) (nrSubs > 0, tWgt)
|
||||
let (nrUnderlings, nrUndersReroute) = errorCount countUnderlings
|
||||
in maybeTable' (MsgProfileSupervisee nrUnderlings nrUndersReroute) (Just MsgProfileNoSupervisee)
|
||||
(toMaybe (nrUndersReroute > 0) $ msg2widget $ MsgProfileSuperviseeRemark nrUnderlings nrUndersReroute) (nrUnderlings > 0, superviseesTable)
|
||||
-- let examTable, ownTutorialTable, tutorialTable :: Widget
|
||||
-- examTable = i18n MsgPersonalInfoExamAchievementsWip
|
||||
-- ownTutorialTable = i18n MsgPersonalInfoOwnTutorialsWip
|
||||
-- tutorialTable = i18n MsgPersonalInfoTutorialsWip
|
||||
-- tutorialTable = i18n MsgPersonalInfoTutorialsWip -- note that tutorials are linked in enrolledCoursesTable
|
||||
|
||||
cID <- encrypt uid
|
||||
mCRoute <- getCurrentRoute
|
||||
@ -701,7 +722,7 @@ mkOwnedCoursesTable =
|
||||
withType = id
|
||||
|
||||
dbtSQLQuery' uid (course `E.InnerJoin` lecturer) = do
|
||||
E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
|
||||
EL.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
|
||||
E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid
|
||||
return ( course E.^. CourseTerm
|
||||
, course E.^. CourseSchool
|
||||
@ -743,18 +764,28 @@ mkOwnedCoursesTable =
|
||||
|
||||
-- | Table listing all courses that the given user is enrolled in
|
||||
mkEnrolledCoursesTable :: UserId -> DB (Bool, Widget)
|
||||
mkEnrolledCoursesTable =
|
||||
let withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a)
|
||||
mkEnrolledCoursesTable uid = do
|
||||
usrTuts <- E.select $ do
|
||||
(tpar :& tut) <- E.from $ E.table @TutorialParticipant `E.innerJoin` E.table @Tutorial
|
||||
`E.on` (\(tpar :& tut) -> tut E.^. TutorialId E.==. tpar E.^. TutorialParticipantTutorial)
|
||||
E.where_ $ tpar E.^. TutorialParticipantUser E.==. E.val uid
|
||||
E.orderBy [E.asc $ tut E.^. TutorialCourse, E.desc $ tut E.^. TutorialName] -- Data.Map.fromAscListWith reverses tutorials, hence E.desc
|
||||
return (tut E.^. TutorialCourse, tut E.^. TutorialName)
|
||||
|
||||
let usrTutMap :: Map CourseId [TutorialName]
|
||||
usrTutMap = Map.fromAscListWith (++) [(tcid, [tnm]) | (E.Value tcid, E.Value tnm) <- usrTuts]
|
||||
|
||||
withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a)
|
||||
-> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a)
|
||||
withType = id
|
||||
|
||||
validator = def & defaultSorting [SortDescBy "time"]
|
||||
|
||||
in \uid -> (_1 %~ getAny) <$> dbTableWidget validator
|
||||
(_1 %~ getAny) <$> dbTableWidget validator
|
||||
DBTable
|
||||
{ dbtIdent = "courseMembership" :: Text
|
||||
, dbtSQLQuery = \(course `E.InnerJoin` participant) -> do
|
||||
E.on $ course E.^. CourseId E.==. participant E.^. CourseParticipantCourse
|
||||
EL.on $ course E.^. CourseId E.==. participant E.^. CourseParticipantCourse
|
||||
E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid
|
||||
E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
|
||||
return (course, participant E.^. CourseParticipantRegistration)
|
||||
@ -771,7 +802,14 @@ mkEnrolledCoursesTable =
|
||||
, sortable (Just "time") (i18nCell MsgProfileRegistered) $ do
|
||||
regTime <- view $ _dbrOutput . _2
|
||||
return $ dateTimeCell regTime
|
||||
]
|
||||
, sortable Nothing (i18nCell MsgCourseTutorials) $ \(view $ _dbrOutput . _1 -> Entity{entityKey=cid, entityVal=Course{..}}) ->
|
||||
cell [whamlet|
|
||||
<ul .list--iconless>
|
||||
$forall tutName <- maybeMonoid (Map.lookup cid usrTutMap)
|
||||
<li>
|
||||
^{simpleLink (citext2widget tutName) (CTutorialR courseTerm courseSchool courseShorthand tutName TUsersR)}
|
||||
|]
|
||||
]
|
||||
, dbtSorting = Map.fromList
|
||||
[ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseName )
|
||||
, ( "term" , SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseTerm )
|
||||
@ -804,9 +842,9 @@ mkSubmissionTable =
|
||||
withType = id
|
||||
|
||||
dbtSQLQuery' uid (course `E.InnerJoin` sheet `E.InnerJoin` submission `E.InnerJoin` subUser) = do
|
||||
E.on $ submission E.^. SubmissionId E.==. subUser E.^. SubmissionUserSubmission
|
||||
E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
|
||||
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
|
||||
EL.on $ submission E.^. SubmissionId E.==. subUser E.^. SubmissionUserSubmission
|
||||
EL.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
|
||||
EL.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
|
||||
E.where_ $ subUser E.^. SubmissionUserUser E.==. E.val uid
|
||||
let crse = ( course E.^. CourseTerm
|
||||
, course E.^. CourseSchool
|
||||
@ -817,7 +855,7 @@ mkSubmissionTable =
|
||||
dbtRowKey (_ `E.InnerJoin` _ `E.InnerJoin` submission `E.InnerJoin` _) = submission E.^. SubmissionId
|
||||
|
||||
lastSubEdit uid submission = -- latest Edit-Time of this user for submission
|
||||
E.subSelectMaybe . E.from $ \subEdit -> do
|
||||
E.subSelectMaybe . EL.from $ \subEdit -> do
|
||||
E.where_ $ subEdit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId
|
||||
E.&&. subEdit E.^. SubmissionEditUser E.==. E.val (Just uid)
|
||||
return . E.max_ $ subEdit E.^. SubmissionEditTime
|
||||
@ -884,8 +922,8 @@ mkSubmissionGroupTable =
|
||||
withType = id
|
||||
|
||||
dbtSQLQuery' uid (course `E.InnerJoin` sgroup `E.InnerJoin` sguser) = do
|
||||
E.on $ sguser E.^. SubmissionGroupUserSubmissionGroup E.==. sgroup E.^. SubmissionGroupId
|
||||
E.on $ sgroup E.^. SubmissionGroupCourse E.==. course E.^. CourseId
|
||||
EL.on $ sguser E.^. SubmissionGroupUserSubmissionGroup E.==. sgroup E.^. SubmissionGroupId
|
||||
EL.on $ sgroup E.^. SubmissionGroupCourse E.==. course E.^. CourseId
|
||||
E.where_ $ sguser E.^. SubmissionGroupUserUser E.==. E.val uid
|
||||
let crse = ( course E.^. CourseTerm
|
||||
, course E.^. CourseSchool
|
||||
@ -938,18 +976,18 @@ mkCorrectionsTable =
|
||||
-> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity SheetCorrector))->a)
|
||||
withType = id
|
||||
|
||||
corrsAssigned uid sheet = E.subSelectCount . E.from $ \submission ->
|
||||
corrsAssigned uid sheet = E.subSelectCount . EL.from $ \submission ->
|
||||
E.where_ $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
|
||||
E.&&. submission E.^. SubmissionRatingBy E.==. E.just (E.val uid)
|
||||
|
||||
corrsCorrected uid sheet = E.subSelectCount . E.from $ \submission ->
|
||||
corrsCorrected uid sheet = E.subSelectCount . EL.from $ \submission ->
|
||||
E.where_ $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
|
||||
E.&&. submission E.^. SubmissionRatingBy E.==. E.just (E.val uid)
|
||||
E.&&. E.not_ (E.isNothing $ submission E.^. SubmissionRatingTime)
|
||||
|
||||
dbtSQLQuery' uid (course `E.InnerJoin` sheet `E.InnerJoin` corrector) = do
|
||||
E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet
|
||||
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
|
||||
EL.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet
|
||||
EL.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
|
||||
E.where_ $ corrector E.^. SheetCorrectorUser E.==. E.val uid
|
||||
let crse = ( course E.^. CourseTerm
|
||||
, course E.^. CourseSchool
|
||||
@ -1014,9 +1052,9 @@ mkQualificationsTable =
|
||||
DBTable
|
||||
{ dbtIdent = "userQualifications" :: Text
|
||||
, dbtSQLQuery = \(quali `E.InnerJoin` quser `E.LeftOuterJoin` qblock) -> do
|
||||
E.on $ quser E.^. QualificationUserId E.=?. qblock E.?. QualificationUserBlockQualificationUser
|
||||
EL.on $ quser E.^. QualificationUserId E.=?. qblock E.?. QualificationUserBlockQualificationUser
|
||||
E.&&. qblock `isLatestBlockBefore` E.val now
|
||||
E.on $ quser E.^. QualificationUserQualification E.==. quali E.^. QualificationId
|
||||
EL.on $ quser E.^. QualificationUserQualification E.==. quali E.^. QualificationId
|
||||
E.where_ $ quser E.^. QualificationUserUser E.==. E.val uid
|
||||
return (quali, quser, qblock)
|
||||
, dbtRowKey = \(_quali `E.InnerJoin` quser `E.LeftOuterJoin` _qblock) -> quser E.^. QualificationUserId
|
||||
@ -1067,14 +1105,14 @@ instance HasUser TblSupervisorData where
|
||||
hasUser = _dbrOutput . _1 . _entityVal
|
||||
|
||||
-- | Table listing all supervisor of the given user
|
||||
mkSupervisorsTable :: UserId -> DB ((Sum Int, Sum Int, Sum Int), Widget)
|
||||
mkSupervisorsTable uid = dbTableWidget validator DBTable{..}
|
||||
mkSupervisorsTable :: UserId -> DB Widget
|
||||
mkSupervisorsTable uid = dbTableWidget' validator DBTable{..}
|
||||
where
|
||||
dbtIdent = "userSupervisedBy" :: Text
|
||||
dbtIdent = "supervisors" :: Text
|
||||
dbtStyle = def
|
||||
|
||||
dbtSQLQuery (usr `E.InnerJoin` spr) = do
|
||||
E.on $ spr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId
|
||||
EL.on $ spr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId
|
||||
E.where_ $ spr E.^. UserSupervisorUser E.==. E.val uid
|
||||
return (usr, spr)
|
||||
dbtRowKey (_ `E.InnerJoin` spr) = spr E.^. UserSupervisorId
|
||||
@ -1088,12 +1126,11 @@ mkSupervisorsTable uid = dbTableWidget validator DBTable{..}
|
||||
, sortable (Just "reroute") (i18nCell MsgTableRerouteActive) $ \row ->
|
||||
let isReroute = row ^. resultUserSupervisor . _entityVal ._userSupervisorRerouteNotifications
|
||||
isLetter = row ^. resultUser . _userPrefersPostal
|
||||
in tellCell (Sum 1, Sum $ fromEnum isReroute, Sum $ fromEnum $ isReroute && isLetter) $
|
||||
if isReroute
|
||||
in if isReroute
|
||||
then iconCell IconReroute <> spacerCell <> iconFixedCell (iconLetterOrEmail isLetter)
|
||||
else mempty
|
||||
, sortable (Just "cshort") (i18nCell MsgTableCompany) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorCompany -> mc) -> maybeCell mc (\(unCompanyKey -> c) -> anchorCell (FirmUsersR c) $ citext2widget c)
|
||||
, sortable (Just "reason") (i18nCell MsgSupervisorReason) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorReason -> mr) -> maybeCell mr textCell
|
||||
, sortable (Just "cshort") (i18nCell MsgTableCompany) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorCompany -> mc) -> maybeCell mc (\(unCompanyKey -> c) -> anchorCell (FirmUsersR c) $ citext2widget c)
|
||||
, sortable (Just "reason") (i18nCell MsgTableReason) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorReason -> mr) -> maybeCell mr textCell
|
||||
]
|
||||
validator = def & defaultSorting [ SortAscBy "cshort", SortAscBy "user-name" ]
|
||||
dbtSorting = mconcat
|
||||
@ -1120,14 +1157,14 @@ mkSupervisorsTable uid = dbTableWidget validator DBTable{..}
|
||||
|
||||
|
||||
-- | Table listing all persons supervised by the given user
|
||||
mkSuperviseesTable ::Bool -> UserId -> DB ((Sum Int, Sum Int), Widget)
|
||||
mkSuperviseesTable userPrefersPostal uid = dbTableWidget validator DBTable{..}
|
||||
mkSuperviseesTable ::Bool -> UserId -> DB Widget
|
||||
mkSuperviseesTable userPrefersPostal uid = dbTableWidget' validator DBTable{..}
|
||||
where
|
||||
dbtIdent = "userSupervisedBy" :: Text
|
||||
dbtIdent = "supervisees" :: Text
|
||||
dbtStyle = def
|
||||
|
||||
dbtSQLQuery (usr `E.InnerJoin` spr) = do
|
||||
E.on $ spr E.^. UserSupervisorUser E.==. usr E.^. UserId
|
||||
EL.on $ spr E.^. UserSupervisorUser E.==. usr E.^. UserId
|
||||
E.where_ $ spr E.^. UserSupervisorSupervisor E.==. E.val uid
|
||||
return (usr, spr)
|
||||
dbtRowKey (_ `E.InnerJoin` spr) = spr E.^. UserSupervisorId
|
||||
@ -1141,9 +1178,9 @@ mkSuperviseesTable userPrefersPostal uid = dbTableWidget validator DBTable{..}
|
||||
-- , sortable (Just "postal-pref") (i18nCell MsgPrefersPostal) $ \(view $ resultUser . _userPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b
|
||||
, sortable (Just "reroute") (i18nCell MsgTableRerouteActive) $ \row ->
|
||||
let isReroute = row ^. resultUserSupervisor . _entityVal ._userSupervisorRerouteNotifications
|
||||
in tellCell (Sum 1, Sum $ fromEnum isReroute) $ boolCell isReroute $ iconCell IconReroute <> iconCellLetterOrEmail
|
||||
, sortable (Just "cshort") (i18nCell MsgTableCompany) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorCompany -> mc) -> maybeCell mc (\(unCompanyKey -> c) -> anchorCell (FirmUsersR c) $ citext2widget c)
|
||||
, sortable (Just "reason") (i18nCell MsgSupervisorReason) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorReason -> mr) -> maybeCell mr textCell
|
||||
in boolCell isReroute $ iconCell IconReroute <> iconCellLetterOrEmail
|
||||
, sortable (Just "cshort") (i18nCell MsgTableCompany) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorCompany -> mc) -> maybeCell mc (\(unCompanyKey -> c) -> anchorCell (FirmUsersR c) $ citext2widget c)
|
||||
, sortable (Just "reason") (i18nCell MsgTableReason) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorReason -> mr) -> maybeCell mr textCell
|
||||
]
|
||||
validator = def & defaultSorting [ SortAscBy "cshort", SortAscBy "user-name" ]
|
||||
dbtSorting = mconcat
|
||||
@ -1286,7 +1323,7 @@ postCsvOptionsR = do
|
||||
Entity uid User{userCsvOptions} <- requireAuth
|
||||
|
||||
userIsExamOffice <- hasReadAccessTo $ ExamOfficeR EOExamsR
|
||||
examOfficeLabels <- if not userIsExamOffice then return mempty else runDB . E.select . E.from $ \examOfficeLabel -> do
|
||||
examOfficeLabels <- if not userIsExamOffice then return mempty else runDB . E.select . EL.from $ \examOfficeLabel -> do
|
||||
E.where_ $ examOfficeLabel E.^. ExamOfficeLabelUser E.==. E.val uid
|
||||
E.orderBy [ E.asc (examOfficeLabel E.^. ExamOfficeLabelName) ]
|
||||
return $ examOfficeLabel E.^. ExamOfficeLabelName
|
||||
|
||||
@ -98,16 +98,18 @@ mkQualificationAllTable isAdmin = do
|
||||
foldMap (textCell . formatCalendarDiffDays . fromMonths) . view (resultAllQualification . _qualificationValidDuration)
|
||||
, sortable Nothing (i18nCell MsgQualificationRefreshWithin & cellTooltips [SomeMessage MsgQualificationRefreshWithinTooltip , SomeMessage MsgTableDiffDaysTooltip]) $
|
||||
foldMap (textCell . formatCalendarDiffDays ) . view (resultAllQualification . _qualificationRefreshWithin)
|
||||
, sortable (Just "qelearning") (i18nCell MsgTableLmsElearning & cellTooltip MsgQualificationElearningStart) $ \row ->
|
||||
let elearnstart = row ^. resultAllQualification . _qualificationElearningStart
|
||||
reminder = row ^. resultAllQualification . _qualificationRefreshReminder
|
||||
in tickmarkCell $ elearnstart && isJust reminder
|
||||
, sortable Nothing (i18nCell MsgQualificationRefreshReminder & cellTooltips [SomeMessage MsgQualificationRefreshReminderTooltip, SomeMessage MsgTableDiffDaysTooltip]) $
|
||||
foldMap (textCell . formatCalendarDiffDays ) . view (resultAllQualification . _qualificationRefreshReminder)
|
||||
, sortable (Just "qelearning") (i18nCell MsgTableLmsElearning & cellTooltip MsgQualificationElearningStart)
|
||||
$ tickmarkCell . view (resultAllQualification . _qualificationElearningStart)
|
||||
, sortable (Just "qelearrenew") (i18nCell MsgTableLmsElearningRenews & cellTooltip MsgQualificationElearningRenew)
|
||||
$ tickmarkCell . view (resultAllQualification . _qualificationElearningRenews)
|
||||
, sortable (Just "noteexpiry") (i18nCell MsgQualificationExpiryNotification & cellTooltip MsgQualificationExpiryNotificationTooltip)
|
||||
$ tickmarkCell . view (resultAllQualification . _qualificationExpiryNotification)
|
||||
, sortable Nothing (i18nCell MsgTableQualificationLmsReuses & cellTooltip MsgTableQualificationLmsReusesTooltip)
|
||||
$ \(view (resultAllQualification . _qualificationLmsReuses) -> reuseQid) -> maybeCell reuseQid qualificationIdShortCell
|
||||
-- , sortable (Just "qelearrenew") (i18nCell MsgTableLmsElearningRenews & cellTooltip MsgQualificationElearningRenew)
|
||||
-- $ tickmarkCell . view (resultAllQualification . _qualificationElearningRenews)
|
||||
-- , sortable Nothing (i18nCell MsgTableQualificationLmsReuses & cellTooltip MsgTableQualificationLmsReusesTooltip)
|
||||
-- $ \(view (resultAllQualification . _qualificationLmsReuses) -> reuseQid) -> maybeCell reuseQid qualificationIdShortCell
|
||||
, sortable Nothing (i18nCell MsgTableQualificationIsAvsLicence & cellTooltip MsgTableQualificationIsAvsLicenceTooltip)
|
||||
$ \(view (resultAllQualification . _qualificationAvsLicence) -> licence) -> maybeCell licence $ textCell . T.singleton . licence2char
|
||||
, sortable Nothing (i18nCell MsgTableQualificationSapExport & cellTooltip MsgTableQualificationSapExportTooltip)
|
||||
@ -156,7 +158,6 @@ data QualificationTableCsv = QualificationTableCsv -- Q..T..C.. -> qtc..
|
||||
{ qtcDisplayName :: UserDisplayName
|
||||
, qtcEmail :: UserEmail
|
||||
, qtcCompany :: Maybe Text
|
||||
, qtcCompanyNumbers :: CsvSemicolonList Int
|
||||
, qtcValidUntil :: Day
|
||||
, qtcLastRefresh :: Day
|
||||
, qtcBlockStatus :: Maybe Bool
|
||||
@ -172,8 +173,7 @@ qtcExample :: QualificationTableCsv
|
||||
qtcExample = QualificationTableCsv
|
||||
{ qtcDisplayName = "Max Mustermann"
|
||||
, qtcEmail = "m.mustermann@example.com"
|
||||
, qtcCompany = Just "Example Brothers LLC, SecondaryJobs Inc"
|
||||
, qtcCompanyNumbers = CsvSemicolonList [27,69]
|
||||
, qtcCompany = Just "Example Brothers LLC"
|
||||
, qtcValidUntil = compDay
|
||||
, qtcLastRefresh = compDay
|
||||
, qtcBlockStatus = Nothing
|
||||
@ -207,8 +207,7 @@ instance CsvColumnsExplained QualificationTableCsv where
|
||||
csvColumnsExplanations = genericCsvColumnsExplanations qtcOptions $ Map.fromList
|
||||
[ ('qtcDisplayName , SomeMessage MsgLmsUser)
|
||||
, ('qtcEmail , SomeMessage MsgTableLmsEmail)
|
||||
, ('qtcCompany , SomeMessage MsgTableCompanies)
|
||||
, ('qtcCompanyNumbers , SomeMessage MsgTableCompanyNos)
|
||||
, ('qtcCompany , SomeMessage MsgTablePrimeCompany)
|
||||
, ('qtcValidUntil , SomeMessage MsgLmsQualificationValidUntil)
|
||||
, ('qtcLastRefresh , SomeMessage MsgTableQualificationLastRefresh)
|
||||
, ('qtcBlockStatus , SomeMessage MsgInfoQualificationBlockStatus)
|
||||
@ -236,7 +235,7 @@ queryLmsUser = $(sqlLOJproj 3 2)
|
||||
queryQualBlock :: QualificationTableExpr -> E.SqlExpr (Maybe (Entity QualificationUserBlock))
|
||||
queryQualBlock = $(sqlLOJproj 3 3)
|
||||
|
||||
type QualificationTableData = DBRow (Entity QualificationUser, Entity User, Maybe (Entity LmsUser), Maybe (Entity QualificationUserBlock), [Entity UserCompany])
|
||||
type QualificationTableData = DBRow (Entity QualificationUser, Entity User, Maybe (Entity LmsUser), Maybe (Entity QualificationUserBlock), E.Value (Maybe CompanyId))
|
||||
|
||||
resultQualUser :: Lens' QualificationTableData (Entity QualificationUser)
|
||||
resultQualUser = _dbrOutput . _1
|
||||
@ -250,8 +249,8 @@ resultLmsUser = _dbrOutput . _3 . _Just
|
||||
resultQualBlock :: Traversal' QualificationTableData (Entity QualificationUserBlock)
|
||||
resultQualBlock = _dbrOutput . _4 . _Just
|
||||
|
||||
resultCompanyUser :: Lens' QualificationTableData [Entity UserCompany]
|
||||
resultCompanyUser = _dbrOutput . _5
|
||||
resultCompanyId :: Traversal' QualificationTableData CompanyId
|
||||
resultCompanyId = _dbrOutput . _5 . _unValue . _Just
|
||||
|
||||
|
||||
instance HasEntity QualificationTableData User where
|
||||
@ -338,6 +337,7 @@ qualificationTableQuery :: UTCTime -> QualificationId -> (_ -> E.SqlExpr (E.Valu
|
||||
, E.SqlExpr (Entity User)
|
||||
, E.SqlExpr (Maybe (Entity LmsUser))
|
||||
, E.SqlExpr (Maybe (Entity QualificationUserBlock))
|
||||
, E.SqlExpr (E.Value (Maybe CompanyId))
|
||||
)
|
||||
qualificationTableQuery now qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser `E.LeftOuterJoin` qualBlock) = do
|
||||
-- E.distinctOnOrderBy will not work: sorting with dbTable should work, except that columns contained in distinctOnOrderBy cannot be sorted inversely by user; but PostgreSQL leftJoin with distinct filters too many results, see SQL Example lead/lag under jost/misc DevOps
|
||||
@ -349,7 +349,11 @@ qualificationTableQuery now qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJo
|
||||
E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser
|
||||
E.where_ $ fltr qualUser
|
||||
E.&&. (E.val qid E.==. qualUser E.^. QualificationUserQualification)
|
||||
return (qualUser, user, lmsUser, qualBlock)
|
||||
let primeComp = E.subSelect . E.from $ \uc -> do
|
||||
E.where_ $ user E.^. UserId E.==. uc E.^. UserCompanyUser
|
||||
E.orderBy [E.desc $ uc E.^. UserCompanyPriority, E.asc $ uc E.^. UserCompanyCompany]
|
||||
return (uc E.^. UserCompanyCompany)
|
||||
return (qualUser, user, lmsUser, qualBlock, primeComp)
|
||||
|
||||
|
||||
mkQualificationTable ::
|
||||
@ -359,17 +363,19 @@ mkQualificationTable ::
|
||||
=> Bool
|
||||
-> Entity Qualification
|
||||
-> Map QualificationTableAction (AForm Handler QualificationTableActionData)
|
||||
-> (Map CompanyId Company -> cols)
|
||||
-> ((CompanyId -> CompanyName) -> cols)
|
||||
-> PSValidator (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableData))
|
||||
-> DB (FormResult (QualificationTableActionData, Set UserId), Widget)
|
||||
mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
|
||||
svs <- getSupervisees
|
||||
now <- liftIO getCurrentTime
|
||||
-- lookup all companies
|
||||
cmpMap <- memcachedBy (Just . Right $ 5 * diffMinute) ("CompanyDictionary"::Text) $ do
|
||||
cmpMap <- memcachedBy (Just . Right $ 15 * diffMinute) ("CompanyDictionary"::Text) $ do
|
||||
cmps <- selectList [] [] -- [Asc CompanyShorthand]
|
||||
return $ Map.fromList $ fmap (\Entity{..} -> (entityKey, entityVal)) cmps
|
||||
let
|
||||
getCompanyName :: CompanyId -> CompanyName
|
||||
getCompanyName cid = maybe (unCompanyKey cid) companyName $ Map.lookup cid cmpMap -- use shorthand in case of impossible failure
|
||||
nowaday = utctDay now
|
||||
mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday
|
||||
csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName)
|
||||
@ -378,15 +384,8 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
|
||||
fltrSvs = if isAdmin then const E.true else \quser -> quser E.^. QualificationUserUser `Ex.in_` E.vals svs
|
||||
dbtSQLQuery = qualificationTableQuery now qid fltrSvs
|
||||
dbtRowKey = queryUser >>> (E.^. UserId)
|
||||
dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr, qUsrBlock) -> do
|
||||
-- cmps <- E.select . E.from $ \(usrComp `E.InnerJoin` comp) -> do
|
||||
-- E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
|
||||
-- E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val (entityKey usr)
|
||||
-- E.orderBy [E.asc (comp E.^. CompanyName)]
|
||||
-- return (comp E.^. CompanyName, comp E.^. CompanyAvsId, usrComp E.^. UserCompanySupervisor)
|
||||
cmpUsr <- selectList [UserCompanyUser ==. entityKey usr] [Desc UserCompanyPriority, Asc UserCompanyCompany, LimitTo 1]
|
||||
return (qualUsr, usr, lmsUsr, qUsrBlock, cmpUsr)
|
||||
dbtColonnade = cols cmpMap
|
||||
dbtProj = dbtProjId
|
||||
dbtColonnade = cols getCompanyName
|
||||
dbtSorting = mconcat
|
||||
[ single $ sortUserNameLink queryUser
|
||||
, single $ sortUserEmail queryUser
|
||||
@ -469,8 +468,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
|
||||
doEncode' = QualificationTableCsv
|
||||
<$> view (resultUser . _entityVal . _userDisplayName)
|
||||
<*> view (resultUser . _entityVal . _userDisplayEmail)
|
||||
<*> (view resultCompanyUser >>= getCompanies)
|
||||
<*> (view resultCompanyUser >>= getCompanyNos)
|
||||
<*> preview (resultCompanyId . to getCompanyName . _CI)
|
||||
<*> view (resultQualUser . _entityVal . _qualificationUserValidUntil)
|
||||
<*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh)
|
||||
<*> preview (resultQualBlock. _entityVal . _qualificationUserBlockUnblock . _not)
|
||||
@ -478,10 +476,6 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
|
||||
<*> view (resultQualUser . _entityVal . _qualificationUserScheduleRenewal)
|
||||
<*> getStatusPlusTxt
|
||||
<*> getStatusPlusDay
|
||||
getCompanies cmps = case mapMaybe (flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) cmps of
|
||||
[] -> pure Nothing
|
||||
somecmps -> pure $ Just $ intercalate ", " $ fmap (view (_companyName . _CI)) somecmps
|
||||
getCompanyNos = pure . CsvSemicolonList . mapMaybe (preview (_Just . _companyAvsId) . flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany))
|
||||
|
||||
getStatusPlusTxt =
|
||||
(join . preview (resultLmsUser . _entityVal . _lmsUserStatus)) >>= \case
|
||||
@ -549,7 +543,7 @@ postQualificationR sid qsh = do
|
||||
Ex.groupBy (qblock Ex.^. QualificationUserBlockReason)
|
||||
let countRows' :: Ex.SqlExpr (Ex.Value Int64) = Ex.countRows
|
||||
Ex.orderBy [Ex.desc countRows']
|
||||
Ex.limit 7
|
||||
Ex.limit 9
|
||||
pure (qblock Ex.^. QualificationUserBlockReason)
|
||||
mkOption :: Ex.Value Text -> Option Text
|
||||
mkOption (Ex.unValue -> t) = Option{ optionDisplay = t, optionInternalValue = t, optionExternalValue = toPathPiece t }
|
||||
@ -583,16 +577,12 @@ postQualificationR sid qsh = do
|
||||
] isAdmin
|
||||
linkLmsUser = toMaybe isAdmin (LmsUserR sid qsh)
|
||||
linkUserName = bool ForProfileR ForProfileDataR isAdmin
|
||||
colChoices cmpMap = mconcat
|
||||
colChoices getCompanyName = mconcat
|
||||
[ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
|
||||
, colUserNameModalHdr MsgLmsUser linkUserName
|
||||
, colUserEmail
|
||||
, sortable (Just "user-company") (i18nCell MsgTableCompany) $ \( view resultCompanyUser -> cmps) ->
|
||||
let cs = [ companyCell (unCompanyKey cmpId) cmpName cmpSpr
|
||||
| Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps
|
||||
, let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap
|
||||
]
|
||||
in intercalate spacerCell cs
|
||||
, sortable (Just "user-company") (i18nCell MsgTablePrimeCompany) $ \(preview resultCompanyId -> mcid) ->
|
||||
maybeEmpty mcid $ \cid -> companyCell (unCompanyKey cid) (getCompanyName cid) False
|
||||
, 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
|
||||
|
||||
@ -48,14 +48,14 @@ import Data.List (genericLength)
|
||||
|
||||
import qualified Data.Csv as Csv
|
||||
|
||||
|
||||
{-# ANN module ("HLint: ignore Functor law" :: String) #-}
|
||||
|
||||
data CorrectionTableFilterProj = CorrectionTableFilterProj
|
||||
{ corrProjFilterSubmission :: Maybe (Set [CI Char])
|
||||
, corrProjFilterPseudonym :: Maybe (Set [CI Char])
|
||||
, corrProjFilterAuthorshipStatementState :: Last AuthorshipStatementSubmissionState
|
||||
}
|
||||
|
||||
|
||||
instance Default CorrectionTableFilterProj where
|
||||
def = CorrectionTableFilterProj
|
||||
{ corrProjFilterSubmission = Nothing
|
||||
@ -64,7 +64,7 @@ instance Default CorrectionTableFilterProj where
|
||||
}
|
||||
|
||||
makeLenses_ ''CorrectionTableFilterProj
|
||||
|
||||
|
||||
|
||||
type CorrectionTableExpr = ( E.SqlExpr (Entity Course)
|
||||
`E.InnerJoin` E.SqlExpr (Entity Sheet)
|
||||
@ -135,7 +135,7 @@ resultSubmittors = _dbrOutput . _6 . itraversed
|
||||
|
||||
resultUserUser :: Lens' CorrectionTableUserData User
|
||||
resultUserUser = _1
|
||||
|
||||
|
||||
resultUserPseudonym :: Traversal' CorrectionTableUserData Pseudonym
|
||||
resultUserPseudonym = _2 . _Just
|
||||
|
||||
@ -207,7 +207,7 @@ instance Csv.ToNamedRecord CorrectionTableCsv where
|
||||
, "rating-points" Csv..= csvCorrectionRatingPoints
|
||||
, "rating-comment" Csv..= csvCorrectionRatingComment
|
||||
]
|
||||
where
|
||||
where
|
||||
mkEmpty = \case
|
||||
[Nothing] -> []
|
||||
x -> x
|
||||
@ -269,7 +269,7 @@ data CorrectionTableCsvQualification
|
||||
= CorrectionTableCsvNoQualification
|
||||
| CorrectionTableCsvQualifySheet
|
||||
| CorrectionTableCsvQualifyCourse
|
||||
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)
|
||||
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)
|
||||
deriving anyclass (Universe, Finite)
|
||||
|
||||
correctionTableCsvHeader :: Bool -- ^ @showCorrector@
|
||||
@ -402,7 +402,7 @@ colSubmissionLink = sortable (Just "submission") (i18nCell MsgTableSubmission) $
|
||||
colSelect :: forall act h epId. (Semigroup act, Monoid act, Headedness h, Ord epId) => Colonnade h CorrectionTableData (DBCell _ (FormResult (act, DBFormResult CryptoFileNameSubmission Bool CorrectionTableData), SheetTypeSummary epId))
|
||||
colSelect = dbSelect (_1 . applying _2) id $ views resultCryptoID return
|
||||
|
||||
|
||||
|
||||
colSubmittors :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
|
||||
colSubmittors = sortable (Just "submittors") (i18nCell MsgSubmissionUsers) $ \x ->
|
||||
let tid = x ^. resultCourseTerm
|
||||
@ -457,7 +457,7 @@ colRating' l = sortable (Just "rating") (i18nCell MsgTableRating) $ \x ->
|
||||
]
|
||||
|
||||
colAssigned :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
|
||||
colAssigned = sortable (Just "assignedtime") (i18nCell MsgAssignedTime) $ \x -> maybeCell (x ^? resultSubmission . _entityVal . _submissionRatingAssigned . _Just) dateTimeCell
|
||||
colAssigned = sortable (Just "assignedtime") (i18nCell MsgAssignedTime) $ \x -> maybeCell (x ^? resultSubmission . _entityVal . _submissionRatingAssigned . _Just) dateTimeCell
|
||||
|
||||
colRated :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
|
||||
colRated = sortable (Just "ratingtime") (i18nCell MsgTableRatingTime) $ \x -> maybeCell (x ^? resultSubmission . _entityVal . _submissionRatingTime . _Just) dateTimeCell
|
||||
@ -515,7 +515,7 @@ colAuthorshipStatementState = sortable (Just "as-state") (i18nCell MsgSubmission
|
||||
csh = x ^. resultCourseShorthand
|
||||
shn = x ^. resultSheet . _entityVal . _sheetName
|
||||
cID = x ^. resultCryptoID
|
||||
|
||||
|
||||
asRoute = CSubmissionR tid ssh csh shn cID SubAuthorshipStatementsR
|
||||
in maybeCell (guardOnM (x ^. resultNonAnonymousAccess) $ x ^. resultASState) (\s -> heatC s $ anchorCell asRoute (i18n s :: Widget))
|
||||
|
||||
@ -537,7 +537,7 @@ filterUIIsRated = flip (prismAForm $ singletonFilter "israted" . maybePrism _Pat
|
||||
|
||||
filterUISubmission :: DBFilterUI
|
||||
filterUISubmission = flip (prismAForm $ singletonFilter "submission") $ aopt (lift `hoistField` textField) (fslI MsgTableSubmission)
|
||||
|
||||
|
||||
filterUIPseudonym :: DBFilterUI
|
||||
filterUIPseudonym = flip (prismAForm $ singletonFilter "pseudonym") $ aopt (lift `hoistField` textField) (fslI MsgSubmissionPseudonym)
|
||||
|
||||
@ -809,7 +809,7 @@ correctionsR whereClause displayColumns dbtFilterUI csvSettings psValidator acti
|
||||
fmap toTypedContent . defaultLayout $ do
|
||||
setTitleI MsgCourseCorrectionsTitle
|
||||
$(widgetFile "corrections")
|
||||
|
||||
|
||||
correctionsR' :: CorrectionTableWhere -> _ -> _ -> Maybe CorrectionTableCsvSettings -> _ -> Map ActionCorrections (AForm (HandlerFor UniWorX) ActionCorrectionsData) -> Handler (Widget, SheetTypeSummary SqlBackendKey)
|
||||
correctionsR' whereClause displayColumns dbtFilterUI csvSettings psValidator actions = do
|
||||
currentRoute <- fromMaybe (error "correctionsR called from 404-handler") <$> getCurrentRoute -- This should never be called from a 404 handler
|
||||
|
||||
@ -91,7 +91,7 @@ tutorialForm cid template html = do
|
||||
where
|
||||
tutTypeDatalist :: HandlerFor UniWorX (OptionList (CI Text))
|
||||
tutTypeDatalist = fmap (mkOptionList . map (\t -> Option (CI.original t) t (toPathPiece $ CI.original t)) . Set.toAscList) . runDB $
|
||||
fmap (setOf $ folded . _Value) . E.select . E.from $ \tutorial -> do
|
||||
fmap (setOf $ folded . _Value) . E.select . E.distinct . E.from $ \tutorial -> do
|
||||
E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
|
||||
return $ tutorial E.^. TutorialType
|
||||
|
||||
|
||||
@ -50,7 +50,7 @@ data TutorialUserActionData
|
||||
| TutorialUserGrantQualificationData
|
||||
{ tuQualification :: QualificationId
|
||||
, tuValidUntil :: Day
|
||||
}
|
||||
}
|
||||
| TutorialUserSendMailData
|
||||
| TutorialUserDeregisterData{}
|
||||
deriving (Eq, Ord, Read, Show, Generic)
|
||||
@ -62,7 +62,7 @@ postTUsersR tid ssh csh tutn = do
|
||||
isAdmin <- hasReadAccessTo AdminR
|
||||
(Entity tutid tut@Tutorial{..}, (participantRes, participantTable), qualifications) <- runDB $ do
|
||||
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
tutEnt@(Entity tutid _) <- fetchTutorial tid ssh csh tutn
|
||||
tutEnt@(Entity tutid _) <- fetchTutorial tid ssh csh tutn
|
||||
qualifications <- getCourseQualifications cid
|
||||
now <- liftIO getCurrentTime
|
||||
let nowaday = utctDay now
|
||||
@ -70,7 +70,7 @@ postTUsersR tid ssh csh tutn = do
|
||||
dayExpiry = flip addGregorianDurationClip nowaday . fromMonths <$> minDur
|
||||
colChoices = mconcat $ catMaybes
|
||||
[ pure $ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
|
||||
, pure $ colUserNameModalHdr MsgTableCourseMembers ForProfileDataR
|
||||
, pure $ colUserNameModalHdr MsgTableCourseMembers ForProfileDataR
|
||||
, pure colUserEmail
|
||||
, pure $ colUserMatriclenr isAdmin
|
||||
, pure $ colUserQualifications nowaday
|
||||
@ -80,34 +80,27 @@ postTUsersR tid ssh csh tutn = do
|
||||
& defaultSortingByName
|
||||
& restrictSorting (\name _ -> none (== name) ["note", "registration", "tutorials", "exams", "submission-group", "state"]) -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information
|
||||
& restrictFilter (\name _ -> none (== name) ["tutorial", "exam", "submission-group", "active", "has-personalised-sheet-files"])
|
||||
isInTut q = E.exists $ do
|
||||
isInTut q = E.exists $ do
|
||||
tutorialParticipant <- E.from $ E.table @TutorialParticipant
|
||||
E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. queryUser q E.^. UserId
|
||||
E.&&. tutorialParticipant E.^. TutorialParticipantTutorial E.==. E.val tutid
|
||||
csvColChoices = flip elem ["name", "matriculation", "email", "qualifications"]
|
||||
|
||||
let
|
||||
qualOpt :: Entity Qualification -> Handler (Option QualificationId)
|
||||
qualOpt (Entity qualId qual) = do
|
||||
cQualId :: CryptoUUIDQualification <- encrypt qualId
|
||||
return $ Option
|
||||
{ optionDisplay = CI.original $ qualificationName qual
|
||||
, optionInternalValue = qualId
|
||||
, optionExternalValue = tshow cQualId
|
||||
}
|
||||
|
||||
qualOptions = qualificationsOptionList qualifications
|
||||
let
|
||||
acts :: Map TutorialUserAction (AForm Handler TutorialUserActionData)
|
||||
acts = Map.fromList $
|
||||
(if null qualifications then mempty else
|
||||
[ ( TutorialUserRenewQualification
|
||||
, TutorialUserRenewQualificationData
|
||||
<$> apopt (selectField . fmap mkOptionList $ mapM qualOpt qualifications) (fslI MsgQualificationName) Nothing
|
||||
<$> apopt (selectField $ pure qualOptions) (fslI MsgQualificationName) Nothing
|
||||
)
|
||||
, ( TutorialUserGrantQualification
|
||||
, TutorialUserGrantQualificationData
|
||||
<$> apopt (selectField . fmap mkOptionList $ mapM qualOpt qualifications) (fslI MsgQualificationName) Nothing
|
||||
<$> apopt (selectField $ pure qualOptions) (fslI MsgQualificationName) Nothing
|
||||
<*> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry
|
||||
)
|
||||
]
|
||||
)
|
||||
]
|
||||
) ++
|
||||
[ ( TutorialUserSendMail , pure TutorialUserSendMailData )
|
||||
, ( TutorialUserDeregister , pure TutorialUserDeregisterData )
|
||||
@ -122,20 +115,20 @@ postTUsersR tid ssh csh tutn = do
|
||||
rcvr <- requireAuth
|
||||
encRcvr <- encrypt $ entityKey rcvr
|
||||
letters <- runDB $ makeCourseCertificates tut Nothing $ toList selectedUsers
|
||||
let mbAletter = anyone letters
|
||||
case mbAletter of
|
||||
let mbAletter = anyone letters
|
||||
case mbAletter of
|
||||
Nothing -> addMessageI Error MsgErrorUnknownFormAction >> return Nothing -- TODO: better error message
|
||||
Just aletter -> do
|
||||
Just aletter -> do
|
||||
now <- liftIO getCurrentTime
|
||||
apcIdent <- letterApcIdent aletter encRcvr now
|
||||
apcIdent <- letterApcIdent aletter encRcvr now
|
||||
let fName = letterFileName aletter
|
||||
renderLetters rcvr letters apcIdent >>= \case
|
||||
Left err -> sendResponseStatus internalServerError500 $ "PDF generation failed: \n" <> err
|
||||
Left err -> sendResponseStatus internalServerError500 $ "PDF generation failed: \n" <> err
|
||||
Right pdf -> return $ Just (sendByteStringAsFile fName (LBS.toStrict pdf) now)
|
||||
-- sendResponseByteStringFile "demoPDF.pdf" (LBS.toStrict pdf)
|
||||
-- let typePDF :: ContentType
|
||||
-- let typePDF :: ContentType
|
||||
-- typePDF = "application/pdf"
|
||||
-- sendResponse (typePDF, toContent pdf)
|
||||
-- sendResponse (typePDF, toContent pdf)
|
||||
(TutorialUserGrantQualificationData{..}, selectedUsers)
|
||||
| tuQualification `Set.member` courseQids -> do
|
||||
-- today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime
|
||||
@ -146,7 +139,7 @@ postTUsersR tid ssh csh tutn = do
|
||||
redirect $ CTutorialR tid ssh csh tutn TUsersR
|
||||
(TutorialUserRenewQualificationData{..}, selectedUsers)
|
||||
| tuQualification `Set.member` courseQids -> do
|
||||
noks <- runDB $ renewValidQualificationUsers tuQualification Nothing Nothing $ Set.toList selectedUsers
|
||||
noks <- runDB $ renewValidQualificationUsers tuQualification Nothing Nothing $ Set.toList selectedUsers
|
||||
addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks
|
||||
redirect $ CTutorialR tid ssh csh tutn TUsersR
|
||||
(TutorialUserSendMailData{}, selectedUsers) -> do
|
||||
@ -160,8 +153,8 @@ postTUsersR tid ssh csh tutn = do
|
||||
addMessageI Success $ MsgTutorialUsersDeregistered nrDel
|
||||
redirect $ CTutorialR tid ssh csh tutn TUsersR
|
||||
_other -> addMessageI Error MsgErrorUnknownFormAction >> return Nothing
|
||||
|
||||
case tcontent of
|
||||
|
||||
case tcontent of
|
||||
Just act -> act -- abort and return produced content
|
||||
Nothing -> do
|
||||
tutors <- runDB $ E.select $ do
|
||||
|
||||
@ -44,7 +44,7 @@ import Data.Aeson hiding (Result(..))
|
||||
|
||||
-- import Handler.Users.Add as Handler.Users
|
||||
|
||||
import qualified Data.Conduit.List as C
|
||||
-- import qualified Data.Conduit.List as C
|
||||
|
||||
import qualified Data.HashSet as HashSet
|
||||
|
||||
@ -56,11 +56,10 @@ hijackUserForm = \csrf -> do
|
||||
(btnResult, btnView) <- mopt (buttonField BtnHijack) "" Nothing
|
||||
return (btnResult >>= guard . is _Just, mconcat [toWidget csrf, fvWidget btnView])
|
||||
|
||||
-- In case of refactoring, use this:
|
||||
-- instance HasEntity (DBRow (Entity User)) User where
|
||||
-- hasEntity = _dbrOutput
|
||||
-- instance HasUser (DBRow (Entity USer)) where
|
||||
-- hasUser = _entityVal
|
||||
instance HasEntity (DBRow (Entity User)) User where
|
||||
hasEntity = _dbrOutput
|
||||
instance HasUser (DBRow (Entity User)) where
|
||||
hasUser = _dbrOutput . _entityVal
|
||||
|
||||
data UserAction = UserAvsSync | UserLdapSync | UserAddSupervisor | UserSetSupervisor | UserRemoveSupervisor | UserRemoveSubordinates
|
||||
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
||||
@ -112,9 +111,9 @@ postUsersR = do
|
||||
, sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \DBRow{ dbrOutput = entUsr } -> cellHasMatrikelnummerLinkedAdmin entUsr
|
||||
, sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ liftHandler $ runDB $ -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX"
|
||||
maybeMonoid <$> wgtCompanies uid
|
||||
, sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM
|
||||
(AdminUserR <$> encrypt uid)
|
||||
(toWgt userCompanyPersonalNumber)
|
||||
-- , sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM -- redundant
|
||||
-- (AdminUserR <$> encrypt uid)
|
||||
-- (toWgt userCompanyPersonalNumber)
|
||||
, sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \DBRow{ dbrOutput = Entity _uid User{..} } -> cellMaybe textCell userCompanyPersonalNumber
|
||||
, sortable (Just "company-department") (i18nCell MsgCompanyDepartment) $ \DBRow{ dbrOutput = Entity _uid User{..} } -> cellMaybe textCell userCompanyDepartment
|
||||
-- , sortable (Just "last-name") (i18nCell MsgName) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM
|
||||
@ -132,6 +131,7 @@ postUsersR = do
|
||||
pure $ mconcat supervisors
|
||||
, sortable (Just "last-login") (i18nCell MsgLastLogin) $ \DBRow{ dbrOutput = Entity _ User{..} } -> maybe mempty dateTimeCell userLastAuthentication
|
||||
, sortable (Just "auth-ldap") (i18nCell MsgAuthMode) $ \DBRow{ dbrOutput = Entity _ User{..} } -> i18nCell userAuthentication
|
||||
, colUserEmail
|
||||
, sortable (Just "ldap-sync") (i18nCell MsgLdapSynced) $ \DBRow{ dbrOutput = Entity _ User{..} } -> maybe mempty dateTimeCell userLastLdapSynchronisation
|
||||
, flip foldMap universeF $ \function ->
|
||||
sortable (Just $ SortingKey $ CI.mk $ toPathPiece function) (i18nCell function) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do
|
||||
@ -186,18 +186,25 @@ postUsersR = do
|
||||
let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap
|
||||
return (act, usrSet)
|
||||
|
||||
superReasons :: HandlerFor UniWorX (OptionList Text)
|
||||
superReasons = fmap (mkOptionList . map (\t -> Option t t t) . Set.toAscList) . runDB $
|
||||
fmap (setOf $ folded . _Value . _Just) . Ex.select . Ex.distinct $ do
|
||||
usrc <- Ex.from $ Ex.table @UserSupervisor
|
||||
E.where_ $ E.isJust (usrc E.^. UserSupervisorReason)
|
||||
Ex.limit 9
|
||||
return $ usrc E.^. UserSupervisorReason
|
||||
acts :: Map UserAction (AForm Handler UserActionData)
|
||||
acts = mconcat
|
||||
[ singletonMap UserLdapSync $ pure UserLdapSyncData
|
||||
, singletonMap UserAvsSync $ pure UserAvsSyncData
|
||||
, singletonMap UserAddSupervisor $ UserAddSupervisorData
|
||||
<$> apopt (textField & cfAnySeparatedSet) (fslI MsgTableSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing
|
||||
<*> apopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just True)
|
||||
<*> aopt textField (fslI MsgSupervisorReason) Nothing
|
||||
<$> apopt (textField & cfAnySeparatedSet) (fslI MsgTableSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing
|
||||
<*> apopt boolField' (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just False)
|
||||
<*> aopt (textField & cfStrip & addDatalist superReasons) (fslI MsgUserSupervisorReason & setTooltip MsgUserSupervisorReasonTooltip) Nothing
|
||||
, singletonMap UserSetSupervisor $ UserSetSupervisorData
|
||||
<$> apopt (textField & cfAnySeparatedSet) (fslI MsgTableSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing
|
||||
<*> apopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just True)
|
||||
<*> aopt textField (fslI MsgSupervisorReason) Nothing
|
||||
<$> apopt (textField & cfAnySeparatedSet) (fslI MsgTableSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing
|
||||
<*> apopt boolField' (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just False)
|
||||
<*> aopt (textField & cfStrip & addDatalist superReasons) (fslI MsgUserSupervisorReason & setTooltip MsgUserSupervisorReasonTooltip) Nothing
|
||||
, singletonMap UserRemoveSupervisor $ pure UserRemoveSupervisorData
|
||||
, singletonMap UserRemoveSubordinates $ pure UserRemoveSubordinatesData
|
||||
]
|
||||
@ -215,11 +222,12 @@ postUsersR = do
|
||||
return (uf E.^. UserFunctionSchool)
|
||||
) | function <- universeF
|
||||
] ++
|
||||
[ ( "name"
|
||||
, SortColumn $ \user -> user E.^. UserSurname
|
||||
[ sortUserEmail id
|
||||
, ( "name"
|
||||
, SortColumn (E.^. UserSurname)
|
||||
)
|
||||
, ( "display-name"
|
||||
, SortColumn $ \user -> user E.^. UserDisplayName
|
||||
, SortColumn (E.^. UserDisplayName)
|
||||
)
|
||||
, ( "matriculation"
|
||||
, SortColumn $ \user -> user E.^. UserMatrikelnummer
|
||||
@ -377,7 +385,7 @@ postUsersR = do
|
||||
| Set.null usersSet && isNotSetSupervisor act ->
|
||||
addMessageI Info MsgActionNoUsersSelected
|
||||
(UserLdapSyncData, userSet) -> do
|
||||
forM_ userSet $ \uid -> queueJob' $ JobSynchroniseLdapUser uid
|
||||
forM_ userSet $ \uid -> void . queueJob $ JobSynchroniseLdapUser uid
|
||||
addMessageI Success . MsgSynchroniseLdapUserQueued $ Set.size userSet
|
||||
redirectKeepGetParams UsersR
|
||||
(UserAvsSyncData, userSet) -> do
|
||||
@ -417,7 +425,8 @@ postUsersR = do
|
||||
|
||||
formResult allUsersRes $ \case
|
||||
AllUsersLdapSync -> do
|
||||
runDBJobs . runConduit $ selectSource [] [] .| C.mapM_ (queueDBJob . JobSynchroniseLdapUser . entityKey)
|
||||
-- runDBJobs . runConduit $ selectSource [] [] .| C.mapM_ (queueDBJob . JobSynchroniseLdapUser . entityKey) -- to slow to execute directly
|
||||
queueJob' JobSynchroniseLdapAll
|
||||
addMessageI Success MsgSynchroniseLdapAllUsersQueued
|
||||
redirect UsersR
|
||||
AllUsersAvsSync -> do
|
||||
@ -437,7 +446,7 @@ postUsersR = do
|
||||
, AvsSyncPause E.=. E.greatest (current E.^. AvsSyncPause) (excluded E.^. AvsSyncPause)
|
||||
]
|
||||
)
|
||||
queueJob' JobSynchroniseAvsQueue
|
||||
void $ queueJob JobSynchroniseAvsQueue
|
||||
addMessageI Success $ MsgSynchroniseAvsAllUsersQueued n
|
||||
redirect UsersR
|
||||
|
||||
|
||||
@ -163,19 +163,23 @@ redirectKeepGetParams route = liftHandler $ do
|
||||
getps <- reqGetParams <$> getRequest
|
||||
redirect (route, getps)
|
||||
|
||||
previousSuperior :: (IsDBTable m a) => Maybe UserId -> DBCell m a
|
||||
previousSuperior Nothing = mempty
|
||||
previousSuperior (Just uid) = spacerCell <> i18nCell MsgAdminProblemCompanySuperiorPrevious <> anchorCellM (AdminUserR <$> encrypt uid) (userIdWidget uid)
|
||||
|
||||
adminProblemCell :: (IsDBTable m a) => AdminProblem -> DBCell m a
|
||||
-- note that adminProblemCompany/adminProblemCompanyOld and adminProblemUser are automatically displayed within their own columns
|
||||
-- WARNING: this function should correspond with adminProblem2Text
|
||||
adminProblemCell AdminProblemNewCompany{}
|
||||
= i18nCell MsgAdminProblemNewCompany
|
||||
adminProblemCell AdminProblemSupervisorNewCompany{adminProblemCompanyNew, adminProblemSupervisorReroute}
|
||||
= i18nCell (MsgAdminProblemSupervisorNewCompany adminProblemSupervisorReroute) <> companyIdCell adminProblemCompanyNew
|
||||
adminProblemCell AdminProblemSupervisorLeftCompany{adminProblemSupervisorReroute}
|
||||
= i18nCell (MsgAdminProblemSupervisorLeftCompany adminProblemSupervisorReroute)
|
||||
adminProblemCell AdminProblemCompanySuperiorChange{adminProblemUserOld=Nothing}
|
||||
= i18nCell MsgAdminProblemCompanySuperiorChange
|
||||
adminProblemCell AdminProblemCompanySuperiorChange{adminProblemUserOld=Just uid}
|
||||
= i18nCell MsgAdminProblemCompanySuperiorChange <> spacerCell <> i18nCell MsgAdminProblemCompanySuperiorPrevious <> anchorCellM (AdminUserR <$> encrypt uid) (userIdWidget uid)
|
||||
adminProblemCell AdminProblemCompanySuperiorChange{adminProblemUserOld}
|
||||
= i18nCell MsgAdminProblemCompanySuperiorChange <> previousSuperior adminProblemUserOld
|
||||
adminProblemCell AdminProblemCompanySuperiorNotFound{..}
|
||||
= i18nCell (MsgAdminProblemCompanySuperiorNotFound (fromMaybe "???" adminProblemEmail)) <> previousSuperior adminProblemUserOld
|
||||
adminProblemCell AdminProblemNewlyUnsupervised{adminProblemCompanyNew}
|
||||
= i18nCell MsgAdminProblemNewlyUnsupervised <> companyIdCell adminProblemCompanyNew
|
||||
adminProblemCell AdminProblemUnknown{adminProblemText}
|
||||
@ -184,6 +188,42 @@ adminProblemCell AdminProblemUnknown{adminProblemText}
|
||||
company2msg :: CompanyId -> SomeMessage UniWorX
|
||||
company2msg = text2message . ciOriginal . unCompanyKey
|
||||
|
||||
-- used to enable filtering, must correspond to function adminProblemCell shown above
|
||||
adminProblem2Text :: AdminProblem -> DB Text
|
||||
adminProblem2Text adprob = do
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
case adprob of
|
||||
AdminProblemNewCompany{}
|
||||
-> return $ mr MsgAdminProblemNewCompany
|
||||
AdminProblemSupervisorNewCompany{adminProblemSupervisorReroute, adminProblemCompanyNew}
|
||||
-> return $ mr $ SomeMessages [SomeMessage $ MsgAdminProblemSupervisorNewCompany adminProblemSupervisorReroute, company2msg adminProblemCompanyNew]
|
||||
AdminProblemSupervisorLeftCompany{adminProblemSupervisorReroute}
|
||||
-> return $ mr (MsgAdminProblemSupervisorLeftCompany adminProblemSupervisorReroute)
|
||||
AdminProblemCompanySuperiorChange{adminProblemUserOld=mbuid}
|
||||
-> maybeT (return $ mr MsgAdminProblemCompanySuperiorChange) $ do
|
||||
uid <- MaybeT $ pure mbuid
|
||||
User{userDisplayName = udn, userSurname = usn} <- MaybeT $ get uid
|
||||
pure $ mr $ SomeMessages [SomeMessage MsgAdminProblemCompanySuperiorChange, SomeMessage MsgAdminProblemCompanySuperiorPrevious, SomeMessage udn, SomeMessage usn]
|
||||
-- AdminProblemCompanySuperiorChange{adminProblemUserOld=Nothing}
|
||||
-- -> return $ mr MsgAdminProblemCompanySuperiorChange
|
||||
-- AdminProblemCompanySuperiorChange{adminProblemUserOld=Just uid}
|
||||
-- -> get uid >>= \case
|
||||
-- Nothing ->
|
||||
-- return $ mr MsgAdminProblemCompanySuperiorChange
|
||||
-- Just User{userDisplayName = udn, userSurname = usn} ->
|
||||
-- return $ mr $ SomeMessages [SomeMessage MsgAdminProblemCompanySuperiorChange, SomeMessage MsgAdminProblemCompanySuperiorPrevious, SomeMessage udn, SomeMessage usn]
|
||||
AdminProblemCompanySuperiorNotFound{adminProblemUserOld=mbuid, adminProblemEmail=eml}
|
||||
-> let basemsg = MsgAdminProblemCompanySuperiorNotFound $ fromMaybe "???" eml
|
||||
in maybeT (return $ mr basemsg) $ do
|
||||
uid <- MaybeT $ pure mbuid
|
||||
User{userDisplayName = udn, userSurname = usn} <- MaybeT $ get uid
|
||||
pure $ mr $ SomeMessages [SomeMessage basemsg, SomeMessage MsgAdminProblemCompanySuperiorPrevious, SomeMessage udn, SomeMessage usn]
|
||||
AdminProblemNewlyUnsupervised{adminProblemCompanyNew}
|
||||
-> return $ mr $ SomeMessages [SomeMessage MsgAdminProblemNewlyUnsupervised, company2msg adminProblemCompanyNew]
|
||||
AdminProblemUnknown{adminProblemText}
|
||||
-> return $ "Problem: " <> adminProblemText
|
||||
|
||||
-- | Show AdminProblem as message, used in message pop-up after manually switching companies for a user
|
||||
msgAdminProblem :: AdminProblem -> DB (SomeMessages UniWorX)
|
||||
msgAdminProblem AdminProblemNewCompany{adminProblemCompany=comp} = return $
|
||||
SomeMessages [SomeMessage MsgAdminProblemNewCompany, text2message ": ", company2msg comp]
|
||||
@ -193,8 +233,10 @@ msgAdminProblem AdminProblemSupervisorLeftCompany{adminProblemCompany=comp, admi
|
||||
SomeMessages [SomeMessage $ MsgAdminProblemSupervisorLeftCompany rer, text2message ": ", company2msg comp]
|
||||
msgAdminProblem AdminProblemCompanySuperiorChange{adminProblemCompany=comp} = return $
|
||||
SomeMessages [SomeMessage MsgAdminProblemCompanySuperiorChange, text2message ": ", company2msg comp]
|
||||
msgAdminProblem AdminProblemCompanySuperiorNotFound{adminProblemCompany=comp, adminProblemEmail=eml} = return $
|
||||
SomeMessages [SomeMessage $ MsgAdminProblemCompanySuperiorNotFound $ fromMaybe "???" eml, text2message ": ", company2msg comp]
|
||||
msgAdminProblem AdminProblemNewlyUnsupervised{adminProblemCompanyOld=comp, adminProblemCompanyNew=newComp} = return $
|
||||
SomeMessages [SomeMessage MsgAdminProblemNewlyUnsupervised, text2message ": ", maybe (text2message "???") company2msg comp, text2message " -> ", company2msg newComp]
|
||||
SomeMessages [SomeMessage MsgAdminProblemNewlyUnsupervised, text2message ": ", maybe (text2message "???") company2msg comp, text2message " -> ", company2msg newComp]
|
||||
msgAdminProblem AdminProblemUnknown{adminProblemText=err} = return $
|
||||
someMessages ["Problem: ", err]
|
||||
|
||||
|
||||
@ -22,7 +22,7 @@ module Handler.Utils.Avs
|
||||
, computeDifferingLicences
|
||||
-- , synchAvsLicences
|
||||
, queryAvsFullStatus
|
||||
-- , lookupAvsUser, lookupAvsUsers
|
||||
, lookupAvsUser, lookupAvsUsers
|
||||
, AvsException(..)
|
||||
, updateReceivers
|
||||
, AvsPersonIdMapPersonCard
|
||||
@ -51,6 +51,7 @@ import Jobs.Queue
|
||||
|
||||
import Utils.Avs
|
||||
import Utils.Users
|
||||
-- import Utils.Mail (validEmail)
|
||||
import Handler.Utils.Users
|
||||
import Handler.Utils.Company
|
||||
import Handler.Utils.Qualification
|
||||
@ -98,10 +99,10 @@ catchAVS2log :: (MonadHandler m, MonadCatch m, RenderMessage (HandlerSite m) Avs
|
||||
catchAVS2log = catchAVShandler False True False Nothing
|
||||
|
||||
catchAll2log :: (MonadHandler m, MonadCatch m, RenderMessage (HandlerSite m) AvsException) => m a -> m ()
|
||||
catchAll2log = voidMaybe $ catchAVShandler True True False Nothing
|
||||
catchAll2log = voidMaybe catchAll2log'
|
||||
|
||||
-- catchAll2log' :: (MonadHandler m, MonadCatch m, RenderMessage (HandlerSite m) AvsException, Monoid a) => m a -> m ()
|
||||
-- catchAll2log' = voidMaybe $ catchAVShandler True True False mempty
|
||||
catchAll2log' :: (MonadHandler m, MonadCatch m, RenderMessage (HandlerSite m) AvsException) => m (Maybe a) -> m (Maybe a)
|
||||
catchAll2log' = catchAVShandler True True False Nothing
|
||||
|
||||
catchAVShandler :: (MonadHandler m, MonadCatch m, RenderMessage (HandlerSite m) AvsException) => Bool -> Bool -> Bool -> a -> m a -> m a
|
||||
catchAVShandler allEx toLog toMsg dft act = act `catches` (avsHandlers <> allHandlers)
|
||||
@ -328,6 +329,8 @@ updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAv
|
||||
let usrId = userAvsUser usravs
|
||||
usr <- MaybeT $ get usrId
|
||||
lift $ do -- maybeT no longer needed from here onwards
|
||||
uuid :: CryptoUUIDUser <- encrypt usrId
|
||||
$logInfoS "AVS" [st|updateAvsUserByADC: #{tshow uuid}|]
|
||||
let oldAvsPersonInfo = userAvsLastPersonInfo usravs -- Nothing is ok here
|
||||
oldAvsFirmInfo = userAvsLastFirmInfo usravs -- Nothing is ok here
|
||||
oldAvsCardNo = userAvsLastCardNo usravs & fmap Just
|
||||
@ -365,11 +368,12 @@ updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAv
|
||||
, CU_API_UserMatrikelnummer
|
||||
-- , CU_API_UserCompanyPersonalNumber -- needs special treatment, see ldap_ups above
|
||||
]
|
||||
eml_up = mkUpdate usr newAvsDataContact oldAvsDataContact $ mkCheckUpdate CU_ADC_UserDisplayEmail -- Email updates erfolgen nur, wenn identisch. Für Firmen-Email leer lassen.
|
||||
eml_up = mkUpdate usr newAvsDataContact oldAvsDataContact $ mkCheckUpdate CU_ADC_UserDisplayEmail -- DisplayEmail updates erfolgen nur, wenn identisch. Für Firmen-Email leer lassen.
|
||||
-- eml_up2 = mkUpdate usr newAvsFirmInfo oldAvsFirmInfo $ mkCheckUpdate CU_AFI_UserEmail -- Email update erfolgt nur, wenn hier die SuperiorEmail als Fallback gespeichert wurde; UserEmail Uniqueness nicht gewährleistet
|
||||
frm_up = mkUpdate' usr newAvsFirmInfo oldAvsFirmInfo $ mkCheckUpdate CU_AFI_UserPostAddress -- Legacy, if company postal is stored in user; should no longer be true for new users, since company address should now be referenced with UserCompany instead
|
||||
pin_up = mkUpdate' usr newAvsCardNo oldAvsCardNo $ -- Maybe update PDF pin to latest card
|
||||
CheckUpdate UserPinPassword $ to $ fmap avsFullCardNo2pin -- _Just . to avsFullCardNo2pin . re _Just
|
||||
usr_up1 = eml_up `mcons` (frm_up `mcons` (pin_up `mcons` (ldap_ups <> per_ups)))
|
||||
usr_up1 = mconss [eml_up, frm_up, pin_up] $ ldap_ups <> per_ups
|
||||
avs_ups = ((UserAvsNoPerson =.) <$> readMay (avsInfoPersonNo newAvsPersonInfo)) `mcons`
|
||||
[ UserAvsLastSynch =. now
|
||||
, UserAvsLastSynchError =. Nothing
|
||||
@ -378,73 +382,76 @@ updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAv
|
||||
, UserAvsLastCardNo =. newAvsCardNo
|
||||
]
|
||||
|
||||
-- update company association & supervision
|
||||
Entity{entityKey=newCompanyId} <- upsertAvsCompany newAvsFirmInfo oldAvsFirmInfo
|
||||
oldCompanyEnt <- getAvsCompany `traverseJoin` oldAvsFirmInfo
|
||||
primaryCompanyId <- userCompanyCompany <<$>> getUserPrimaryCompany usrId
|
||||
let oldCompanyId = entityKey <$> oldCompanyEnt
|
||||
-- oldCompanyMb = entityVal <$> oldCompanyEnt
|
||||
-- pst_up = if
|
||||
-- -- | isNothing oldCompanyMb || oldCompanyId == primaryCompanyId -- refactor could replace next 4 lines
|
||||
-- -- -> mkUpdate' usr newCompany oldCompanyMb $ CheckUpdate UserPrefersPostal _companyPrefersPostal -- always update if company association is fresh (case should not occur in practice though)
|
||||
-- | isNothing oldCompanyMb
|
||||
-- -> mkUpdateDirect usr newCompany $ CheckUpdate UserPrefersPostal _companyPrefersPostal -- always update if company association is fresh (case should not occur in practice though)
|
||||
-- | oldCompanyId == primaryCompanyId -- && isJust oldCompanyId -- is ensured by previous line
|
||||
-- -> mkUpdate usr newCompany oldCompanyMb $ CheckUpdate UserPrefersPostal _companyPrefersPostal -- possibly change postal preference
|
||||
-- | otherwise
|
||||
-- -> Nothing
|
||||
superReasonComDef = tshow SupervisorReasonCompanyDefault
|
||||
newUserComp = UserCompany usrId newCompanyId False False 1 True -- default value for new company insertion, if no update can be done
|
||||
usr_up2 <- 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
|
||||
|
||||
usr_up2 <- case oldAvsFirmInfo of
|
||||
_ | Just newCompanyId == oldCompanyId -- company unchanged entirely
|
||||
-> return mempty -- => do nothing
|
||||
(Just oafi) | isJust (view _avsFirmPostAddressSimple oafi)
|
||||
&& ((==) `on` view _avsFirmPostAddressSimple) oafi newAvsFirmInfo -- non-empty company address unchanged OR
|
||||
|| isJust (view _avsFirmPrimaryEmail oafi)
|
||||
&& ((==) `on` view _avsFirmPrimaryEmail) oafi newAvsFirmInfo -- non-empty company primary email unchanged
|
||||
-> do -- => just update user company association, keeping supervision privileges
|
||||
case oldCompanyId of
|
||||
Nothing -> void $ insertUnique newUserComp -- it's ok if this already exists
|
||||
Just ocid -> do
|
||||
void $ upsertBySafe (UniqueUserCompany usrId ocid) newUserComp (_userCompanyCompany .~ newCompanyId) -- keep default supervisor settings
|
||||
void $ updateWhere [ UserSupervisorSupervisor ==. usrId -- update company-related supervisions
|
||||
, UserSupervisorCompany ==. Just ocid -- to new company, regardless of
|
||||
, UserSupervisorReason ==. Just superReasonComDef] -- user
|
||||
[ UserSupervisorCompany =. Just newCompanyId]
|
||||
return mempty
|
||||
_ | Just newCompanyId == primaryCompanyId -- old primaryCompany is now also AVS-company
|
||||
-> do
|
||||
whenIsJust oldCompanyId $ \oldCid -> do
|
||||
deleteBy $ UniqueUserCompany usrId oldCid
|
||||
deleteWhere $ (UserSupervisorUser ==. usrId):(UserSupervisorCompany ==. oldCompanyId):(UserSupervisorReason ~=. superReasonComDef)
|
||||
return mempty
|
||||
_ -- company changed completely
|
||||
-> do
|
||||
(pst_up, problems) <- switchAvsUserCompany False False usrId newCompanyId
|
||||
mapM_ reportAdminProblem problems
|
||||
-- Following line does not type, hence additional parameter needed
|
||||
-- return [ u | u@Update{updateField=f} <- pst_up, f /= UserPostAddress ] -- already computed in frm_up above, duplicate update must be prevented (version above accounts for legacy updates)
|
||||
return pst_up
|
||||
-- SPECIALISED CODE, PROBABLY DEPRECATED
|
||||
-- switch user company, keeping old priority
|
||||
-- (getBy . UniqueUserCompany usrId) `traverseJoin` oldCompanyId >>= \case
|
||||
-- Nothing ->
|
||||
-- void $ insertUnique newUserComp
|
||||
-- Just Entity{entityKey=ucidOld, entityVal=UserCompany{userCompanyCompany, userCompanySupervisor, userCompanySupervisorReroute, userCompanyPriority}} -> do
|
||||
-- when userCompanySupervisor $ reportAdminProblem $ AdminProblemSupervisorNewCompany usrId userCompanyCompany newCompanyId userCompanySupervisorReroute
|
||||
-- delete ucidOld
|
||||
-- void $ insertUnique newUserComp{userCompanyPriority} -- keep priority, if insert succeeds
|
||||
-- -- adjust supervison
|
||||
-- let oldCompDefSuperFltr = mconcat [UserSupervisorCompany ~~. oldCompanyId, UserSupervisorReason ~=. superReasonComDef]
|
||||
-- deleteWhere $ (UserSupervisorSupervisor ==. usrId) : oldCompDefSuperFltr
|
||||
-- oldAPs <- deleteWhereCount $ (UserSupervisorUser ==. usrId) : oldCompDefSuperFltr
|
||||
-- addCompanySupervisors newCompanyId usrId
|
||||
-- newAPs <- count $ (UserSupervisorUser ==. usrId) : (UserSupervisorCompany ==. Just newCompanyId) : (UserSupervisorReason ~=. superReasonComDef)
|
||||
-- when (oldAPs > 0 && newAPs <= 0) $ reportAdminProblem $ AdminProblemNewlyUnsupervised usrId oldCompanyId newCompanyId
|
||||
-- return pst_up
|
||||
update usrId $ usr_up2 <> usr_up1 -- update user eventually
|
||||
update uaId avs_ups -- update stored avsinfo for future updates
|
||||
case oldAvsFirmInfo of
|
||||
_ | Just newCompanyId == oldCompanyId -- company unchanged entirely
|
||||
-> return mempty -- => do nothing
|
||||
(Just oafi) | isJust (view _avsFirmPostAddressSimple oafi)
|
||||
&& ((==) `on` view _avsFirmPostAddressSimple) oafi newAvsFirmInfo -- non-empty company address unchanged OR
|
||||
|| isJust (view _avsFirmPrimaryEmail oafi)
|
||||
&& ((==) `on` view _avsFirmPrimaryEmail) oafi newAvsFirmInfo -- non-empty company primary email unchanged
|
||||
-> do -- => just update user company association, keeping supervision privileges
|
||||
case oldCompanyId of
|
||||
Nothing -> void $ insertUnique newUserComp -- it's ok if this already exists
|
||||
Just ocid -> do
|
||||
void $ upsertBySafe (UniqueUserCompany usrId ocid) newUserComp (_userCompanyCompany .~ newCompanyId) -- keep default supervisor settings
|
||||
void $ updateWhere [ UserSupervisorSupervisor ==. usrId -- update company-related supervisions
|
||||
, UserSupervisorCompany ==. Just ocid -- to new company, regardless of
|
||||
, UserSupervisorReason ==. Just superReasonComDef] -- user
|
||||
[ UserSupervisorCompany =. Just newCompanyId]
|
||||
return mempty
|
||||
_ | Just newCompanyId == primaryCompanyId -- old primaryCompany is now also AVS-company
|
||||
-> do
|
||||
whenIsJust oldCompanyId $ \oldCid -> do
|
||||
deleteBy $ UniqueUserCompany usrId oldCid
|
||||
deleteWhere $ (UserSupervisorUser ==. usrId):(UserSupervisorCompany ==. oldCompanyId):(UserSupervisorReason ~=. superReasonComDef)
|
||||
return mempty
|
||||
_ -- company changed completely
|
||||
-> do
|
||||
(pst_up, problems) <- switchAvsUserCompany False False usrId newCompanyId
|
||||
mapM_ reportAdminProblem problems
|
||||
-- Following line does not type, hence additional parameter needed
|
||||
-- return [ u | u@Update{updateField=f} <- pst_up, f /= UserPostAddress ] -- already computed in frm_up above, duplicate update must be prevented (version above accounts for legacy updates)
|
||||
return pst_up
|
||||
-- SPECIALISED CODE, PROBABLY DEPRECATED
|
||||
-- switch user company, keeping old priority
|
||||
-- (getBy . UniqueUserCompany usrId) `traverseJoin` oldCompanyId >>= \case
|
||||
-- Nothing ->
|
||||
-- void $ insertUnique newUserComp
|
||||
-- Just Entity{entityKey=ucidOld, entityVal=UserCompany{userCompanyCompany, userCompanySupervisor, userCompanySupervisorReroute, userCompanyPriority}} -> do
|
||||
-- when userCompanySupervisor $ reportAdminProblem $ AdminProblemSupervisorNewCompany usrId userCompanyCompany newCompanyId userCompanySupervisorReroute
|
||||
-- delete ucidOld
|
||||
-- void $ insertUnique newUserComp{userCompanyPriority} -- keep priority, if insert succeeds
|
||||
-- -- adjust supervison
|
||||
-- let oldCompDefSuperFltr = mconcat [UserSupervisorCompany ~~. oldCompanyId, UserSupervisorReason ~=. superReasonComDef]
|
||||
-- deleteWhere $ (UserSupervisorSupervisor ==. usrId) : oldCompDefSuperFltr
|
||||
-- oldAPs <- deleteWhereCount $ (UserSupervisorUser ==. usrId) : oldCompDefSuperFltr
|
||||
-- addDefaultSupervisors' newCompanyId $ singleton usrId
|
||||
-- newAPs <- count $ (UserSupervisorUser ==. usrId) : (UserSupervisorCompany ==. Just newCompanyId) : (UserSupervisorReason ~=. superReasonComDef)
|
||||
-- when (oldAPs > 0 && newAPs <= 0) $ reportAdminProblem $ AdminProblemNewlyUnsupervised usrId oldCompanyId newCompanyId
|
||||
-- return pst_up
|
||||
update usrId usr_up2 -- update user by company switch first (due to possible conflicts with usr_up2)
|
||||
update usrId usr_up1 -- update user eventually
|
||||
update uaId avs_ups -- update stored avsinfo for future updates
|
||||
return (apid, usrId)
|
||||
|
||||
|
||||
@ -490,13 +497,12 @@ createAvsUserById muid api = do
|
||||
-- check for matching existing user
|
||||
let internalPersNo :: Maybe Text = cpi ^? _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo
|
||||
-- persMail :: Maybe UserEmail = cpi ^? _avsInfoPersonEMail . _Just . from _CI
|
||||
oldUsr <- runDBRead $ do
|
||||
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!
|
||||
oldUsr <- runDB $ do
|
||||
mbUid <- firstJustM $ return muid : maybe [] (\ipn ->
|
||||
[ getKeyByFilter [UserCompanyPersonalNumber ==. Just ipn] -- must ensure filter isnt ==. Nothing
|
||||
, catchAll2log' (Just . entityKey <$> ldapLookupAndUpsert ipn) -- attempt to insert by LDAP first
|
||||
]
|
||||
) internalPersNo
|
||||
mbUAvs <- (getBy . UniqueUserAvsUser) `traverseJoin` mbUid
|
||||
return (mbUid, mbUAvs)
|
||||
usrCardNo <- queryAvsFullCardNo api
|
||||
@ -528,6 +534,7 @@ createAvsUserById muid api = do
|
||||
(Nothing, Nothing) -> do -- create fresh user
|
||||
Entity{entityKey=cid, entityVal=cmp} <- runDB $ upsertAvsCompany firmInfo Nothing -- individual runDB, since no need to rollback
|
||||
let pinPass = avsFullCardNo2pin <$> usrCardNo
|
||||
-- superiorEmail = filterMaybe validEmail $ adc ^. _avsContactFirmInfo . _avsFirmEMailSuperior
|
||||
newUserData = AddUserData
|
||||
{ audTitle = Nothing
|
||||
, audFirstName = cpi ^. _avsInfoFirstName & Text.strip
|
||||
@ -550,17 +557,17 @@ createAvsUserById muid api = do
|
||||
}
|
||||
runDB $ do -- any failure must rollback all DB write transactions here
|
||||
uid <- maybeThrowM (AvsUserCreationFailed api) $ addNewUserDB newUserData
|
||||
let userComp = UserCompany uid cid False False 1 True -- default value for new company insertion, if no update can be done
|
||||
let userComp = UserCompany uid cid False False 1 True Nothing -- default value for new company insertion, if no update can be done
|
||||
void $ insertUnique userComp -- Nothing indicates that the user is already linked to the company (which is unlikely here)
|
||||
-- Supervision
|
||||
addCompanySupervisors cid uid
|
||||
void $ addDefaultSupervisors' cid $ singleton uid
|
||||
-- Save AVS data for future updates
|
||||
insert_ $ usrAvs uid (Just cpi) (Just firmInfo) usrCardNo -- unlikely that uid cannot be linked with avsid, but throw if it is not possible
|
||||
return uid
|
||||
|
||||
|
||||
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))
|
||||
@ -581,16 +588,18 @@ getAvsCompany afi =
|
||||
|
||||
-- | insert a company from AVS firm info or update an existing one based on previous values
|
||||
upsertAvsCompany :: AvsFirmInfo -> Maybe AvsFirmInfo -> DB (Entity Company)
|
||||
-- upsertAvsCompany newAvsFirmInfo (Just oldAvsFirmInfo)
|
||||
-- | newAvsFirmInfo == oldAvsFirmInfo = maybeM (upsertAvsCompany newAvsFirmInfo Nothing) pure $ getAvsCompany newAvsFirmInfo -- firmInfo unchanged, shortcircuit; SHORTCIRCUIT no longer needed, checked at call-site due to result not being wrapped in Maybe
|
||||
upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do
|
||||
mbFirmEnt <- getAvsCompany newAvsFirmInfo -- primarily by AvsId, then Shorthand, then name
|
||||
$logInfoS "AVS" [st|upsertAvsCompany: old #{tshow mbFirmEnt} new #{tshow newAvsFirmInfo}|]
|
||||
cmpEnt <- case (mbFirmEnt, mbOldAvsFirmInfo) of
|
||||
(Nothing, _) -> do -- insert new company, neither AvsId nor Shorthand exist in DB
|
||||
$logInfoS "AVS" [st|upsertAvsCompany: old #{tshow mbOldAvsFirmInfo} new #{tshow newAvsFirmInfo} ent-new #{tshow mbFirmEnt}|]
|
||||
case mbFirmEnt of
|
||||
Nothing -> do -- insert new company, neither AvsId nor Shorthand exist in DB
|
||||
afn <- if 0 < newAvsFirmInfo ^. _avsFirmFirmNo
|
||||
then return $ newAvsFirmInfo ^. _avsFirmFirmNo
|
||||
else maybe (-1) (pred . companyAvsId . entityVal) <$> selectMaybe [CompanyAvsId <. 0] [Asc CompanyAvsId]
|
||||
let upd = flip updateRecord newAvsFirmInfo
|
||||
dmy = Company -- mostly dummy, values are actually prodcued through firmInfo2company below for consistency
|
||||
dmy = Company -- mostly dummy, values are actually produced through firmInfo2company below for consistency
|
||||
{ companyName = newAvsFirmInfo ^. _avsFirmFirm . from _CI
|
||||
, companyShorthand = newAvsFirmInfo ^. _avsFirmAbbreviation . from _CI
|
||||
, companyAvsId = afn
|
||||
@ -602,11 +611,12 @@ upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do
|
||||
$logInfoS "AVS" $ "Insert new company: " <> tshow cmp
|
||||
newCmp <- insertEntity cmp
|
||||
reportAdminProblem $ AdminProblemNewCompany $ entityKey newCmp
|
||||
$logInfoS "AVS" "Insert new company completed."
|
||||
return newCmp
|
||||
|
||||
(Just Entity{entityKey=firmid, entityVal=firm}, oldAvsFirmInfo) -> do -- possibly update existing company, if isJust oldAvsFirmInfo and changed occurred
|
||||
let cmp_ups = mapMaybe (mkUpdate' firm newAvsFirmInfo oldAvsFirmInfo) firmInfo2company
|
||||
(Just Entity{entityKey=firmid, entityVal=firm}) -> do -- possibly update existing company, if isJust oldAvsFirmInfo and identical AvsFirmNo and changes occurred
|
||||
let oldHasSameFirmNo = Just (newAvsFirmInfo ^. _avsFirmFirmNo) == (mbOldAvsFirmInfo ^? _Just . _avsFirmFirmNo)
|
||||
oldAvsFirmInfo = guardOnM oldHasSameFirmNo mbOldAvsFirmInfo
|
||||
cmp_ups = mapMaybe (mkUpdate' firm newAvsFirmInfo oldAvsFirmInfo) firmInfo2company
|
||||
key_ups = mkUpdate' firm newAvsFirmInfo oldAvsFirmInfo firmInfo2key
|
||||
uniq_ups <- mkUpdateCheckUnique' firm newAvsFirmInfo oldAvsFirmInfo firmInfo2companyNo
|
||||
$logInfoS "AVS" [st|Update company #{companyShorthand firm}: #{tshow (length cmp_ups)}, #{tshow (length key_ups)}, #{tshow (length uniq_ups)} for #{tshow oldAvsFirmInfo}|]
|
||||
@ -625,10 +635,8 @@ upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do
|
||||
| otherwise -> $logInfoS "AVS" $ "Update company shorthand failed for " <> ciOriginal cmp_key <> " and " <> ciOriginal alt_key
|
||||
maybeM (return res_cmp) return $ getBy uniq_cmp
|
||||
_otherwise -> return res_cmp
|
||||
$logInfoS "AVS" "Update company completed."
|
||||
$logInfoS "AVS" [st|Update company #{companyShorthand firm} completed.|]
|
||||
return res_cmp2
|
||||
void $ upsertCompanySuperior (Just $ entityKey cmpEnt, newAvsFirmInfo) mbOldAvsFirmInfo -- ensure firmInfo superior is supervisor
|
||||
return cmpEnt
|
||||
where
|
||||
firmInfo2key =
|
||||
CheckUpdate CompanyShorthand $ _avsFirmAbbreviation . from _CI -- Updating primary key works in principle thanks to OnUpdateCascade, but fails due to update get
|
||||
@ -641,49 +649,43 @@ 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 = runMaybeT $ do
|
||||
supemail <- MaybeT . pure $ newAfi ^. _avsFirmEMailSuperior
|
||||
cid <- MaybeT $ altM (pure mbCid) (getAvsCompanyId newAfi)
|
||||
supid <- MaybeT $ altM (guessUserByEmail $ stripCI supemail)
|
||||
(catchAVShandler True True False Nothing $ Just . entityKey <$> ldapLookupAndUpsert supemail)
|
||||
lift $ do
|
||||
let reasonSuperior = Just $ tshow SupervisorReasonAvsSuperior
|
||||
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
|
||||
)
|
||||
deleteWhere [UserSupervisorSupervisor ==. oldSup, UserSupervisorCompany ==. Just cid, UserSupervisorReason ==. reasonSuperior] -- 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)
|
||||
[UserCompanySupervisor =. True, UserCompanyPriority =. maxPrio]
|
||||
|
||||
-- | adjust superiors, assumes that CompanyUser exists for all usrs for given company; does not work otherwise
|
||||
upsertCompanySuperior :: Entity Company -> AvsFirmInfo -> Maybe AvsFirmInfo -> UserId -> DB () -- may return superior (Maybe UserId), but currently not needed
|
||||
upsertCompanySuperior Entity{entityKey=cid, entityVal=Company{}} newAfi oldAfi usrId =
|
||||
let reasonSuperior = Just $ tshow SupervisorReasonAvsSuperior
|
||||
getInsertUid eml = altM (guessUserByEmail $ stripCI eml) (catchAll2log' $ Just . entityKey <$> ldapLookupAndUpsert eml)
|
||||
newAvsNo = newAfi ^. _avsFirmFirmNo
|
||||
oldAvsNo = oldAfi ^? _Just . _avsFirmFirmNo
|
||||
mbSupEmail = newAfi ^. _avsFirmEMailSuperior
|
||||
mbOldEmail = oldAfi ^? _Just . _avsFirmEMailSuperior . _Just
|
||||
getSupId = getInsertUid `traverseJoin` mbSupEmail
|
||||
getOldId = (guessUserByEmail . stripCI) `traverseJoin` mbOldEmail
|
||||
getSupervision :: Maybe UserId -> DB (Maybe (Entity UserSupervisor))
|
||||
getSupervision = traverseJoin (getBy . flip UniqueUserSupervisor usrId)
|
||||
unchangedCompany = oldAvsNo == Just newAvsNo
|
||||
changedSuperior = mbSupEmail /= mbOldEmail -- beware we only have AvsFirmInfo for one user; also both could be Nothing
|
||||
-- 1. not unchangedCompany: do not delete, but ensure that superior supervision is set, since it could be a just a single user company change
|
||||
-- 2. unchangedCompany && not changedSuperior: superior must already been set, short-circuit
|
||||
-- 3. unchangedCompany && changedSuperior: update superior for all users
|
||||
in unless (unchangedCompany && not changedSuperior) $ do -- do nothing if (unchangedCompany && not changedSuperior).
|
||||
mbSupId <- getSupId
|
||||
mbUsrSup <- getSupervision mbSupId
|
||||
-- delete old superiors, if any
|
||||
when (unchangedCompany && changedSuperior) $
|
||||
deleteWhere $ mcons ((UserSupervisorSupervisor !=.) <$> mbSupId)
|
||||
[ UserSupervisorCompany ==. Just cid, UserSupervisorReason ==. reasonSuperior ]
|
||||
unless unchangedCompany $
|
||||
deleteWhere [ UserSupervisorReason ==. reasonSuperior, UserSupervisorUser ==. usrId ]
|
||||
-- ensure superior supervision
|
||||
case (mbSupId, mbUsrSup) of
|
||||
(_ , Just _) -> return () -- supId is already supervisor for uid for any reason
|
||||
(Just supId, Nothing) -> do
|
||||
-- ensure association between company and superior at equal-to-top priority
|
||||
prio <- getCompanyUserMaxPrio supId
|
||||
void $ insertUnique (UserCompany supId cid False False prio True reasonSuperior) -- superior is not a supervisor, do not change existing user company associations
|
||||
|
||||
-- ensure all company associates are irregularly supervised by the superior
|
||||
E.insertSelectWithConflict UniqueUserSupervisor
|
||||
(do
|
||||
usr <- E.from $ E.table @UserCompany
|
||||
@ -695,20 +697,25 @@ upsertCompanySuperior (mbCid, newAfi) mbOldAfi = runMaybeT $ do
|
||||
-- E.&&. othr E.^. UserCompanyCompany E.!=. E.val cid -- redundant due to > above, but likely performance improving
|
||||
-- )
|
||||
return $ UserSupervisor
|
||||
E.<# E.val supid
|
||||
E.<# E.val supId
|
||||
E.<&> (usr E.^. UserCompanyUser)
|
||||
E.<&> E.val (suprEnt ^. _entityVal . _userCompanySupervisorReroute)
|
||||
E.<&> E.false
|
||||
E.<&> E.justVal cid
|
||||
E.<&> E.val reasonSuperior
|
||||
)
|
||||
(\old new ->
|
||||
[ UserSupervisorCompany E.=. E.coalesce [old E.^. UserSupervisorCompany, new E.^. UserSupervisorCompany]
|
||||
, UserSupervisorReason E.=. E.coalesce [old E.^. UserSupervisorReason , new E.^. UserSupervisorReason ]
|
||||
]
|
||||
(\_old _new -> [] -- do not change exisitng supervision
|
||||
-- [ UserSupervisorCompany E.=. new E.^. UserSupervisorCompany
|
||||
-- , UserSupervisorReason E.=. new E.^. UserSupervisorReason
|
||||
-- , UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications
|
||||
-- ]
|
||||
)
|
||||
reportAdminProblem $ AdminProblemCompanySuperiorChange supid cid oldSup
|
||||
return (cid,supid)
|
||||
|
||||
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)
|
||||
@ -879,32 +886,34 @@ avsLicenceDifferences2personLicences AvsLicenceDifferences{..} =
|
||||
<> Set.map (AvsPersonLicence AvsLicenceRollfeld) avsLicenceDiffGrantRollfeld
|
||||
|
||||
computeDifferingLicences :: AvsResponseGetLicences -> Handler (Set AvsPersonLicence)
|
||||
computeDifferingLicences = fmap avsLicenceDifferences2personLicences . getDifferingLicences
|
||||
computeDifferingLicences = fmap (avsLicenceDifferences2personLicences . fst) . getDifferingLicences
|
||||
|
||||
type AvsPersonIdMapPersonCard = Map AvsPersonId (Set AvsDataPersonCard)
|
||||
|
||||
avsResponseStatusMap :: AvsResponseStatus -> AvsPersonIdMapPersonCard
|
||||
avsResponseStatusMap (AvsResponseStatus status) = Map.fromDistinctAscList [(avsStatusPersonID,avsStatusPersonCardStatus) | AvsStatusPerson{..}<- Set.toAscList status]
|
||||
|
||||
retrieveDifferingLicences :: Handler AvsLicenceDifferences
|
||||
retrieveDifferingLicences :: Handler (AvsLicenceDifferences, Set AvsPersonId)
|
||||
retrieveDifferingLicences = fst <$> retrieveDifferingLicences' False
|
||||
|
||||
retrieveDifferingLicencesStatus :: Handler (AvsLicenceDifferences, AvsPersonIdMapPersonCard)
|
||||
retrieveDifferingLicencesStatus :: Handler ((AvsLicenceDifferences, Set AvsPersonId), AvsPersonIdMapPersonCard)
|
||||
retrieveDifferingLicencesStatus = retrieveDifferingLicences' True
|
||||
|
||||
retrieveDifferingLicences' :: Bool -> Handler (AvsLicenceDifferences, AvsPersonIdMapPersonCard)
|
||||
retrieveDifferingLicences' :: Bool -> Handler ((AvsLicenceDifferences, Set AvsPersonId), AvsPersonIdMapPersonCard)
|
||||
retrieveDifferingLicences' getStatus = do
|
||||
#ifdef DEVELOPMENT
|
||||
avsUsrs <- runDB $ selectList [] [LimitTo 444]
|
||||
avsUsrs <- runDBRead $ selectList [] [LimitTo 444]
|
||||
let allLicences = AvsResponseGetLicences $ Set.fromList $
|
||||
[ AvsPersonLicence AvsLicenceVorfeld $ AvsPersonId 77 -- AVS:1 FD:2
|
||||
, AvsPersonLicence AvsLicenceRollfeld $ AvsPersonId 12345678 -- AVS:2 FD:1
|
||||
, AvsPersonLicence AvsLicenceVorfeld $ AvsPersonId 5 -- AVS:1 FD:0 (nichts)
|
||||
, AvsPersonLicence AvsLicenceVorfeld $ AvsPersonId 2 -- AVS:1 FD:0 (ungültig)
|
||||
-- , AvsPersonLicence AvsLicenceVorfeld $ AvsPersonId 4 -- AVS:1 FD:1
|
||||
] ++ [AvsPersonLicence AvsLicenceVorfeld avsid | Entity _ UserAvs{userAvsPersonId = avsid} <- avsUsrs]
|
||||
] ++ [AvsPersonLicence (bool AvsLicenceRollfeld AvsLicenceVorfeld $ even $ avsPersonId avsid) avsid
|
||||
| Entity _ UserAvs{userAvsPersonId = avsid} <- avsUsrs
|
||||
]
|
||||
#else
|
||||
allLicences <- avsQuery AvsQueryGetAllLicences
|
||||
allLicences <- avsQueryNoCache AvsQueryGetAllLicences
|
||||
#endif
|
||||
lDiff <- getDifferingLicences allLicences
|
||||
#ifdef DEVELOPMENT
|
||||
@ -918,7 +927,7 @@ retrieveDifferingLicences' getStatus = do
|
||||
] <>
|
||||
[ AvsStatusPerson avsid $ Set.singleton $ mkAdpc (even $ avsPersonId avsid) AvsCardColorGelb | Entity _ UserAvs{userAvsPersonId = avsid} <- avsUsrs ]
|
||||
#else
|
||||
let statQry = avsLicenceDifferences2LicenceIds lDiff
|
||||
let statQry = avsLicenceDifferences2LicenceIds $ fst lDiff
|
||||
lStat <- if getStatus && notNull statQry
|
||||
then avsQueryNoCache (AvsQueryStatus statQry)
|
||||
-- `catch` handler
|
||||
@ -930,18 +939,18 @@ retrieveDifferingLicences' getStatus = do
|
||||
return (lDiff, avsResponseStatusMap lStat)
|
||||
|
||||
|
||||
getDifferingLicences :: AvsResponseGetLicences -> Handler AvsLicenceDifferences
|
||||
getDifferingLicences :: AvsResponseGetLicences -> Handler (AvsLicenceDifferences, Set AvsPersonId)
|
||||
getDifferingLicences (AvsResponseGetLicences licences) = do
|
||||
now <- liftIO getCurrentTime
|
||||
--let (vorfeld, nonvorfeld) = Set.partition (`avsPersonLicenceIs` AvsLicenceVorfeld) licences
|
||||
-- rollfeld = Set.filter (`avsPersonLicenceIs` AvsLicenceRollfeld) nonvorfeld
|
||||
-- Note: FRADrive users with 'R' also own 'F' qualification, but AvsGetResponseGetLicences yields only either
|
||||
let vorORrollfeld' = Set.dropWhileAntitone (`avsPersonLicenceIsLEQ` AvsNoLicence) licences
|
||||
let vorORrollfeld' = Set.dropWhileAntitone (`avsPersonLicenceIsLEQ` AvsNoLicence) licences -- antitone is ok, see test/Utils/TypesSpec -> "Ord AvsPersonLicence"
|
||||
rollfeld' = Set.dropWhileAntitone (`avsPersonLicenceIsLEQ` AvsLicenceVorfeld) vorORrollfeld'
|
||||
vorORrollfeld = Set.map avsLicencePersonID vorORrollfeld'
|
||||
rollfeld = Set.map avsLicencePersonID rollfeld'
|
||||
|
||||
antijoinAvsLicences :: AvsLicence -> Set AvsPersonId -> DB (Set AvsPersonId,Set AvsPersonId)
|
||||
antijoinAvsLicences :: AvsLicence -> Set AvsPersonId -> DBRead (Set AvsPersonId,Set AvsPersonId)
|
||||
antijoinAvsLicences lic avsLics = fmap unwrapIds $
|
||||
E.select $ do
|
||||
((_qauli :& _qualUser :& usrAvs) :& excl) <-
|
||||
@ -967,19 +976,21 @@ getDifferingLicences (AvsResponseGetLicences licences) = do
|
||||
aux (E.Value(Just api), _) (l,r) = (Set.insert api l, r)
|
||||
aux _ acc = acc -- should never occur
|
||||
|
||||
((vorfGrant, vorfRevoke), (rollGrant, rollRevoke)) <- runDB $ (,)
|
||||
((vorfGrant, vorfRevoke), (rollGrant, rollRevoke)) <- runDBRead $ (,)
|
||||
<$> antijoinAvsLicences AvsLicenceVorfeld vorORrollfeld
|
||||
<*> antijoinAvsLicences AvsLicenceRollfeld rollfeld
|
||||
let setTo0 = vorfRevoke -- revoke driving licences
|
||||
setTo1up = vorfGrant Set.\\ rollGrant -- grant apron driving licence
|
||||
setTo1up = vorfGrant Set.\\ rollGrant -- grant apron driving licence
|
||||
setTo1down = rollRevoke Set.\\ vorfRevoke -- revoke maneuvering area licence, but retain apron driving licence
|
||||
setTo2 = (rollGrant Set.\\ vorfRevoke) `Set.intersection` (vorfGrant `Set.union` vorORrollfeld) -- grant maneuvering driving licence
|
||||
return AvsLicenceDifferences
|
||||
{ avsLicenceDiffRevokeAll = setTo0
|
||||
, avsLicenceDiffGrantVorfeld = setTo1up
|
||||
, avsLicenceDiffRevokeRollfeld = setTo1down
|
||||
, avsLicenceDiffGrantRollfeld = setTo2
|
||||
}
|
||||
rsChanged = rollfeld `Set.intersection` Set.unions [vorfRevoke, rollRevoke, setTo1up] -- maneuvering driving licences to downgrade in AVS
|
||||
alds = AvsLicenceDifferences
|
||||
{ avsLicenceDiffRevokeAll = setTo0
|
||||
, avsLicenceDiffGrantVorfeld = setTo1up
|
||||
, avsLicenceDiffRevokeRollfeld = setTo1down
|
||||
, avsLicenceDiffGrantRollfeld = setTo2
|
||||
}
|
||||
return (alds, rsChanged)
|
||||
{- Cases to consider (AVS_Licence,has_valid_F, has_valid_R) -> (vorfeld@(toset,unset), rollfeld@(toset,unset)) :
|
||||
A (0,0,0) -> ((_,_),(_,_)) : nop; avs_id not returned from queries, no problem
|
||||
B (0,0,1) -> ((_,_),(x,_)) : nop; do nothing -- CHECK since id is returned by roll-query
|
||||
|
||||
@ -67,11 +67,11 @@ instance MkCheckUpdate CU_AvsPersonInfo_User where
|
||||
mkCheckUpdate CU_API_UserFirstName = CheckUpdate UserFirstName _avsInfoFirstName
|
||||
mkCheckUpdate CU_API_UserSurname = CheckUpdate UserSurname _avsInfoLastName
|
||||
mkCheckUpdate CU_API_UserDisplayName = CheckUpdate UserDisplayName _avsInfoDisplayName
|
||||
mkCheckUpdate CU_API_UserBirthday = CheckUpdate UserBirthday _avsInfoDateOfBirth
|
||||
mkCheckUpdate CU_API_UserMobile = CheckUpdate UserMobile _avsInfoPersonMobilePhoneNo
|
||||
mkCheckUpdate CU_API_UserMatrikelnummer = CheckUpdate UserMatrikelnummer $ _avsInfoPersonNo . re _Just -- Maybe im User, aber nicht im AvsInfo; also: `re _Just` work like `to Just
|
||||
mkCheckUpdate CU_API_UserCompanyPersonalNumber = CheckUpdate UserCompanyPersonalNumber $ _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just -- Maybe im User und im AvsInfo; needs special treatment, see ldap_ups abov
|
||||
mkCheckUpdate CU_API_UserLdapPrimaryKey = CheckUpdate UserLdapPrimaryKey $ _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just
|
||||
mkCheckUpdate CU_API_UserBirthday = CheckUpdateMay UserBirthday _avsInfoDateOfBirth
|
||||
mkCheckUpdate CU_API_UserMobile = CheckUpdateMay UserMobile _avsInfoPersonMobilePhoneNo
|
||||
mkCheckUpdate CU_API_UserMatrikelnummer = CheckUpdateMay UserMatrikelnummer $ _avsInfoPersonNo . re _Just -- Maybe im User, aber nicht im AvsInfo; also: `re _Just` work like `to Just
|
||||
mkCheckUpdate CU_API_UserCompanyPersonalNumber = CheckUpdateMay UserCompanyPersonalNumber $ _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just -- Maybe im User und im AvsInfo; needs special treatment, see ldap_ups abov
|
||||
mkCheckUpdate CU_API_UserLdapPrimaryKey = CheckUpdateMay UserLdapPrimaryKey $ _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just
|
||||
-- mkCheckUpdate CU_API_UserDisplayEmail = CheckUpdateOpt UserDisplayEmail $ _avsInfoPersonEMail . _Just . from _CI -- Maybe im AvsInfo, aber nicht im User, daher Opt
|
||||
|
||||
data CU_AvsDataContcat_User
|
||||
@ -82,19 +82,21 @@ data CU_AvsDataContcat_User
|
||||
instance MkCheckUpdate CU_AvsDataContcat_User where
|
||||
type MCU_Rec CU_AvsDataContcat_User = User
|
||||
type MCU_Raw CU_AvsDataContcat_User = AvsDataContact
|
||||
mkCheckUpdate CU_ADC_UserPostAddress = CheckUpdate UserPostAddress _avsContactPrimaryPostAddress
|
||||
mkCheckUpdate CU_ADC_UserPostAddress = CheckUpdateMay UserPostAddress _avsContactPrimaryPostAddress
|
||||
mkCheckUpdate CU_ADC_UserDisplayEmail = CheckUpdateOpt UserDisplayEmail $ _avsContactPrimaryEmail . _Just . from _CI
|
||||
|
||||
data CU_AvsFirmInfo_User
|
||||
= CU_AFI_UserPostAddress
|
||||
-- CU_AFI_UserEmail -- PROBLEM: UserEmail must be unique!
|
||||
-- CU_AFI_UserDisplayEmail -- use _avsContactPrimaryEmailAddress instead
|
||||
deriving (Show, Eq)
|
||||
|
||||
instance MkCheckUpdate CU_AvsFirmInfo_User where
|
||||
type MCU_Rec CU_AvsFirmInfo_User = User
|
||||
type MCU_Raw CU_AvsFirmInfo_User = AvsFirmInfo
|
||||
mkCheckUpdate CU_AFI_UserPostAddress = CheckUpdate UserPostAddress _avsFirmPostAddress
|
||||
-- mkCheckUpdate CU_AFI_UserDisplayEmail = CheckUpdateOpt UserDisplayEmail $ _avsFirmPrimaryEmail . _Just . from _CI -- Maybe im AvsInfo, aber nicht im User, daher Opt
|
||||
mkCheckUpdate CU_AFI_UserPostAddress = CheckUpdateMay UserPostAddress _avsFirmPostAddress
|
||||
-- mkCheckUpdate CU_AFI_UserEmail = CheckUpdateOpt UserEmail $ _avsFirmEMailSuperior . _Just . from _CI -- in rare cases, firm superior email is used as fallback here; but UserEmail must be unique!
|
||||
-- mkCheckUpdate CU_AFI_UserDisplayEmail = CheckUpdateOpt UserDisplayEmail $ _avsFirmPrimaryEmail . _Just . from _CI -- Maybe im AvsInfo, aber nicht im User, daher Opt
|
||||
|
||||
|
||||
-- NOTE: Ensure that the lenses between CU_UserAvs_User and CU_AvsPersonInfo_User/CU_AvsFirmInfo_User agree!
|
||||
|
||||
@ -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")
|
||||
|
||||
@ -21,6 +21,14 @@ import qualified Database.Esqueleto.PostgreSQL as E
|
||||
import Handler.Utils.Users
|
||||
import Handler.Utils.Widgets
|
||||
|
||||
-- Snippet to restrict to primary company only
|
||||
-- E.&&. E.notExists (do
|
||||
-- othr <- E.from $ E.table @UserCompany
|
||||
-- E.where_ $ othr E.^. UserCompanyPriority E.>. userCompany E.^. UserCompanyPriority
|
||||
-- E.&&. othr E.^. UserCompanyUser E.==. userCompany E.^. UserCompanyUser
|
||||
-- E.&&. othr E.^. UserCompanyCompany E.!=. E.val cid -- redundant due to > above, but likely performance improving
|
||||
-- )
|
||||
|
||||
company2msg :: CompanyId -> SomeMessage UniWorX
|
||||
company2msg = text2message . ciOriginal . unCompanyKey
|
||||
|
||||
@ -51,37 +59,94 @@ wgtCompanies = \uid -> do
|
||||
(accPri,accTop,accRem) = procCmp maxPri cs
|
||||
in (max cmpPrio accPri, bool accTop (cmpWgt : accTop) isTop, bool (cmpWgt : accRem) accRem isTop) -- lazy evaluation after repmin example, don't factor out the bool!
|
||||
|
||||
-- TODO: use this function in company view Handler.Firm #157
|
||||
-- | add all company supervisors for a given users
|
||||
addCompanySupervisors :: (MonadIO m, BackendCompatible SqlBackend backend, PersistQueryWrite backend, PersistUniqueWrite backend)
|
||||
=> Key Company -> Key User -> ReaderT backend m ()
|
||||
addCompanySupervisors cid uid =
|
||||
E.insertSelectWithConflict
|
||||
UniqueUserSupervisor
|
||||
( do
|
||||
userCompany <- E.from $ E.table @UserCompany
|
||||
E.where_ $ userCompany E.^. UserCompanyCompany E.==. E.val cid
|
||||
E.&&. userCompany E.^. UserCompanySupervisor
|
||||
-- E.&&. E.notExists (do -- restrict to primary company only
|
||||
-- othr <- E.from $ E.table @UserCompany
|
||||
-- E.where_ $ othr E.^. UserCompanyPriority E.>. userCompany E.^. UserCompanyPriority
|
||||
-- E.&&. othr E.^. UserCompanyUser E.==. userCompany E.^. UserCompanyUser
|
||||
-- E.&&. othr E.^. UserCompanyCompany E.!=. E.val cid -- redundant due to > above, but likely performance improving
|
||||
-- )
|
||||
type AnySuperReason = Either SupervisorReason (Maybe Text)
|
||||
|
||||
return $ UserSupervisor
|
||||
E.<# (userCompany E.^. UserCompanyUser)
|
||||
E.<&> E.val uid
|
||||
E.<&> (userCompany E.^. UserCompanySupervisorReroute)
|
||||
E.<&> E.justVal cid
|
||||
E.<&> E.justVal (tshow SupervisorReasonCompanyDefault)
|
||||
)
|
||||
(\current excluded -> -- Supervision between chosen individuals exists already; keep old reason and company, if exists
|
||||
[ UserSupervisorCompany E.=. E.coalesce [current E.^. UserSupervisorCompany, excluded E.^. UserSupervisorCompany] -- do we want this? Ok, since we delete unconditionally first?!
|
||||
, UserSupervisorReason E.=. E.coalesce [current E.^. UserSupervisorReason , excluded E.^. UserSupervisorReason ]
|
||||
]
|
||||
)
|
||||
|
||||
addDefaultSupervisors' :: CompanyId -> NonEmpty UserId -> DB Int64
|
||||
addDefaultSupervisors' = addDefaultSupervisors $ Just $ tshow SupervisorReasonCompanyDefault
|
||||
|
||||
-- adds the default company supervisors as supervisor to a given set of users, which themselves may belong to any company
|
||||
-- if no reason is given, SupervisorReasonCompanyDefault is used, except if reason == Just "NULL"
|
||||
addDefaultSupervisors :: Maybe Text -> CompanyId -> NonEmpty UserId -> DB Int64
|
||||
addDefaultSupervisors reason cid employees = do
|
||||
E.insertSelectWithConflictCount UniqueUserSupervisor
|
||||
(do
|
||||
(spr :& usr) <- E.from $ E.table @UserCompany `E.crossJoin` E.toValues employees
|
||||
E.where_ $ spr E.^. UserCompanyCompany E.==. E.val cid
|
||||
E.&&. spr E.^. UserCompanySupervisor
|
||||
E.distinct $ return $ UserSupervisor
|
||||
E.<# (spr E.^. UserCompanyUser)
|
||||
E.<&> usr
|
||||
E.<&> (spr E.^. UserCompanySupervisorReroute)
|
||||
E.<&> E.justVal cid
|
||||
E.<&> case reason of
|
||||
Nothing -> E.justVal $ tshow SupervisorReasonCompanyDefault
|
||||
Just "NULL" -> E.nothing
|
||||
other -> E.val other
|
||||
)
|
||||
(\old new ->
|
||||
[ UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications
|
||||
, UserSupervisorCompany E.=. E.justVal cid
|
||||
, UserSupervisorReason E.=. E.coalesce [new E.^. UserSupervisorReason, old E.^. UserSupervisorReason] -- keep existing reason, if no new one was given
|
||||
])
|
||||
|
||||
|
||||
-- like `Handler.Utils.addDefaultSupervisors`, but selects all employees of given companies from database, optionally filtered by being under supervision of a given individual
|
||||
-- TODO: check redundancies
|
||||
addDefaultSupervisorsFor :: (CompanyId ~ Element mono, MonoFoldable mono) => Maybe Text -> Maybe UserId -> Bool -> mono -> DB Int64
|
||||
addDefaultSupervisorsFor reason mbSuperId mutualSupervision cids = do
|
||||
E.insertSelectWithConflictCount UniqueUserSupervisor
|
||||
(do
|
||||
(spr :& usr) <- E.from $ E.table @UserCompany `E.innerJoin` E.table @UserCompany `E.on` (\(spr :& usr) -> spr E.^. UserCompanyCompany E.==. usr E.^. UserCompanyCompany)
|
||||
E.where_ $ E.and $ guardMonoid (not mutualSupervision)
|
||||
[ E.not__ $ usr E.^. UserCompanySupervisor ]
|
||||
<> maybeEmpty mbSuperId (\sprId -> [E.exists $ do
|
||||
superv <- E.from $ E.table @UserSupervisor
|
||||
E.where_ $ superv E.^. UserSupervisorSupervisor E.==. E.val sprId
|
||||
E.&&. superv E.^. UserSupervisorUser E.==. usr E.^. UserCompanyUser
|
||||
])
|
||||
<> [ spr E.^. UserCompanySupervisor
|
||||
, spr E.^. UserCompanyCompany `E.in_` E.vals cids
|
||||
, usr E.^. UserCompanyCompany `E.in_` E.vals cids
|
||||
]
|
||||
E.distinct $ return $ UserSupervisor
|
||||
E.<# (spr E.^. UserCompanyUser)
|
||||
E.<&> (usr E.^. UserCompanyUser)
|
||||
E.<&> (spr E.^. UserCompanySupervisorReroute)
|
||||
E.<&> E.just (spr E.^. UserCompanyCompany)
|
||||
E.<&> E.val reason
|
||||
)
|
||||
(\old new ->
|
||||
[ UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications
|
||||
, UserSupervisorCompany E.=. new E.^. UserSupervisorCompany
|
||||
, UserSupervisorReason E.=. E.coalesce [new E.^. UserSupervisorReason, old E.^. UserSupervisorReason] -- keep existing reason, if no new one was given
|
||||
] )
|
||||
|
||||
-- like `addDefaultSupervisors`, but selects all employees of given companies from database
|
||||
-- TODO: check redundancies
|
||||
addDefaultSupervisorsAll :: (CompanyId ~ Element mono, MonoFoldable mono) => Maybe Text -> Bool -> mono -> DB Int64
|
||||
addDefaultSupervisorsAll reason mutualSupervision cids = do
|
||||
E.insertSelectWithConflictCount UniqueUserSupervisor
|
||||
(do
|
||||
(spr :& usr) <- E.from $ E.table @UserCompany `E.innerJoin` E.table @UserCompany `E.on` (\(spr :& usr) -> spr E.^. UserCompanyCompany E.==. usr E.^. UserCompanyCompany)
|
||||
E.where_ $ E.and $ guardMonoid (not mutualSupervision)
|
||||
[ E.not__ $ usr E.^. UserCompanySupervisor ]
|
||||
<> [ spr E.^. UserCompanySupervisor
|
||||
, spr E.^. UserCompanyCompany `E.in_` E.vals cids
|
||||
, usr E.^. UserCompanyCompany `E.in_` E.vals cids
|
||||
]
|
||||
E.distinct $ return $ UserSupervisor
|
||||
E.<# (spr E.^. UserCompanyUser)
|
||||
E.<&> (usr E.^. UserCompanyUser)
|
||||
E.<&> (spr E.^. UserCompanySupervisorReroute)
|
||||
E.<&> E.just (spr E.^. UserCompanyCompany)
|
||||
E.<&> E.val reason
|
||||
)
|
||||
(\old new ->
|
||||
[ UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications
|
||||
, UserSupervisorCompany E.=. new E.^. UserSupervisorCompany
|
||||
, UserSupervisorReason E.=. E.coalesce [old E.^. UserSupervisorReason, new E.^. UserSupervisorReason] -- keep any existing reason
|
||||
] )
|
||||
|
||||
-- | removes user supervisorship on switch. WARNING: problems are not yet written to DB via reportProblem yet
|
||||
switchAvsUserCompany :: Bool -> Bool -> UserId -> CompanyId -> DB ([Update User], [AdminProblem])
|
||||
@ -98,23 +163,29 @@ switchAvsUserCompany usrPostEmailUpds keepOldCompanySupervs uid newCompanyId = d
|
||||
usrPrefPost = userPrefersPostal usrRec
|
||||
usrPrefPostUp = toMaybe (Just usrPrefPost == (mbOldComp ^? _Just . _companyPrefersPostal))
|
||||
(UserPrefersPostal =. companyPrefersPostal newCompany)
|
||||
usrEmail :: UserEmail = userDisplayEmail usrRec
|
||||
-- newCmpEmail :: UserEmail = fromMaybe "" $ companyEmail newCompany
|
||||
usrDisplayEmail :: UserEmail = userDisplayEmail usrRec
|
||||
avsEmail :: Maybe UserEmail = mbUsrAvs ^? _Just . _entityVal . _userAvsLastFirmInfo . _Just . _avsFirmPrimaryEmail . _Just . from _CI
|
||||
usrEmailUp = toMaybe (usrPostEmailUpds && avsEmail == Just usrEmail) (UserDisplayEmail =. "")
|
||||
usrUpdate = catMaybes [usrPostUp, usrPrefPostUp, usrEmailUp]
|
||||
usrDisplayEmailUp = toMaybe (usrPostEmailUpds && avsEmail == Just usrDisplayEmail) (UserDisplayEmail =. "") -- delete DisplayEmail, if equal to AVS Firm Email
|
||||
usrUpdate = catMaybes [usrPostUp, usrPrefPostUp, usrDisplayEmailUp]
|
||||
-- [UserPostAddress =. Nothing, UserPrefersPostal =. companyPrefersPostal newCompany] -- unconditional
|
||||
|
||||
newUserComp = UserCompany uid newCompanyId False False 1 True Nothing -- default value for new company insertion, if no update can be done
|
||||
superReasonComDef = tshow SupervisorReasonCompanyDefault
|
||||
|
||||
-- update uid usrUpdate
|
||||
-- repsertSuperiorSupervisor is not called here, since the Superior is indepentent of the actual company association
|
||||
case mbUsrComp of
|
||||
Nothing -> do -- create company user
|
||||
void $ insertUnique newUserComp
|
||||
addCompanySupervisors newCompanyId uid
|
||||
void $ addDefaultSupervisors Nothing newCompanyId $ singleton uid
|
||||
return (usrUpdate, mempty)
|
||||
Just UserCompany{userCompanyCompany=oldCompanyId, userCompanyPriority=oldPrio, userCompanySupervisor=oldSuper, userCompanySupervisorReroute=oldSuperReroute}
|
||||
Just UserCompany{userCompanyCompany=oldCompanyId, userCompanyPriority=oldPrio, userCompanySupervisor=oldSuper, userCompanySupervisorReroute=oldSuperReroute, userCompanyReason=oldAssocReason}
|
||||
| newCompanyId == oldCompanyId -> return mempty -- nothing to do
|
||||
| otherwise -> do -- switch company
|
||||
void $ upsertBy (UniqueUserCompany uid newCompanyId) newUserComp
|
||||
[UserCompanyPriority =. succ oldPrio, UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False, UserCompanyUseCompanyAddress =. True]
|
||||
when (isNothing oldAssocReason) $ deleteBy $ UniqueUserCompany uid oldCompanyId
|
||||
void $ upsertBy (UniqueUserCompany uid newCompanyId) newUserComp{userCompanyPriority = succ oldPrio}
|
||||
[UserCompanyPriority =. succ oldPrio, UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False, UserCompanyUseCompanyAddress =. True, UserCompanyReason =. Nothing]
|
||||
-- supervised by uid
|
||||
supervisees :: [(Entity UserSupervisor, E.Value Bool)] <- E.select $ do
|
||||
usrSup <- E.from $ E.table @UserSupervisor
|
||||
@ -139,13 +210,34 @@ switchAvsUserCompany usrPostEmailUpds keepOldCompanySupervs uid newCompanyId = d
|
||||
oldAPs <- if keepOldCompanySupervs
|
||||
then updateWhereCount oldSubFltr [UserSupervisorReason =. Nothing]
|
||||
else deleteWhereCount oldSubFltr
|
||||
addCompanySupervisors newCompanyId uid
|
||||
void $ addDefaultSupervisors Nothing newCompanyId $ singleton uid
|
||||
newAPs <- count $ (UserSupervisorCompany ==. Just newCompanyId) : superDeftFltr
|
||||
let isNoLongerSupervised = not keepOldCompanySupervs && oldAPs > 0 && newAPs <= 0
|
||||
problems = bcons oldSuper (AdminProblemSupervisorNewCompany uid oldCompanyId newCompanyId oldSuperReroute)
|
||||
$ bcons isNoLongerSupervised (AdminProblemNewlyUnsupervised uid (Just oldCompanyId) newCompanyId)
|
||||
newlyUnsupervised
|
||||
return (usrUpdate ,problems)
|
||||
where
|
||||
newUserComp = UserCompany uid newCompanyId False False 1 True -- default value for new company insertion, if no update can be done
|
||||
superReasonComDef = tshow SupervisorReasonCompanyDefault
|
||||
|
||||
defaultSupervisorReasonFilter :: [Filter UserSupervisor]
|
||||
defaultSupervisorReasonFilter =
|
||||
[UserSupervisorReason ==. Nothing]
|
||||
||. [UserSupervisorReason ==. Just (tshow SupervisorReasonCompanyDefault)]
|
||||
||. [UserSupervisorReason ==. Just (tshow SupervisorReasonAvsSuperior )]
|
||||
-- ||. [UserSupervisorReason <-. Nothing : [Just $ tshow r | r <- [SupervisorReasonCompanyDefault, SupervisorReasonAvsSuperior]]] -- Does <-. work with Nothing?
|
||||
|
||||
-- | remove supervisors for given users; maybe restricted to those linked to given companies or supervisors
|
||||
deleteDefaultSupervisorsForUsers :: [CompanyId] -> [UserId] -> NonEmpty UserId -> DB Int64
|
||||
deleteDefaultSupervisorsForUsers cids sprs usrs =
|
||||
deleteWhereCount
|
||||
$ bcons (notNull cids) (UserSupervisorCompany <-. (cids <&> Just))
|
||||
$ bcons (notNull sprs) (UserSupervisorSupervisor <-. sprs)
|
||||
$ (UserSupervisorUser <-. toList usrs) : defaultSupervisorReasonFilter
|
||||
|
||||
-- | retrieve maximum company user priority fo a user
|
||||
getCompanyUserMaxPrio :: UserId -> DB Int
|
||||
getCompanyUserMaxPrio uid = do
|
||||
mbMaxPrio <- E.selectOne $ do
|
||||
usrCmp <- E.from $ E.table @UserCompany
|
||||
E.where_ $ usrCmp E.^. UserCompanyUser E.==. E.val uid
|
||||
return . E.max_ $ usrCmp E.^. UserCompanyPriority
|
||||
return $ maybe 1 (fromMaybe 1 . E.unValue) mbMaxPrio
|
||||
|
||||
@ -109,14 +109,14 @@ showCourseEventRoom uid courseEvent = E.or
|
||||
]
|
||||
|
||||
getCourseQualifications :: ( MonadHandler m
|
||||
, backend ~ SqlBackend
|
||||
)
|
||||
, backend ~ SqlBackend
|
||||
)
|
||||
=> CourseId -> ReaderT backend m [Entity Qualification]
|
||||
getCourseQualifications cid = Ex.select $ do
|
||||
getCourseQualifications cid = Ex.select $ do
|
||||
(qual :& courseQual) <-
|
||||
Ex.from $ Ex.table @Qualification
|
||||
`Ex.innerJoin` Ex.table @CourseQualification
|
||||
`Ex.on` (\(qual :& courseQual) -> qual E.^. QualificationId E.==. courseQual E.^. CourseQualificationQualification)
|
||||
`Ex.on` (\(qual :& courseQual) -> qual E.^. QualificationId E.==. courseQual E.^. CourseQualificationQualification)
|
||||
Ex.where_ $ courseQual E.^. CourseQualificationCourse E.==. E.val cid
|
||||
Ex.orderBy [E.asc $ courseQual E.^. CourseQualificationSortOrder]
|
||||
Ex.orderBy [E.asc $ courseQual E.^. CourseQualificationSortOrder, E.asc $ qual E.^. QualificationName]
|
||||
pure qual
|
||||
@ -10,7 +10,8 @@ module Handler.Utils.DateTime
|
||||
, toTimeOfDay
|
||||
, toMidnight, beforeMidnight, toMidday, toMorning
|
||||
, toFullHour, roundDownToMinutes, addHours
|
||||
, formatDiffDays, formatCalendarDiffDays
|
||||
, formatDiffDays, formatDiffHours
|
||||
, formatCalendarDiffDays
|
||||
, formatTime'
|
||||
, formatTime, formatTimeUser, formatTimeW, formatTimeMail
|
||||
, formatTimeRange, formatTimeRangeW, formatTimeRangeMail
|
||||
@ -144,8 +145,8 @@ getDateTimeFormatUser sel mUser = do
|
||||
|
||||
getDateTimeFormatUser' :: SelDateTimeFormat -> User -> DateTimeFormat
|
||||
getDateTimeFormatUser' SelFormatDateTime usr = usr & userDateTimeFormat
|
||||
getDateTimeFormatUser' SelFormatDate usr = usr & userDateFormat
|
||||
getDateTimeFormatUser' SelFormatTime usr = usr & userTimeFormat
|
||||
getDateTimeFormatUser' SelFormatDate usr = usr & userDateFormat
|
||||
getDateTimeFormatUser' SelFormatTime usr = usr & userTimeFormat
|
||||
|
||||
getDateTimeFormatter :: (MonadHandler m, HandlerSite m ~ UniWorX, YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId) => m DateTimeFormatter
|
||||
getDateTimeFormatter = do
|
||||
@ -160,7 +161,7 @@ getDateTimeFormatterUser mUser = do
|
||||
return $ mkDateTimeFormatter locale formatMap appTZ
|
||||
|
||||
getDateTimeFormatterUser' :: (MonadHandler m) => User -> m DateTimeFormatter
|
||||
getDateTimeFormatterUser' usr = do
|
||||
getDateTimeFormatterUser' usr = do
|
||||
locale <- getTimeLocale
|
||||
let formatMap = flip getDateTimeFormatUser' usr
|
||||
return $ mkDateTimeFormatter locale formatMap appTZ
|
||||
@ -263,18 +264,21 @@ formatDiffDays t
|
||||
inHours = tshow $ convertBy nominalHour
|
||||
inMinutes = tshow $ convertBy nominalMinute
|
||||
|
||||
formatDiffHours :: Integral a => a -> Text
|
||||
formatDiffHours = pack . iso8601Show . calendarTimeTime . secondsToNominalDiffTime . (* 3600) . fromIntegral
|
||||
|
||||
formatCalendarDiffDays :: CalendarDiffDays -> Text
|
||||
formatCalendarDiffDays = pack . iso8601Show
|
||||
formatCalendarDiffDays = pack . iso8601Show
|
||||
|
||||
setYear :: Integer -> Day -> Day
|
||||
setYear year date = fromGregorian year m d
|
||||
where
|
||||
(_,m,d) = toGregorian date
|
||||
|
||||
getYear :: Day -> Integer
|
||||
getYear :: Day -> Integer
|
||||
getYear date = y
|
||||
where
|
||||
(y,_,_) = toGregorian date
|
||||
where
|
||||
(y,_,_) = toGregorian date
|
||||
|
||||
dayOfWeekDiff :: DayOfWeek -> DayOfWeek -> Int
|
||||
dayOfWeekDiff a b = mod (fromEnum a - fromEnum b) 7
|
||||
@ -310,10 +314,10 @@ addLocalDays n utct = localTimeToUTCTZ appTZ newLocal
|
||||
-- CalendarDiffDays --
|
||||
----------------------
|
||||
|
||||
fromMonths :: Integral a => a -> CalendarDiffDays
|
||||
fromMonths :: Integral a => a -> CalendarDiffDays
|
||||
fromMonths (toInteger -> m) = CalendarDiffDays { cdMonths = m, cdDays = 0 } -- above is equivalent
|
||||
|
||||
fromDays :: Integral a => a -> CalendarDiffDays
|
||||
fromDays :: Integral a => a -> CalendarDiffDays
|
||||
fromDays (toInteger -> d) = CalendarDiffDays { cdMonths = 0, cdDays = d }
|
||||
|
||||
addDiffDaysClip :: CalendarDiffDays -> UTCTime -> UTCTime
|
||||
@ -393,7 +397,7 @@ formatTimeRangeMail = formatTimeRange' formatTimeMail
|
||||
formatGregorianW :: (YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId) => Integer -> Int -> Int -> WidgetFor UniWorX ()
|
||||
formatGregorianW y m d = formatTimeW SelFormatDate $ fromGregorian y m d
|
||||
|
||||
instance Csv.ToField ZonedTime where
|
||||
instance Csv.ToField ZonedTime where
|
||||
toField = Csv.toField . iso8601Show
|
||||
|
||||
-- also see Data.Time.Clock.Instances
|
||||
|
||||
@ -77,7 +77,7 @@ import qualified Data.Text.Lazy.Builder as Builder
|
||||
-- import Control.Monad.Catch.Pure (runCatch)
|
||||
|
||||
import qualified Data.List.NonEmpty as NonEmpty
|
||||
|
||||
|
||||
{-# ANN module ("HLint: ignore Use const" :: String) #-}
|
||||
|
||||
|
||||
@ -217,7 +217,7 @@ optionalAction'' negated minp justAct fs@FieldSettings{..} defActive csrf = do
|
||||
let actionViews = over (mapped . _fvInput) (\w -> $(widgetFile "widgets/multi-action/optional-action")) actionViews'
|
||||
|
||||
return (doRes >>= bool (pure Nothing) (Just <$> actionRes), over _fvInput (mappend $ toWidget csrf) doView : actionViews)
|
||||
|
||||
|
||||
optionalAction :: AForm Handler a
|
||||
-> FieldSettings UniWorX
|
||||
-> Maybe Bool
|
||||
@ -236,7 +236,7 @@ optionalActionA :: AForm Handler a
|
||||
-> Maybe Bool
|
||||
-> AForm Handler (Maybe a)
|
||||
optionalActionA = optionalActionA' mpopt
|
||||
|
||||
|
||||
optionalActionNegatedA :: AForm Handler a
|
||||
-> FieldSettings UniWorX
|
||||
-> Maybe Bool
|
||||
@ -740,8 +740,7 @@ uploadModeForm fs prev = multiActionA actions fs (classifyUploadMode <$> prev)
|
||||
let iStart = maybe 0 (succ . fst) $ Map.lookupMax oldRess
|
||||
in pure $ Map.singleton iStart fileRes
|
||||
return (addRes', formWidget')
|
||||
miCell _ initFile _ nudge csrf =
|
||||
sFileForm nudge (Just initFile) csrf
|
||||
miCell _ initFile _ nudge = sFileForm nudge (Just initFile)
|
||||
miDelete :: MassInputDelete ListLength
|
||||
miDelete = miDeleteList
|
||||
miAddEmpty _ _ _ = Set.empty
|
||||
@ -966,9 +965,9 @@ genericFileField mkOpts = Field{..}
|
||||
$logDebugS "genericFileField.getPermittedFiles" $ "Additional: " <> tshow fieldAdditionalFiles
|
||||
$logDebugS "genericFileField.getPermittedFiles" $ "Session: " <> tshow sessionFiles'
|
||||
return $ mconcat
|
||||
[ Map.filter (views _3 $ (||) <$> not . fieldOptionForce <*> not . fieldOptionDefault) $ fieldAdditionalFiles ^. _FileReferenceFileReferenceTitleMap
|
||||
[ Map.filter (views _3 $ (||) <$> not . fieldOptionForce <*> not . fieldOptionDefault) $ fieldAdditionalFiles ^. _FileReferenceFileReferenceTitleMap
|
||||
, sessionFiles'
|
||||
, Map.filter (views _3 $ (&&) <$> fieldOptionForce <*> fieldOptionDefault) $ fieldAdditionalFiles ^. _FileReferenceFileReferenceTitleMap
|
||||
, Map.filter (views _3 $ (&&) <$> fieldOptionForce <*> fieldOptionDefault) $ fieldAdditionalFiles ^. _FileReferenceFileReferenceTitleMap
|
||||
]
|
||||
|
||||
handleUpload :: FileField FileReference -> Maybe Text -> ConduitT (File Handler) FileReference (YesodDB UniWorX) ()
|
||||
@ -1002,7 +1001,7 @@ genericFileField mkOpts = Field{..}
|
||||
fieldParse :: [Text] -> [FileInfo] -> m (Either (SomeMessage (HandlerSite m)) (Maybe FileUploads))
|
||||
fieldParse vals files' = runExceptT $ do
|
||||
let files = filter (not . null . fileName) files'
|
||||
|
||||
|
||||
opts@FileField{..} <- liftHandler mkOpts
|
||||
|
||||
mIdent <- fmap getFirst . flip foldMapM vals $ \v ->
|
||||
@ -1116,7 +1115,7 @@ genericFileField mkOpts = Field{..}
|
||||
fuiChecked
|
||||
| Right sentVals' <- sentVals
|
||||
= fuiTitle `Set.member` sentVals'
|
||||
| Just (_, _, FileFieldUserOption{..}) <- Map.lookup fuiTitle $ fieldAdditionalFiles ^. _FileReferenceFileReferenceTitleMap
|
||||
| Just (_, _, FileFieldUserOption{..}) <- Map.lookup fuiTitle $ fieldAdditionalFiles ^. _FileReferenceFileReferenceTitleMap
|
||||
= fieldOptionDefault
|
||||
| otherwise = False
|
||||
fuiSession = fuiTitle `Map.notMember` view _FileReferenceFileReferenceTitleMap fieldAdditionalFiles
|
||||
@ -1201,7 +1200,7 @@ zipFileField :: Bool -- ^ Unpack zips?
|
||||
-> Bool -- ^ Empty files ok?
|
||||
-> Field Handler FileUploads
|
||||
zipFileField doUnpack permittedExtensions emptyOk = zipFileField' doUnpack permittedExtensions emptyOk Nothing
|
||||
|
||||
|
||||
zipFileField' :: Bool -- ^ Unpack zips?
|
||||
-> Maybe (NonNull (Set Extension)) -- ^ Restrictions on file extensions
|
||||
-> Bool -- ^ Empty files ok?
|
||||
@ -1315,16 +1314,16 @@ sheetTypeAFormReq cId fs template = wFormToAForm $ do
|
||||
|
||||
editableExams <- fmap Map.keysSet . flip mapFilterM (foldMap (\(Entity eId exam, Entity _ course, _) -> Map.singleton eId (exam, course)) examParts'') $ \(Exam{..}, Course{..}) ->
|
||||
hasWriteAccessTo $ CExamR courseTerm courseSchool courseShorthand examName EEditR
|
||||
|
||||
|
||||
return (examParts'', editableExams)
|
||||
|
||||
let
|
||||
examParts' = flip foldMap examParts'' $ \(eEnt@(Entity eId _), _, epEnt) -> guardOn @[] (eId `Set.member` editableExams) (eEnt, epEnt)
|
||||
examParts = flip sortOn examParts' $ \(Entity _ Exam{..}, Entity _ ExamPart{..}) -> (examName, examPartNumber)
|
||||
|
||||
|
||||
doExamPartPoints = fmap classifySheetType template == Just ExamPartPoints'
|
||||
|| not (null examParts)
|
||||
|
||||
|
||||
acts = Map.fromList $ catMaybes
|
||||
[ pure ( Normal', Normal <$> gradingReq )
|
||||
, pure ( Bonus' , Bonus <$> gradingReq )
|
||||
@ -1346,7 +1345,7 @@ sheetTypeAFormReq cId fs template = wFormToAForm $ do
|
||||
Informational' -> return $ i18n MsgSheetTypeInfoInformational
|
||||
NotGraded' -> return $ i18n MsgSheetTypeInfoNotGraded
|
||||
ExamPartPoints' -> return $ i18n MsgSheetTypeInfoExamPartPoints
|
||||
|
||||
|
||||
aFormToWForm . explainedMultiActionA acts opts fs $ classifySheetType <$> template
|
||||
|
||||
sheetGroupAFormReq :: FieldSettings UniWorX -> Maybe SheetGroup -> AForm Handler SheetGroup
|
||||
@ -1468,7 +1467,7 @@ jsonField fieldKind = Field{..}
|
||||
{- was only used in workflows; if needed recreate MsgYAMLFieldDecodeFailure
|
||||
yamlField :: ( ToJSON a, FromJSON a
|
||||
, MonadHandler m
|
||||
, RenderMessage (HandlerSite m) FormMessage
|
||||
, RenderMessage (HandlerSite m) FormMessage
|
||||
)
|
||||
=> Field m a
|
||||
yamlField = Field{..}
|
||||
@ -1483,7 +1482,14 @@ yamlField = Field{..}
|
||||
#{either id (decodeUtf8 . Yaml.encode) val}
|
||||
|]
|
||||
fieldEnctype = UrlEncoded
|
||||
-}
|
||||
-}
|
||||
|
||||
|
||||
boolField' :: ( MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
)
|
||||
=> Field m Bool
|
||||
boolField' = boolField (Just $ SomeMessage MsgBoolIrrelevant) -- MsgBoolIrrelevant is shown if the field is optional
|
||||
|
||||
boolField :: ( MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
@ -2309,7 +2315,7 @@ examModeForm mPrev = examMode
|
||||
<*> customPresetForm examRequiredEquipmentEither (Just (SomeMessage MsgExamModeFormNone, Nothing)) (Just (SomeMessage MsgExamModeFormCustom, Nothing)) (id &&& Just . examRequiredEquipmentPresetWidget) (apreq htmlField (fslI MsgExamModeFormRequiredEquipment)) (fslI MsgExamModeFormRequiredEquipment & setTooltip MsgExamModeFormRequiredEquipmentIdentificationTip) (examRequiredEquipment <$> mPrev)
|
||||
where
|
||||
examMode examSynchronicity examOnline examAids examRequiredEquipment = ExamMode{..}
|
||||
|
||||
|
||||
examAidsEither :: Iso' ExamAids (Either StoredMarkup ExamAidsPreset)
|
||||
examAidsEither = iso examAidsToEither examAidsFromEither
|
||||
where examAidsToEither (ExamAidsPreset p) = Right p
|
||||
|
||||
@ -52,13 +52,13 @@ quserToNotify cutoff quser qblock = -- either recently become invalid with no pr
|
||||
quser E.^. QualificationUserScheduleRenewal
|
||||
E.&&. (( quser E.^. QualificationUserValidUntil E.<. E.val (utctDay cutoff)
|
||||
E.&&. quser E.^. QualificationUserValidUntil E.>. E.day (quser E.^. QualificationUserLastNotified)
|
||||
E.&&. E.not_ (E.isFalse (qblock E.?. QualificationUserBlockUnblock)) -- not currently blocked
|
||||
E.&&. E.not__ (E.isFalse (qblock E.?. QualificationUserBlockUnblock)) -- not currently blocked
|
||||
) E.||. ( -- was recently blocked
|
||||
E.isFalse (qblock E.?. QualificationUserBlockUnblock)
|
||||
E.&&. qblock E.?. QualificationUserBlockFrom E.>. E.just (quser E.^. QualificationUserLastNotified)
|
||||
))
|
||||
|
||||
-- condition to ensure that the lastest QualificationUserBlock was picked, better to be used in join-on clauses, since inside a where-clause it might not work as intended
|
||||
-- | condition to ensure that the lastest QualificationUserBlock was picked, better to be used in join-on clauses, since inside a where-clause it might not work as intended
|
||||
isLatestBlockBefore :: E.SqlExpr (Maybe (Entity QualificationUserBlock)) -> E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value Bool)
|
||||
isLatestBlockBefore qualBlock cutoff = (cutoff E.>~. qualBlock E.?. QualificationUserBlockFrom) E.&&. E.notExists (do
|
||||
newerBlock <- E.from $ E.table @QualificationUserBlock
|
||||
@ -71,6 +71,20 @@ isLatestBlockBefore qualBlock cutoff = (cutoff E.>~. qualBlock E.?. Qualificatio
|
||||
))
|
||||
)
|
||||
|
||||
-- | condition to ensure that the lastest QualificationUserBlock was picked, better to be used in join-on clauses, since inside a where-clause it might not work as intended
|
||||
-- variant for inner joins
|
||||
isLatestBlockBefore' :: E.SqlExpr (Entity QualificationUserBlock) -> E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value Bool)
|
||||
isLatestBlockBefore' qualBlock cutoff = (cutoff E.>. qualBlock E.^. QualificationUserBlockFrom) E.&&. E.notExists (do
|
||||
newerBlock <- E.from $ E.table @QualificationUserBlock
|
||||
E.where_ $ newerBlock E.^. QualificationUserBlockQualificationUser E.==. qualBlock E.^. QualificationUserBlockQualificationUser
|
||||
E.&&. newerBlock E.^. QualificationUserBlockFrom E.<=. cutoff
|
||||
E.&&. newerBlock E.^. QualificationUserBlockId E.!=. qualBlock E.^. QualificationUserBlockId
|
||||
E.&&. (( newerBlock E.^. QualificationUserBlockFrom E.>. qualBlock E.^. QualificationUserBlockFrom)
|
||||
E.||. ( newerBlock E.^. QualificationUserBlockUnblock -- in case of equal timestamps, any unblock wins
|
||||
E.&&. (newerBlock E.^. QualificationUserBlockFrom E.==. qualBlock E.^. QualificationUserBlockFrom)
|
||||
))
|
||||
)
|
||||
|
||||
-- cutoff can be `E.val now` or even `Database.Esqueleto.PostgreSQL.now_`
|
||||
quserBlockAux :: Bool -> E.SqlExpr (E.Value UTCTime) -> (E.SqlExpr (E.Value QualificationUserId) -> E.SqlExpr (E.Value Bool)) -> Maybe (E.SqlExpr (Entity QualificationUserBlock) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (E.Value Bool)
|
||||
quserBlockAux negCond cutoff checkQualUserId mbBlockCondition = bool E.notExists E.exists negCond $ do
|
||||
@ -289,3 +303,31 @@ qualificationUserUnblockByReason qid uids mbUnblockTime (qualificationChangeReas
|
||||
E.&&. quserBlockAux True (E.val cutoff) (E.==. (quser E.^. QualificationUserId)) (Just (\qblock -> (qblock E.^. QualificationUserBlockReason) E.==. E.val reason))
|
||||
return $ quser E.^. QualificationUserUser
|
||||
qualificationUserBlocking qid (E.unValue <$> toUnblock) True mbUnblockTime undo_reason notify
|
||||
|
||||
|
||||
-----------
|
||||
-- Forms --
|
||||
-----------
|
||||
|
||||
|
||||
qualificationOption :: Entity Qualification -> Option QualificationId
|
||||
qualificationOption (Entity qid Qualification{..}) =
|
||||
let qsh = ciOriginal $ unSchoolKey qualificationSchool
|
||||
in Option{ optionDisplay = ciOriginal qualificationName <> " (" <> qsh <> ")"
|
||||
, optionExternalValue = toPathPiece $ ciOriginal qualificationShorthand <> "___" <> qsh -- both a publicly known already
|
||||
, optionInternalValue = qid
|
||||
}
|
||||
|
||||
qualificationsOptionList :: [Entity Qualification] -> OptionList QualificationId
|
||||
qualificationsOptionList = mkOptionList . map qualificationOption
|
||||
|
||||
{- Should we encrypt the external value or simply rely on uniqueness? --TODO: still used in Handler.Admin.Avs
|
||||
qualOpt :: Entity Qualification -> Handler (Option QualificationId)
|
||||
qualOpt (Entity qualId qual) = do
|
||||
cQualId :: CryptoUUIDQualification <- encrypt qualId
|
||||
return $ Option
|
||||
{ optionDisplay = ciOriginal $ qualificationName qual
|
||||
, optionInternalValue = qualId
|
||||
, optionExternalValue = tshow cQualId
|
||||
}
|
||||
-}
|
||||
|
||||
@ -32,6 +32,7 @@ spacerCell = cell [whamlet| |]
|
||||
semicolonCell :: IsDBTable m a => DBCell m a
|
||||
semicolonCell = cell [whamlet|; |]
|
||||
|
||||
-- | Contribute to DBResult. BEWARE: only shown cells are executed; pagination makes tellCell useless for rowcounts; instead use dbtProj for computations on all rows regardless of pagination
|
||||
tellCell :: IsDBTable m a => a -> DBCell m a -> DBCell m a
|
||||
tellCell = flip mappend . writerCell . tell
|
||||
|
||||
|
||||
@ -1000,11 +1000,13 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
|
||||
E.<&> (userCompany E.^. UserCompanySupervisorReroute)
|
||||
E.<&> (userCompany E.^. UserCompanyPriority)
|
||||
E.<&> (userCompany E.^. UserCompanyUseCompanyAddress)
|
||||
E.<&> (userCompany E.^. UserCompanyReason)
|
||||
)
|
||||
(\current excluded ->
|
||||
[ UserCompanySupervisor E.=. E.greatest (current E.^. UserCompanySupervisor) (excluded E.^. UserCompanySupervisor) -- t > f
|
||||
, UserCompanyPriority E.=. E.greatest (current E.^. UserCompanyPriority) (excluded E.^. UserCompanyPriority)
|
||||
, UserCompanyUseCompanyAddress E.=. E.greatest (current E.^. UserCompanyUseCompanyAddress) (excluded E.^. UserCompanyUseCompanyAddress)
|
||||
, UserCompanyReason E.=. E.coalesce [current E.^. UserCompanyReason ,excluded E.^. UserCompanyReason]
|
||||
]
|
||||
)
|
||||
deleteWhere [ UserCompanyUser ==. oldUserId]
|
||||
|
||||
@ -93,18 +93,36 @@ nameHtml :: Text -> Text -> Html
|
||||
nameHtml displayName surname
|
||||
| null surname = toHtml displayName
|
||||
| otherwise = case reverse $ T.splitOn surname displayName of
|
||||
[_notContained] -> [shamlet|$newline never
|
||||
[_notContained]
|
||||
| (suffix:prefixes) <- reverse $ T.splitOn (T.toTitle surname) (T.toTitle displayName), notNull prefixes ->
|
||||
let prefix = T.intercalate surname $ reverse prefixes
|
||||
in [shamlet|$newline never
|
||||
#{prefix} #
|
||||
<b .surname>#{surname}
|
||||
\ #{suffix}
|
||||
|]
|
||||
| (suffix:prefixes) <- reverse $ T.splitOn (fullyNormalize surname) (fullyNormalize displayName), notNull prefixes ->
|
||||
let prefix = T.intercalate surname $ reverse prefixes
|
||||
in [shamlet|$newline never
|
||||
#{prefix} #
|
||||
<b .surname>#{surname}
|
||||
\ #{suffix}
|
||||
|]
|
||||
| otherwise -> [shamlet|$newline never
|
||||
#{displayName} (
|
||||
<b .surname>#{surname}
|
||||
)|]
|
||||
(suffix:prefixes) ->
|
||||
let prefix = T.intercalate surname $ reverse prefixes
|
||||
in [shamlet|$newline never
|
||||
#{prefix}
|
||||
#{prefix} #
|
||||
<b .surname>#{surname}
|
||||
#{suffix}
|
||||
\ #{suffix}
|
||||
|]
|
||||
[] -> error "Data.Text.splitOn returned empty list in violation of specification."
|
||||
where
|
||||
fullyNormalize :: Text -> Text
|
||||
fullyNormalize = T.toTitle . T.unwords . map text2asciiAlphaNum . T.words
|
||||
|
||||
nameHtml' :: HasUser u => u -> Html
|
||||
nameHtml' u = nameHtml (u ^. _userDisplayName) (u ^. _userSurname)
|
||||
@ -155,6 +173,23 @@ companyWidget isPrimary (csh, cname, isSupervisor)
|
||||
| otherwise = text2markup corg
|
||||
|
||||
|
||||
---------------------
|
||||
-- Status Tooltips --
|
||||
---------------------
|
||||
|
||||
-- | generate a generic colored icon to display success or failure to user
|
||||
mkErrorFlag :: Handler (Maybe Bool -> Widget)
|
||||
mkErrorFlag = do
|
||||
-- we abuse messageTooltip for colored icons here
|
||||
msgSuccessTooltip <- messageI Success MsgMessageSuccess
|
||||
msgWarningTooltip <- messageI Warning MsgMessageWarning
|
||||
msgErrorTooltip <- messageI Error MsgMessageError
|
||||
let flagError Nothing = messageTooltip msgWarningTooltip
|
||||
flagError (Just False) = messageTooltip msgErrorTooltip
|
||||
flagError (Just True) = messageTooltip msgSuccessTooltip
|
||||
return flagError
|
||||
|
||||
|
||||
----------
|
||||
-- HEAT --
|
||||
----------
|
||||
|
||||
@ -110,7 +110,7 @@ determineCrontab = execWriterT $ do
|
||||
sheetJobs (Entity nSheet Sheet{..}) = do
|
||||
for_ (max <$> sheetVisibleFrom <*> sheetActiveFrom) $ \aFrom -> do
|
||||
tellPrewarmJobs (JobCtlPrewarmSheetFile nSheet SheetExercise) aFrom
|
||||
|
||||
|
||||
when (isn't _JobsOffload appJobMode) $ do
|
||||
tell $ HashMap.singleton
|
||||
(JobCtlQueue $ JobQueueNotification NotificationSheetActive{..})
|
||||
@ -181,7 +181,7 @@ determineCrontab = execWriterT $ do
|
||||
|
||||
runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ sheetJobs
|
||||
|
||||
|
||||
|
||||
when (isn't _JobsOffload appJobMode) $ do
|
||||
case appJobFlushInterval of
|
||||
Just interval | maybe True (> 0) appJobMaxFlush -> tell $ HashMap.singleton
|
||||
@ -396,28 +396,41 @@ determineCrontab = execWriterT $ do
|
||||
whenIsJust appJobLmsQualificationsEnqueueHour $ \hour -> tell $ HashMap.singleton
|
||||
(JobCtlQueue JobLmsQualificationsEnqueue)
|
||||
Cron
|
||||
{ cronInitial = CronAsap -- time after scheduling
|
||||
{ cronInitial = CronAsap -- time after scheduling
|
||||
, cronRepeat = CronRepeatScheduled $ cronCalendarAny { cronDayOfWeek = CronMatchSome . impureNonNull . Set.fromList $ [1..5]
|
||||
, cronHour = cronMatchOne hour -- cronHour = CronMatchSome (impureNonNull $ Set.fromList [3,15] )
|
||||
, cronHour = cronMatchOne hour -- cronHour = CronMatchSome (impureNonNull $ Set.fromList [3,15] )
|
||||
, cronMinute = cronMatchOne 2
|
||||
, cronSecond = cronMatchOne 27
|
||||
}
|
||||
, cronRateLimit = 600 -- minimal time between two executions, before the second job is skipped
|
||||
, cronNotAfter = Right CronNotScheduled -- maximal delay of an execution, before it is skipped entirely
|
||||
}
|
||||
}
|
||||
|
||||
whenIsJust appJobLmsQualificationsDequeueHour $ \hour -> tell $ HashMap.singleton
|
||||
(JobCtlQueue JobLmsQualificationsDequeue)
|
||||
Cron
|
||||
{ cronInitial = CronAsap -- time after scheduling
|
||||
{ cronInitial = CronAsap -- time after scheduling
|
||||
, cronRepeat = CronRepeatScheduled $ cronCalendarAny { cronDayOfWeek = CronMatchSome . impureNonNull . Set.fromList $ [1..5]
|
||||
, cronHour = cronMatchOne hour -- cronHour = CronMatchSome (impureNonNull $ Set.fromList [3,15] )
|
||||
, cronHour = cronMatchOne hour -- cronHour = CronMatchSome (impureNonNull $ Set.fromList [3,15] )
|
||||
, cronMinute = cronMatchOne 7
|
||||
, cronSecond = cronMatchOne 27
|
||||
}
|
||||
, cronRateLimit = 600 -- minimal time between two executions, before the second job is skipped
|
||||
, cronNotAfter = Right CronNotScheduled -- maximal delay of an execution, before it is skipped entirely
|
||||
}
|
||||
}
|
||||
|
||||
when (notNull (avsLicenceSynchTimes appAvsLicenceSynchConf)) $ tell $ HashMap.singleton
|
||||
(JobCtlQueue JobSynchroniseAvsLicences)
|
||||
Cron
|
||||
{ cronInitial = CronAsap
|
||||
, cronRateLimit = 10 -- minimal time between two executions, before the second job is skipped
|
||||
, cronNotAfter = Right CronNotScheduled -- maximal delay of an execution, before it is skipped entirely
|
||||
, cronRepeat = CronRepeatScheduled $ cronCalendarAny { cronDayOfWeek = CronMatchSome . impureNonNull . Set.fromList $ [1..5] --weekdays only
|
||||
, cronHour = CronMatchSome . impureNonNull . Set.fromList $ avsLicenceSynchTimes appAvsLicenceSynchConf
|
||||
, cronMinute = cronMatchOne 1
|
||||
, cronSecond = cronMatchOne 3
|
||||
}
|
||||
}
|
||||
|
||||
let
|
||||
correctorNotifications :: Map (UserId, SheetId) (Max UTCTime) -> WriterT (Crontab JobCtl) (ReaderT SqlReadBackend (HandlerFor UniWorX)) ()
|
||||
@ -455,7 +468,7 @@ determineCrontab = execWriterT $ do
|
||||
ExamPart{examPartExam} <- MaybeT . $cachedHereBinary epId $ get epId
|
||||
Exam{..} <- MaybeT . $cachedHereBinary examPartExam $ get examPartExam
|
||||
return examFinished
|
||||
notifyTime <- hoistMaybe . nBot $ maybe NTop (max `on` NTop) examFinishedTime submissionRatingTime
|
||||
notifyTime <- hoistMaybe . nBot $ maybe NTop (max `on` NTop) examFinishedTime submissionRatingTime
|
||||
tell $ HashMap.singleton
|
||||
(JobCtlQueue . JobQueueNotification $ NotificationSubmissionRated subId)
|
||||
Cron
|
||||
|
||||
@ -46,12 +46,15 @@ fetchRefreshQualifications qidJob = do
|
||||
qids <- E.select $ do
|
||||
q <- E.from $ E.table @Qualification
|
||||
E.where_ $ E.isJust (q E.^. QualificationRefreshWithin)
|
||||
E.||. E.isJust (q E.^. QualificationRefreshReminder)
|
||||
E.||. q E.^. QualificationExpiryNotification
|
||||
pure $ q E.^. QualificationId
|
||||
forM_ qids $ \(E.unValue -> qid) ->
|
||||
queueDBJob $ qidJob qid
|
||||
|
||||
|
||||
-- | enlist expiring qualification holders to e-learning
|
||||
-- Second reminders sent for users with validQualifications and open LMS only
|
||||
-- NOTE: getting rid of QualificationId parameter and using a DB-join fails, since addGregorianDurationClip cannot be performed within DB
|
||||
dispatchJobLmsEnqueue :: QualificationId -> JobHandler UniWorX
|
||||
dispatchJobLmsEnqueue qid = JobHandlerAtomic act
|
||||
@ -62,62 +65,66 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act
|
||||
let qshort = CI.original $ qualificationShorthand quali
|
||||
$logInfoS "LMS" $ "Notifying about expiring qualification " <> qshort
|
||||
now <- liftIO getCurrentTime
|
||||
case qualificationRefreshWithin quali of
|
||||
Nothing -> return () -- TODO: no renewal period, no reminders currently
|
||||
(Just renewalPeriod) -> do
|
||||
let nowaday = utctDay now
|
||||
renewalDate = addGregorianDurationClip renewalPeriod nowaday
|
||||
sendReminders remindPeriod = do
|
||||
let remindDate = addGregorianDurationClip remindPeriod nowaday
|
||||
reminders <- E.select $ do -- TODO: refactor to remove some redundancies with later query
|
||||
(luser :& quser) <- E.from $ E.table @LmsUser `E.innerJoin` E.table @QualificationUser
|
||||
`E.on` (\(luser :& quser) -> luser E.^. LmsUserQualification E.==. quser E.^. QualificationUserQualification
|
||||
E.&&. luser E.^. LmsUserUser E.==. quser E.^. QualificationUserUser
|
||||
)
|
||||
E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid
|
||||
E.&&. quser E.^. QualificationUserScheduleRenewal
|
||||
E.&&. quser E.^. QualificationUserValidUntil E.<=. E.val remindDate
|
||||
E.&&. validQualification now quser
|
||||
E.&&. E.isNothing (luser E.^. LmsUserEnded)
|
||||
E.&&. E.isNothing (luser E.^. LmsUserStatus)
|
||||
E.&&. E.isJust (luser E.^. LmsUserNotified)
|
||||
-- E.&&. ((day_ (luser E.^. LmsUserNotified) E.+. E.interval remindPeriod) E.<. quser E.^. QualificationUserValidUntil) -- not sure whether may throw runtime errors, so we check in Haskell-Land instead
|
||||
return (luser, quser E.^. QualificationUserValidUntil)
|
||||
forM_ reminders $ \case
|
||||
(Entity _ LmsUser{lmsUserUser=luser, lmsUserNotified=Just lnotified}, E.Value quValidUntil)
|
||||
| addGregorianDurationClip remindPeriod (utctDay lnotified) < quValidUntil ->
|
||||
queueDBJob JobUserNotification
|
||||
{ jRecipient = luser
|
||||
, jNotification = NotificationQualificationRenewal { nQualification = qid, nReminder = True }
|
||||
}
|
||||
_ -> return ()
|
||||
-- send second reminders first, before enqueing even more
|
||||
ifNothingM (qualificationRefreshReminder quali) () sendReminders
|
||||
|
||||
renewalUsers <- E.select $ do
|
||||
quser <- E.from $ E.table @QualificationUser
|
||||
E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid
|
||||
E.&&. quser E.^. QualificationUserScheduleRenewal
|
||||
E.&&. quser E.^. QualificationUserValidUntil E.<=. E.val renewalDate
|
||||
E.&&. (quser `qualificationValid` now)
|
||||
E.&&. E.notExists (do
|
||||
luser <- E.from $ E.table @LmsUser
|
||||
E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid
|
||||
E.&&. luser E.^. LmsUserUser E.==. quser E.^. QualificationUserUser
|
||||
E.&&. E.isNothing (luser E.^. LmsUserEnded)
|
||||
)
|
||||
pure quser
|
||||
let usr_job :: Entity QualificationUser -> Job
|
||||
usr_job quser =
|
||||
let uid = quser ^. _entityVal . _qualificationUserUser
|
||||
uex = quser ^. _entityVal . _qualificationUserValidUntil
|
||||
in if qualificationElearningStart quali
|
||||
then JobLmsEnqueueUser { jQualification = qid, jUser = uid }
|
||||
else JobUserNotification { jRecipient = uid, jNotification =
|
||||
NotificationQualificationExpiry { nQualification = qid, nExpiry = uex }
|
||||
}
|
||||
forM_ renewalUsers (queueDBJob . usr_job)
|
||||
logInterface "LMS" (qshort <> "-enq") True (Just $ length renewalUsers) ""
|
||||
let nowaday = utctDay now
|
||||
-- send second reminders first, before enqueing even more, but only for users with currently open LMS and still valid Qualificiations
|
||||
whenIsJust (qualificationRefreshReminder quali) $ \remindPeriod -> do
|
||||
let remindDate = addGregorianDurationClip remindPeriod nowaday
|
||||
reminders <- E.select $ do
|
||||
(luser :& quser) <- E.from $ E.table @LmsUser `E.innerJoin` E.table @QualificationUser
|
||||
`E.on` (\(luser :& quser) -> luser E.^. LmsUserQualification E.==. quser E.^. QualificationUserQualification
|
||||
E.&&. luser E.^. LmsUserUser E.==. quser E.^. QualificationUserUser
|
||||
)
|
||||
E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid
|
||||
E.&&. quser E.^. QualificationUserScheduleRenewal
|
||||
E.&&. quser E.^. QualificationUserValidUntil E.<=. E.val remindDate
|
||||
E.&&. validQualification now quser
|
||||
E.&&. E.isNothing (luser E.^. LmsUserEnded)
|
||||
E.&&. E.isNothing (luser E.^. LmsUserStatus)
|
||||
E.&&. E.isJust (luser E.^. LmsUserNotified)
|
||||
-- E.&&. ((day_ (luser E.^. LmsUserNotified) E.+. E.interval remindPeriod) E.<. quser E.^. QualificationUserValidUntil) -- not sure whether this may throw runtime errors, so we check in Haskell-Land instead
|
||||
return (luser, quser E.^. QualificationUserValidUntil)
|
||||
forM_ reminders $ \case
|
||||
(Entity _ LmsUser{lmsUserUser=luser, lmsUserNotified=Just lnotified}, E.Value quValidUntil)
|
||||
| addGregorianDurationClip remindPeriod (utctDay lnotified) < quValidUntil ->
|
||||
queueDBJob JobUserNotification
|
||||
{ jRecipient = luser
|
||||
, jNotification = NotificationQualificationRenewal { nQualification = qid, nReminder = True }
|
||||
}
|
||||
_ -> return ()
|
||||
-- send initial reminders
|
||||
whenIsJust (qualificationRefreshWithin quali) $ \renewalPeriod -> do -- no refreshWithin, no first reminders
|
||||
let renewalDate = addGregorianDurationClip renewalPeriod nowaday
|
||||
renewalUsers <- E.select $ do
|
||||
quser <- E.from $ E.table @QualificationUser
|
||||
E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid
|
||||
E.&&. quser E.^. QualificationUserScheduleRenewal
|
||||
E.&&. quser E.^. QualificationUserValidUntil E.<=. E.val renewalDate
|
||||
E.&&. (quser `qualificationValid` now)
|
||||
E.&&. E.notExists (do
|
||||
luser <- E.from $ E.table @LmsUser
|
||||
E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid
|
||||
E.&&. luser E.^. LmsUserUser E.==. quser E.^. QualificationUserUser
|
||||
E.&&. E.isNothing (luser E.^. LmsUserEnded)
|
||||
)
|
||||
pure quser
|
||||
let usr_job :: Entity QualificationUser -> Maybe Job
|
||||
usr_job quser =
|
||||
let uid = quser ^. _entityVal . _qualificationUserUser
|
||||
uex = quser ^. _entityVal . _qualificationUserValidUntil
|
||||
unf = quser ^. _entityVal . _qualificationUserLastNotified
|
||||
nfy_cutoff = addGregorianDurationClip renewalPeriod $ utctDay unf
|
||||
do_notify = uex > nfy_cutoff || (uex == nfy_cutoff && utctDayTime now >= utctDayTime unf)
|
||||
in if
|
||||
| qualificationElearningStart quali -- repetition avoided since LmsUser does not exist
|
||||
-> Just $ JobLmsEnqueueUser { jQualification = qid, jUser = uid }
|
||||
| do_notify -- repetition avoided by QualificationUserLastNotified
|
||||
-> Just $ JobUserNotification
|
||||
{ jRecipient = uid
|
||||
, jNotification = NotificationQualificationExpiry { nQualification = qid, nExpiry = uex }
|
||||
}
|
||||
| otherwise -> Nothing
|
||||
forM_ renewalUsers (flip whenIsJust queueDBJob . usr_job)
|
||||
logInterface "LMS" (qshort <> "-enq") True (Just $ length renewalUsers) ""
|
||||
|
||||
dispatchJobLmsEnqueueUser :: QualificationId -> UserId -> JobHandler UniWorX
|
||||
dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act
|
||||
@ -203,6 +210,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
|
||||
-- E.&&. E.isNothing (luser E.^. LmsUserEnded)
|
||||
E.&&. E.not__ (validQualification now quser)
|
||||
pure (luser E.?. LmsUserId, quser E.^. QualificationUserUser)
|
||||
-- TODO: why do we block expired users again? to notify?
|
||||
nrBlocked <- qualificationUserBlocking qid (E.unValue . snd <$> expiredUsers) False (Just now) (Right QualificationBlockExpired) True -- essential that blocks occur only once
|
||||
let expiredLearners = [ luid | (E.Value (Just luid), _) <- expiredUsers ]
|
||||
-- let expiredLearners = catMaybes (E.unValue . fst <$> expiredUsers)
|
||||
@ -405,7 +413,7 @@ dispatchJobLmsReports qid = JobHandlerAtomic act
|
||||
E.<&> E.false)
|
||||
E.insertSelect $ do
|
||||
lrl <- E.from $ E.table @LmsReportLog
|
||||
E.where_ $ E.not_ (lrl E.^. LmsReportLogMissing)
|
||||
E.where_ $ E.not__ (lrl E.^. LmsReportLogMissing)
|
||||
E.&&. lrl E.^. LmsReportLogQualification E.==. E.val qid
|
||||
E.&&. E.notExists (do
|
||||
lreport <- E.from $ E.table @LmsReport
|
||||
|
||||
@ -18,34 +18,52 @@ import qualified Data.Text as Text
|
||||
|
||||
-- import Database.Persist.Sql (deleteWhereCount)
|
||||
-- import Database.Esqueleto.Experimental ((:&)(..))
|
||||
-- import qualified Database.Esqueleto.Experimental as E
|
||||
-- import qualified Database.Esqueleto.Legacy as E
|
||||
import qualified Database.Esqueleto.Experimental as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
-- import qualified Database.Esqueleto.PostgreSQL as E -- for insertSelect variant
|
||||
-- import qualified Database.Esqueleto.Utils as E
|
||||
-- import qualified Database.Esqueleto.Legacy as E
|
||||
|
||||
|
||||
jobPrintAckChunkSize :: Int
|
||||
jobPrintAckChunkSize :: Int
|
||||
jobPrintAckChunkSize = 64
|
||||
|
||||
-- | Maximum length difference between received and stored apcIdent
|
||||
-- APC sometimes sends ids back that are shorter than expected
|
||||
apcIdentMaxDiff :: Int
|
||||
apcIdentMaxDiff = 3
|
||||
|
||||
-- needed, since JobPrintAck cannot requeue itself due to JobNoQueueSame (and having no parameters)
|
||||
dispatchJobPrintAckAgain :: JobHandler UniWorX
|
||||
dispatchJobPrintAckAgain = JobHandlerException act
|
||||
where
|
||||
where
|
||||
act = void $ queueJob JobPrintAck
|
||||
-- liftIO $ threadDelay 3e6 -- wait 3s before continuing UPDATE: no wait needed
|
||||
|
||||
|
||||
|
||||
dispatchJobPrintAck :: JobHandler UniWorX
|
||||
dispatchJobPrintAck = JobHandlerException act
|
||||
where
|
||||
where
|
||||
act = do
|
||||
moretodo <- runDB $ do
|
||||
moretodo <- runDB $ do
|
||||
aliases <- selectList [] [Desc PrintAckIdAliasPriority]
|
||||
let ftransAliases = id : fmap (\Entity{entityVal=PrintAckIdAlias{printAckIdAliasNeedle=n, printAckIdAliasReplacement=r}} -> Text.replace n r) aliases
|
||||
ackOneId ackt apci = selectKeysList [PrintJobApcIdent ==. apci, PrintJobAcknowledged ==. Nothing] [Asc PrintJobCreated, LimitTo 1] >>= \case
|
||||
[pjid] -> update pjid [PrintJobAcknowledged =. Just ackt] >>
|
||||
return True
|
||||
_ -> return False
|
||||
ackOneId ackt apci = selectKeysList [PrintJobApcIdent ==. apci, PrintJobAcknowledged ==. Nothing] [Asc PrintJobCreated, LimitTo 1] >>= \case -- mark oldest as done, if there are multiple with the same identifier
|
||||
[pjid] -> update pjid [PrintJobAcknowledged =. Just ackt] $> True
|
||||
_ -> do
|
||||
pjcs <- E.select $ do
|
||||
let len_apci = Text.length apci
|
||||
ifx_bounds = (E.val $ len_apci - apcIdentMaxDiff, E.val $ len_apci + apcIdentMaxDiff)
|
||||
pj <- E.from $ E.table @PrintJob
|
||||
E.where_ $ E.isNothing (pj E.^. PrintJobAcknowledged)
|
||||
E.&&. (E.length_ (pj E.^. PrintJobApcIdent) `E.between` ifx_bounds)
|
||||
E.&&. (E.isInfixOf (E.val apci) (pj E.^. PrintJobApcIdent)
|
||||
E.||. E.isInfixOf (pj E.^. PrintJobApcIdent) (E.val apci)
|
||||
)
|
||||
E.orderBy [E.asc $ pj E.^. PrintJobCreated] -- mark oldest printjob as done, if there are multiple matching jobs
|
||||
E.limit 1
|
||||
return $ pj E.^. PrintJobId
|
||||
case pjcs of
|
||||
[E.Value pjid] -> update pjid [PrintJobAcknowledged =. Just ackt] $> True
|
||||
_ -> return False
|
||||
procOneId oks Entity{entityKey=paid, entityVal=PrintAcknowledge{printAcknowledgeApcIdent=Text.strip -> apci, printAcknowledgeTimestamp=ackt}} =
|
||||
orM [ackOneId ackt $ ftrans apci | ftrans <- ftransAliases] >>= \case
|
||||
True -> delete paid >> return (succ oks)
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
-- SPDX-FileCopyrightText: 2022-23 Steffen Jost <jost@tcs.ifi.lmu.de>
|
||||
-- SPDX-FileCopyrightText: 2022-24 Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
|
||||
--
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
@ -22,24 +22,22 @@ import Text.Hamlet
|
||||
|
||||
|
||||
dispatchNotificationQualificationExpiry :: QualificationId -> Day -> UserId -> Handler ()
|
||||
dispatchNotificationQualificationExpiry nQualification dExpiry jRecipient = userMailT jRecipient $ do
|
||||
(recipient@User{..}, Qualification{..}) <- liftHandler . runDB $ (,)
|
||||
dispatchNotificationQualificationExpiry nQualification dExpiry jRecipient = do
|
||||
now <- liftIO getCurrentTime
|
||||
encRecipient :: CryptoUUIDUser <- liftHandler $ encrypt jRecipient
|
||||
(recipient@User{..}, Qualification{..}) <- runDB $ (,)
|
||||
<$> getJust jRecipient
|
||||
<*> getJust nQualification
|
||||
|
||||
encRecipient :: CryptoUUIDUser <- liftHandler $ encrypt jRecipient
|
||||
let entRecipient = Entity jRecipient recipient
|
||||
qname = CI.original qualificationName
|
||||
expiryDate <- formatTimeUser SelFormatDate dExpiry $ Just entRecipient
|
||||
|
||||
$logDebugS "LMS" $ "Notify " <> tshow encRecipient <> " about expiry of qualification " <> qname
|
||||
|
||||
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
|
||||
setSubjectI $ MsgMailSubjectQualificationExpiry qname
|
||||
|
||||
editNotifications <- mkEditNotifications jRecipient
|
||||
|
||||
addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/qualificationExpiry.hamlet")
|
||||
userMailT jRecipient $ do
|
||||
expiryDate <- formatTimeUser SelFormatDate dExpiry $ Just entRecipient
|
||||
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
|
||||
setSubjectI $ MsgMailSubjectQualificationExpiry qname
|
||||
editNotifications <- mkEditNotifications jRecipient
|
||||
addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/qualificationExpiry.hamlet")
|
||||
runDB $ updateBy (UniqueQualificationUser nQualification jRecipient) [QualificationUserLastNotified =. now]
|
||||
$logDebugS "LMS" $ "Notified " <> tshow encRecipient <> " about soonish expiry of qualification " <> qname
|
||||
|
||||
|
||||
dispatchNotificationQualificationExpired :: QualificationId -> UserId -> Handler ()
|
||||
@ -81,7 +79,7 @@ dispatchNotificationQualificationExpired nQualification jRecipient = do
|
||||
$logInfoS "LMS" $ "Notified " <> tshow encRecipient <> " about expired qualification " <> qname
|
||||
else
|
||||
$logErrorS "LMS" $ "Failed to notify " <> tshow encRecipient <> " about expired qualification " <> qname
|
||||
else $logInfoS "LMS" $ "Suppressed repeated notification " <> tshow encRecipient <> " about expired qualification " <> qname
|
||||
else $logInfoS "LMS" $ "Suppressed repeated notification " <> tshow encRecipient <> " about expired qualification " <> qname -- should no longer happen to using quserToNotify filter in Jobs.Handler.Lms, but sometimes does after restarts
|
||||
_ -> $logErrorS "LMS" $ "Failed to notify " <> tshow encRecipient <> " about expired qualification " <> tshow nQualification
|
||||
|
||||
|
||||
@ -110,6 +108,7 @@ dispatchNotificationQualificationRenewal nQualification nReminder jRecipient = d
|
||||
, qualSchool = qualificationSchool
|
||||
, qualDuration = qualificationValidDuration
|
||||
, qualRenewAuto = qualificationElearningRenews
|
||||
, qualELimit = qualificationElearningLimit
|
||||
, isReminder = nReminder
|
||||
}
|
||||
$logInfoS "LMS" $ "Notify " <> tshow encRecipient <> " for renewal of qualification " <> qname
|
||||
|
||||
@ -7,11 +7,14 @@ module Jobs.Handler.SynchroniseAvs
|
||||
-- , dispatchJobSynchroniseAvsId
|
||||
-- , dispatchJobSynchroniseAvsUser
|
||||
, dispatchJobSynchroniseAvsQueue
|
||||
, dispatchJobSynchroniseAvsLicences
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Set as Set
|
||||
-- import qualified Data.Map as Map
|
||||
import qualified Data.Conduit.List as C
|
||||
|
||||
import Database.Esqueleto.Experimental ((:&)(..))
|
||||
@ -23,6 +26,7 @@ import qualified Database.Esqueleto.Utils as E
|
||||
import Jobs.Queue
|
||||
|
||||
import Handler.Utils.Avs
|
||||
import Handler.Utils.Qualification
|
||||
|
||||
-- pause is a date in the past; don't synch again if the last synch was after pause
|
||||
dispatchJobSynchroniseAvs :: Natural -> Natural -> Natural -> Maybe Day -> JobHandler UniWorX
|
||||
@ -118,13 +122,66 @@ dispatchJobSynchroniseAvsQueue = JobHandlerException $ do
|
||||
-- E.truncateTable $ AvsSync (error "truncateTable: AvsSyncUser not needed") now Nothing
|
||||
-- return jobs
|
||||
let (unlinked, linked) = foldl' discernJob mempty jobs
|
||||
$logInfoS "SynchronisAvs" [st|AVS synch performing for #{length linked} AVS linked users and #{length unlinked} unlinked users|]
|
||||
$logInfoS "SynchronisAvs" [st|AVS synch start for #{length linked} AVS linked users and #{length unlinked} unlinked users|]
|
||||
void $ updateAvsUserByIds linked
|
||||
void $ linktoAvsUserByUIDs unlinked
|
||||
runDB $ deleteWhere [AvsSyncUser <-. (E.unValue . fst3 <$> jobs)]
|
||||
$logInfoS "SynchronisAvs" [st|AVS synch performed for #{length linked} AVS linked users and #{length unlinked} unlinked users|]
|
||||
$logInfoS "SynchronisAvs" [st|AVS synch end for #{length linked} AVS linked users and #{length unlinked} unlinked users|]
|
||||
-- we do not reschedule failed synchs here in order to avoid a loop
|
||||
where
|
||||
discernJob accs ( _ , E.Value (Just api), E.Value True ) = accs & over _2 (Set.insert api)
|
||||
discernJob accs (E.Value uid, E.Value Nothing , E.Value True ) = accs & over _1 (Set.insert uid)
|
||||
discernJob accs ( _ , _ , E.Value False ) = accs
|
||||
|
||||
|
||||
-----------------
|
||||
-- AVS Licences
|
||||
|
||||
dispatchJobSynchroniseAvsLicences :: JobHandler UniWorX
|
||||
-- dispatchJobSynchroniseAvsLicences = error "TODO"
|
||||
dispatchJobSynchroniseAvsLicences = JobHandlerException $ do -- when (synchLevel > 0) $ do
|
||||
AvsLicenceSynchConf
|
||||
{ avsLicenceSynchLevel = synchLevel -- SynchLevel corresponds to tables of ProblemAvsSynchR: 4=top grant R, 3= reduce R->F, 2= grant F, 1= revoke F
|
||||
, avsLicenceSynchReasonFilter = reasonFilter
|
||||
, avsLicenceSynchMaxChanges = maxChanges
|
||||
} <- getsYesod $ view _appAvsLicenceSynchConf
|
||||
|
||||
let procLic :: AvsLicence -> Bool -> Set AvsPersonId -> Handler ()
|
||||
procLic aLic up apids
|
||||
| n <- Set.size apids, n > 0 =
|
||||
let subtype = Text.cons (bool '↧' '↥' up) $ Text.singleton $ licence2char aLic
|
||||
logit errm = runDB $ logInterface' "AVS" subtype False (isNothing errm) (Just n) (fromMaybe "Automatic synch" errm)
|
||||
catchAllAvs = flip catch (\err -> logit (Just $ tshow (err :: SomeException)) >> return (-1))
|
||||
in if NTop (Just n) <= NTop maxChanges
|
||||
then do
|
||||
oks <- catchAllAvs $ setLicencesAvs $ Set.map (AvsPersonLicence aLic) apids
|
||||
when (oks > 0) $ logit $ toMaybe (oks /= n) [st|Only #{tshow oks}/#{tshow n} licence changes accepted by AVS|]
|
||||
else
|
||||
logit $ Just [st|Too many changes at once. Consider increasing avs-licence-synch-max-changes #{tshow maxChanges}|]
|
||||
| otherwise = return ()
|
||||
|
||||
(AvsLicenceDifferences{..}, rsChanged) <- retrieveDifferingLicences
|
||||
-- prevent automatic changes to users blocked with certain reasons and with currently being associated with multiple companies
|
||||
reasonFltrdIds <- ifNothingM reasonFilter mempty $ \reasons -> do
|
||||
now <- liftIO getCurrentTime
|
||||
firmBlocks <- runDBRead $ E.select $ do
|
||||
(uavs :& _qualUser :& qblock) <- E.from $ E.table @UserAvs
|
||||
`E.innerJoin` E.table @QualificationUser `E.on` (\(uavs :& qualUser) -> uavs E.^. UserAvsUser E.==. qualUser E.^. QualificationUserUser)
|
||||
`E.innerJoin` E.table @QualificationUserBlock `E.on` (\(_uavs :& qualUser :& qblock) ->
|
||||
qualUser E.^. QualificationUserId E.==. qblock E.^. QualificationUserBlockQualificationUser
|
||||
E.&&. qblock `isLatestBlockBefore'` E.val now)
|
||||
E.where_ $ (qblock E.^. QualificationUserBlockReason E.~*. E.val reasons)
|
||||
E.&&. uavs E.^. UserAvsPersonId `E.in_` E.vals (Set.unions [avsLicenceDiffRevokeAll, avsLicenceDiffRevokeRollfeld, avsLicenceDiffGrantVorfeld, avsLicenceDiffGrantRollfeld])
|
||||
return $ uavs E.^. UserAvsPersonId
|
||||
return $ Set.fromList $ map E.unValue firmBlocks
|
||||
|
||||
let fltrIds
|
||||
| synchLevel >= 5 = id
|
||||
| synchLevel >= 3 = flip Set.difference reasonFltrdIds
|
||||
| otherwise = flip Set.difference $ reasonFltrdIds `Set.union` rsChanged
|
||||
|
||||
when (synchLevel >= 1) $ procLic AvsNoLicence False $ fltrIds avsLicenceDiffRevokeAll --revoke Vorfeld and maybe also Rollfeld
|
||||
when (synchLevel >= 2) $ procLic AvsLicenceVorfeld True $ fltrIds avsLicenceDiffGrantVorfeld --grant Vorfeld
|
||||
when (synchLevel >= 3) $ procLic AvsLicenceVorfeld False $ fltrIds avsLicenceDiffRevokeRollfeld --downgrade Rollfeld -> Vorfeld
|
||||
when (synchLevel >= 4) $ procLic AvsLicenceRollfeld True $ fltrIds avsLicenceDiffGrantRollfeld --grant Rollfeld
|
||||
|
||||
|
||||
@ -3,7 +3,9 @@
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
module Jobs.Handler.SynchroniseLdap
|
||||
( dispatchJobSynchroniseLdap, dispatchJobSynchroniseLdapUser
|
||||
( dispatchJobSynchroniseLdap
|
||||
, dispatchJobSynchroniseLdapUser
|
||||
, dispatchJobSynchroniseLdapAll
|
||||
, SynchroniseLdapException(..)
|
||||
) where
|
||||
|
||||
@ -49,7 +51,7 @@ dispatchJobSynchroniseLdapUser jUser = JobHandlerException $ do
|
||||
Just ldapPool ->
|
||||
runDB . void . runMaybeT . handleExc $ do
|
||||
user@User{userIdent,userLdapPrimaryKey} <- MaybeT $ get jUser
|
||||
let upsertIdent = maybe userIdent CI.mk userLdapPrimaryKey
|
||||
let upsertIdent = maybe userIdent CI.mk userLdapPrimaryKey
|
||||
$logInfoS "SynchroniseLdap" [st|Synchronising #{upsertIdent}|]
|
||||
|
||||
reTestAfter <- getsYesod $ view _appLdapReTestFailover
|
||||
@ -62,3 +64,6 @@ dispatchJobSynchroniseLdapUser jUser = JobHandlerException $ do
|
||||
handleExc
|
||||
= catchMPlus (Proxy @CampusUserException)
|
||||
. catchMPlus (Proxy @CampusUserConversionException)
|
||||
|
||||
dispatchJobSynchroniseLdapAll :: JobHandler UniWorX
|
||||
dispatchJobSynchroniseLdapAll = JobHandlerAtomic . runConduit $ selectSource [] [] .| C.mapM_ (queueDBJob . JobSynchroniseLdapUser . entityKey)
|
||||
@ -97,6 +97,7 @@ data Job
|
||||
, jIteration :: Natural
|
||||
}
|
||||
| JobSynchroniseLdapUser { jUser :: UserId }
|
||||
| JobSynchroniseLdapAll
|
||||
| JobSynchroniseAvs { jNumIterations
|
||||
, jEpoch
|
||||
, jIteration :: Natural
|
||||
@ -109,6 +110,7 @@ data Job
|
||||
-- , jSynchAfter :: Maybe Day
|
||||
-- }
|
||||
| JobSynchroniseAvsQueue
|
||||
| JobSynchroniseAvsLicences
|
||||
| JobChangeUserDisplayEmail { jUser :: UserId
|
||||
, jDisplayEmail :: UserEmail
|
||||
}
|
||||
@ -349,6 +351,7 @@ jobNoQueueSame = \case
|
||||
JobDeleteTransactionLogIPs{} -> Just JobNoQueueSame
|
||||
JobSynchroniseLdap{} -> Just JobNoQueueSame
|
||||
JobSynchroniseLdapUser{} -> Just JobNoQueueSame
|
||||
JobSynchroniseLdapAll{} -> Just JobNoQueueSameTag
|
||||
JobSynchroniseAvs{} -> Just JobNoQueueSame
|
||||
-- JobSynchroniseAvsUser{} -> Just JobNoQueueSame
|
||||
-- JobSynchroniseAvsId{} -> Just JobNoQueueSame
|
||||
|
||||
45
src/Mail.hs
45
src/Mail.hs
@ -38,7 +38,7 @@ module Mail
|
||||
, setDate, setDateCurrent
|
||||
, getMailSmtpData
|
||||
, _addressName, _addressEmail
|
||||
, _mailFrom, _mailTo, _mailCc, _mailBcc, _mailReplyTo, _mailReplyTo', _mailHeaders, _mailHeader, _mailParts
|
||||
, _mailFrom, _mailTo, _mailCc, _mailBcc, _mailReplyTo, _mailReplyTo', _mailHeaders, _mailHeader, _mailHeader', _mailParts
|
||||
, _partType, _partEncoding, _partDisposition, _partFilename, _partHeaders, _partContent
|
||||
) where
|
||||
|
||||
@ -140,9 +140,9 @@ import Web.HttpApiData (ToHttpApiData(toHeader))
|
||||
|
||||
newtype AddressEqIgnoreName = AddressEqIgnoreName { getAddress :: Address }
|
||||
deriving (Show, Generic)
|
||||
instance Eq AddressEqIgnoreName where
|
||||
instance Eq AddressEqIgnoreName where
|
||||
(==) = (==) `on` (addressEmail . getAddress)
|
||||
instance Ord AddressEqIgnoreName where
|
||||
instance Ord AddressEqIgnoreName where
|
||||
compare = compare `on` (addressEmail . getAddress)
|
||||
|
||||
|
||||
@ -159,16 +159,19 @@ _partFilename = _partDisposition . dispositionFilename
|
||||
dispositionFilename _ DefaultDisposition = pure DefaultDisposition
|
||||
|
||||
_mailHeader :: CI ByteString -> Traversal' Mail Text
|
||||
_mailHeader hdrName = _mailHeaders . traverse . filtered (views _1 $ (== hdrName) . CI.mk) . _2
|
||||
_mailHeader = (_mailHeaders .) . _mailHeader'
|
||||
|
||||
_mailReplyTo' :: Lens' Mail Text
|
||||
_mailHeader' :: CI ByteString -> Traversal' Headers Text
|
||||
_mailHeader' hdrName = traverse . filtered (views _1 $ (== hdrName) . CI.mk) . _2
|
||||
|
||||
_mailReplyTo' :: Lens' Mail Text
|
||||
_mailReplyTo' = _mailHeaders . _headerReplyTo'
|
||||
|
||||
_headerReplyTo' :: Lens' Headers Text
|
||||
_headerReplyTo' :: Lens' Headers Text
|
||||
-- Functor f => (Text -> f Text) -> [(ByteString, Text)] -> f [(ByteString, Text)]
|
||||
_headerReplyTo' f hdrs = (\x -> insertAssoc replyto x hdrs) <$> f (maybeMonoid $ lookup replyto hdrs)
|
||||
where
|
||||
replyto = "Reply-To"
|
||||
where
|
||||
replyto = "Reply-To"
|
||||
|
||||
_mailReplyTo :: Lens' Mail Address
|
||||
_mailReplyTo = _mailHeaders . _headerReplyTo
|
||||
@ -176,8 +179,8 @@ _mailReplyTo = _mailHeaders . _headerReplyTo
|
||||
_headerReplyTo :: Lens' Headers Address
|
||||
-- Functor f => (Address -> f Address) -> [(ByteString, Text)] -> f [(ByteString, Text)]
|
||||
_headerReplyTo f hdrs = (\x -> insertAssoc replyto (renderAddress x) hdrs) <$> f (fromString $ unpack $ maybeMonoid $ lookup replyto hdrs)
|
||||
where
|
||||
replyto = "Reply-To"
|
||||
where
|
||||
replyto = "Reply-To"
|
||||
-- _addressEmail :: Lens' Address Text might help to simplify this code?
|
||||
|
||||
newtype MailT m a = MailT { _unMailT :: RWST MailContext MailSmtpData Mail m a }
|
||||
@ -270,7 +273,7 @@ instance Exception MailException
|
||||
class Yesod site => YesodMail site where
|
||||
defaultFromAddress :: (MonadHandler m, HandlerSite m ~ site) => m Address
|
||||
defaultFromAddress = Address Nothing . ("yesod@" <>) . pack <$> liftIO getHostName
|
||||
|
||||
|
||||
envelopeFromAddress :: (MonadHandler m, HandlerSite m ~ site) => m Text
|
||||
envelopeFromAddress = addressEmail <$> defaultFromAddress
|
||||
|
||||
@ -336,12 +339,12 @@ defMailT :: ( MonadHandler m
|
||||
-> MailT m a
|
||||
-> m a
|
||||
defMailT ls (MailT mailC) = do
|
||||
fromAddress <- defaultFromAddress
|
||||
(ret, mail0, smtpData0) <- runRWST mailC ls (emptyMail fromAddress)
|
||||
fromAddress <- defaultFromAddress
|
||||
(ret, mail0, smtpData0) <- runRWST mailC ls (emptyMail fromAddress)
|
||||
mail1 <- maybeT (return mail0) $ do
|
||||
guardM useReplyToInstead -- if sender must be fixed within ObjectIdDomain, use replyTo instead
|
||||
domain <- mailObjectIdDomain
|
||||
let sender = mail0 ^. _mailFrom
|
||||
let sender = mail0 ^. _mailFrom
|
||||
isdomainaddress = (Text.isInfixOf `on` Text.toCaseFold) domain (sender ^. _addressEmail) -- not sure how to use CI.mk and isInfixOf here
|
||||
$logDebugS "Mail" $ "Use ReplyTo instead of Sender: " <> tshow isdomainaddress <> " From was: " <> renderAddress sender <> " From is: " <> renderAddress fromAddress
|
||||
guard isdomainaddress -- allowing foreign senders might be Fraport specific; maybe remove this guard
|
||||
@ -378,7 +381,7 @@ instance Semigroup (PrioritisedAlternatives m) where
|
||||
(<>) = mappenddefault
|
||||
|
||||
instance Monoid (PrioritisedAlternatives m) where
|
||||
mempty = memptydefault
|
||||
mempty = memptydefault
|
||||
|
||||
class YesodMail site => ToMailPart site a where
|
||||
type MailPartReturn site a :: Type
|
||||
@ -452,14 +455,14 @@ instance YesodMail site => ToMailPart site YamlValue where
|
||||
_partContent .= PartContent (fromStrict $ Yaml.encode val)
|
||||
|
||||
|
||||
data NamedMailPart a = NamedMailPart { disposition :: Disposition, namedPart :: a }
|
||||
data NamedMailPart a = NamedMailPart { disposition :: Disposition, namedPart :: a }
|
||||
|
||||
instance ToMailPart site a => ToMailPart site (NamedMailPart a) where
|
||||
type MailPartReturn site (NamedMailPart a) = MailPartReturn site a
|
||||
toMailPart nmp = do
|
||||
r <- toMailPart $ namedPart nmp
|
||||
toMailPart nmp = do
|
||||
r <- toMailPart $ namedPart nmp
|
||||
_partDisposition .= disposition nmp
|
||||
return r
|
||||
return r
|
||||
|
||||
|
||||
addAlternatives :: (MonadMail m)
|
||||
@ -546,7 +549,7 @@ lookupMailHeader :: MonadHeader m => MailHeader -> m (Maybe Text)
|
||||
lookupMailHeader = fmap listToMaybe . getMailHeaders
|
||||
|
||||
mapMailHeader :: MonadHeader m => MailHeader -> (Text -> Text) -> m ()
|
||||
mapMailHeader header f = modifyHeaders $ adjustAssoc f header
|
||||
mapMailHeader header f = modifyHeaders $ adjustAssoc f header
|
||||
|
||||
replaceMailHeaderI :: ( RenderMessage site msg
|
||||
, MonadMail m
|
||||
@ -642,5 +645,5 @@ getMailSmtpData = execWriterT $ do
|
||||
|
||||
tell $ mempty
|
||||
{ smtpRecipients = recps
|
||||
, smtpEnvelopeFrom = Last $ Just from
|
||||
, smtpEnvelopeFrom = Last $ Just from
|
||||
}
|
||||
|
||||
@ -216,7 +216,7 @@ instance PersistFieldSql AvsFullCardNo where
|
||||
parseAvsCardNo :: Text -> Maybe (Either AvsCardNo AvsFullCardNo)
|
||||
parseAvsCardNo = splitDigitsByDot AvsCardNo (AvsFullCardNo . AvsCardNo)
|
||||
|
||||
discernAvsCardPersonalNo :: Text -> Maybe (Either AvsInternalPersonalNo AvsFullCardNo)
|
||||
discernAvsCardPersonalNo :: Text -> Maybe (Either AvsInternalPersonalNo AvsFullCardNo)
|
||||
discernAvsCardPersonalNo = splitDigitsByDot mkAvsInternalPersonalNo (AvsFullCardNo . AvsCardNo)
|
||||
|
||||
-- | Just implies that argument is a whole number or decimal with one single digit after the point. Helper functions receive digit-parts without dot
|
||||
@ -227,7 +227,7 @@ splitDigitsByDot fl fr (Text.span Char.isDigit -> (c, pv))
|
||||
= Just $ Left $ fl c
|
||||
| Just ('.', v) <- Text.uncons pv
|
||||
, Just (Char.isDigit -> True, "") <- Text.uncons v
|
||||
= Just $ Right $ fr c v
|
||||
= Just $ Right $ fr c v
|
||||
splitDigitsByDot _ _ _ = Nothing
|
||||
|
||||
-- The AVS API requires PersonIds sometimes as as mere numbers `AvsPersonId` and sometimes as tagged objects `AvsObjPersonId`
|
||||
@ -453,7 +453,7 @@ deriveJSON defaultOptions
|
||||
} ''AvsStatusPerson
|
||||
|
||||
makeLenses_ ''AvsStatusPerson
|
||||
|
||||
|
||||
|
||||
data AvsDataPerson = AvsDataPerson
|
||||
{ avsPersonFirstName :: Text -- WARNING: name stored as is, but AVS does contain weird whitespaces
|
||||
@ -501,6 +501,12 @@ deriveJSON defaultOptions
|
||||
} ''AvsDataPerson
|
||||
-}
|
||||
|
||||
{- Did not work as intended! Verify, if needed again.
|
||||
hasMultipleFirms :: AvsDataPerson -> Bool
|
||||
hasMultipleFirms AvsDataPerson{avsPersonPersonCards=crds} =
|
||||
1 < Set.size (Set.filter isJust $ Set.map avsDataFirm crds)
|
||||
-}
|
||||
|
||||
data AvsPersonLicence = AvsPersonLicence
|
||||
{ avsLicenceRampLicence :: AvsLicence
|
||||
, avsLicencePersonID :: AvsPersonId
|
||||
@ -551,7 +557,7 @@ _avsInfoDisplayName :: Lens' AvsPersonInfo Text
|
||||
_avsInfoDisplayName = lens g s
|
||||
where
|
||||
g AvsPersonInfo{avsInfoFirstName, avsInfoLastName} = Text.append avsInfoFirstName $ Text.cons ' ' avsInfoLastName
|
||||
s api dn = let (Text.strip -> fn, Text.strip -> ln) = Text.breakOnEnd " " dn
|
||||
s api dn = let (Text.strip -> fn, Text.strip -> ln) = Text.breakOnEnd " " dn
|
||||
in api{avsInfoFirstName = fn, avsInfoLastName = ln}
|
||||
|
||||
|
||||
@ -603,7 +609,7 @@ instance {-# OVERLAPS #-} Canonical (Maybe AvsFirmCommunication) where
|
||||
makeLenses_ ''AvsFirmCommunication
|
||||
_avsCommunicationAddress :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmCommunication (Maybe Text)
|
||||
_avsCommunicationAddress = to mkAddr
|
||||
where
|
||||
where
|
||||
mkAddr AvsFirmCommunication{..} = composeAddress avsCommunicationStreetANDHouseNo avsCommunicationZIPCode avsCommunicationCity avsCommunicationCountry
|
||||
|
||||
instance FromJSON AvsFirmCommunication where
|
||||
@ -645,7 +651,7 @@ _avsFirmPostAddress :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo
|
||||
_avsFirmPostAddress = to mkPost
|
||||
where
|
||||
mkPost afi@AvsFirmInfo{avsFirmFirm} =
|
||||
let someAddr = afi ^. _avsFirmPostAddressSimple
|
||||
let someAddr = afi ^. _avsFirmPostAddressSimple
|
||||
prefAddr = plaintextToStoredMarkup . (avsFirmFirm <>) . Text.cons '\n'
|
||||
in prefAddr <$> someAddr
|
||||
|
||||
@ -657,27 +663,27 @@ _avsFirmPostAddressSimple = to mkPost
|
||||
mkPost AvsFirmInfo{..} =
|
||||
let firmAddr = composeAddress avsFirmStreetANDHouseNo avsFirmZIPCode avsFirmCity avsFirmCountry
|
||||
commAddr = avsFirmCommunication ^. _Just . _avsCommunicationAddress
|
||||
in asum $ [res | res@(Just addr) <- [commAddr, firmAddr], validPostAddressText addr]
|
||||
in asum $ [res | res@(Just addr) <- [commAddr, firmAddr], validPostAddressText addr]
|
||||
|
||||
_avsFirmPrimaryEmail :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe Text)
|
||||
_avsFirmPrimaryEmail = to mkEmail
|
||||
where
|
||||
mkEmail afi =
|
||||
let candidates = catMaybes
|
||||
let candidates = catMaybes
|
||||
[ afi ^. _avsFirmCommunication . _Just . _avsCommunicationEMail
|
||||
, afi ^. _avsFirmEMail
|
||||
, afi ^. _avsFirmEMailSuperior -- only set for Fraport departments, hence this is a non-personal department wide email suitable as company email
|
||||
, afi ^. _avsFirmEMailSuperior -- only set for Fraport departments, hence this is a non-personal department wide email suitable as company email
|
||||
]
|
||||
in pickValidEmail candidates -- should we return an invalid email rather than none?
|
||||
|
||||
-- | Not sure this is useful, since postal is ignored if there is no post address anyway
|
||||
_avsFirmPrefersPostal :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo Bool
|
||||
_avsFirmPrefersPostal = to mkPostPref
|
||||
where
|
||||
where
|
||||
mkPostPref afi = isJust (afi ^. _avsFirmPostAddress) || isNothing (afi ^. _avsFirmPrimaryEmail)
|
||||
|
||||
-- Note _avsFirmAddress is never empty; always includes the company name; consider using user _avsFirmPostAddress instead
|
||||
-- _avsFirmAddress :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo Text
|
||||
-- _avsFirmAddress :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo Text
|
||||
-- _avsFirmAddress = to mkAddr
|
||||
-- where
|
||||
-- mkAddr AvsFirmInfo{..} =
|
||||
@ -726,12 +732,12 @@ makeLenses_ ''AvsDataContact
|
||||
_avsContactPrimaryEmail :: (Profunctor p, Contravariant f) => Optic' p f AvsDataContact (Maybe Text)
|
||||
_avsContactPrimaryEmail = to mkEmail
|
||||
where
|
||||
mkEmail adc =
|
||||
mkEmail adc =
|
||||
let candidates = catMaybes
|
||||
[ adc ^. _avsContactFirmInfo . _avsFirmCommunication . _Just . _avsCommunicationEMail
|
||||
, adc ^. _avsContactFirmInfo . _avsFirmEMail
|
||||
, adc ^. _avsContactPersonInfo . _avsInfoPersonEMail
|
||||
, adc ^. _avsContactFirmInfo . _avsFirmEMailSuperior -- only set for Fraport departments, hence this is a non-personal department wide email suitable as company email
|
||||
-- , adc ^. _avsContactFirmInfo . _avsFirmEMailSuperior -- only set for Fraport departments, hence this is a non-personal department wide email suitable as company email. Superior email is used as systemEmail only.
|
||||
]
|
||||
in pickValidEmail candidates -- should we return an invalid email rather than none?
|
||||
|
||||
@ -848,15 +854,15 @@ fixAvsQueryPerson AvsQueryPerson{avsPersonQueryVersionNo=Nothing, avsPersonQuery
|
||||
= AvsQueryPerson
|
||||
{ avsPersonQueryCardNo = Just acn1
|
||||
, avsPersonQueryVersionNo = Just avc1
|
||||
, avsPersonQueryFirstName = canonical avsPersonQueryFirstName
|
||||
, avsPersonQueryLastName = canonical avsPersonQueryLastName
|
||||
, avsPersonQueryFirstName = canonical avsPersonQueryFirstName
|
||||
, avsPersonQueryLastName = canonical avsPersonQueryLastName
|
||||
, avsPersonQueryInternalPersonalNo = canonical avsPersonQueryInternalPersonalNo
|
||||
}
|
||||
fixAvsQueryPerson AvsQueryPerson{..} = AvsQueryPerson
|
||||
{ avsPersonQueryCardNo = canonical avsPersonQueryCardNo
|
||||
, avsPersonQueryVersionNo = canonical avsPersonQueryVersionNo
|
||||
, avsPersonQueryFirstName = canonical avsPersonQueryFirstName
|
||||
, avsPersonQueryLastName = canonical avsPersonQueryLastName
|
||||
{ avsPersonQueryCardNo = canonical avsPersonQueryCardNo
|
||||
, avsPersonQueryVersionNo = canonical avsPersonQueryVersionNo
|
||||
, avsPersonQueryFirstName = canonical avsPersonQueryFirstName
|
||||
, avsPersonQueryLastName = canonical avsPersonQueryLastName
|
||||
, avsPersonQueryInternalPersonalNo = canonical avsPersonQueryInternalPersonalNo
|
||||
}
|
||||
|
||||
@ -878,7 +884,7 @@ deriveJSON defaultOptions ''AvsQueryGetLicences
|
||||
|
||||
data AvsQueryGetAllLicences = AvsQueryGetAllLicences -- for convenience, encoding AvsQueryGetLicences (AvsObjPersonId avsPersonIdZero)
|
||||
deriving (Eq, Ord, Show, Generic)
|
||||
|
||||
|
||||
newtype AvsQuerySetLicences = AvsQuerySetLicences (Set AvsPersonLicence)
|
||||
deriving (Eq, Ord, Show, Generic)
|
||||
deriveJSON defaultOptions ''AvsQuerySetLicences
|
||||
|
||||
@ -34,6 +34,7 @@ import Data.ByteString.Base32
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import qualified Database.Esqueleto.Experimental as E
|
||||
|
||||
-- ^ `NotificationSettings` is for now a series of boolean checkboxes, i.e. a mapping @NotificationTrigger -> Bool@
|
||||
--
|
||||
@ -121,7 +122,7 @@ instance PathPiece BounceSecret where
|
||||
toPathPiece = CI.foldCase . encodeBase32Unpadded . BA.convert
|
||||
fromPathPiece = fmap BounceSecret . digestFromByteString <=< either (const Nothing) Just . decodeBase32Unpadded . encodeUtf8
|
||||
|
||||
newtype MailContent = MailContent [Alternatives]
|
||||
newtype MailContent = MailContent {getMailContent :: [Alternatives]}
|
||||
deriving (Eq, Show, Generic)
|
||||
deriving newtype (ToJSON, FromJSON)
|
||||
deriving anyclass (Binary, NFData)
|
||||
@ -140,3 +141,5 @@ instance PersistFieldSql MailContentReference where
|
||||
sqlType _ = sqlType $ Proxy @(Digest SHA3_512)
|
||||
|
||||
derivePersistFieldJSON ''MailHeaders
|
||||
|
||||
instance E.SqlString MailHeaders
|
||||
@ -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)
|
||||
|
||||
@ -65,9 +65,11 @@ data SupervisorReason
|
||||
deriving (Eq, Ord, Enum, Bounded, Generic)
|
||||
deriving anyclass (Universe, Finite, NFData)
|
||||
|
||||
-- NOTE: it is intentional not to have an embedRenderMessage here; within the DB, we allow arbitrary text, but we do match on these ones to recognise certain functions
|
||||
-- so do not change values here without a proper migration
|
||||
instance Show SupervisorReason where
|
||||
show SupervisorReasonCompanyDefault = "Firmenstandard"
|
||||
show SupervisorReasonAvsSuperior = "Vorgesetzer"
|
||||
show SupervisorReasonAvsSuperior = "Vorgesetzter"
|
||||
show SupervisorReasonUnknown = "Unbekannt"
|
||||
|
||||
|
||||
|
||||
@ -56,8 +56,7 @@ instance Csv.ToNamedRecord Address where
|
||||
instance Csv.DefaultOrdered Address where
|
||||
headerOrder _ = Csv.header [ "name", "email" ]
|
||||
|
||||
|
||||
newtype MailHeaders = MailHeaders Headers
|
||||
newtype MailHeaders = MailHeaders {toHeaders:: Headers}
|
||||
deriving (Eq, Ord, Read, Show, Generic)
|
||||
deriving anyclass (NFData)
|
||||
|
||||
@ -79,7 +78,7 @@ deriving anyclass instance NFData PartContent
|
||||
deriving anyclass instance NFData Part
|
||||
deriving anyclass instance NFData Address
|
||||
deriving anyclass instance NFData Mail
|
||||
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ constructorTagModifier = camelToPathPiece
|
||||
} ''Encoding
|
||||
|
||||
@ -102,6 +102,8 @@ data AppSettings = AppSettings
|
||||
-- ^ Configuration settings for accessing the LDAP-directory
|
||||
, appAvsConf :: Maybe AvsConf
|
||||
-- ^ Configuration settings for accessing AVS Server (= Ausweis Verwaltungs System)
|
||||
, appAvsLicenceSynchConf :: AvsLicenceSynchConf
|
||||
-- ^ Configuration settings for automatically synching driving licences with AVS
|
||||
, appLprConf :: LprConf
|
||||
-- ^ Configuration settings for accessing a printer queue via lpr for letter mailing
|
||||
, appSmtpConf :: Maybe SmtpConf
|
||||
@ -248,11 +250,11 @@ data AppSettings = AppSettings
|
||||
|
||||
, appCommunicationAttachmentsMaxSize :: Maybe Natural
|
||||
, appCommunicationGlobalCC :: Maybe UserEmail
|
||||
|
||||
|
||||
, appFileChunkingParams :: FastCDCParameters
|
||||
|
||||
, appLegalExternal :: Set LegalExternal
|
||||
|
||||
|
||||
} deriving Show
|
||||
|
||||
|
||||
@ -335,6 +337,21 @@ data AvsConf = AvsConf
|
||||
, avsCacheExpiry :: DiffTime -- Seconds, only for non-licence related queries
|
||||
} deriving (Show)
|
||||
|
||||
data AvsLicenceSynchConf = AvsLicenceSynchConf
|
||||
{ avsLicenceSynchTimes :: [Natural] -- hours, when a synch should occur
|
||||
, avsLicenceSynchLevel :: Int -- 0: No synch, 1: revoke Vorfeld, 2: Grant Vorfeld, 3: Downgrade to Vorfeld, 4: Grant Rollfeld
|
||||
, avsLicenceSynchReasonFilter :: Maybe Text -- regular expression matched case-insensitive against latest block/grant reason, preventing automatic synch to users with this reason AND being associated with multiple companies
|
||||
, avsLicenceSynchMaxChanges :: Maybe Int -- abort synch for group, if there are too many changes overall
|
||||
} deriving (Show)
|
||||
|
||||
instance Default AvsLicenceSynchConf where
|
||||
def = AvsLicenceSynchConf
|
||||
{ avsLicenceSynchTimes = []
|
||||
, avsLicenceSynchLevel = 0
|
||||
, avsLicenceSynchReasonFilter = Nothing
|
||||
, avsLicenceSynchMaxChanges = Nothing
|
||||
}
|
||||
|
||||
data LprConf = LprConf
|
||||
{ lprHost :: String
|
||||
, lprPort :: Int
|
||||
@ -423,11 +440,11 @@ data SettingBotMitigation
|
||||
deriving anyclass (Universe, Finite)
|
||||
|
||||
data LegalExternal = LegalExternal
|
||||
{ externalLanguage :: Lang
|
||||
{ externalLanguage :: Lang
|
||||
, externalImprint :: Text
|
||||
, externalDataProtection :: Text
|
||||
, externalTermsOfUse :: Text
|
||||
, externalPayments :: Text
|
||||
, externalPayments :: Text
|
||||
}
|
||||
deriving (Eq, Ord, Read, Show, Generic)
|
||||
makeLenses_ ''LegalExternal
|
||||
@ -523,7 +540,7 @@ instance FromJSON LmsConf where
|
||||
lmsUploadHeader <- o .: "upload-header"
|
||||
lmsUploadDelimiter <- o .:? "upload-delimiter"
|
||||
lmsDownloadHeader <- o .: "download-header"
|
||||
lmsDownloadDelimiter <- o .: "download-delimiter"
|
||||
lmsDownloadDelimiter <- o .: "download-delimiter"
|
||||
lmsDownloadCrLf <- o .: "download-cr-lf"
|
||||
lmsDeletionDays <- o .: "deletion-days"
|
||||
return LmsConf{..}
|
||||
@ -540,7 +557,17 @@ instance FromJSON AvsConf where
|
||||
avsCacheExpiry <- o .: "cache-expiry"
|
||||
return AvsConf{..}
|
||||
|
||||
makeLenses_ ''AvsConf
|
||||
makeLenses_ ''AvsConf
|
||||
|
||||
instance FromJSON AvsLicenceSynchConf where
|
||||
parseJSON = withObject "AvsLicenceSynch" $ \o -> do
|
||||
avsLicenceSynchTimes <- o .: "times"
|
||||
avsLicenceSynchLevel <- o .: "level"
|
||||
avsLicenceSynchReasonFilter <- o .:? "reason-filter"
|
||||
avsLicenceSynchMaxChanges <- o .:? "max-changes"
|
||||
return AvsLicenceSynchConf{..}
|
||||
|
||||
makeLenses_ ''AvsLicenceSynchConf
|
||||
|
||||
instance FromJSON LprConf where
|
||||
parseJSON = withObject "LprConf" $ \o -> do
|
||||
@ -611,7 +638,7 @@ instance FromJSON ServerSessionSettings where
|
||||
, ServerSession.setPersistentCookies <$> persistentCookies
|
||||
])
|
||||
|
||||
instance FromJSON LegalExternal where
|
||||
instance FromJSON LegalExternal where
|
||||
parseJSON = withObject "LegalExternal" $ \o -> do
|
||||
externalLanguage <- o .: "language"
|
||||
externalImprint <- o .: "imprint"
|
||||
@ -640,6 +667,7 @@ instance FromJSON AppSettings where
|
||||
appLdapConf <- P.fromList . mapMaybe (assertM nonEmptyHost) <$> o .:? "ldap" .!= []
|
||||
appLmsConf <- o .: "lms-direct"
|
||||
appAvsConf <- assertM (not . null . avsPass) <$> o .:? "avs"
|
||||
appAvsLicenceSynchConf <- o .:? "avs-licence-synch" .!= def
|
||||
appLprConf <- o .: "lpr"
|
||||
appSmtpConf <- assertM (not . null . smtpHost) <$> o .:? "smtp"
|
||||
let validMemcachedConf MemcachedConf{memcachedConnectInfo = Memcached.ConnectInfo{..}} = and
|
||||
|
||||
59
src/Utils.hs
59
src/Utils.hs
@ -714,9 +714,9 @@ bcons :: Bool -> a -> [a] -> [a]
|
||||
bcons False _ = id
|
||||
bcons True x = (x:)
|
||||
|
||||
bsnoc :: Bool -> a -> [a] -> [a]
|
||||
bsnoc False _ xs = xs
|
||||
bsnoc True x xs = xs ++ [x]
|
||||
bsnoc :: Bool -> [a] -> a -> [a]
|
||||
bsnoc False xs _ = xs
|
||||
bsnoc True xs x = xs ++ [x]
|
||||
|
||||
-- | Merge/Add any attribute-value pair to an existing list of such pairs.
|
||||
-- If the attribute exists, the new valu will be prepended, separated by a single empty space
|
||||
@ -813,6 +813,19 @@ checkAsc :: Ord a => [a] -> Bool
|
||||
checkAsc (x:r@(y:_)) = x<=y && checkAsc r
|
||||
checkAsc _ = True
|
||||
|
||||
-- return a part of a list between two given elements, if it exists
|
||||
listBracket :: Eq a => (a,a) -> [a] -> Maybe [a]
|
||||
listBracket _ [] = Nothing
|
||||
listBracket b@(s,e) (h:t)
|
||||
| s == h = listUntil [] t
|
||||
| otherwise = listBracket b t
|
||||
where
|
||||
listUntil _ [] = Nothing
|
||||
listUntil l1 (h1:t1)
|
||||
| e == h1 = Just $ reverse l1
|
||||
| otherwise = listUntil (h1:l1) t1
|
||||
|
||||
|
||||
----------
|
||||
-- Sets --
|
||||
----------
|
||||
@ -879,6 +892,12 @@ mapFilterM f m = ($ m) . runKleisli $ foldMap (Kleisli . Map.alterF (runMaybeT .
|
||||
_MapUnit :: Iso' (Map k ()) (Set k)
|
||||
_MapUnit = iso Map.keysSet $ Map.fromSet (const ())
|
||||
|
||||
foldMapWithKeyM :: (Monad m, Monoid o) => (k -> a -> m o) -> Map k a -> m o
|
||||
foldMapWithKeyM act = foldMapM (uncurry act) . Map.toAscList
|
||||
|
||||
foldWithKeyMapM :: (Monad m, Monoid o) => Map k a -> (k -> a -> m o) -> m o
|
||||
foldWithKeyMapM = flip foldMapWithKeyM
|
||||
|
||||
---------------
|
||||
-- Functions --
|
||||
---------------
|
||||
@ -991,6 +1010,7 @@ catchIfMPlus :: forall m e a. (MonadPlus m, MonadCatch m, Exception e) => (e ->
|
||||
catchIfMPlus p act = catchIf p act (const mzero)
|
||||
|
||||
-- | Monadic version of 'fromMaybe'
|
||||
-- Warning: fromMaybeM [1,2,3] [Nothing, Just 4, Just 5, Nothing] == [1,2,3,4,5,1,2,3] and fromMaybeM [1,2,3] [Just 4] == [4], use `mconss` instead
|
||||
fromMaybeM :: Monad m => m a -> m (Maybe a) -> m a
|
||||
fromMaybeM act = maybeM act pure
|
||||
|
||||
@ -1001,6 +1021,17 @@ mcons :: Maybe a -> [a] -> [a]
|
||||
mcons Nothing xs = xs
|
||||
mcons (Just x) xs = x:xs
|
||||
|
||||
msnoc :: [a] -> Maybe a -> [a]
|
||||
msnoc xs Nothing = xs
|
||||
msnoc xs (Just x) = xs ++ [x]
|
||||
|
||||
mconss :: [Maybe a] -> [a] -> [a]
|
||||
mconss [] tl = tl
|
||||
mconss (m:xs) tl
|
||||
| Just x <- m = x : mconss xs tl
|
||||
| otherwise = mconss xs tl
|
||||
|
||||
|
||||
-- | apply binary function to maybes, but ignores Nothing by using id if possible, unlike fmap/ap
|
||||
ignoreNothing :: (a -> a -> a) -> Maybe a -> Maybe a -> Maybe a
|
||||
ignoreNothing _ Nothing y = y
|
||||
@ -1297,7 +1328,7 @@ ofoldl1M _ _ = error "otoList of NonNull is empty"
|
||||
foldMapM :: (Foldable f, Monad m, Monoid b) => (a -> m b) -> f a -> m b
|
||||
foldMapM f = foldrM (\x xs -> (<> xs) <$> f x) mempty
|
||||
|
||||
{- left as a remineder: if you need these, use MaybeT instead!
|
||||
{- left as a reminder: if you need these below, rather use MaybeT instead!
|
||||
-- convenient synonym for `flip foldMapM`
|
||||
continueJust :: (Applicative m, Monoid b) => Maybe a -> (a -> m b) -> m b
|
||||
continueJust (Just x) f = f x
|
||||
@ -1433,6 +1464,26 @@ anyone :: (Foldable t, Alternative f) => t a -> f a
|
||||
anyone = Fold.foldr ((<|>).pure) empty
|
||||
|
||||
|
||||
|
||||
-- returns true, if the foldable contains an element twice
|
||||
hasDuplicates :: (Foldable t, Ord a) => t a -> Bool
|
||||
hasDuplicates = fst . Fold.foldl' aux (False, mempty)
|
||||
where
|
||||
aux r@(True , _) _ = r
|
||||
aux (False, xs) x
|
||||
| x `Set.member` xs = (True , xs)
|
||||
| otherwise = (False, Set.insert x xs)
|
||||
|
||||
{-
|
||||
-- | like `hasDuplicates` but terminates on infinte lists that contain duplicates
|
||||
hasDuplicates' :: Ord a => [a] -> Bool
|
||||
hasDuplicates' = aux mempty
|
||||
where
|
||||
aux _ [] = False
|
||||
aux seen (x:xs) = Set.member x seen || aux (Set.insert x seen) xs
|
||||
-}
|
||||
|
||||
|
||||
------------
|
||||
-- Writer --
|
||||
------------
|
||||
|
||||
@ -43,14 +43,14 @@ getField = view . fieldLensVal
|
||||
-- | Obtain a lens from an EntityField
|
||||
fieldLensVal :: PersistEntity record => EntityField record typ -> Lens' record typ
|
||||
fieldLensVal f = entityLens . fieldLens f
|
||||
where
|
||||
where
|
||||
entityLens :: Lens' record (Entity record)
|
||||
entityLens = lens getVal setVal
|
||||
getVal :: record -> Entity record
|
||||
getVal = Entity (error "fieldLensVal unexpectectly required an entity key") -- this is safe, since the lens is only used locally
|
||||
setVal :: record -> Entity record -> record
|
||||
setVal _ = entityVal
|
||||
|
||||
|
||||
|
||||
emptyOrIn :: PersistField typ
|
||||
=> E.SqlExpr (E.Value typ) -> Set typ -> E.SqlExpr (E.Value Bool)
|
||||
@ -115,16 +115,16 @@ existsKey404 = bool notFound (return ()) <=< existsKey
|
||||
|
||||
-- | given filter criteria like `selectList` this function returns Just if and only if there is precisely one result
|
||||
-- getByPeseudoUnique
|
||||
getByFilter :: (PersistRecordBackend record backend, PersistQueryRead backend, MonadIO m)
|
||||
getByFilter :: (PersistRecordBackend record backend, PersistQueryRead backend, MonadIO m)
|
||||
=> [Filter record] -> ReaderT backend m (Maybe (Entity record))
|
||||
getByFilter crit =
|
||||
selectList crit [LimitTo 2] <&> \case
|
||||
getByFilter crit =
|
||||
selectList crit [LimitTo 2] <&> \case
|
||||
[singleEntity] -> Just singleEntity
|
||||
_ -> Nothing -- not existing or not unique
|
||||
|
||||
getKeyByFilter :: (PersistRecordBackend record backend, PersistQueryRead backend, MonadIO m)
|
||||
getKeyByFilter :: (PersistRecordBackend record backend, PersistQueryRead backend, MonadIO m)
|
||||
=> [Filter record] -> ReaderT backend m (Maybe (Key record))
|
||||
getKeyByFilter crit =
|
||||
getKeyByFilter crit =
|
||||
selectKeysList crit [LimitTo 2] <&> \case
|
||||
[singleKey] -> Just singleKey
|
||||
_ -> Nothing -- not existing or not unique
|
||||
@ -142,9 +142,9 @@ updateGetEntity k = fmap (Entity k) . updateGet k
|
||||
|
||||
-- | insert or replace a record based on a single uniqueness constraint
|
||||
-- this function was meant to be supplied with the uniqueness constraint, but it would be unsafe if the uniqueness constraint would not match the supplied record
|
||||
replaceBy :: (PersistUniqueWrite backend, MonadIO m, OnlyOneUniqueKey record, PersistEntityBackend record ~ BaseBackend backend)
|
||||
replaceBy :: (PersistUniqueWrite backend, MonadIO m, OnlyOneUniqueKey record, PersistEntityBackend record ~ BaseBackend backend)
|
||||
=> record -> ReaderT backend m ()
|
||||
replaceBy r = do
|
||||
replaceBy r = do
|
||||
u <- onlyUnique r
|
||||
deleteBy u
|
||||
insert_ r
|
||||
@ -189,15 +189,15 @@ replaceEntity Entity{..} = replace entityKey entityVal
|
||||
-- * Unique denotes old record
|
||||
-- * Changes to fields involved in uniqueness work, but may throw an error if updated record already exists
|
||||
|
||||
-- | Safe version of upsertBy which does nothing if the new or updated record would violate a uniqueness constraint
|
||||
-- | Safe version of upsertBy which does nothing if the new or updated record would violate a uniqueness constraint
|
||||
upsertBySafe :: ( MonadIO m
|
||||
, PersistEntity record
|
||||
, PersistUniqueWrite backend
|
||||
, PersistEntityBackend record ~ BaseBackend backend
|
||||
)
|
||||
)
|
||||
=> Unique record -> record -> (record -> record) -> ReaderT backend m (Maybe (Key record))
|
||||
upsertBySafe uniq newr upd = maybeM (insertUnique newr) do_upd (getBy uniq)
|
||||
where
|
||||
where
|
||||
do_upd Entity{entityKey = oid, entityVal = oldr} = do
|
||||
delete oid
|
||||
insertUnique $ upd oldr
|
||||
@ -263,13 +263,13 @@ instance WithRunDB backend m (ReaderT backend m) where
|
||||
useRunDB = id
|
||||
|
||||
-- Could be used at Handler.Admin.postAdminProblemsR, but not yet elsewhere, thus inlined for now, as it may be too special:
|
||||
-- updateWithMessage
|
||||
-- updateWithMessage
|
||||
-- :: ( YesodPersist site, PersistEntity val, BackendCompatible SqlBackend (YesodPersistBackend site), PersistEntityBackend val ~ SqlBackend
|
||||
-- , Num a, Ord a, RenderMessage site msg, RedirectUrl site (url,[(Text,Text)]))
|
||||
-- => url -- where to redirect, if changes were mage
|
||||
-- -> [Filter val] -- update filter
|
||||
-- -> [Update val] -- actual update
|
||||
-- -> a -- expected updates
|
||||
-- -> a -- expected updates
|
||||
-- -> (a -> msg) -- message to add with number of actual changes
|
||||
-- -> HandlerFor site ()
|
||||
-- updateWithMessage route flt upd no_req msg = do
|
||||
@ -290,7 +290,7 @@ instance WithRunDB backend m (ReaderT backend m) where
|
||||
-- DBRunner site
|
||||
-- -> DBRunner' (YesodPersistBackend site) (HandlerFor site)
|
||||
-- fromDBRunner' DBRunner{..} = DBRunner' runDBRunner
|
||||
|
||||
|
||||
-- toDBRunner :: forall site.
|
||||
-- DBRunner' (YesodPersistBackend site) (HandlerFor site)
|
||||
-- -> DBRunner site
|
||||
@ -332,27 +332,34 @@ instance WithRunDB backend m (ReaderT backend m) where
|
||||
-- void . atomically $ tryPutTMVar runnerTMVar runner
|
||||
-- return runner
|
||||
-- getRunnerNoLock = maybe getRunner return =<< atomically (tryReadTMVar runnerTMVar)
|
||||
|
||||
|
||||
-- runCachedDBRunnerUsing act getRunnerNoLock
|
||||
|
||||
|
||||
|
||||
-- A datatype for a specific heterogeneous list to compute DB updates, consisting of a persistent record field and a fitting lens
|
||||
data CheckUpdate record iraw =
|
||||
forall typ. (Eq typ, PersistField typ) =>
|
||||
data CheckUpdate record iraw =
|
||||
forall typ. (Eq typ, PersistField typ) =>
|
||||
CheckUpdate (EntityField record typ) (Getting typ iraw typ) -- A persistent record field and fitting getting (also use for typ ~ Maybe typ')
|
||||
| forall typ. (Eq typ, PersistField typ) =>
|
||||
| forall typ. (Eq typ, PersistField typ) =>
|
||||
CheckUpdateMay (EntityField record (Maybe typ)) (Getting (Maybe typ) iraw (Maybe typ)) -- Special case, when `typ` is optional everywhere, forces update of Nothing to Just values
|
||||
| forall typ. (Eq typ, PersistField typ) =>
|
||||
CheckUpdateOpt (EntityField record typ) (Getting (Monoid.First typ) iraw typ) -- Special case, when `typ` is optional for the lens, but not optional in DB.
|
||||
|
||||
-- deriving instance Lift (CheckUpdate record iraw) -- not possible, seee Handler.Utils.AvsUpdate for a workaround
|
||||
-- instance Lift (CheckUpdate record iraw) where
|
||||
-- lift = $(makeLift ''CheckUpdate)
|
||||
|
||||
-- | checks if an update would be performed, if a new different value would be presented. Should agree with `mkUpdate` familiy of functions
|
||||
mayUpdate :: PersistEntity record => record -> Maybe iraw -> CheckUpdate record iraw -> Bool
|
||||
mayUpdate ent (Just old) (CheckUpdate up l)
|
||||
| let oldval = old ^. l
|
||||
, let entval = ent ^. fieldLensVal up
|
||||
= oldval == entval
|
||||
= oldval == entval
|
||||
mayUpdate ent (Just old) (CheckUpdateMay up l)
|
||||
| let oldval = old ^. l
|
||||
, let entval = ent ^. fieldLensVal up
|
||||
= isNothing entval || oldval == entval
|
||||
mayUpdate ent (Just old) (CheckUpdateOpt up l)
|
||||
| Just oldval <- old ^? l
|
||||
, let entval = ent ^. fieldLensVal up
|
||||
@ -369,6 +376,12 @@ mkUpdate ent new (Just old) (CheckUpdate up l)
|
||||
, newval /= entval
|
||||
, oldval == entval
|
||||
= Just (up =. newval)
|
||||
mkUpdate ent new (Just old) (CheckUpdateMay up l)
|
||||
| let newval = new ^. l
|
||||
, let oldval = old ^. l
|
||||
, let entval = ent ^. fieldLensVal up
|
||||
, (isNothing entval && isJust newval) || (newval /= entval && oldval == entval)
|
||||
= Just (up =. newval)
|
||||
mkUpdate ent new (Just old) (CheckUpdateOpt up l)
|
||||
| Just newval <- new ^? l
|
||||
, Just oldval <- old ^? l
|
||||
@ -383,12 +396,18 @@ mkUpdate' :: PersistEntity record => record -> iraw -> Maybe iraw -> CheckUpdate
|
||||
mkUpdate' ent new Nothing = mkUpdateDirect ent new
|
||||
mkUpdate' ent new just = mkUpdate ent new just
|
||||
|
||||
-- | Like `mkUpdate` but performs the update without comparison to a previous older value, whenever current entity value and new value are different
|
||||
mkUpdateDirect :: PersistEntity record => record -> iraw -> CheckUpdate record iraw -> Maybe (Update record)
|
||||
mkUpdateDirect ent new (CheckUpdate up l)
|
||||
| let newval = new ^. l
|
||||
, let entval = ent ^. fieldLensVal up
|
||||
, newval /= entval
|
||||
= Just (up =. newval)
|
||||
mkUpdateDirect ent new (CheckUpdateMay up l)
|
||||
| let newval = new ^. l
|
||||
, let entval = ent ^. fieldLensVal up
|
||||
, newval /= entval
|
||||
= Just (up =. newval)
|
||||
mkUpdateDirect ent new (CheckUpdateOpt up l)
|
||||
| Just newval <- new ^? l
|
||||
, let entval = ent ^. fieldLensVal up
|
||||
@ -398,33 +417,43 @@ mkUpdateDirect _ _ _ = Nothing
|
||||
|
||||
-- | Unconditionally update a record through CheckUpdate
|
||||
updateRecord :: PersistEntity record => record -> iraw -> CheckUpdate record iraw -> record
|
||||
updateRecord ent new (CheckUpdate up l) =
|
||||
updateRecord ent new (CheckUpdate up l) =
|
||||
let newval = new ^. l
|
||||
lensRec = fieldLensVal up
|
||||
in ent & lensRec .~ newval
|
||||
updateRecord ent new (CheckUpdateMay up l) =
|
||||
let newval = new ^. l
|
||||
lensRec = fieldLensVal up
|
||||
in ent & lensRec .~ newval
|
||||
updateRecord ent new (CheckUpdateOpt up l)
|
||||
| Just newval <- new ^? l
|
||||
| Just newval <- new ^? l
|
||||
= ent & fieldLensVal up .~ newval
|
||||
| otherwise
|
||||
= ent
|
||||
= ent
|
||||
|
||||
-- | like mkUpdate' but only returns the update if the new value would be unique
|
||||
-- mkUpdateCheckUnique' :: PersistEntity record => record -> iraw -> Maybe iraw -> CheckUpdate record iraw -> DB (Maybe (Update record))
|
||||
mkUpdateCheckUnique' :: (MonadIO m, PersistQueryRead backend, PersistEntity record, PersistEntityBackend record ~ BaseBackend backend)
|
||||
mkUpdateCheckUnique' :: (MonadIO m, PersistQueryRead backend, PersistEntity record, PersistEntityBackend record ~ BaseBackend backend)
|
||||
=> record -> a -> Maybe a -> CheckUpdate record a -> ReaderT backend m (Maybe (Update record))
|
||||
|
||||
mkUpdateCheckUnique' ent new Nothing (CheckUpdate up l)
|
||||
| let newval = new ^. l
|
||||
, let entval = ent ^. fieldLensVal up
|
||||
, newval /= entval
|
||||
= do
|
||||
= do
|
||||
newval_exists <- exists [up ==. newval]
|
||||
return $ toMaybe (not newval_exists) (up =. newval)
|
||||
mkUpdateCheckUnique' ent new Nothing (CheckUpdateMay up l)
|
||||
| let newval = new ^. l
|
||||
, let entval = ent ^. fieldLensVal up
|
||||
, newval /= entval
|
||||
= do
|
||||
newval_exists <- exists [up ==. newval]
|
||||
return $ toMaybe (not newval_exists) (up =. newval)
|
||||
mkUpdateCheckUnique' ent new Nothing (CheckUpdateOpt up l)
|
||||
| Just newval <- new ^? l
|
||||
, let entval = ent ^. fieldLensVal up
|
||||
, newval /= entval
|
||||
= do
|
||||
= do
|
||||
newval_exists <- exists [up ==. newval]
|
||||
return $ toMaybe (not newval_exists) (up =. newval)
|
||||
mkUpdateCheckUnique' ent new (Just old) (CheckUpdate up l)
|
||||
@ -433,7 +462,15 @@ mkUpdateCheckUnique' ent new (Just old) (CheckUpdate up l)
|
||||
, let entval = ent ^. fieldLensVal up
|
||||
, newval /= entval
|
||||
, oldval == entval
|
||||
= do
|
||||
= do
|
||||
newval_exists <- exists [up ==. newval]
|
||||
return $ toMaybe (not newval_exists) (up =. newval)
|
||||
mkUpdateCheckUnique' ent new (Just old) (CheckUpdateMay up l)
|
||||
| let newval = new ^. l
|
||||
, let oldval = old ^. l
|
||||
, let entval = ent ^. fieldLensVal up
|
||||
, (isNothing entval && isJust newval) || (newval /= entval && oldval == entval)
|
||||
= do
|
||||
newval_exists <- exists [up ==. newval]
|
||||
return $ toMaybe (not newval_exists) (up =. newval)
|
||||
mkUpdateCheckUnique' ent new (Just old) (CheckUpdateOpt up l)
|
||||
@ -442,7 +479,7 @@ mkUpdateCheckUnique' ent new (Just old) (CheckUpdateOpt up l)
|
||||
, let entval = ent ^. fieldLensVal up
|
||||
, newval /= entval
|
||||
, oldval == entval
|
||||
= do
|
||||
= do
|
||||
newval_exists <- exists [up ==. newval]
|
||||
return $ toMaybe (not newval_exists) (up =. newval)
|
||||
mkUpdateCheckUnique' _ _ _ _ = return Nothing
|
||||
|
||||
@ -10,7 +10,7 @@ module Utils.Form where
|
||||
|
||||
import ClassyPrelude.Yesod hiding (addMessage, addMessageI, cons, Proxy(..), identifyForm, addClass, mreq, areq, wreq, urlField)
|
||||
import Yesod.Auth (YesodAuth(maybeAuthId))
|
||||
|
||||
|
||||
import Data.Kind (Type, Constraint)
|
||||
import qualified Yesod.Form as Yesod
|
||||
import Yesod.Core.Instances ()
|
||||
@ -94,7 +94,7 @@ _olOptionsGrouped :: Traversal' (OptionList a) (Text, [Option a])
|
||||
_olOptionsGrouped f = \case
|
||||
x@OptionList{} -> pure x
|
||||
x@OptionListGrouped{} -> (\olOptionsGrouped -> x{olOptionsGrouped}) <$> traverse f (olOptionsGrouped x)
|
||||
|
||||
|
||||
_olReadExternal :: Lens' (OptionList a) (Text -> Maybe a)
|
||||
_olReadExternal f = \case
|
||||
x@OptionList{} -> (\olReadExternal -> x{olReadExternal}) <$> f (olReadExternal x)
|
||||
@ -103,7 +103,7 @@ _olReadExternal f = \case
|
||||
-- if a field is required, but none should be there
|
||||
noField :: Monad m => Field m a
|
||||
noField = Field{..}
|
||||
where
|
||||
where
|
||||
fieldParse _ _ = return $ Right Nothing
|
||||
fieldView _ _ _ _ _ = mempty
|
||||
fieldEnctype = UrlEncoded
|
||||
@ -320,6 +320,7 @@ data FormIdentifier
|
||||
| FIDAddSupervisor
|
||||
| FIDFirmUserChangeRequest
|
||||
| FIDFirmAction
|
||||
| FIDUnreachableUsersAction
|
||||
deriving (Eq, Ord, Read, Show)
|
||||
|
||||
instance PathPiece FormIdentifier where
|
||||
@ -576,52 +577,52 @@ runButtonForm' btns fid = do
|
||||
return (btnForm, res)
|
||||
|
||||
|
||||
-- | like runButtonForm, but may include a hash value enclosed in a hidden field to ensure
|
||||
-- | like runButtonForm, but may include a hash value enclosed in a hidden field to ensure
|
||||
-- that the button press still applies to the correct situation
|
||||
runButtonFormHash ::( PathPiece ident, Eq ident, RenderAFormSite site
|
||||
runButtonFormHash ::( PathPiece ident, Eq ident, RenderAFormSite site
|
||||
, Button site ButtonSubmit, Button site a, Finite a, Hashable h)
|
||||
=> h -> ident -> HandlerT site IO (WidgetT site IO (), Maybe a)
|
||||
runButtonFormHash (hash -> hVal) fid = do
|
||||
currentRoute <- getCurrentRoute
|
||||
let bForm = disambiguateButtons $ combinedButtonFieldF ""
|
||||
hForm = aopt hiddenField "" $ Just $ Just hVal
|
||||
((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm fid $ \html ->
|
||||
hForm = aopt hiddenField "" $ Just $ Just hVal
|
||||
((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm fid $ \html ->
|
||||
flip (renderAForm FormStandard) html $ (,) <$> bForm <*> hForm
|
||||
let btnForm = wrapForm btnWdgt def { formAction = SomeRoute <$> currentRoute
|
||||
, formEncoding = btnEnctype
|
||||
, formSubmit = FormNoSubmit
|
||||
}
|
||||
res <- formResultMaybe btnResult $ \case
|
||||
res <- formResultMaybe btnResult $ \case
|
||||
(btn, Just rVal) | hVal == rVal -> return $ Just btn -- hash value from hidden field must be present and matching
|
||||
_ -> do
|
||||
addMessageI Error MsgBtnFormOutdated
|
||||
_ -> do
|
||||
addMessageI Error MsgBtnFormOutdated
|
||||
whenIsJust currentRoute redirect -- redirect is needed to reset hidden-field value
|
||||
return Nothing
|
||||
return (btnForm, res)
|
||||
|
||||
-- | like runButtonFormHash, but showing only a given list of buttons, especially for buttons that are not in the Finite typeclass.
|
||||
runButtonFormHash' :: ( PathPiece ident, Eq ident, RenderAFormSite site
|
||||
runButtonFormHash' :: ( PathPiece ident, Eq ident, RenderAFormSite site
|
||||
, Button site ButtonSubmit, Button site a, Hashable h)
|
||||
=> h -> [a] -> ident -> HandlerT site IO (WidgetT site IO (), Maybe a)
|
||||
runButtonFormHash' (hash -> hVal) btns fid = do
|
||||
currentRoute <- getCurrentRoute
|
||||
let bForm = disambiguateButtons $ combinedButtonField btns ""
|
||||
hForm = aopt hiddenField "" $ Just $ Just hVal
|
||||
((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm fid $ \html ->
|
||||
hForm = aopt hiddenField "" $ Just $ Just hVal
|
||||
((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm fid $ \html ->
|
||||
flip (renderAForm FormStandard) html $ (,) <$> bForm <*> hForm
|
||||
let btnForm = wrapForm btnWdgt def { formAction = SomeRoute <$> currentRoute
|
||||
, formEncoding = btnEnctype
|
||||
, formSubmit = FormNoSubmit
|
||||
}
|
||||
res <- formResultMaybe btnResult $ \case
|
||||
res <- formResultMaybe btnResult $ \case
|
||||
(btn, Just rVal) | hVal == rVal -> return $ Just btn -- hash value from hidden field must be present and matching
|
||||
_ -> do
|
||||
addMessageI Error MsgBtnFormOutdated
|
||||
_ -> do
|
||||
addMessageI Error MsgBtnFormOutdated
|
||||
whenIsJust currentRoute redirect -- redirect is needed to reset hidden-field value
|
||||
return Nothing
|
||||
return (btnForm, res)
|
||||
|
||||
|
||||
|
||||
-------------------
|
||||
-- Custom Fields --
|
||||
-------------------
|
||||
@ -801,7 +802,7 @@ intMinMaxField :: (Monad m, Integral i, Show i, RenderMessage (HandlerSite m) Fo
|
||||
intMinMaxField lower upper = intF{ fieldView=newView }
|
||||
where
|
||||
intF@Field{ fieldView=oldView } = intField
|
||||
newView theId name attrs val isReq = oldView theId name (newAttrs <> attrs) val isReq
|
||||
newView theId name attrs = oldView theId name (newAttrs <> attrs)
|
||||
newAttrs = [ (a,tshow v) | (a,Just v) <- [("min", lower),("max", upper)] ]
|
||||
|
||||
daysField :: (Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m NominalDiffTime
|
||||
@ -873,10 +874,10 @@ cfAnySeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . m
|
||||
-- cfAnySeparatedSet :: (Functor m) => Field m Text -> Field m (Set Text)
|
||||
-- cfAnySeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . mapMaybe (assertM' (not . T.null) . T.strip) . splitConditionally) (T.intercalate "; " . Set.toList)
|
||||
-- where splitConditionally :: Text -> [Text]
|
||||
-- splitConditionally t
|
||||
-- splitConditionally t
|
||||
-- | ';' `telem` t = T.split (==';') t
|
||||
-- | ',' `telem` t = T.split (==',') t
|
||||
-- | otherwise = T.split C.isSeparator t
|
||||
-- | otherwise = T.split C.isSeparator t
|
||||
-- -- Our version of Data.Text does not yet support T.elem
|
||||
-- telem :: Char -> Text -> Bool
|
||||
-- telem c = T.any (==c)
|
||||
@ -885,10 +886,10 @@ cfAnySeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . m
|
||||
-- cfAnySeparatedSet :: (Functor m) => Field m Text -> Field m (Set Text)
|
||||
-- cfAnySeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . mapMaybe (assertM' (not . T.null) . T.strip) . splitConditionally) (T.intercalate "; " . Set.toList)
|
||||
-- where splitConditionally :: Text -> [Text]
|
||||
-- splitConditionally t
|
||||
-- splitConditionally t
|
||||
-- | ';' `telem` t = T.split (==';') t
|
||||
-- | ',' `telem` t = T.split (==',') t
|
||||
-- | otherwise = T.split C.isSeparator t
|
||||
-- | otherwise = T.split C.isSeparator t
|
||||
-- -- Our version of Data.Text does not yet support T.elem
|
||||
-- telem :: Char -> Text -> Bool
|
||||
-- telem c = T.any (==c)
|
||||
@ -978,7 +979,7 @@ multiSelectField' optMsg mkOpts = Field{..}
|
||||
let
|
||||
rendered = case val of
|
||||
Left _ -> []
|
||||
Right xs -> [optionExternalValue o | o <- opts ^.. _olOptions, x <- xs, x == optionInternalValue o]
|
||||
Right xs -> [optionExternalValue o | o <- opts ^.. _olOptions, x <- xs, x == optionInternalValue o]
|
||||
isSel Nothing = ClassyPrelude.Yesod.null rendered
|
||||
isSel (Just opt) = optionExternalValue opt `elem` rendered
|
||||
[whamlet|
|
||||
@ -1112,7 +1113,7 @@ urlFieldText :: ( Monad m
|
||||
)
|
||||
=> Field m Text
|
||||
urlFieldText = urlField' (pack . ($ mempty) . uriToString id) id
|
||||
|
||||
|
||||
|
||||
-----------
|
||||
-- Forms --
|
||||
@ -1183,7 +1184,7 @@ type RenderAFormSite site = ( RenderMessage site AFormMessage
|
||||
, RenderMessage site UrlFieldMessage
|
||||
, MonadSecretBox (HandlerFor site)
|
||||
, MonadSecretBox (MaybeT (RWST (Maybe (Env, FileEnv), site, [Lang]) Enctype Ints (Lazy.WriterT [FieldView site] (HandlerFor site))))
|
||||
, YesodAuth site, HasAppSettings site
|
||||
, YesodAuth site, HasAppSettings site
|
||||
)
|
||||
|
||||
renderAForm :: (MonadHandler m, RenderAFormSite (HandlerSite m)) => FormLayout -> FormRender m a
|
||||
@ -1272,7 +1273,7 @@ doFormHoneypots :: ( MonadHandler m
|
||||
doFormHoneypots = and2M
|
||||
(getsYesod . views _appBotMitigations $ Set.member SettingBotMitigationUnauthorizedFormHoneypots)
|
||||
(is _Nothing <$> maybeAuthId)
|
||||
|
||||
|
||||
honeypotSecrets :: ( MonadSecretBox m
|
||||
, MonadThrow m
|
||||
)
|
||||
@ -1285,8 +1286,8 @@ honeypotSecrets = secretBoxCSPRNGPure (encodeUtf8 $ tshow 'honeypotSecrets) (Bin
|
||||
secretsNum = 10
|
||||
|
||||
randomIdent = decodeUtf8 . Base64.encodeUnpadded . BS.pack <$> replicateM 18 getRandom
|
||||
|
||||
|
||||
|
||||
|
||||
aformHoneypot :: forall m a.
|
||||
( RenderAFormSite (HandlerSite m)
|
||||
, MonadHandler m
|
||||
|
||||
@ -121,7 +121,8 @@ data Icon
|
||||
| IconUserEdit
|
||||
-- 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)
|
||||
|
||||
@ -220,6 +221,8 @@ iconText = \case
|
||||
IconUserEdit -> "user-edit"
|
||||
-- IconMagic -> "wand-magic"
|
||||
IconReroute -> "directions"
|
||||
IconTop -> "arrow-to-top"
|
||||
IconWildcard -> "asterisk"
|
||||
nullaryPathPiece ''Icon $ camelToPathPiece' 1
|
||||
deriveLift ''Icon
|
||||
|
||||
@ -329,6 +332,10 @@ iconQualificationBlock :: Bool -> Markup
|
||||
iconQualificationBlock True = icon IconCertificate
|
||||
iconQualificationBlock False = icon IconBlocked
|
||||
|
||||
iconWriteReadOnly :: Bool -> Markup
|
||||
iconWriteReadOnly True = icon IconEdit
|
||||
iconWriteReadOnly False = icon IconVisible
|
||||
|
||||
----------------
|
||||
-- For documentation on how to avoid these unneccessary functions
|
||||
-- we implement them here just once for the first icon:
|
||||
|
||||
@ -186,8 +186,8 @@ class HasEntity c record where
|
||||
hasEntity :: Lens' c (Entity record)
|
||||
|
||||
--Trivial instance, usefull for lifting to maybes
|
||||
instance HasEntity (Entity r) r where
|
||||
hasEntity = id
|
||||
instance HasEntity (Entity r) r where
|
||||
hasEntity = id
|
||||
|
||||
-- Typed convenience to avoid type signatures, due to the missing FunctionalDepenency that we do not want.
|
||||
hasEntityUser :: (HasEntity a User) => Lens' a (Entity User)
|
||||
@ -299,6 +299,9 @@ makeLenses_ ''FallbackPersonalisedSheetFilesKey
|
||||
makeWrapped ''Textarea
|
||||
makeLenses_ ''SentMail
|
||||
|
||||
_mailHeaders' :: Iso' MailHeaders Headers
|
||||
_mailHeaders' = coerced
|
||||
|
||||
makePrisms ''RoomReference
|
||||
makeLenses_ ''RoomReference
|
||||
|
||||
@ -313,6 +316,7 @@ makeLenses_ ''AuthorshipStatementDefinition
|
||||
makeLenses_ ''PrintJob
|
||||
|
||||
makeLenses_ ''InterfaceLog
|
||||
makeLenses_ ''InterfaceHealth
|
||||
makeLenses_ ''AdminProblem
|
||||
makeLenses_ ''ProblemLog
|
||||
|
||||
|
||||
@ -228,3 +228,5 @@ messageTooltip Message{..} = let urgency = statusToUrgencyClass messageStatus
|
||||
tooltip = toWidget messageContent :: WidgetFor site ()
|
||||
isInlineTooltip = False
|
||||
in $(whamletFile "templates/widgets/tooltip.hamlet")
|
||||
|
||||
-- also see Handler.Utils.Widgets.mkErrorFlag for generic error icon tooltips
|
||||
|
||||
@ -17,13 +17,21 @@ import qualified Text.Pandoc as P
|
||||
|
||||
|
||||
markdownToHtml :: Html -> Either P.PandocError Html
|
||||
markdownToHtml html = P.runPure $ P.writeHtml5 htmlWriterOptions =<< P.readMarkdown markdownReaderOptions (toStrict $ renderHtml html)
|
||||
markdownToHtml html = P.runPure $ P.writeHtml5 htmlWriterOptions =<< P.readMarkdown markdownReaderOptions (toStrict $ renderHtml html)
|
||||
|
||||
plaintextToHtml :: Text -> Html
|
||||
plaintextToHtml text = fromRight (toMarkup text) $ P.runPure $
|
||||
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 $
|
||||
P.writeHtml5 htmlWriterOptions =<< P.readMarkdown markdownReaderOptions text
|
||||
-- Line below does not work as intended, also see Handler.Utils.Pandoc.plaintextToMarkdownWith which uses this code
|
||||
-- where pandoc = P.Pandoc mempty [P.Plain [P.Str text]]
|
||||
-- where pandoc = P.Pandoc mempty [P.Plain [P.Str text]]
|
||||
|
||||
plainHtmlToHtml :: Text -> Html
|
||||
plainHtmlToHtml text = fromRight (toMarkup text) $ P.runPure $
|
||||
P.writeHtml5 htmlWriterOptions =<< P.readHtml markdownReaderOptions text
|
||||
|
||||
|
||||
|
||||
htmlReaderOptions, markdownReaderOptions :: P.ReaderOptions
|
||||
|
||||
@ -20,41 +20,40 @@ import Handler.Utils.Widgets (nameHtml) -- , nameHtml')
|
||||
import Handler.Utils.Qualification (computeNewValidDate)
|
||||
|
||||
|
||||
defaultNotice :: Bool -> Lang -> Text -> Text -> Text -> [Text]
|
||||
defaultNotice renewAuto l qualName qualShort newExpire
|
||||
| isDe l, renewAuto
|
||||
= [ [st|Ein Zertifikat für Ihre Unterlagen kann nur direkt nach dem erfolgreichen Test erstellt werden.
|
||||
Das Zertifikat wird auf die Benutzerkennung ausgestellt. Zusammen mit diesem Schreiben können Sie Ihrem Arbeitgeber zeigen, dass Sie bestanden haben.
|
||||
Bei erfolgreichem Abschluss der Schulung verlängert sich das Ablaufdatum automatisch auf den #{newExpire}.
|
||||
Wir empfehlen die Schulung zeitnah durchzuführen.
|
||||
Sollte bis zum Ablaufdatum das E-Learning nicht innerhalb von 5 Versuchen erfolgreich abgeschlossen sein, muss zur Wiedererlangung der Fahrberechtigung „#{qualShort}“ ein Grundkurs #{qualName} bei der Fraport Fahrerausbildung absolviert werden.|]
|
||||
, "Benötigen Sie die Fahrberechtigung nicht mehr, informieren Sie bitte die Fraport Fahrerausbildung."
|
||||
, "(Please contact us if you prefer letters in English.)"
|
||||
]
|
||||
| isDe l
|
||||
= [ [st|Ein Zertifikat für Ihre Unterlagen kann nur direkt nach dem erfolgreichen Test erstellt werden.
|
||||
Das Zertifikat wird auf die Benutzerkennung ausgestellt. Zusammen mit diesem Schreiben können Sie Ihrem Arbeitgeber zeigen, dass Sie bestanden haben.
|
||||
Wir empfehlen die Schulung zeitnah durchzuführen.
|
||||
Sollte bis zum Ablaufdatum das E-Learning und der Praxisteil nicht erfolgreich abgeschlossen sein, muss zur Wiedererlangung der Fahrberechtigung „#{qualShort}“ ein Grundkurs #{qualName} bei der Fraport Fahrerausbildung absolviert werden.|]
|
||||
, "Benötigen Sie die Fahrberechtigung nicht mehr, informieren Sie bitte die Fraport Fahrerausbildung."
|
||||
]
|
||||
| renewAuto
|
||||
= [ [st|A certificate for your records can only be generated immediately after a successful test.
|
||||
The certificate will be issued for the user login. The certificate and this letter may then prove that you have passed.
|
||||
Upon successful completion of the training, the expiry date will automatically be extended until #{newExpire}.
|
||||
We recommend completing the training as soon as possible.
|
||||
The licence irrevocably expires, if the e-learning is not successfully completed within 5 attempts by the expiry date. In this case, regaining licence "#{qualShort}" requires the completing of a normal training course #{qualName} again, as if no prior experience existed.|]
|
||||
, "Please inform us, if this driving licence is no longer required."
|
||||
, "(Kontaktieren Sie uns bitte, um zukünftige Briefe von uns in deutscher Sprache zu erhalten.)"
|
||||
]
|
||||
| otherwise
|
||||
= [ [st|A certificate for your records can only be generated immediately after a successful test.
|
||||
The certificate will be issued for the user login. The certificate and this letter may then prove that you have passed.
|
||||
We recommend completing the training as soon as possible.
|
||||
The licence irrevocably expires, if the e-learning is not successfully completed within 5 attempts by the expiry date. In this case, regaining licence "#{qualShort}" requires the completing of a normal training course #{qualName} again, as if no prior experience existed.|]
|
||||
, "Please inform us, if this driving licence is no longer required."
|
||||
, "(Kontaktieren Sie uns bitte, um zukünftige Briefe von uns in deutscher Sprache zu erhalten.)"
|
||||
]
|
||||
defaultNotice :: Lang -> Bool -> Maybe Int -> Text -> Text -> Text -> [Text]
|
||||
defaultNotice l renewAuto elimit qualName qualShort newExpire =
|
||||
[intro <> renewal <> bequick <> outro, still_needed, switch_lang] -- list of separate paragraphs
|
||||
where
|
||||
intro :: Text
|
||||
| isDe l = [st|Ein Zertifikat für Ihre Unterlagen kann nur direkt nach dem erfolgreichen Test erstellt werden.
|
||||
Das Zertifikat wird auf die Benutzerkennung ausgestellt. Zusammen mit diesem Schreiben können Sie Ihrem Arbeitgeber zeigen, dass Sie bestanden haben. |]
|
||||
| otherwise = [st|A certificate for your records can only be generated immediately after a successful test.
|
||||
The certificate will be issued for the user login. The certificate and this letter may then prove that you have passed. |]
|
||||
renewal :: Text
|
||||
| not renewAuto = mempty
|
||||
| isDe l = [st|Bei erfolgreichem Abschluss der Schulung verlängert sich das Ablaufdatum automatisch auf den #{newExpire}. |]
|
||||
| otherwise = [st|Upon successful completion of the training, the expiry date will automatically be extended until #{newExpire}. |]
|
||||
bequick :: Text
|
||||
| isDe l = "Wir empfehlen die Schulung zeitnah durchzuführen. "
|
||||
| otherwise = "We recommend completing the training as soon as possible. "
|
||||
limit :: Text
|
||||
| Just n <- elimit, n > 0, isDe l = [st|innerhalb von #{n} Versuchen |]
|
||||
| Just n <- elimit, n > 0 = [st|within #{n} attempts |]
|
||||
| otherwise = mempty
|
||||
praxis :: Text
|
||||
| renewAuto = mempty
|
||||
| isDe l = "der Praxisteil und "
|
||||
| otherwise = "the practical part and "
|
||||
outro :: Text
|
||||
| isDe l = [st|Sollte bis zum Ablaufdatum #{praxis}das E-Learning nicht #{limit}erfolgreich abgeschlossen sein, muss zur Wiedererlangung der Fahrberechtigung „#{qualShort}“ ein Grundkurs #{qualName} bei der Fraport Fahrerausbildung absolviert werden.|]
|
||||
| otherwise = [st|The licence irrevocably expires, if #{praxis}the e-learning is not successfully completed #{limit}by the expiry date. In this case, regaining licence "#{qualShort}" requires the completing of a normal training course #{qualName} again, as if no prior experience existed.|]
|
||||
still_needed :: Text
|
||||
| isDe l = "Benötigen Sie die Fahrberechtigung nicht mehr, informieren Sie bitte die Fraport Fahrerausbildung."
|
||||
| otherwise = "Please inform us, if this driving licence is no longer required."
|
||||
switch_lang :: Text
|
||||
| isDe l = "(Please contact us if you prefer letters in English.)"
|
||||
| otherwise = "(Kontaktieren Sie uns bitte, um zukünftige Briefe von uns in deutscher Sprache zu erhalten.)"
|
||||
|
||||
|
||||
isAnyDrivingLicence :: Text -> Maybe Text
|
||||
-- isAnyDrivingLicence = firstJust (Text.stripSuffix "führerschein") . Text.words . Text.replace "-" " " . Text.replace "+" ""
|
||||
@ -101,6 +100,7 @@ data LetterRenewQualification = LetterRenewQualification
|
||||
, qualSchool :: SchoolId
|
||||
, qualDuration :: Maybe Int
|
||||
, qualRenewAuto :: Bool
|
||||
, qualELimit :: Maybe Int
|
||||
, isReminder :: Bool
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
@ -153,7 +153,7 @@ instance MDLetter LetterRenewQualification where
|
||||
, mbMeta "validduration" (show <$> qualDuration)
|
||||
, toMeta "url-text" lmsUrl
|
||||
, toMeta "url" lmsUrlPassword -- ok for PDF, since it contains the PIN already
|
||||
, toMeta "notice" $ defaultNotice qualRenewAuto lang qualName qualShort $ format SelFormatDate newExpire
|
||||
, toMeta "notice" $ defaultNotice lang qualRenewAuto qualELimit qualName qualShort $ format SelFormatDate newExpire
|
||||
, toMeta "de-subject" [st|Verlängerung Fahrberechtigung „#{qualShort}“ (#{qualName})|]
|
||||
, toMeta "en-subject" [st|Renewal of driving licence "#{qualShort}" (#{qualName})|]
|
||||
, toMeta "de-opening" $ bool [st|Guten Tag #{qualHolderDN},|] [st|Guten Tag #{userDisplayName},|] isSupervised
|
||||
|
||||
@ -1,6 +1,6 @@
|
||||
$newline never
|
||||
|
||||
$# SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
|
||||
$# SPDX-FileCopyrightText: 2022-24 Steffen Jost <s.jost@fraport.de>
|
||||
$#
|
||||
$# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
@ -62,7 +62,9 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
$else
|
||||
_{MsgInterfacesOk}
|
||||
^{interfaceTable}
|
||||
|
||||
<p>
|
||||
<a href=@{ConfigInterfacesR}>
|
||||
_{MsgConfigInterfacesHeading}
|
||||
<section>
|
||||
<h2>
|
||||
_{MsgProblemsHeadingMisc}
|
||||
|
||||
@ -8,8 +8,14 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
^{thisUserActWgt}
|
||||
<section>
|
||||
^{userDataWidget}
|
||||
<section>
|
||||
<h3>
|
||||
|
||||
<p>
|
||||
#{iconNotificationSent}
|
||||
<a href=@{CommCenterR}?comms-sorting=date-desc&comms-recipient=#{toPathPiece userDisplayName}>
|
||||
_{MsgAdminUserAllNotifications}
|
||||
|
||||
|
||||
<h3>
|
||||
_{MsgAdminUserRightsHeading}
|
||||
^{systemFunctionsForm}
|
||||
^{rightsForm}
|
||||
|
||||
@ -35,6 +35,9 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
$maybe answer <- mbQryLic
|
||||
<p>
|
||||
^{answer}
|
||||
$maybe autodiffs <- mbAutoDiffs
|
||||
<p>
|
||||
#{autodiffs}
|
||||
|
||||
<section>
|
||||
<p>
|
||||
|
||||
9
templates/comm-center.hamlet
Normal file
9
templates/comm-center.hamlet
Normal file
@ -0,0 +1,9 @@
|
||||
$newline never
|
||||
|
||||
$# SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
|
||||
$#
|
||||
$# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
<section>
|
||||
<p>
|
||||
^{ccTable}
|
||||
@ -35,7 +35,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
<p>
|
||||
^{tb2}
|
||||
<h3>
|
||||
Fahrbrechtigung Rollfeld ungültig in FRADrive, aber im AVS vorhanden
|
||||
Fahrbrechtigung Rollfeld ungültig in FRADrive, aber im AVS vorhanden und Fahrberechtigung Vorfeld gültig in FRADrive
|
||||
<p>
|
||||
^{tb1down}
|
||||
<h3>
|
||||
@ -43,7 +43,41 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
<p>
|
||||
^{tb1up}
|
||||
<h3>
|
||||
Keine gültige Fahrberechtigung in FRADrive, aber im AVS vorhanden
|
||||
Keine gültige Fahrberechtigung in FRADrive, aber im AVS vorhanden (Roll- oder Vorfeld)
|
||||
<p>
|
||||
^{tb0}
|
||||
|
||||
|
||||
$if notNull avsLicenceSynchTimes
|
||||
<section>
|
||||
<h2>
|
||||
Automatische AVS Fahrlizenzen Sychronisation
|
||||
<p>
|
||||
<dl .deflist>
|
||||
<dt .deflist__dt>
|
||||
Uhrzeiten Synchronisation
|
||||
<dd .deflist__dd>
|
||||
Werktags, wenige Minuten nach folgenden vollen Stunden: #{tshow avsLicenceSynchTimes}
|
||||
<dt .deflist__dt>
|
||||
Synchronisationslevel
|
||||
<dd .deflist__dd>
|
||||
<strong>#{avsLicenceSynchLevel}: #
|
||||
$case avsLicenceSynchLevel
|
||||
$of 1
|
||||
Nur Vorfeld-Fahrberechtigungen entziehen
|
||||
$of 2
|
||||
Vorfeld-Fahrberechtigungen entziehen und gewähren
|
||||
$of 3
|
||||
Vorfeld-Fahrberechtigungen entziehen und gewähren, #
|
||||
so wie Rollfeld-Fahrberechtigungen zu Vorfeld-Fahrberechtigungen herabstufen
|
||||
$of _
|
||||
Vorfeld- und Rollfeld-Fahrberechtigungen entziehen und gewähren
|
||||
$maybe reasons <- avsLicenceSynchReasonFilter
|
||||
<dt .deflist__dt>
|
||||
Ausnahmen
|
||||
<dd .deflist__dd>
|
||||
Keine automatische Synchronisation, wenn die Begründung des letzten Un-/Blocks zu diesen regulären Ausdruck passt: #{reasons}
|
||||
$maybe maxChange <- avsLicenceSynchMaxChanges
|
||||
<dt .deflist__dt>
|
||||
Maximal Änderungen
|
||||
<dd .deflist__dd>
|
||||
Keine Synchronisation eines Levels durchführen, welches mehr als #{maxChange} Änderungen hätte
|
||||
|
||||
@ -35,7 +35,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
<p>
|
||||
^{tb2}
|
||||
<h3>
|
||||
Maneuvering area driving licence 'R' invalid in FRADrive, but valid in AVS
|
||||
Maneuvering area driving licence 'R' invalid in FRADrive, but valid in AVS and having a valid 'F' in FRADrive
|
||||
<p>
|
||||
^{tb1down}
|
||||
<h3>
|
||||
@ -43,6 +43,40 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
<p>
|
||||
^{tb1up}
|
||||
<h3>
|
||||
No valid driving licence in FRADrive, but having a driving licence in AVS
|
||||
No valid driving licence in FRADrive, but having any driving licence in AVS (maneuvering or apron)
|
||||
<p>
|
||||
^{tb0}
|
||||
|
||||
$if notNull avsLicenceSynchTimes
|
||||
<section>
|
||||
<h2>
|
||||
Automatic AVS licence sychronisation
|
||||
<p>
|
||||
<dl .deflist>
|
||||
<dt .deflist__dt>
|
||||
Synchronisation times
|
||||
<dd .deflist__dd>
|
||||
Synchronize on weekdays, few minutes after each full hour: #{tshow avsLicenceSynchTimes}
|
||||
<dt .deflist__dt>
|
||||
Synchronisation level
|
||||
<dd .deflist__dd>
|
||||
<strong>#{avsLicenceSynchLevel}: #
|
||||
$case avsLicenceSynchLevel
|
||||
$of 1
|
||||
Revoke apron driving licences only
|
||||
$of 2
|
||||
Grant and revoke apron driving licences only
|
||||
$of 3
|
||||
Grant and revoke apron driving licences and downgrade maneuvering area licences to apron driving licences
|
||||
$of _
|
||||
Grant and revoke all driving licences automatically
|
||||
$maybe reasons <- avsLicenceSynchReasonFilter
|
||||
<dt .deflist__dt>
|
||||
Exemptions
|
||||
<dd .deflist__dd>
|
||||
Do not synchronize changes where the last un-/block reason matches #{reasons}
|
||||
$maybe maxChange <- avsLicenceSynchMaxChanges
|
||||
<dt .deflist__dt>
|
||||
Max changes
|
||||
<dd .deflist__dd>
|
||||
Do not synchronize a licence level if the number of changes exceeds #{maxChange}
|
||||
|
||||
Some files were not shown because too many files have changed in this diff Show More
Reference in New Issue
Block a user