Compare commits

...

52 Commits

Author SHA1 Message Date
3b0029ba04 fix(avs): fix #225 by skipping firm updates entirely if AVS FirmInfo is unchanged for previously seen values for AVS User to be updated 2024-10-09 12:50:32 +02:00
e554048f5a fix(avs): avs firm update no longer may update wrong company
Note: noticed while working on #225
2024-10-09 12:50:32 +02:00
e59fff352f fix(avs): fix #224 repeated superior changes no longer occur
furthermore AdminProblems are only inserted if the same problem does not exist unsolved
2024-10-09 12:50:32 +02:00
e9d4174b83 chore(release): 27.4.79 2024-09-10 17:56:40 +02:00
90613faf72 Merge branch 'fradrive/jost' 2024-09-10 17:55:52 +02:00
6a070a6775 fix(supervision): fix #181 by unifying deletion of supervision 2024-09-10 17:47:09 +02:00
ea113cf57a chore(login): limit number of suggestions for dummy development login for convenience 2024-09-10 17:45:27 +02:00
6ffc49ae0e chore(avs): auto licence synch preview show AVS-No as well 2024-09-10 12:36:52 +02:00
ab8b17229a chore(health): show db time on status page and status time diffs in a human readable format 2024-09-09 16:41:43 +02:00
74f7633837 fix(notifications): fix #180 qualification expiry notification are sent only once 2024-09-09 15:34:41 +02:00
d92d23bc99 chore(release): 27.4.78 2024-09-05 17:55:54 +02:00
4959736c90 Merge branch 'fradrive/jost' 2024-09-05 17:55:09 +02:00
ade27e6479 fix(avs): fix #178 by deleting old superiors for individual users 2024-09-05 17:53:18 +02:00
cbadef0a73 chore(mail): fix #179 reorder attachments and guess PDF pin password in Text display 2024-09-05 16:28:20 +02:00
2a27a1efa6 fix(avs): fix #124 avs auto synch filter working
also, provide test facility for auto synch
2024-09-05 16:27:10 +02:00
620e3e4700 fix(mail): fix #179 by adding download links for PDF attachments 2024-09-05 14:09:50 +02:00
f0798e8836 chore(avs): debug automatic avs licence synch within admin avs test page 2024-09-04 18:08:08 +02:00
3c5edb1b97 fix(avs): typo in superior remark, towards #178 2024-09-04 16:29:12 +02:00
4f7855b9ee fix(avs): acs auto synch had inverted success/failure
also: some minor typo fixes
2024-09-03 12:53:51 +02:00
547f34d2ec chore(release): 27.4.77 2024-09-02 10:50:31 +02:00
08788427a8 Merge branch 'fradrive/jost' into 'master'
HOTFIX(avs): switch company did not always increase priority

Closes #175 and #174

See merge request fradrive/fradrive!41
2024-09-02 08:42:32 +00:00
1e896da4a3 chore(avs): prepare superior update shortcircuit for future 2024-09-02 09:08:44 +02:00
7e5c256b4c fix(avs): company superiors are now irregular supervisors and old ones are deleted
DETAILS:

Superiors:
- Superiors do not become Company-Default-Supervisors automatically
- Superiors become irregular supervisors without rerouting, existing supervisions are not changed
- Superiors become company users at equal-to-max priority, if not already

For each AVN User update:
- if superior change for unchanged company:
    all company supervisions with remark "Vorgesetzter" are removed
    create admin problem that notifies about superior change (special if new superior could not be created)
- all company associates are irregularly supervised by the new superior with remark "Vorgesetzer"

Questions:
 - company had superior, but no longer: just remove superior-supervisions, do not report admin problem?
 - Problem: superior changed, but we first encounter this through a user changing company. Change is not detected at this point, old superiors remain until an old company associate is updated too
2024-08-30 17:41:33 +02:00
43319fbcca chore(admin): unreachable page offers convient avs and ldap synch buttons 2024-08-29 18:12:10 +02:00
f946e99da3 fix(ldap): no more timeout for ldap synch all button 2024-08-29 16:45:39 +02:00
cfe2318f81 fix(avs): attempt LDAP upsert before creating avs users 2024-08-29 16:15:16 +02:00
64ff002ffb chore(firm): provide more filters for supervisors
also fix build #175
2024-08-29 14:34:37 +02:00
8397c468a0 fix(firm): fix #175 by separating superiors in firm tables and selections 2024-08-28 17:50:44 +02:00
81721b0794 chore(status): improve readability of time spans 2024-08-28 10:45:11 +02:00
40dadd5876 fix(firm): fix #174 by adding address search filter to all company view 2024-08-28 10:44:27 +02:00
b7e5b8f111 fix(model): flip erroneous boolean SQL default for CompanyPostalAddress
changing this SQL default value now is admittedly too late, as the damage is already done, but documents the right default value nevertheless
2024-08-28 09:55:57 +02:00
8ec2875590 fix(avs): switch company did not always increase priority 2024-08-27 16:23:42 +02:00
6d1b177ce9 Merge branch 'fradrive/jost' into 'master'
Fradrive/jost - two minor fixes

See merge request fradrive/fradrive!40
2024-08-26 18:04:38 +00:00
9c82558d71 fix(user): fix pagination and count for supervision tables 2024-08-26 17:40:57 +02:00
e8f9c21b7c chore(problem): admin problem filtering works on full text now 2024-08-26 15:17:01 +02:00
e1a02879d6 Merge branch 'fradrive/jost' into 'master'
chore(health): augement #154 by adding option to disable interface warnings

See merge request fradrive/fradrive!39
2024-08-22 18:08:52 +00:00
109e845db6 chore(problem): towards admin problem filtering 2024-08-22 17:44:19 +02:00
53abdb7cc3 chore(health): augement #154 by adding option to disable interface warnings
Also:
- add usage explanation
- show intervals in a human readable form
2024-08-22 17:28:28 +02:00
97446aa9ef Merge branch 'fradrive/jost' into 'master'
minor update

Closes #154 and #5

See merge request fradrive/fradrive!38
2024-08-21 17:59:22 +00:00
407ba543a1 chore(health): fix #154 by adding interface warning threshold edit handler 2024-08-21 17:34:19 +02:00
f61c35cfe7 refactor(companies): mark table columns showing only prime company as such, fix #5
- also improve performance by changing dbtProj/selectList into a subselect
- fix #5 no longer sensible, as most are single values to be displayed right away
2024-08-21 11:52:29 +02:00
b0972bb154 fix(mail): display html emails no longer distorts page
html is filtered once through pandoc, as proposed in #2
2024-08-20 12:35:16 +02:00
8bc3663ee2 fix(linter): minor bug in exam-correct.hs 2024-08-19 17:52:11 +02:00
776e6b6736 Merge branch 'fradrive/jost' into 'master'
AVS automatic synchronisation

See merge request fradrive/fradrive!37
2024-08-12 18:29:21 +00:00
be5e609b1f fix(build): minor linter fix 2024-08-12 18:01:59 +02:00
cc5da9a2a9 fix(avs): fix #124 implement automatic avs driving licence synchronisation 2024-08-12 18:01:04 +02:00
e551fadd29 chore(sql): add regex match for sql 2024-08-12 12:36:27 +02:00
2ed626ea4a chore(avs): towards #124 add filter for multiple firm users with block reason '%firm%'
- also add warning to admin avs licence difference for AVS R licence holders about to be changed
2024-08-09 18:33:23 +02:00
f4823aaf28 refactor(avs): switch some runDB to runDBRead 2024-08-09 17:59:14 +02:00
760b102d52 chore(avs): flag AVS R-holders about to be revoked
- flag on admin problem view
- exempt from automatic avs licence synch for levels below 3
2024-08-09 17:01:10 +02:00
000d8100db chore(avs): towards #124 add jobworker for AVS licence synch (WIP) 2024-08-08 18:19:09 +02:00
d209a110e8 refactor(linter): implement minor hlit suggestion 2024-08-08 17:30:03 +02:00
74 changed files with 1571 additions and 638 deletions

View File

@ -2,6 +2,43 @@
All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines.
## [27.4.79](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.78...v27.4.79) (2024-09-10)
### Bug Fixes
* **notifications:** fix [#180](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/180) qualification expiry notification are sent only once ([74f7633](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/74f7633837870448f7cab1013719f42ab49941fe))
* **supervision:** fix [#181](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/181) by unifying deletion of supervision ([6a070a6](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/6a070a67756bd4ef4b9b5efc176f34c7ed183f1a))
## [27.4.78](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.77...v27.4.78) (2024-09-05)
### Bug Fixes
* **avs:** acs auto synch had inverted success/failure ([4f7855b](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/4f7855b9ee7133c5ee7e2ca63d63e5d9f060d62f))
* **avs:** fix [#124](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/124) avs auto synch filter working ([2a27a1e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/2a27a1efa673a4245a7e8667bd30c79ac1891b9c))
* **avs:** fix [#178](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/178) by deleting old superiors for individual users ([ade27e6](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ade27e647913ffe4432b41d585b3e00d1c68d4a0))
* **avs:** typo in superior remark, towards [#178](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/178) ([3c5edb1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/3c5edb1b970c8c154d9957837007815b29e23964))
* **mail:** fix [#179](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/179) by adding download links for PDF attachments ([620e3e4](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/620e3e470080831826ccc960dd876e7bb4fcea03))
## [27.4.77](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.76...v27.4.77) (2024-09-02)
### Bug Fixes
* **avs:** attempt LDAP upsert before creating avs users ([cfe2318](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/cfe2318f81c951a7f7310e8bcd9ec25d79417587))
* **avs:** company superiors are now irregular supervisors and old ones are deleted ([7e5c256](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/7e5c256b4c15a15f7218dd7c1490d5e7add4b1c1))
* **avs:** fix [#124](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/124) implement automatic avs driving licence synchronisation ([cc5da9a](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/cc5da9a2a9bfc8a29f6fe19260bd6dc5412ad4a1))
* **avs:** switch company did not always increase priority ([8ec2875](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/8ec2875590718f28c3bab8c10141065e11f1405c))
* **build:** minor linter fix ([be5e609](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/be5e609b1fe879428784d78fa62a559d0764a85a))
* **firm:** fix [#174](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/174) by adding address search filter to all company view ([40dadd5](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/40dadd58762156005b5889b93a56ffdc044b4460))
* **firm:** fix [#175](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/175) by separating superiors in firm tables and selections ([8397c46](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/8397c468a04af42ba3baee2f84a0051adbc74374))
* **ldap:** no more timeout for ldap synch all button ([f946e99](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/f946e99da3bc37514a4e3621438ac133cdc16732))
* **linter:** minor bug in exam-correct.hs ([8bc3663](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/8bc3663ee2e4ded19091ebe350de82cd693093fc))
* **mail:** display html emails no longer distorts page ([b0972bb](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/b0972bb154f453edd545fb4f658d9f5ff79966eb)), closes [#2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/2)
* **model:** flip erroneous boolean SQL default for CompanyPostalAddress ([b7e5b8f](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/b7e5b8f111b5115d816d984c6ef2f12edfcef5bb))
* **user:** fix pagination and count for supervision tables ([9c82558](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/9c82558d71a032dad27e892c489c7004d091e088))
## [27.4.76](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.75...v27.4.76) (2024-08-08)

View File

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

View File

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

View File

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

View File

@ -1,4 +1,4 @@
# SPDX-FileCopyrightText: 2023 Steffen Jost <s.jost@fraport.de>
# SPDX-FileCopyrightText: 2023-24 Steffen Jost <s.jost@fraport.de>
#
# SPDX-License-Identifier: AGPL-3.0-or-later
@ -15,11 +15,15 @@ FirmActionInfo: Betrifft alle Firmenangehörigen unter Ihrer Aufsicht.
FirmActNotify: Mitteilung versenden
FirmActResetSupervision: Ansprechpartner für alle Firmenangehörigen zurücksetzen
FirmActResetSuperKeep: Bisherige Ansprechpartner der Firmenangehörigen zusätzlich beibehalten?
FirmActRemoveSupers: Alle rein firmenbezogenen Ansprechpartnerbeziehungen für diese Personen entfernen?
FirmActResetMutualSupervision: Ansprechpartner beaufsichtigen sich gegenseitig
FirmActResetSupersKeepAll: Alle behalten
FirmActResetSupersRemoveAps: Nur Standardansprechpartner entfernen
FirmActResetSupersRemoveAll: Alle entfernen
FirmActAddSupervisors: Ansprechpartner hinzufügen
FirmActAddSupersEmpty: Es konnten keine Ansprechpartner hinzugefügt werden
FirmActAddSupersSet n@Int64 postal@(Maybe Bool): #{n} Standardansprechpartner geändert #{maybeBoolMessage postal "" "und auf Briefversand geschaltet" "und Benachrichtigungen per Email gesetzt"}, aber nicht nicht aktiviert.
RemoveSupervisors ndef@Int64 nact@Int64: #{ndef} Standard Ansprechpartner entfernt#{bool ", aber keine aktiven Ansprechpartnerbeziehungen wurden deaktiviert" (", " <> tshow nact <> " aktive Ansprechpartnerbeziehungen gelöscht") (nact > 0)}
RemoveSupervisors ndef@Int64: #{ndef} Standardansprechpartner entfernt.
FirmActChangeContactUser: Kontaktinformationen von allen Firmenangehörigen ändern
FirmActChangeContactFirm: Kontaktinformationen der Firma ändern
FirmActChangeContactFirmInfo: Firmenkontaktinformationen werden nur für neue Firmenangehörige verwendet, für die sonst keine Kontaktinformationen vorliegen.
@ -33,7 +37,8 @@ FirmUserActRemove: Firmenassoziation entfernen
FirmUserActMkSuper: Zum Firmenansprechpartner ernennen
FirmUserActChangeDetailsResult n@Int64 t@Int64: Firmenassoziation von #{n}/#{t} #{pluralDE n "Firmenangehörigen" "Firmenangehörige"} wurden aktualisiert
FirmUserActChangeResult n@Int64 t@Int64: Benachrichtigungseinstellung für #{n}/#{t} #{pluralDE n "Firmenangehörigen" "Firmenangehörige"} wurden geändert
FirmuserActRemoveResult uc@Int64 sup@Int64 sub@Int64: #{uc} #{pluralDE uc "Firmenassoziation" "Firmenassoziationen"} entfernt. #{noneMoreDE sup "" (tshow sup <> "Ansprechpartnerbeziehungen wegen entferntem Ansprechpartner gelöschtt. ")} #{noneMoreDE sub "" (tshow sup <> "Ansprechpartnerbeziehungen wegen entfernten Angesprochenen gelöscht.")}
FirmUserActRemoveResult uc@Int64: #{uc} #{pluralDE uc "Firmenassoziation" "Firmenassoziationen"} entfernt.
FirmRemoveSupervision sup@Int64 sub@Int64: #{noneMoreDE sup "" (tshow sup <> " Ansprechpartnerbeziehungen wegen entferntem Ansprechpartner gelöscht. ")} #{noneOneMoreDE sub "Keine Ansprechpartnerbeziehung" "Eine Ansprechpartnerbeziehung" (tshow sup <> " Ansprechpartnerbeziehungen")} wegen entferntem Angesprochenem gelöscht.
FirmNewSupervisor: Neue individuelle Ansprechpartner hinzufügen
FirmSetSupervisor: Existierende Ansprechpartner hinzufügen
FirmSetSupersReport nusr@Int64 nspr@Int64 nrem@Int64: Für #{nusr} Firmenangehörige wurden #{nspr} individuelle Ansprechpartner eingetragen#{bool "." (" und " <> tshow nrem <> " individuelle Ansprechpartnerbeziehungen gelöscht.") (nrem >0)}
@ -42,7 +47,7 @@ FirmSuperActNotify: Mitteilung versenden
FirmSuperActSwitchSuper: Standard Firmenansprechpartner abändern
FirmSuperActSwitchSuperInfo: Betrifft keine firmenfremden Ansprechpartner und ändert keine aktiven individuellen Ansprechpartnerbeziehungen. Gegebenfalls im Anschluss die Funktion "Ansprechpartner auf Firmenstandard zurücksetzen" nutzen.
FirmSuperActRMSuperDef: Firmenansprechpartner entfernen
FirmSuperActRMSuperActive: Auch aktive Ansprechpartnerbeziehungen innerhalb dieser Firma beenden
FirmSuperActRMSuperActive: Aktive Ansprechpartnerbeziehungen innerhalb dieser Firma beenden?
FirmsNotification: Firmen E-Mail versenden
FirmNotification fsh@CompanyShorthand: E-Mail an #{fsh} senden
FirmsNotificationTitle: Firmen benachrichtigen
@ -51,7 +56,9 @@ FilterSupervisor: Hat aktiven Ansprechpartner
FilterSupervisorCompany fsh@CompanyShorthand: Hat aktiven Ansprechpartner, #{fsh} der angehört
FilterSupervisorForeign fsh@CompanyShorthand: Hat aktiven Ansprechpartner, der selbst nicht #{fsh} angehört
FilterForeignSupervisor: Hat firmenfremde Ansprechpartner
FilterIsForeignSupervisee: Ist Ansprechpartner für Firmenfremde
FilterFirmExtern: Externe Firma
FilterFirmExternTooltip: Hat die Firma eine Postanschrift im AVS?
FilterFirmPrimary: Ist primäre Firma in FRADrive
FilterHasQualification: Hat Firmenangehörige mit aktuell gültiger Qualifikation
FirmSupervisorOf fsh@CompanyShorthand: Ansprechpartner #{fsh} angehörig
@ -59,6 +66,7 @@ FirmSupervisorIndependent: Ansprechpartner ohne jegliche Firmenzugehörigkeit
FirmEmployeeOf fsh@CompanyShorthand: Firmenangehörige #{fsh}
NoCompanySelected: Bitte wählen Sie mindestens eine Firma aus.
TableIsDefaultSupervisor: Standardansprechpartner
TableSuperior: Vorgesetzter
TableIsDefaultReroute: Standardumleitung
FormFieldPostal: Benachrichtigungseinstellung
FormFieldPostalTip: Gilt für alle Benachrichtigungen an diese Person, nicht nur für Umleitungen an diesen Ansprechpartner

View File

@ -1,4 +1,4 @@
# SPDX-FileCopyrightText: 2023 Steffen Jost <s.jost@fraport.de>
# SPDX-FileCopyrightText: 2023-24 Steffen Jost <s.jost@fraport.de>
#
# SPDX-License-Identifier: AGPL-3.0-or-later
@ -15,11 +15,15 @@ FirmActionInfo: Affects alle company associates under your supervision.
FirmActNotify: Send message
FirmActResetSupervision: Reset supervisors for all company associates
FirmActResetSuperKeep: Additionally keep existing supervisors of company associates?
FirmActRemoveSupers: Terminate all company related supervisonships?
FirmActResetMutualSupervision: Supervisors supervise each other
FirmActResetSupersKeepAll: Keep all
FirmActResetSupersRemoveAps: Remove default supervisors only
FirmActResetSupersRemoveAll: Remove all
FirmActAddSupervisors: Add supervisors
FirmActAddSupersEmpty: No supervisors added
FirmActAddSupersSet n postal: #{n} default company supervisors changed #{maybeBoolMessage postal "" "and switched to postal notifications" "and switched to email notifications"}, but not yet activated.
RemoveSupervisors ndef nact: #{ndef} default supervisors removed#{bool ", but no active supervisions were deactivated" (" and " <> tshow nact <> " active supervisions terminated") (nact > 0)}
RemoveSupervisors ndef: #{ndef} default supervisors removed.
FirmActChangeContactUser: Change contact data for all company associates
FirmActChangeContactFirm: Change company contact data
FirmActChangeContactFirmInfo: The company contact data is only used for new company associates that would habe no contact information of their own otherwise.
@ -33,7 +37,8 @@ FirmUserActRemove: Delete company association
FirmUserActMkSuper: Mark as company supervisor
FirmUserActChangeDetailsResult n t: #{n}/#{t} #{pluralENs n "company association"} updated
FirmUserActChangeResult n t: Notification settings changed for #{n}/#{t} company #{pluralENs n "associate"}
FirmuserActRemoveResult uc sup sub: #{pluralENsN uc "Company association"} deleted. #{noneMoreEN sup "" ((pluralENsN sup "supervision") <> " removed due to eliminated supervisors.")} #{noneMoreEN sub "" ((pluralENsN sub "supervision") <> " removed due to eliminated supervisees.")}
FirmUserActRemoveResult uc: #{pluralENsN uc "Company association"} deleted.
FirmRemoveSupervision sup sub: #{noneMoreEN sup "" ((pluralENsN sup "supervision") <> " removed due to eliminated supervisors.")} #{noneMoreEN sub "No supervision" (pluralENsN sub "supervision")} removed due to eliminated supervisees.
FirmNewSupervisor: Appoint new individual supervisors
FirmSetSupervisor: Add existing supervisors
FirmSetSupersReport nusr nspr nrem: #{nspr} individual supervisors set for #{nusr} company associates#{bool "." (" and " <> tshow nrem <> " other individual supervisions terminated.") (nrem >0)}
@ -42,7 +47,7 @@ FirmSuperActNotify: Send message
FirmSuperActSwitchSuper: Change default company supervisor
FirmSuperActSwitchSuperInfo: Does not affect company-external supervisors and does not change any active individual supervisions. Additionally use reset action, if desired.
FirmSuperActRMSuperDef: Remove default supervisor
FirmSuperActRMSuperActive: Also remove active supervisions within this company
FirmSuperActRMSuperActive: Terminate active supervisions within this company?
FirmsNotification: Send company notification e-mail
FirmNotification fsh: Send e-mail to #{fsh}
FirmsNotificationTitle: Company notification
@ -51,7 +56,9 @@ FilterSupervisor: Has active supervisor
FilterSupervisorCompany fsh: Has active company supervisor belonging to #{fsh}
FilterSupervisorForeign fsh: Has active supervisor not belonging to #{fsh}
FilterForeignSupervisor: Has company-external supervisors
FilterIsForeignSupervisee: Supervisor for company external users
FilterFirmExtern: External company
FilterFirmExternTooltip: i.e. is a postal address registered within AVS?
FilterFirmPrimary: Is primary company in FRADrive
FilterHasQualification: Has company associates with currently valid qualification
FirmSupervisorOf fsh@CompanyShorthand: Supervisors belonging to #{fsh}
@ -59,6 +66,7 @@ FirmSupervisorIndependent: Independent supervisors
FirmEmployeeOf fsh@CompanyShorthand: #{fsh} associated users
NoCompanySelected: Select at least one company, please.
TableIsDefaultSupervisor: Default supervisor
TableSuperior: Superior
TableIsDefaultReroute: Default reroute
FormFieldPostal: Notification type
FormFieldPostalTip: Affects all notifications to this person, not just reroutes to this supervisor

View File

@ -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")}

View File

@ -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")}

View File

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

View File

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

View File

@ -12,6 +12,7 @@ FieldSecondary: Nebenfach
MultiEmailFieldTip: Es sind mehrere, Komma-separierte, E-Mail-Adressen möglich
MultiSelectTip: Mehrfachauswahl und Abwählen mit Strg-Klick
WeekDay: Wochentag
Hours: Stunden
LdapIdentificationOrEmail: Fraport AG-Kennung / E-Mail-Adresse
Months num@Int64: #{num} #{pluralDE num "Monat" "Monate"}
Days num@Int64: #{num} #{pluralDE num "Tag" "Tage"}

View File

@ -12,6 +12,7 @@ FieldSecondary: Minor
MultiEmailFieldTip: Multiple emails addresses may be specified (comma-separated)
MultiSelectTip: Multiple selection and desection via Ctrl-Click
WeekDay: Day of the week
Hours: Hours
LdapIdentificationOrEmail: Fraport AG-Kennung / email address
Months num: #{num} #{pluralEN num "Month" "Months"}
Days num: #{num} #{pluralEN num "Day" "Days"}

View File

@ -153,6 +153,7 @@ MenuCommCenter: Benachrichtigungen
MenuMailCenter: EMails
MenuMailHtml !ident-ok: Html
MenuMailPlain !ident-ok: Text
MenuMailAttachment: Anhang
MenuApiDocs: API-Dokumentation (Englisch)
MenuSwagger !ident-ok: OpenAPI 2.0 (Swagger)

View File

@ -153,6 +153,7 @@ MenuCommCenter: Notifications
MenuMailCenter: Email
MenuMailHtml: Html
MenuMailPlain: Text
MenuMailAttachment: Attachment
MenuApiDocs: API documentation
MenuSwagger: OpenAPI 2.0 (Swagger)

View File

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

View File

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

View File

@ -83,6 +83,7 @@ MultiUserFieldInvitationExplanationAlways: Es wird an alle Adressen, die Sie hie
AmbiguousEmail: E-Mail-Adresse nicht eindeutig
InvalidEmailAddress: E-Mail-Adresse ist ungültig
InvalidEmailAddressWith e@Text: E-Mail-Adresse #{show e} ist ungültig
MailFileAttachment: Dateianhang
UtilExamResultGrade: Note
UtilExamResultPass: Bestanden/Nicht Bestanden
UtilExamResultNoShow: Nicht erschienen

View File

@ -83,6 +83,7 @@ MultiUserFieldInvitationExplanationAlways: An invitation will be sent via email
AmbiguousEmail: Email address is ambiguous
InvalidEmailAddress: Email address is invalid
InvalidEmailAddressWith e: Email asdress #{show e} is invalid
MailFileAttachment: Attached file
UtilExamResultGrade: Grade
UtilExamResultPass: Passed/Failed
UtilExamResultNoShow: Not present

View File

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

View File

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

2
package-lock.json generated
View File

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

View File

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

View File

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

4
routes
View File

@ -71,16 +71,18 @@
/admin/avs/#CryptoUUIDUser AdminAvsUserR GET POST
/admin/ldap AdminLdapR GET POST
/admin/problems AdminProblemsR GET POST
/admin/problems/no-contact ProblemUnreachableR GET
/admin/problems/no-contact ProblemUnreachableR GET POST
/admin/problems/no-avs-id ProblemWithoutAvsId GET
/admin/problems/r-without-f ProblemFbutNoR GET
/admin/problems/avs ProblemAvsSynchR GET POST
/admin/problems/avs/errors ProblemAvsErrorR GET
/admin/config/interfaces ConfigInterfacesR GET POST
/comm CommCenterR GET
/comm/email MailCenterR GET POST
/comm/email/html/#CryptoUUIDSentMail MailHtmlR GET
/comm/email/plain/#CryptoUUIDSentMail MailPlainR GET
/comm/email/attachment/#CryptoUUIDSentMail/#Text MailAttachmentR GET
/print PrintCenterR GET POST !system-printer
/print/acknowledge/#Day/#Int/#Int PrintAckR GET POST !system-printer

View File

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

View File

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

View File

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

View File

@ -15,6 +15,7 @@ module Database.Esqueleto.Utils
, (=?.), (?=.)
, (=~.), (~=.)
, (>~.), (<~.)
, (~.), (~*.), (!~.), (!~*.)
, or, and
, any, all
, not__, parens
@ -26,6 +27,7 @@ module Database.Esqueleto.Utils
, mkContainsFilterWithSet, mkContainsFilterWithComma, mkContainsFilterWithCommaPlus
, mkDayFilter, mkDayFilterFrom, mkDayFilterTo
, mkExistsFilter, mkExistsFilterWithComma
-- , mkRegExFilterWith
, anyFilter, allFilter
, ascNullsFirst, descNullsLast
, orderByList
@ -53,6 +55,7 @@ module Database.Esqueleto.Utils
, day, day', dayMaybe, interval, diffDays, diffTimes
, exprLift
, explicitUnsafeCoerceSqlExprValue
, psqlVersion_
, truncateTable
, module Database.Esqueleto.Utils.TH
) where
@ -163,6 +166,24 @@ infixl 4 <~.
(<~.) :: PersistField typ => E.SqlExpr (E.Value typ) -> E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value Bool)
(<~.) a b = E.isNothing b E.||. (E.just a E.<. b)
infixr 2 ~., ~*., !~., !~*.
-- | PostgreSQL regular expression match, case sensitive. Works, but may throw SQL error for unblanced parenthesis, etc. Not suitable for dbTable filters
(~.) :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value Bool)
(~.) = E.unsafeSqlBinOp " ~ "
-- | PostgreSQL regular expression match, case insensitive. Works, but may throw SQL errors
(~*.) :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value Bool)
(~*.) = E.unsafeSqlBinOp " ~* "
-- | PostgreSQL regular expression does not match, case sensitive. Works, but may throw SQL error for unblanced parenthesis, etc. Not suitable for dbTable filters
(!~.) :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value Bool)
(!~.) = E.unsafeSqlBinOp " !~ "
-- | PostgreSQL regular expression does not match, case insensitive. Works, but may throw SQL errors
(!~*.) :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value Bool)
(!~*.) = E.unsafeSqlBinOp " !~* "
-- | Negation of `isNothing` which is missing
isJust :: PersistField typ => E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value Bool)
@ -415,6 +436,18 @@ mkContainsFilterWithCommaPlus cast lenslike row (foldMap commaSeparatedText -> c
cond_compulsory = all (hasInfix (lenslike row) . E.val . cast) compulsories
cond_optional = any (hasInfix (lenslike row) . E.val . cast) alternatives
-- like `mkContainsFilterWith` but allows regular expression criterias
-- This works, but throws SQL errors for unbalanced parenthesis and similar invalid regex expressions
-- mkRegExFilterWith :: (E.SqlString b, Ord a)
-- => (a -> b)
-- -> (t -> E.SqlExpr (E.Value b)) -- ^ getter from query to searched element
-- -> t -- ^ query row
-- -> Set.Set a -- ^ needle collection
-- -> E.SqlExpr (E.Value Bool)
-- mkRegExFilterWith cast lenslike row criterias
-- | Set.null criterias = true
-- | otherwise = any ((~.) (lenslike row) . E.val . cast) criterias
mkDayFilter :: (t -> E.SqlExpr (E.Value UTCTime)) -- ^ getter from query to searched element
-> t -- ^ query row
-> Last Day -- ^ a day to filter for
@ -656,6 +689,7 @@ infixl 8 ->.
infixl 8 ->>.
-- Unsafe variant, see Database.Esqueleto.PostgreSQL.JSON for a safe version!
(->>.) :: E.SqlExpr (E.Value a) -> Text -> E.SqlExpr (E.Value Text)
(->>.) expr t = E.unsafeSqlBinOp "->>" expr $ E.val t
@ -781,6 +815,8 @@ instance (PersistField a1, PersistField a2, PersistField b, Finite a1, Finite a2
]
(E.else_ $ E.else_ $ E.veryUnsafeCoerceSqlExprValue (E.nothing :: E.SqlExpr (E.Value (Maybe ()))))
psqlVersion_ :: E.SqlExpr (E.Value Text)
psqlVersion_ = E.unsafeSqlFunction "VERSION" ()
-- Suspected to cause trouble. Needs more testing!
-- truncateTable :: (MonadIO m, BackendCompatible SqlBackend backend, PersistEntity record)

View File

@ -122,6 +122,7 @@ breadcrumb ProblemWithoutAvsId = i18nCrumb MsgProblemsNoAvsIdHeading $ Just
breadcrumb ProblemFbutNoR = i18nCrumb MsgProblemsRWithoutFHeading $ Just AdminProblemsR
breadcrumb ProblemAvsSynchR = i18nCrumb MsgProblemsAvsSynchHeading $ Just AdminProblemsR
breadcrumb ProblemAvsErrorR = i18nCrumb MsgProblemsAvsErrorHeading $ Just AdminProblemsR
breadcrumb ConfigInterfacesR = i18nCrumb MsgConfigInterfacesHeading $ Just AdminProblemsR
breadcrumb FirmAllR = i18nCrumb MsgMenuFirms Nothing
breadcrumb FirmsCommR{} = i18nCrumb MsgMenuFirmsComm $ Just FirmAllR
@ -133,6 +134,7 @@ breadcrumb CommCenterR = i18nCrumb MsgMenuCommCenter Nothing
breadcrumb MailCenterR = i18nCrumb MsgMenuMailCenter $ Just CommCenterR
breadcrumb MailHtmlR{} = i18nCrumb MsgMenuMailHtml $ Just MailCenterR
breadcrumb MailPlainR{} = i18nCrumb MsgMenuMailPlain $ Just MailCenterR
breadcrumb (MailAttachmentR mid _) = i18nCrumb MsgMenuMailAttachment $ Just $ MailHtmlR mid
breadcrumb PrintCenterR = i18nCrumb MsgMenuApc $ Just CommCenterR
breadcrumb PrintSendR = i18nCrumb MsgMenuPrintSend $ Just PrintCenterR
@ -2533,6 +2535,20 @@ pageActions AdminCrontabR = return
}
]
pageActions AdminProblemsR = return
[ NavPageActionPrimary
{ navLink = defNavLink MsgConfigInterfacesHeading ConfigInterfacesR
, navChildren = []
}
, NavPageActionPrimary
{ navLink = defNavLink MsgProblemsAvsSynchHeading ProblemAvsSynchR
, navChildren = []
}
, NavPageActionSecondary
{ navLink = defNavLink MsgProblemsAvsErrorHeading ProblemAvsErrorR
}
]
pageActions _ = return []
submissionList :: ( MonadIO m

View File

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

View File

@ -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>
@ -316,7 +341,13 @@ resultUser :: Traversal' ProblemLogTableData (Entity User)
resultUser = _dbrOutput . _3 . _Just
mkProblemLogTable :: DB (FormResult (ProblemTableActionData, Set ProblemLogId), Widget)
mkProblemLogTable = over _1 postprocess <$> dbTable validator DBTable{..}
mkProblemLogTable = do
-- problem_types <- E.select $ do
-- ap <- E.from $ E.table @ProblemLog
-- let res = ap E.^. ProblemLogInfo E.->>. "problem"
-- E.groupBy res
-- return res
over _1 postprocess <$> dbTable validator DBTable{..}
where
-- TODO: query to collect all occurring problem types to use as tooltip for the problem filter, so that these don't run out of synch
dbtIdent = "problem-log" :: Text
@ -326,7 +357,7 @@ mkProblemLogTable = over _1 postprocess <$> dbTable validator DBTable{..}
EL.on (solver E.?. UserId E.==. problem E.^. ProblemLogSolver)
return (problem, solver, usr)
dbtRowKey = queryProblem >>> (E.^. ProblemLogId)
dbtProj = dbtProjId
dbtProj = dbtProjFilteredPostId
dbtColonnade = formColonnade $ mconcat
[ dbSelect (applying _2) id $ return . view (resultProblem . _entityKey)
, sortable (Just "time") (i18nCell MsgAdminProblemCreated) $ \( view $ resultProblem . _entityVal . _problemLogTime -> t) -> dateTimeCell t
@ -349,14 +380,20 @@ mkProblemLogTable = over _1 postprocess <$> dbTable validator DBTable{..}
dbtFilter = mconcat
[ single ("user" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to queryUser) (E.?. UserDisplayName))
, single ("solver" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to querySolver) (E.?. UserDisplayName))
, single ("problem" , FilterColumn . E.mkContainsFilter $ views (to queryProblem) ((E.->>. "problem").(E.^. ProblemLogInfo)))
, single ("company" , FilterColumn . E.mkContainsFilter $ views (to queryProblem) ((E.->>. "company").(E.^. ProblemLogInfo)))
, single ("solved" , FilterColumn . E.mkExactFilterLast $ views (to queryProblem) (E.isJust . (E.^. ProblemLogSolved)))
-- , single ("problem" , FilterColumn . E.mkContainsFilter $ views (to queryProblem) ((E.->>. "problem").(E.^. ProblemLogInfo))) -- not stored in plaintext!
, single ("problem" , mkFilterProjectedPost $ \(getLast -> criterion) dbr -> -- falls es nicht schnell genug ist: in dbtProj den Anzeigetext nur einmal berechnen
ifNothingM criterion True $ \(crit::Text) -> do
let problem = dbr ^. resultProblem . _entityVal . _problemLogAdminProblem
protxt <- adminProblem2Text problem
return $ crit `Text.isInfixOf` protxt
)
]
dbtFilterUI mPrev = mconcat
[ prismAForm (singletonFilter "user" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgAdminProblemUser & setTooltip MsgTableFilterCommaPlus)
, prismAForm (singletonFilter "solver" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgAdminProblemSolver & setTooltip MsgTableFilterCommaPlusShort)
, prismAForm (singletonFilter "problem" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgAdminProblemInfo & setTooltip MsgAdminProblemInfoTooltip)
, prismAForm (singletonFilter "problem" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgAdminProblemInfo)
, prismAForm (singletonFilter "company" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableCompanyShort)
, prismAForm (singletonFilter "solved" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgAdminProblemSolved)
]

View File

@ -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 <- 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,9 +624,11 @@ instance HasUser LicenceTableData where
-- instance HasQualificationUser LicenceTableData where -- Not possible, since not all rows have a QualificationUser
-- hasQualificationUser = resultQualUser . _entityVal
mkLicenceTable :: AvsPersonIdMapPersonCard -> Text -> AvsLicence -> Set AvsPersonId -> DB (FormResult (LicenceTableActionData, Set AvsPersonId), Widget)
mkLicenceTable apidStatus dbtIdent aLic apids = do
currentRoute <- fromMaybe (error "mkLicenceTable called from 404-handler") <$> liftHandler getCurrentRoute
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
@ -571,7 +669,18 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do
(\(E.Value cmpSh, E.Value cmpName, E.Value cmpSpr) -> simpleLink (citext2widget cmpName) (FirmUsersR cmpSh) <> bool mempty icnSuper cmpSpr) <$> companies'
pure $ intercalate (text2widget "; ") companies
, sortable (Just "qualification") (i18nCell MsgTableQualifications) $ \(preview resultQualification -> q) -> cellMaybe lmsShortCell q
, sortable (Just "qualification") (i18nCell MsgTableQualifications) $
if aLic /= AvsLicenceVorfeld
then
\(preview resultQualification -> q) -> cellMaybe lmsShortCell q
else
\row ->
let q = row ^? resultQualification
apid = row ^. resultUserAvs . _userAvsPersonId
warnCell c = if Set.member apid rsChanged
then c <> spacerCell <> wgtCell usrHasAvsRerr -- expected to be effectively dead code in practice, but we never know
else c
in warnCell $ cellMaybe lmsShortCell q
, sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \(preview $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> cellMaybe dayCell d
, sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \(preview $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> cellMaybe dayCell d
-- , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \(preview $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> cellMaybe dayCell d

View File

@ -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)}
|]

View File

@ -97,7 +97,7 @@ firmActionMap mr isAdmin acts = mconcat (mkAct isAdmin <$> acts)
<$> aopt boolField' (fslI MsgFirmActResetSuperKeep) (Just $ Just False)
<*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True )
mkAct _ FirmActAddSupervisors = singletonMap FirmActAddSupervisors $ FirmActAddSupervisorsData
<$> areq (textField & cfAnySeparatedSet) (fslI MsgTableIsDefaultSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing
<$> areq (textField & cfAnySeparatedSet) (fslI MsgFirmSuperDefault & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing
<*> areq checkBoxField (fslI MsgTableIsDefaultReroute) (Just True)
<*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing
<*> aopt (textField & cfStrip & addDatalist ucdefSuperReasons)
@ -666,6 +666,8 @@ mkFirmAllTable isAdmin uid = do
E.&&. qual E.^. QualificationShorthand E.==. E.val criterion
E.&&. validQualification now usrQual
)
, single ("company-address", FilterColumn $ E.mkContainsFilterWithCommaPlus id $ views (to queryAllCompany) ((E.->>. "markup-input").(E.^. CompanyPostAddress))
)
]
dbtFilterUI mPrev = mconcat
[ fltrCompanyNameUI mPrev
@ -675,7 +677,8 @@ mkFirmAllTable isAdmin uid = do
, prismAForm (singletonFilter "is-supervisor") mPrev $ aopt textField (fslI MsgTableSupervisor)
, prismAForm (singletonFilter "is-default-supervisor") mPrev $ aopt textField (fslI MsgFirmSuperDefault)
, prismAForm (singletonFilter "foreign-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterForeignSupervisor)
, prismAForm (singletonFilter "company-postal" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterFirmExtern)
, prismAForm (singletonFilter "company-postal" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterFirmExtern & setTooltip MsgFilterFirmExternTooltip)
, prismAForm (singletonFilter "company-address") mPrev $ aopt textField (fslI MsgFirmAddress)
, fltrQualificationHdrUI MsgFilterHasQualification mPrev
]
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
@ -739,29 +742,28 @@ embedRenderMessage ''UniWorX ''FirmUserAction id
data FirmUserActionData = FirmUserActNotifyData
| FirmUserActResetSupervisionData
{ firmUserActResetKeepOldSupers :: Maybe Bool
-- , firmUserActResetMutualSupervision :: Maybe Bool
{ firmUserActResetSupers :: Maybe Bool
}
| FirmUserActSetSupervisorData
{ firmUserActSetSuperNames :: Maybe (Set Text)
, firmUserActSetSuperIds :: Maybe [UserId]
, firmUserActSetSuperReason :: Maybe Text
, 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
{ firmUserActDetailPriority :: Maybe Int
, firmUserActDetailReason :: Maybe Text
}
| FirmUserActChangeContactData
{ firmUserActPostalAddr :: Maybe StoredMarkup
, firmUserActUseCompanyPostal :: Maybe Bool
, firmUserActPostalPref :: Maybe Bool
{ firmUserActPostalAddr :: Maybe StoredMarkup
, firmUserActUseCompanyPostal :: Maybe Bool
, firmUserActPostalPref :: Maybe Bool
}
| FirmUserActRemoveData
{ firmUserActRemoveKeepSuper :: Bool
{ firmUserActRemoveSupers :: Bool
}
deriving (Eq, Ord, Show, Generic)
@ -801,24 +803,27 @@ mkFirmUserTable :: Bool -> CompanyId -> DB (FormResult (FirmUserActionData, Set
mkFirmUserTable isAdmin cid = do
mr <- getMessageRender
let
mkSprOption (E.Value uid, E.Value udn, E.Value mbSpr) = do
reasonSuperior = Just $ tshow SupervisorReasonAvsSuperior
mkSprOption (E.Value uid, E.Value udn, E.Value mbSpr, E.Value mbmbReason) = do
uuid <- toPathPiece <$> encryptUser uid
return (Option{ optionDisplay = udn, optionInternalValue = uid, optionExternalValue = uuid }, mbSpr)
return (Option{ optionDisplay = udn, optionInternalValue = uid, optionExternalValue = uuid }, mbSpr, mbmbReason == Just reasonSuperior)
procOptions rawSupers = do
procSupers <- traverse mkSprOption rawSupers
return $ mkOptionListGrouped $ filter (notNull . snd)
[ (mr MsgFirmSuperDefault , [opt | (opt, Just True ) <- procSupers])
, (mr 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
@ -962,25 +967,24 @@ mkFirmUserTable isAdmin cid = do
acts = mconcat
[ guardMonoid isAdmin $ singletonMap FirmUserActNotify $ pure FirmUserActNotifyData
, singletonMap FirmUserActResetSupervision $ FirmUserActResetSupervisionData
<$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just $ Just False)
-- <*> aopt 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
<*> aopt (textField & cfStrip & addDatalist superReasons) (fslI MsgUserSupervisorReason & setTooltip MsgUserSupervisorReasonTooltip) Nothing
<*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just False)
<*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just False)
<*> 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 FirmUserActChangeDetails $ FirmUserActChangeDetailsData
<$> aopt intField (fslI MsgCompanyUserPriority & setTooltip MsgCompanyUserPriorityTip) Nothing
<*> aopt (textField & cfStrip & addDatalist userReasons) (fslI MsgUserCompanyReason & setTooltip (SomeMessages [SomeMessage MsgUserCompanyReasonTooltip, SomeMessage MsgNullDeletes])) Nothing
, singletonMap FirmUserActChangeContact $ FirmUserActChangeContactData
<$> aopt htmlField (fslI MsgPostAddress & setTooltip (SomeMessages [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing
<*> aopt boolField' (fslI MsgCompanyUserUseCompanyAddress & setTooltip MsgCompanyUserUseCompanyAddressTip) Nothing
<*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing
, singletonMap FirmUserActChangeDetails $ FirmUserActChangeDetailsData
<$> aopt intField (fslI MsgCompanyUserPriority & setTooltip MsgCompanyUserPriorityTip) Nothing
<*> aopt (textField & cfStrip & addDatalist userReasons) (fslI MsgUserCompanyReason & setTooltip (SomeMessages [SomeMessage MsgUserCompanyReasonTooltip, SomeMessage MsgNullDeletes])) Nothing
, singletonMap FirmUserActRemove $ FirmUserActRemoveData
<$> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just False)
<$> areq boolField' (fslI MsgFirmActRemoveSupers) (Just True)
]
dbtParams = DBParamsForm
{ dbParamsFormMethod = POST
@ -1047,6 +1051,10 @@ postFirmUsersR fsh = do
-- return usr
<*> mkFirmUserTable isAdmin cid
let resetSupers :: Maybe Bool -> NonEmpty UserId -> DB Int64
resetSupers Nothing _ = return 0
resetSupers (Just False) uids = deleteDefaultSupervisorsForUsers [] [] uids
resetSupers (Just True ) uids = deleteWhereCount [UserSupervisorUser <-. toList uids]
formResult fusrRes $ \case
(_, uids) | null uids -> addMessageI Error MsgUtilEmptyChoice
(FirmUserActNotifyData , uids) -> do
@ -1054,9 +1062,7 @@ postFirmUsersR fsh = do
redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids])
(FirmUserActResetSupervisionData{..}, set2NonEmpty (error "Unexpected empty user list in getFirmUserR action handler.") -> uids) -> do -- set guaranteed to be non-empty due to first case clause
runDB $ do
delSupers <- if firmUserActResetKeepOldSupers == Just False
then deleteDefaultSupervisorsForUsers [] [] uids
else return 0
delSupers <- resetSupers firmUserActResetSupers uids
newSupers <- addDefaultSupervisors Nothing cid uids
addMessageI Info $ MsgFirmResetSupervision delSupers newSupers
reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
@ -1075,8 +1081,7 @@ postFirmUsersR fsh = do
<li>#{usr}
|]
in addMessageModal Error (i18n . MsgCourseParticipantsRegisterNotFoundInAvs $ length usersNotFound) (Right msgContent)
delSupers <- runDB
$ bool (deleteDefaultSupervisorsForUsers [cid] [] uids) (return 0) firmUserActSetSuperKeep
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
@ -1113,11 +1118,15 @@ postFirmUsersR fsh = do
allok = bool Warning Success $ nrChanged == total
addMessageI allok $ MsgFirmUserActChangeResult nrChanged total
reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
(FirmUserActRemoveData{}, Set.toList -> uids) -> do
(nrUc, nrSuper, nrSubs) <- runDB $ deleteCompanyUser cid uids
(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 $ nrUc == total
addMessageI allok $ MsgFirmuserActRemoveResult nrUc nrSuper nrSubs
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, FirmActAddSupervisors, FirmActChangeContactFirm, FirmActChangeContactUser]
@ -1147,7 +1156,7 @@ data FirmSuperActionData = FirmSuperActNotifyData
, firmSuperActSwitchReroute :: Maybe Bool
}
| FirmSuperActRMSuperDefData
{ firmSuperActRMSuperActive :: Maybe Bool }
{ firmSuperActRMSuperActive :: Bool }
deriving (Eq, Ord, Show, Generic)
@ -1198,20 +1207,22 @@ mkFirmSuperTable :: Bool -> CompanyId -> DB (FormResult (FirmSuperActionData, Se
mkFirmSuperTable isAdmin cid = do
msgSupervisorUnchanged <- messageI Info MsgFirmSuperActSwitchSuperInfo
let
reasonSuperior = Just $ tshow SupervisorReasonAvsSuperior
reasonSuperior = tshow SupervisorReasonAvsSuperior
-- fsh = unCompanyKey cid
resultDBTable = DBTable{..}
where
dbtSQLQuery = \(usr `E.LeftOuterJoin` usrCmp) -> do
EL.on $ usr E.^. UserId E.=?. usrCmp E.?. UserCompanyUser E.&&. usrCmp E.?. UserCompanyCompany E.?=. E.val cid
E.where_ $ E.isTrue (usrCmp E.?. UserCompanySupervisor)
E.||. 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
@ -1232,15 +1243,11 @@ mkFirmSuperTable isAdmin cid = do
, colUserEmail
, sortable (Just "supervised") (i18nCell MsgTableCompanyNrEmpSupervised) $ \(view resultSuperCompanySupervised -> nr) -> wgtCell $ word2widget nr
, sortable (Just "rerouted") (i18nCell MsgTableCompanyNrEmpRerouted ) $ \(view resultSuperCompanyReroutes -> nr) -> wgtCell $ word2widget nr
-- , sortable (Just "def-super") (i18nCell MsgTableIsDefaultSupervisor) $ \(view resultSuperCompanyDefaultSuper -> mb) -> case mb of { Nothing -> iconCell IconSupervisorForeign; Just True -> iconCell IconSupervisor; Just False -> iconSpacerCell }
, sortable (Just "def-super") (i18nCell MsgTableIsDefaultSupervisor) $ \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
]
@ -1263,20 +1270,40 @@ mkFirmSuperTable isAdmin cid = do
]
dbtFilter = mconcat
[ single $ fltrUserNameEmail querySuperUser
, singletonMap "is-foreign-supervisor" $ FilterColumn $ \(querySuperUserCompany -> suc) (getLast -> criterion) ->
case criterion of
Nothing -> E.true
Just True -> E.isNothing $ suc E.?. UserCompanyUser
Just False -> E.isJust $ suc E.?. UserCompanyUser
, singletonMap "super-relation-foreign" $ FilterColumn $ \row (getLast -> criterion) ->
let checkSuper = do
usrSpr <- E.from $ E.table @UserSupervisor
E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. querySuperUser row E.^. UserId
E.&&. E.exists (do
usr <- E.from $ E.table @UserCompany
E.where_ $ usr E.^. UserCompanyCompany E.!=. E.val cid
E.&&. usr E.^. UserCompanyUser E.==. usrSpr E.^. UserSupervisorUser
)
in case criterion of
Nothing -> E.true
Just True -> E.exists checkSuper
Just False -> E.notExists checkSuper
]
dbtFilterUI mPrev = mconcat
[ fltrUserNameEmailHdrUI MsgTableSupervisor mPrev
, prismAForm (singletonFilter "is-foreign-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmSuperForeign)
, prismAForm (singletonFilter "super-relation-foreign" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterIsForeignSupervisee)
]
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
acts :: Map FirmSuperAction (AForm Handler FirmSuperActionData)
acts = mconcat
[ guardMonoid isAdmin $ singletonMap FirmSuperActNotify $ pure FirmSuperActNotifyData
, singletonMap FirmSuperActSwitchSuper $ FirmSuperActSwitchSuperData
<$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableIsDefaultSupervisor) (Just $ Just True)
<*> aopt (boolField . 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
@ -1320,19 +1347,14 @@ postFirmSupersR fsh = do
formResult fsprRes $ \case
(_, uids) | null uids -> addMessageI Error MsgUtilEmptyChoice
(FirmSuperActRMSuperDefData{..}, Set.toList -> uids) -> do
(nrRmSuper,nrRmActual) <- runDB $ (,)
let optRemove = if firmSuperActRMSuperActive then id else const $ return 0
(nrRmSuper,nrRmSupers,nrRmSubs) <- runDB $ (,,)
<$> updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False]
<*> if firmSuperActRMSuperActive /= Just True
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
@ -1352,7 +1374,7 @@ postFirmSupersR fsh = do
formFirmAction <- runFirmActionFormPost cid (FirmSupersR fsh) isAdmin [FirmActAddSupervisors, FirmActResetSupervision, FirmActChangeContactFirm]
siteLayout (citext2widget fsh) $ do
siteLayout (citext2widget companyName) $ do
setTitle $ citext2Html $ fsh <> " Supers"
let firmContactInfo = $(widgetFile "firm-contact-info")
$(i18nWidgetFile "firm-supervisors")

View File

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

View File

@ -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
@ -148,32 +155,34 @@ mkInterfaceLogTable flagError interfs@(reqIfs, banIfs) = do
-- E.where_ $ E.not_ (ilog E.^. InterfaceLogInterface E.==. E.val "LMS" E.&&. ilog E.^. InterfaceLogSubtype E.==. E.val (sanitize "F")) -- BAD All missing, except for "Printer" "F"
-- E.where_ $ E.not_ $ E.parens (ilog E.^. InterfaceLogInterface E.==. E.val "LMS" E.&&. ilog E.^. InterfaceLogSubtype E.==. E.val (sanitize "F")) -- WORKS OKAY
-- E.where_ $ ilog E.^. InterfaceLogInterface E.!=. E.val "LMS" E.||. ilog E.^. InterfaceLogSubtype E.!=. E.val (sanitize "F") -- WORKS OKAY
let ihour = E.coalesceDefault [ihealth E.?. InterfaceHealthHours] (E.val $ 3 * 24) -- if no default time is set, use 3 days instead
let ihour = E.coalesceDefault [ihealth E.?. InterfaceHealthHours] (E.val defaultInterfaceWarnHours) -- if no default time is set, use a default instead
return (ilog, ihour)
queryILog :: (E.SqlExpr (Entity InterfaceLog) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity InterfaceHealth))) -> E.SqlExpr (Entity InterfaceLog)
queryILog = $(E.sqlLOJproj 2 1)
queryHealth :: (E.SqlExpr (Entity InterfaceLog) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity InterfaceHealth))) -> E.SqlExpr (Maybe (Entity InterfaceHealth))
queryHealth = $(E.sqlLOJproj 2 2)
resultILog :: Lens' (DBRow (Entity InterfaceLog, E.Value Int)) InterfaceLog
resultILog = _dbrOutput . _1 . _entityVal
resultHours :: Lens' (DBRow (Entity InterfaceLog, E.Value Int)) Int
resultHours = _dbrOutput . _2 . E._unValue
dbtRowKey = queryILog >>> (E.^.InterfaceLogId)
colonnade now = mconcat
colonnade now flagError = mconcat
[ sortable Nothing (i18nCell MsgInterfaceStatus) $ \row -> -- do
let hours = row ^. resultHours
-- defmsg = row ^? resultErrMsg
logtime = row ^. resultILog . _interfaceLogTime
success = row ^. resultILog . _interfaceLogSuccess
iface = row ^. resultILog . _interfaceLogInterface
status = success && (hours < 0 || now <= addHours hours logtime)
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
@ -189,6 +198,7 @@ mkInterfaceLogTable flagError interfs@(reqIfs, banIfs) = do
, singletonMap "time" $ SortColumn $ queryILog >>> (E.^. InterfaceLogTime)
, singletonMap "rows" $ SortColumn $ queryILog >>> (E.^. InterfaceLogRows)
, singletonMap "success" $ SortColumn $ queryILog >>> (E.^. InterfaceLogSuccess)
, singletonMap "hours" $ SortColumn $ \r -> E.coalesceDefault [queryHealth r E.?. InterfaceHealthHours] (E.val defaultInterfaceWarnHours)
]
ilvalidator = def & defaultSorting [SortAscBy "interface", SortAscBy "subtype", SortAscBy "write"]
dbtFilter = mempty
@ -258,3 +268,135 @@ avsInterfaceCheck interfs = maybeRunCheck interfs (UniqueInterfaceHealth "AVS" (
-- lastOk <- userAvsLastSynch . entityVal <<$>> selectFirst [UserAvsLastSynchError ==. Nothing] [Desc UserAvsLastSynch]
writeAvsSynchStats Nothing =<< mkBadInfo badRows badTime
_ -> return ()
data IWTableAction
= IWTActAdd
| IWTActDelete
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
instance Universe IWTableAction
instance Finite IWTableAction
nullaryPathPiece ''IWTableAction $ camelToPathPiece' 2
embedRenderMessage ''UniWorX ''IWTableAction id
data IWTableActionData
= IWTActAddData
{ iwtActInterface :: Text
, iwtActSubtype :: Maybe Text
, iwtActWrite :: Maybe Bool
, iwtActHours :: Int
}
| IWTActDeleteData
deriving (Eq, Ord, Read, Show, Generic)
type IWTableExpr = E.SqlExpr (Entity InterfaceHealth)
queryInterfaceHealth :: IWTableExpr -> E.SqlExpr (Entity InterfaceHealth)
queryInterfaceHealth = id
type IWTableData = DBRow (Entity InterfaceHealth)
resultInterfaceHealth :: Lens' IWTableData (Entity InterfaceHealth)
resultInterfaceHealth = _dbrOutput
wildcardCell :: IsDBTable m b => (a -> DBCell m b) -> Maybe a -> DBCell m b
wildcardCell _ Nothing = iconFixedCell $ icon IconWildcard
wildcardCell c (Just x) = c x
mkInterfaceWarnTable :: DB (FormResult (IWTableActionData, Set InterfaceHealthId), Widget)
mkInterfaceWarnTable = do
let
mkOption :: E.Value Text -> Option Text
mkOption (E.unValue -> t) = Option{ optionDisplay = t, optionInternalValue = t, optionExternalValue = toPathPiece t }
getSuggestion pj = E.select $ E.distinct $ do
il <- E.from $ E.table @InterfaceLog
let res = il E.^. pj
E.orderBy [E.asc res]
pure res
suggestionInterface :: HandlerFor UniWorX (OptionList Text)
suggestionInterface = mkOptionList . fmap mkOption <$> runDB (getSuggestion InterfaceLogInterface)
suggestionSubtype :: HandlerFor UniWorX (OptionList Text)
suggestionSubtype = mkOptionList . fmap mkOption <$> runDB (getSuggestion InterfaceLogSubtype)
dbtIdent = "interface-warnings" :: Text
dbtSQLQuery :: IWTableExpr -> E.SqlQuery IWTableExpr
dbtSQLQuery = return
dbtRowKey = queryInterfaceHealth >>> (E.^. InterfaceHealthId)
dbtProj = dbtProjId
dbtColonnade = formColonnade $ mconcat
[ dbSelect (applying _2) id (return . view (resultInterfaceHealth . _entityKey))
, sortable (Just "interface") (i18nCell MsgInterfaceName ) $ \(view (resultInterfaceHealth . _entityVal . _interfaceHealthInterface) -> n) -> textCell n
, sortable (Just "subtype") (i18nCell MsgInterfaceSubtype ) $ wildcardCell textCell . view (resultInterfaceHealth . _entityVal . _interfaceHealthSubtype )
, sortable (Just "write") (i18nCell MsgInterfaceWrite ) $ wildcardCell (iconFixedCell . iconWriteReadOnly) . view (resultInterfaceHealth . _entityVal . _interfaceHealthWrite )
-- , sortable (Just "hours") (i18nCell MsgInterfaceFreshness ) $ numCell . view (resultInterfaceHealth . _entityVal . _interfaceHealthHours )
, sortable (Just "hours") (i18nCell MsgInterfaceFreshness
& cellTooltip MsgTableDiffDaysTooltip ) $ warnIntervalCell . view (resultInterfaceHealth . _entityVal . _interfaceHealthHours )
]
dbtSorting = mconcat
[ singletonMap "interface" $ SortColumn $ queryInterfaceHealth >>> (E.^. InterfaceHealthInterface)
, singletonMap "subtype" $ SortColumn $ queryInterfaceHealth >>> (E.^. InterfaceHealthSubtype)
, singletonMap "write" $ SortColumn $ queryInterfaceHealth >>> (E.^. InterfaceHealthWrite)
, singletonMap "hours" $ SortColumn $ queryInterfaceHealth >>> (E.^. InterfaceHealthHours)
]
dbtFilter = mempty
dbtFilterUI = mempty
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
dbtParams = DBParamsForm
{ dbParamsFormMethod = POST
, dbParamsFormAction = Nothing -- Just $ SomeRoute currentRoute
, dbParamsFormAttrs = []
, dbParamsFormSubmit = FormSubmit
, dbParamsFormAdditional
= let acts :: Map IWTableAction (AForm Handler IWTableActionData)
acts = mconcat
[ singletonMap IWTActAdd $ IWTActAddData
<$> apreq (textField & cfStrip & addDatalist suggestionInterface) (fslI MsgInterfaceName) Nothing
<*> aopt (textField & cfStrip & addDatalist suggestionSubtype) (fslI MsgInterfaceSubtype) Nothing
<*> aopt boolField' (fslI MsgInterfaceWrite) Nothing
<*> apreq intField (fslI MsgInterfaceFreshness & setTooltip MsgHours) Nothing
, singletonMap IWTActDelete $ pure IWTActDeleteData
]
in renderAForm FormStandard
$ (, mempty) . First . Just
<$> multiActionA acts (fslI MsgTableAction) Nothing
, dbParamsFormEvaluate = liftHandler . runFormPost
, dbParamsFormResult = id
, dbParamsFormIdent = def
}
dbtCsvEncode = noCsvEncode
dbtCsvDecode = Nothing
dbtExtraReps = []
postprocess :: FormResult (First IWTableActionData, DBFormResult InterfaceHealthId Bool IWTableData)
-> FormResult ( IWTableActionData, Set InterfaceHealthId)
postprocess inp = do
(First (Just act), jobMap) <- inp
let jobSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) jobMap
return (act, jobSet)
psValidator = def & defaultSorting [SortAscBy "interface", SortAscBy "subtype", SortAscBy "write"]
over _1 postprocess <$> dbTable psValidator DBTable{..}
getConfigInterfacesR, postConfigInterfacesR :: Handler Html
getConfigInterfacesR = postConfigInterfacesR
postConfigInterfacesR = do
((interfaceOks, interfaceTable), (warnRes, configTable)) <- runDB $ (,)
<$> mkInterfaceLogTable mempty
<*> mkInterfaceWarnTable
let interfacesBadNr = length $ filter (not . snd) interfaceOks
formResult warnRes $ \case
(IWTActAddData{..}, _) -> do
void $ runDB $ upsertBy
(UniqueInterfaceHealth iwtActInterface iwtActSubtype iwtActWrite)
( InterfaceHealth iwtActInterface iwtActSubtype iwtActWrite iwtActHours)
[InterfaceHealthHours =. iwtActHours]
addMessageI Success MsgInterfaceWarningAdded
reloadKeepGetParams ConfigInterfacesR
(IWTActDeleteData, ihids) -> do
runDB $ mapM_ delete ihids
addMessageI Success $ MsgInterfaceWarningDeleted $ Set.size ihids
reloadKeepGetParams ConfigInterfacesR
siteLayoutMsg MsgConfigInterfacesHeading $ do
setTitleI MsgConfigInterfacesHeading
let defWarnTime = formatDiffHours defaultInterfaceWarnHours
$(i18nWidgetFile "config-interfaces")

View File

@ -220,7 +220,6 @@ data LmsTableCsv = LmsTableCsv -- L..T..C.. -> ltc..
{ ltcDisplayName :: UserDisplayName
, ltcEmail :: UserEmail
, ltcCompany :: Maybe Text
, ltcCompanyNumbers :: CsvSemicolonList Int
, ltcValidUntil :: Day
, ltcLastRefresh :: Day
, ltcFirstHeld :: Day
@ -242,8 +241,7 @@ ltcExample :: LmsTableCsv
ltcExample = LmsTableCsv
{ ltcDisplayName = "Max Mustermann"
, ltcEmail = "m.mustermann@example.com"
, ltcCompany = Just "Example Brothers LLC, SecondaryJobs Inc"
, ltcCompanyNumbers = CsvSemicolonList [27,69]
, ltcCompany = Just "Example Brothers LLC"
, ltcValidUntil = succ compDay
, ltcLastRefresh = compDay
, ltcFirstHeld = pred $ pred compDay
@ -285,8 +283,7 @@ instance CsvColumnsExplained LmsTableCsv where
csvColumnsExplanations = genericCsvColumnsExplanations ltcOptions $ Map.fromList
[ ('ltcDisplayName , SomeMessage MsgLmsUser)
, ('ltcEmail , SomeMessage MsgTableLmsEmail)
, ('ltcCompany , SomeMessage MsgTableCompanies)
, ('ltcCompanyNumbers , SomeMessage MsgTableCompanyNos)
, ('ltcCompany , SomeMessage MsgTablePrimeCompany)
, ('ltcValidUntil , SomeMessage MsgLmsQualificationValidUntil)
, ('ltcLastRefresh , SomeMessage MsgTableQualificationLastRefresh)
, ('ltcFirstHeld , SomeMessage MsgTableQualificationFirstHeld)
@ -320,7 +317,7 @@ queryQualBlock :: LmsTableExpr -> E.SqlExpr (Maybe (Entity QualificationUserBloc
queryQualBlock = $(sqlLOJproj 2 2)
type LmsTableData = DBRow (Entity QualificationUser, Entity User, Entity LmsUser, Maybe (Entity QualificationUserBlock), E.Value (Maybe [Maybe UTCTime]), [Entity UserCompany], E.Value Bool)
type LmsTableData = DBRow (Entity QualificationUser, Entity User, Entity LmsUser, Maybe (Entity QualificationUserBlock), E.Value (Maybe [Maybe UTCTime]), E.Value (Maybe CompanyId), E.Value Bool)
resultQualUser :: Lens' LmsTableData (Entity QualificationUser)
resultQualUser = _dbrOutput . _1
@ -337,8 +334,8 @@ resultQualBlock = _dbrOutput . _4 . _Just
resultPrintAck :: Traversal' LmsTableData [Maybe UTCTime]
resultPrintAck = _dbrOutput . _5 . _unValue . _Just
resultCompanyUser :: Lens' LmsTableData [Entity UserCompany]
resultCompanyUser = _dbrOutput . _6
resultCompanyId :: Traversal' LmsTableData CompanyId
resultCompanyId = _dbrOutput . _6 . _unValue . _Just
resultValidQualification :: Lens' LmsTableData Bool
resultValidQualification = _dbrOutput . _7 . _unValue
@ -406,6 +403,7 @@ lmsTableQuery :: UTCTime -> QualificationId -> LmsTableExpr
, E.SqlExpr (Entity LmsUser)
, E.SqlExpr (Maybe (Entity QualificationUserBlock))
, E.SqlExpr (E.Value (Maybe [Maybe UTCTime])) -- outer maybe indicates, whether a printJob exists, inner maybe indicates all acknowledged printJobs
, E.SqlExpr (E.Value (Maybe CompanyId))
, E.SqlExpr (E.Value Bool)
)
lmsTableQuery now qid (qualUser `E.InnerJoin` user `E.InnerJoin` lmsUser `E.LeftOuterJoin` qualBlock) = do
@ -421,12 +419,16 @@ lmsTableQuery now qid (qualUser `E.InnerJoin` user `E.InnerJoin` lmsUser `E.Left
E.where_ $ E.val qid E.==. qualUser E.^. QualificationUserQualification
-- Letztes Datum anzeigen, wenn mehrere, dann diese in klickbaren Tooltip verstecken!
let printAcknowledged = E.subSelectMaybe . E.from $ \pj -> do
E.where_ $ E.isJust (pj E.^. PrintJobLmsUser)
E.&&. ((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
@ -435,25 +437,26 @@ mkLmsTable :: ( Functor h, ToSortable h
=> Bool
-> Entity Qualification
-> Map LmsTableAction (AForm Handler LmsTableActionData)
-> (Map CompanyId Company -> cols)
-> ((CompanyId -> CompanyName) -> cols)
-> PSValidator (MForm Handler) (FormResult (First LmsTableActionData, DBFormResult UserId Bool LmsTableData))
-> DB (FormResult (LmsTableActionData, Set UserId), Widget)
mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
now <- liftIO getCurrentTime
-- lookup all companies
cmpMap <- memcachedBy (Just . Right $ 5 * diffMinute) ("CompanyDictionary"::Text) $ do
cmpMap <- memcachedBy (Just . Right $ 15 * diffMinute) ("CompanyDictionary"::Text) $ do
cmps <- selectList [] [] -- [Asc CompanyShorthand]
return $ Map.fromList $ fmap (\Entity{..} -> (entityKey, entityVal)) cmps
let
getCompanyName :: CompanyId -> CompanyName
getCompanyName cid = maybe (unCompanyKey cid) companyName $ Map.lookup cid cmpMap -- use shorthand in case of impossible failure
csvName = T.replace " " "-" $ ciOriginal (quali ^. _qualificationName)
dbtIdent :: Text
dbtIdent = "lms"
dbtSQLQuery = lmsTableQuery now qid
dbtRowKey = queryUser >>> (E.^. UserId)
dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr, qUsrBlock, printAcks, validQ) -> do
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
@ -544,25 +547,20 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
doEncode' = LmsTableCsv
<$> view (resultUser . _entityVal . _userDisplayName)
<*> view (resultUser . _entityVal . _userDisplayEmail)
<*> (view resultCompanyUser >>= getCompanies)
<*> (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 = []
@ -627,16 +625,12 @@ postLmsR sid qsh = do
-- <*> aopt (commentField MsgQualificationActBlockSupervisor) (fslI MsgMessageWarning) Nothing
<* aformMessage msgRestartWarning
]
colChoices cmpMap = mconcat
colChoices getCompanyName = mconcat
[ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultUser . _entityKey))
, colUserNameModalHdrAdmin MsgLmsUser AdminUserR
, colUserEmail
, sortable (Just "user-company") (i18nCell MsgTableCompany) $ \( view resultCompanyUser -> cmps) ->
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

View File

@ -8,6 +8,7 @@ module Handler.MailCenter
( getMailCenterR, postMailCenterR
, getMailHtmlR
, getMailPlainR
, getMailAttachmentR
) where
import Import
@ -96,7 +97,7 @@ mkMCTable = do
, sortable Nothing (i18nCell MsgCommSubject) $ \(view resultMail -> Entity k v) ->
let subject = v ^? _sentMailHeaders . _mailHeaders' . _mailHeader' "Subject"
linkWgt = maybe (msg2widget MsgUtilEMail) text2widget subject
in anchorCellM (MailPlainR <$> encrypt k) linkWgt
in anchorCellM (MailHtmlR <$> encrypt k) linkWgt
-- , sortable Nothing (i18nCell MsgCommContent) $ \(view $ resultMail . _entityKey -> k) -> anchorCellM (MailHtmlR <$> encrypt k) (text2widget "html")
-- , sortable Nothing (i18nCell MsgCommSubject) $ \(preview $ resultMail . _entityVal . _sentMailHeaders . _mailHeaders' . _mailHeader' "Subject" -> h) -> cellMaybe textCell h
]
@ -107,12 +108,14 @@ mkMCTable = do
dbtFilter = mconcat
[ single ("sent" , FilterColumn . E.mkDayFilterTo $ views (to queryMail) (E.^. SentMailSentAt))
, single ("recipient" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to queryRecipient) (E.?. UserDisplayName))
, single ("subject" , FilterColumn . E.mkContainsFilter $ views (to queryMail) (E.str2text . (E.^. SentMailHeaders)))
, single ("subject" , FilterColumn . E.mkContainsFilterWithCommaPlus id $ views (to queryMail) (E.str2text . (E.^. SentMailHeaders)))
-- , single ("regex" , FilterColumn . E.mkRegExFilterWith id $ views (to queryMail) (E.str2text . (E.^. SentMailHeaders)))
]
dbtFilterUI mPrev = mconcat
[ prismAForm (singletonFilter "sent" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift dayField) (fslI MsgPrintJobCreated)
, prismAForm (singletonFilter "recipient" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintRecipient & setTooltip MsgTableFilterCommaPlus)
, prismAForm (singletonFilter "subject" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgCommSubject & setTooltip MsgTableFilterCommaPlusShort)
-- , prismAForm (singletonFilter "regex" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgCommSubject )
]
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout}
dbtIdent :: Text
@ -161,6 +164,27 @@ postMailCenterR = do
$(widgetFile "mail-center")
typePDF :: ContentType
typePDF = "application/pdf"
getMailAttachmentR :: CryptoUUIDSentMail -> Text -> Handler TypedContent
getMailAttachmentR cusm attdisp = do
smid <- decrypt cusm
(sm,cn) <- runDBRead $ do
sm <- get404 smid
cn <- get404 $ sm ^. _sentMailContentRef
return (sm,cn)
let mcontent = getMailContent (sentMailContentContent cn)
getAttm alts = case selectAlternative [typePDF] alts of
(Just Part{partContent=PartContent (LB.toStrict -> pc), partDisposition=AttachmentDisposition t}) -- partType=pt,
| t == attdisp
-> Just pc
_ -> Nothing
attm = firstJust getAttm mcontent
case attm of
(Just pc) -> sendByteStringAsFile (T.unpack attdisp) pc $ sm ^. _sentMailSentAt
_ -> notFound
getMailHtmlR :: CryptoUUIDSentMail -> Handler Html
getMailHtmlR = handleMailShow (SomeMessages [SomeMessage MsgUtilEMail, SomeMessage MsgMenuMailHtml]) [typeHtml,typePlain]
@ -178,6 +202,7 @@ handleMailShow hdr prefTypes cusm = do
setTitleI hdr
let mcontent = getMailContent (sentMailContentContent cn)
getHeader h = preview (_mailHeader' h) (sm ^. _sentMailHeaders . _mailHeaders')
mparts = reorderParts $ mapMaybe (selectAlternative prefTypes) mcontent
[whamlet|
<section>
<dl .deflist>
@ -212,15 +237,16 @@ handleMailShow hdr prefTypes cusm = do
#{decodeEncodedWord r}
<section>
$forall mc <- mcontent
$maybe pt <- selectAlternative prefTypes mc
<p>
^{part2widget pt}
$forall pt <- mparts
^{part2widget cusm pt}
|]
-- Include for Debugging:
-- ^{jsonWidget (sm ^. _sentMailHeaders)}
-- ^{jsonWidget (sentMailContentContent cn)}
-- 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
@ -232,34 +258,76 @@ selectAlternative (fmap decodeUtf8 -> prefTypes) allAlts = aux prefTypes allAlts
aux [] (pt:_) = Just pt
aux _ [] = Nothing
reorderParts :: [Part] -> [Part]
reorderParts = sortBy pOrder
where
pOrder Part{partDisposition=d1} Part{partDisposition=d2} = dispoOrder d1 d2
dispoOrder DefaultDisposition DefaultDisposition = EQ
dispoOrder DefaultDisposition _ = LT
dispoOrder _ DefaultDisposition = GT
dispoOrder (InlineDisposition t1) (InlineDisposition t2) = compare t1 t2
dispoOrder (InlineDisposition _) _ = LT
dispoOrder _ (InlineDisposition _) = GT
dispoOrder (AttachmentDisposition t1) (AttachmentDisposition t2) = compare t1 t2
disposition2widget :: Disposition -> Widget
disposition2widget (AttachmentDisposition n) = [whamlet|<h3>Attachment #{n}|]
disposition2widget (InlineDisposition n) = [whamlet|<h3>#{n}|]
disposition2widget (AttachmentDisposition _) = [whamlet|<h3>_{MsgMailFileAttachment}|]
disposition2widget (InlineDisposition n) = [whamlet|<h3>_{MsgMenuMailAttachment} #{n}|]
disposition2widget DefaultDisposition = mempty
part2widget :: Part -> Widget
part2widget Part{partContent=NestedParts ps} =
part2widget :: CryptoUUIDSentMail -> Part -> Widget
part2widget cusm Part{partContent=NestedParts ps} =
[whamlet|
<section>
$forall p <- ps
<p>
^{part2widget p}
^{part2widget cusm p}
|]
part2widget Part{partContent=PartContent (LB.toStrict -> pc), partType=pt, partDisposition=dispo} =
part2widget cusm Part{partContent=PartContent (LB.toStrict -> pc), partType=pt, partDisposition=dispo} =
[whamlet|
<section>
^{disposition2widget dispo}
^{showBody}
^{showPass}
|]
where
showBody
| pt == decodeUtf8 typePlain = toWidget $ preEscapedToHtml $ plaintextToHtml $ decodeUtf8 pc
| pt == decodeUtf8 typeHtml = toWidget $ preEscapedToHtml $ decodeUtf8 pc -- preEscapedToHtml :: ToMarkup a => a -> Html
| 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
| otherwise = [whamlet|part2widget cannot decode parts of type #{pt} yet.|]
| pt == decodeUtf8 typePDF
, AttachmentDisposition t <- dispo
= [whamlet|<a href=@{MailAttachmentR cusm t}>#{t}|]
| otherwise = [whamlet|FRADrive cannot decode email parts of type #{pt} yet.|]
showPass
| pt == decodeUtf8 typePlain
, let cw = T.words $ decodeUtf8 pc
, Just name <- listBracket ("Inhaber","Gültig") cw -- heursitic for dirving licence renewal letters only; improve
<|> listBracket ("Licensee","Valid") cw
= let sdn = T.filter (/= '*') (T.unwords $ dropWhile (":"==) name) in
liftHandler (runDBRead $ getByFilter [UserDisplayName ==. sdn]) >>= \case
Nothing -> mempty -- DEBUG: [whamlet|<h2>Not found: #{sdn}|]
Just Entity{entityVal = u@User{userPinPassword=mbpw}} ->
[whamlet|
<section>
$maybe pw <- mbpw
<details>
<summary>
_{MsgAdminUserPinPassword}
<p>
<dl .deflist>
<dt .deflist__dt>
^{userWidget u}
<dd .deflist__dd>
<b>
#{pw}
<p>
_{MsgAdminUserPinPassNotIncluded}
$nothing
_{MsgAdminUserNoPassword}
|]
| otherwise = mempty
------------------------------
-- Decode MIME Encoded Word

View File

@ -35,6 +35,7 @@ import Database.Esqueleto.Experimental ((:&)(..))
import qualified Database.Esqueleto.Experimental as E
import qualified Database.Esqueleto.Legacy as EL (on,from)
import qualified Database.Esqueleto.Utils as E
import qualified Database.Esqueleto.PostgreSQL as E
import qualified Data.Text as Text
import Data.List (inits)
@ -605,6 +606,7 @@ tableWidget :: TableHasData -> Widget
tableWidget = snd
-}
-- | Given a header message, a bool and widget; display widget and header only if the boolean is true
maybeTable :: (RenderMessage UniWorX a)
=> a -> (Bool, Widget) -> Widget
maybeTable m = maybeTable' m Nothing Nothing
@ -675,14 +677,24 @@ makeProfileData usrEnt@(Entity uid usrVal@User{..}) = do
qualificationsTable <- mkQualificationsTable now uid -- Tabelle mit allen Qualifikationen
supervisorsTable <- mkSupervisorsTable uid -- Tabelle mit allen Supervisors
superviseesTable <- mkSuperviseesTable actualPrefersPostal uid -- Tabelle mit allen Supervisees
let supervisorsWgt :: Widget =
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
@ -1093,10 +1105,10 @@ instance HasUser TblSupervisorData where
hasUser = _dbrOutput . _1 . _entityVal
-- | Table listing all supervisor of the given user
mkSupervisorsTable :: UserId -> DB ((Sum Int, Sum Int, Sum Int), Widget)
mkSupervisorsTable 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
@ -1114,8 +1126,7 @@ mkSupervisorsTable uid = dbTableWidget validator DBTable{..}
, sortable (Just "reroute") (i18nCell MsgTableRerouteActive) $ \row ->
let isReroute = row ^. resultUserSupervisor . _entityVal ._userSupervisorRerouteNotifications
isLetter = row ^. resultUser . _userPrefersPostal
in tellCell (Sum 1, Sum $ fromEnum isReroute, Sum $ fromEnum $ isReroute && isLetter) $
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)
@ -1146,10 +1157,10 @@ mkSupervisorsTable uid = dbTableWidget validator DBTable{..}
-- | Table listing all persons supervised by the given user
mkSuperviseesTable ::Bool -> UserId -> DB ((Sum Int, Sum Int), Widget)
mkSuperviseesTable 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
@ -1167,7 +1178,7 @@ mkSuperviseesTable userPrefersPostal uid = dbTableWidget validator DBTable{..}
-- , sortable (Just "postal-pref") (i18nCell MsgPrefersPostal) $ \(view $ resultUser . _userPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b
, sortable (Just "reroute") (i18nCell MsgTableRerouteActive) $ \row ->
let isReroute = row ^. resultUserSupervisor . _entityVal ._userSupervisorRerouteNotifications
in tellCell (Sum 1, Sum $ fromEnum isReroute) $ boolCell isReroute $ iconCell IconReroute <> iconCellLetterOrEmail
in boolCell isReroute $ iconCell IconReroute <> iconCellLetterOrEmail
, sortable (Just "cshort") (i18nCell MsgTableCompany) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorCompany -> mc) -> maybeCell mc (\(unCompanyKey -> c) -> anchorCell (FirmUsersR c) $ citext2widget c)
, sortable (Just "reason") (i18nCell MsgTableReason) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorReason -> mr) -> maybeCell mr textCell
]

View File

@ -96,12 +96,12 @@ mkQualificationAllTable isAdmin = do
maybeCell (qualificationDescription quali) markupCellLargeModal
, sortable Nothing (i18nCell MsgQualificationValidDuration & cellTooltip MsgTableDiffDaysTooltip) $
foldMap (textCell . formatCalendarDiffDays . fromMonths) . view (resultAllQualification . _qualificationValidDuration)
, sortable Nothing (i18nCell MsgQualificationRefreshWithin & cellTooltips [SomeMessage MsgQualificationRefreshWithinTooltip , SomeMessage MsgTableDiffDaysTooltip]) $
foldMap (textCell . formatCalendarDiffDays ) . view (resultAllQualification . _qualificationRefreshWithin)
, sortable (Just "qelearning") (i18nCell MsgTableLmsElearning & cellTooltip MsgQualificationElearningStart) $ \row ->
let elearnstart = row ^. resultAllQualification . _qualificationElearningStart
reminder = row ^. resultAllQualification . _qualificationRefreshReminder
in tickmarkCell $ elearnstart && isJust reminder
, sortable Nothing (i18nCell MsgQualificationRefreshWithin & cellTooltips [SomeMessage MsgQualificationRefreshWithinTooltip , SomeMessage MsgTableDiffDaysTooltip]) $
foldMap (textCell . formatCalendarDiffDays ) . view (resultAllQualification . _qualificationRefreshWithin)
, sortable Nothing (i18nCell MsgQualificationRefreshReminder & cellTooltips [SomeMessage MsgQualificationRefreshReminderTooltip, SomeMessage MsgTableDiffDaysTooltip]) $
foldMap (textCell . formatCalendarDiffDays ) . view (resultAllQualification . _qualificationRefreshReminder)
, sortable (Just "noteexpiry") (i18nCell MsgQualificationExpiryNotification & cellTooltip MsgQualificationExpiryNotificationTooltip)
@ -158,7 +158,6 @@ data QualificationTableCsv = QualificationTableCsv -- Q..T..C.. -> qtc..
{ qtcDisplayName :: UserDisplayName
, qtcEmail :: UserEmail
, qtcCompany :: Maybe Text
, qtcCompanyNumbers :: CsvSemicolonList Int
, qtcValidUntil :: Day
, qtcLastRefresh :: Day
, qtcBlockStatus :: Maybe Bool
@ -174,8 +173,7 @@ qtcExample :: QualificationTableCsv
qtcExample = QualificationTableCsv
{ qtcDisplayName = "Max Mustermann"
, qtcEmail = "m.mustermann@example.com"
, qtcCompany = Just "Example Brothers LLC, SecondaryJobs Inc"
, qtcCompanyNumbers = CsvSemicolonList [27,69]
, qtcCompany = Just "Example Brothers LLC"
, qtcValidUntil = compDay
, qtcLastRefresh = compDay
, qtcBlockStatus = Nothing
@ -209,8 +207,7 @@ instance CsvColumnsExplained QualificationTableCsv where
csvColumnsExplanations = genericCsvColumnsExplanations qtcOptions $ Map.fromList
[ ('qtcDisplayName , SomeMessage MsgLmsUser)
, ('qtcEmail , SomeMessage MsgTableLmsEmail)
, ('qtcCompany , SomeMessage MsgTableCompanies)
, ('qtcCompanyNumbers , SomeMessage MsgTableCompanyNos)
, ('qtcCompany , SomeMessage MsgTablePrimeCompany)
, ('qtcValidUntil , SomeMessage MsgLmsQualificationValidUntil)
, ('qtcLastRefresh , SomeMessage MsgTableQualificationLastRefresh)
, ('qtcBlockStatus , SomeMessage MsgInfoQualificationBlockStatus)
@ -238,7 +235,7 @@ queryLmsUser = $(sqlLOJproj 3 2)
queryQualBlock :: QualificationTableExpr -> E.SqlExpr (Maybe (Entity QualificationUserBlock))
queryQualBlock = $(sqlLOJproj 3 3)
type QualificationTableData = DBRow (Entity QualificationUser, Entity User, Maybe (Entity LmsUser), Maybe (Entity QualificationUserBlock), [Entity UserCompany])
type QualificationTableData = DBRow (Entity QualificationUser, Entity User, Maybe (Entity LmsUser), Maybe (Entity QualificationUserBlock), E.Value (Maybe CompanyId))
resultQualUser :: Lens' QualificationTableData (Entity QualificationUser)
resultQualUser = _dbrOutput . _1
@ -252,8 +249,8 @@ resultLmsUser = _dbrOutput . _3 . _Just
resultQualBlock :: Traversal' QualificationTableData (Entity QualificationUserBlock)
resultQualBlock = _dbrOutput . _4 . _Just
resultCompanyUser :: Lens' QualificationTableData [Entity UserCompany]
resultCompanyUser = _dbrOutput . _5
resultCompanyId :: Traversal' QualificationTableData CompanyId
resultCompanyId = _dbrOutput . _5 . _unValue . _Just
instance HasEntity QualificationTableData User where
@ -340,6 +337,7 @@ qualificationTableQuery :: UTCTime -> QualificationId -> (_ -> E.SqlExpr (E.Valu
, E.SqlExpr (Entity User)
, E.SqlExpr (Maybe (Entity LmsUser))
, E.SqlExpr (Maybe (Entity QualificationUserBlock))
, E.SqlExpr (E.Value (Maybe CompanyId))
)
qualificationTableQuery now qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser `E.LeftOuterJoin` qualBlock) = do
-- E.distinctOnOrderBy will not work: sorting with dbTable should work, except that columns contained in distinctOnOrderBy cannot be sorted inversely by user; but PostgreSQL leftJoin with distinct filters too many results, see SQL Example lead/lag under jost/misc DevOps
@ -351,7 +349,11 @@ qualificationTableQuery now qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJo
E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser
E.where_ $ fltr qualUser
E.&&. (E.val qid E.==. qualUser E.^. QualificationUserQualification)
return (qualUser, user, lmsUser, qualBlock)
let primeComp = E.subSelect . E.from $ \uc -> do
E.where_ $ user E.^. UserId E.==. uc E.^. UserCompanyUser
E.orderBy [E.desc $ uc E.^. UserCompanyPriority, E.asc $ uc E.^. UserCompanyCompany]
return (uc E.^. UserCompanyCompany)
return (qualUser, user, lmsUser, qualBlock, primeComp)
mkQualificationTable ::
@ -361,17 +363,19 @@ mkQualificationTable ::
=> Bool
-> Entity Qualification
-> Map QualificationTableAction (AForm Handler QualificationTableActionData)
-> (Map CompanyId Company -> cols)
-> ((CompanyId -> CompanyName) -> cols)
-> PSValidator (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableData))
-> DB (FormResult (QualificationTableActionData, Set UserId), Widget)
mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
svs <- getSupervisees
now <- liftIO getCurrentTime
-- lookup all companies
cmpMap <- memcachedBy (Just . Right $ 5 * diffMinute) ("CompanyDictionary"::Text) $ do
cmpMap <- memcachedBy (Just . Right $ 15 * diffMinute) ("CompanyDictionary"::Text) $ do
cmps <- selectList [] [] -- [Asc CompanyShorthand]
return $ Map.fromList $ fmap (\Entity{..} -> (entityKey, entityVal)) cmps
let
getCompanyName :: CompanyId -> CompanyName
getCompanyName cid = maybe (unCompanyKey cid) companyName $ Map.lookup cid cmpMap -- use shorthand in case of impossible failure
nowaday = utctDay now
mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday
csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName)
@ -380,15 +384,8 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
fltrSvs = if isAdmin then const E.true else \quser -> quser E.^. QualificationUserUser `Ex.in_` E.vals svs
dbtSQLQuery = qualificationTableQuery now qid fltrSvs
dbtRowKey = queryUser >>> (E.^. UserId)
dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr, qUsrBlock) -> do
-- 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
@ -471,8 +468,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
doEncode' = QualificationTableCsv
<$> view (resultUser . _entityVal . _userDisplayName)
<*> view (resultUser . _entityVal . _userDisplayEmail)
<*> (view resultCompanyUser >>= getCompanies)
<*> (view resultCompanyUser >>= getCompanyNos)
<*> preview (resultCompanyId . to getCompanyName . _CI)
<*> view (resultQualUser . _entityVal . _qualificationUserValidUntil)
<*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh)
<*> preview (resultQualBlock. _entityVal . _qualificationUserBlockUnblock . _not)
@ -480,10 +476,6 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
<*> view (resultQualUser . _entityVal . _qualificationUserScheduleRenewal)
<*> getStatusPlusTxt
<*> getStatusPlusDay
getCompanies cmps = case mapMaybe (flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) cmps of
[] -> pure Nothing
somecmps -> pure $ Just $ intercalate ", " $ fmap (view (_companyName . _CI)) somecmps
getCompanyNos = pure . CsvSemicolonList . mapMaybe (preview (_Just . _companyAvsId) . flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany))
getStatusPlusTxt =
(join . preview (resultLmsUser . _entityVal . _lmsUserStatus)) >>= \case
@ -551,7 +543,7 @@ postQualificationR sid qsh = do
Ex.groupBy (qblock Ex.^. QualificationUserBlockReason)
let countRows' :: Ex.SqlExpr (Ex.Value Int64) = Ex.countRows
Ex.orderBy [Ex.desc countRows']
Ex.limit 7
Ex.limit 9
pure (qblock Ex.^. QualificationUserBlockReason)
mkOption :: Ex.Value Text -> Option Text
mkOption (Ex.unValue -> t) = Option{ optionDisplay = t, optionInternalValue = t, optionExternalValue = toPathPiece t }
@ -585,16 +577,12 @@ postQualificationR sid qsh = do
] isAdmin
linkLmsUser = toMaybe isAdmin (LmsUserR sid qsh)
linkUserName = bool ForProfileR ForProfileDataR isAdmin
colChoices cmpMap = mconcat
colChoices getCompanyName = mconcat
[ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
, colUserNameModalHdr MsgLmsUser linkUserName
, colUserEmail
, sortable (Just "user-company") (i18nCell MsgTableCompany) $ \( view resultCompanyUser -> cmps) ->
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

View File

@ -44,7 +44,7 @@ import Data.Aeson hiding (Result(..))
-- import Handler.Users.Add as Handler.Users
import qualified Data.Conduit.List as C
-- import qualified Data.Conduit.List as C
import qualified Data.HashSet as HashSet
@ -191,18 +191,19 @@ postUsersR = do
fmap (setOf $ folded . _Value . _Just) . Ex.select . Ex.distinct $ do
usrc <- Ex.from $ Ex.table @UserSupervisor
E.where_ $ E.isJust (usrc E.^. UserSupervisorReason)
Ex.limit 9
return $ usrc E.^. UserSupervisorReason
acts :: Map UserAction (AForm Handler UserActionData)
acts = mconcat
[ singletonMap UserLdapSync $ pure UserLdapSyncData
, singletonMap UserAvsSync $ pure UserAvsSyncData
, singletonMap UserAddSupervisor $ UserAddSupervisorData
<$> apopt (textField & cfAnySeparatedSet) (fslI MsgTableSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing
<*> apopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just True)
<$> 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)
<$> 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
@ -424,7 +425,8 @@ postUsersR = do
formResult allUsersRes $ \case
AllUsersLdapSync -> do
runDBJobs . runConduit $ selectSource [] [] .| C.mapM_ (queueDBJob . JobSynchroniseLdapUser . entityKey)
-- runDBJobs . runConduit $ selectSource [] [] .| C.mapM_ (queueDBJob . JobSynchroniseLdapUser . entityKey) -- to slow to execute directly
queueJob' JobSynchroniseLdapAll
addMessageI Success MsgSynchroniseLdapAllUsersQueued
redirect UsersR
AllUsersAvsSync -> do

View File

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

View File

@ -22,7 +22,7 @@ module Handler.Utils.Avs
, computeDifferingLicences
-- , synchAvsLicences
, queryAvsFullStatus
-- , lookupAvsUser, lookupAvsUsers
, lookupAvsUser, lookupAvsUsers
, AvsException(..)
, updateReceivers
, AvsPersonIdMapPersonCard
@ -99,10 +99,10 @@ catchAVS2log :: (MonadHandler m, MonadCatch m, RenderMessage (HandlerSite m) Avs
catchAVS2log = catchAVShandler False True False Nothing
catchAll2log :: (MonadHandler m, MonadCatch m, RenderMessage (HandlerSite m) AvsException) => m a -> m ()
catchAll2log = voidMaybe $ catchAVShandler True True False Nothing
catchAll2log = voidMaybe catchAll2log'
-- catchAll2log' :: (MonadHandler m, MonadCatch m, RenderMessage (HandlerSite m) AvsException, Monoid a) => m a -> m ()
-- catchAll2log' = 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)
@ -329,6 +329,8 @@ updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAv
let usrId = userAvsUser usravs
usr <- MaybeT $ get usrId
lift $ do -- maybeT no longer needed from here onwards
uuid :: CryptoUUIDUser <- encrypt usrId
$logInfoS "AVS" [st|updateAvsUserByADC: #{tshow uuid}|]
let oldAvsPersonInfo = userAvsLastPersonInfo usravs -- Nothing is ok here
oldAvsFirmInfo = userAvsLastFirmInfo usravs -- Nothing is ok here
oldAvsCardNo = userAvsLastCardNo usravs & fmap Just
@ -380,71 +382,73 @@ updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAv
, UserAvsLastCardNo =. newAvsCardNo
]
-- update company association & supervision
Entity{entityKey=newCompanyId} <- upsertAvsCompany newAvsFirmInfo oldAvsFirmInfo
oldCompanyEnt <- getAvsCompany `traverseJoin` oldAvsFirmInfo
primaryCompanyId <- userCompanyCompany <<$>> getUserPrimaryCompany usrId
let oldCompanyId = entityKey <$> oldCompanyEnt
-- oldCompanyMb = entityVal <$> oldCompanyEnt
-- pst_up = if
-- -- | isNothing oldCompanyMb || oldCompanyId == primaryCompanyId -- refactor could replace next 4 lines
-- -- -> mkUpdate' usr newCompany oldCompanyMb $ CheckUpdate UserPrefersPostal _companyPrefersPostal -- always update if company association is fresh (case should not occur in practice though)
-- | isNothing oldCompanyMb
-- -> mkUpdateDirect usr newCompany $ CheckUpdate UserPrefersPostal _companyPrefersPostal -- always update if company association is fresh (case should not occur in practice though)
-- | oldCompanyId == primaryCompanyId -- && isJust oldCompanyId -- is ensured by previous line
-- -> mkUpdate usr newCompany oldCompanyMb $ CheckUpdate UserPrefersPostal _companyPrefersPostal -- possibly change postal preference
-- | otherwise
-- -> Nothing
superReasonComDef = tshow SupervisorReasonCompanyDefault
newUserComp = UserCompany usrId newCompanyId False False 1 True Nothing -- default value for new company insertion, if no update can be done
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
-- 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
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
@ -493,13 +497,12 @@ createAvsUserById muid api = do
-- check for matching existing user
let internalPersNo :: Maybe Text = cpi ^? _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo
-- persMail :: Maybe UserEmail = cpi ^? _avsInfoPersonEMail . _Just . from _CI
oldUsr <- runDBRead $ do
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
@ -563,8 +566,8 @@ createAvsUserById muid api = do
return uid
getAvsCompanyId :: AvsFirmInfo -> DB (Maybe CompanyId)
getAvsCompanyId = fmap (fmap entityKey) . getAvsCompany
-- getAvsCompanyId :: AvsFirmInfo -> DB (Maybe CompanyId)
-- getAvsCompanyId = fmap (fmap entityKey) . getAvsCompany
-- | Query DB from given AvsFirmInfo. Guarantees that all Uniqueness-Constraints are checked. Highly unlikely that Nothing is returned, since all AvsResponseContact always contains an AvsFirmInfo
getAvsCompany :: AvsFirmInfo -> DB (Maybe (Entity Company))
@ -585,16 +588,18 @@ getAvsCompany afi =
-- | insert a company from AVS firm info or update an existing one based on previous values
upsertAvsCompany :: AvsFirmInfo -> Maybe AvsFirmInfo -> DB (Entity Company)
-- upsertAvsCompany newAvsFirmInfo (Just oldAvsFirmInfo)
-- | newAvsFirmInfo == oldAvsFirmInfo = maybeM (upsertAvsCompany newAvsFirmInfo Nothing) pure $ getAvsCompany newAvsFirmInfo -- firmInfo unchanged, shortcircuit; SHORTCIRCUIT no longer needed, checked at call-site due to result not being wrapped in Maybe
upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do
mbFirmEnt <- getAvsCompany newAvsFirmInfo -- primarily by AvsId, then Shorthand, then name
$logInfoS "AVS" [st|upsertAvsCompany: old #{tshow mbFirmEnt} new #{tshow newAvsFirmInfo}|]
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
@ -606,11 +611,12 @@ upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do
$logInfoS "AVS" $ "Insert new company: " <> tshow cmp
newCmp <- insertEntity cmp
reportAdminProblem $ AdminProblemNewCompany $ entityKey newCmp
$logInfoS "AVS" "Insert new company completed."
return newCmp
(Just Entity{entityKey=firmid, entityVal=firm}, oldAvsFirmInfo) -> do -- possibly update existing company, if isJust oldAvsFirmInfo and changed occurred
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}|]
@ -629,10 +635,8 @@ upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do
| otherwise -> $logInfoS "AVS" $ "Update company shorthand failed for " <> ciOriginal cmp_key <> " and " <> ciOriginal alt_key
maybeM (return res_cmp) return $ getBy uniq_cmp
_otherwise -> return res_cmp
$logInfoS "AVS" "Update company completed."
$logInfoS "AVS" [st|Update company #{companyShorthand firm} completed.|]
return res_cmp2
void $ upsertCompanySuperior (Just $ entityKey cmpEnt, newAvsFirmInfo) mbOldAvsFirmInfo -- ensure firmInfo superior is supervisor
return cmpEnt
where
firmInfo2key =
CheckUpdate CompanyShorthand $ _avsFirmAbbreviation . from _CI -- Updating primary key works in principle thanks to OnUpdateCascade, but fails due to update get
@ -645,94 +649,73 @@ upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do
-- , CheckUpdate CompanyPrefersPostal _avsFirmPrefersPostal -- Guessing here is not useful, since postal preference is ignored anyway when there is only one option available
]
-- upsert company supervisor from AvsFirmEMailSuperior
upsertCompanySuperior :: (Maybe CompanyId, AvsFirmInfo) -> Maybe AvsFirmInfo -> DB (Maybe (CompanyId, UserId))
upsertCompanySuperior (mbCid, newAfi) mbOldAfi
| Just supemail <- newAfi ^. _avsFirmEMailSuperior -- superior given
= runMaybeT $ do
cid <- MaybeT $ altM (pure mbCid) (getAvsCompanyId newAfi)
supid <- MaybeT $ altM (guessUserByEmail $ stripCI supemail)
(catchAVShandler True True False Nothing $ Just . entityKey <$> ldapLookupAndUpsert supemail)
lift $ do
oldChanges <- runMaybeT $ do -- remove old superior, if any
oldAfi <- MaybeT $ pure mbOldAfi
oldEml <- MaybeT $ pure $ oldAfi ^. _avsFirmEMailSuperior
oldCid <- MaybeT $ getAvsCompanyId oldAfi
oldSup <- MaybeT $ guessUserByEmail $ stripCI oldEml
let supChange = oldSup /= supid
when (supChange && oldCid == cid) $ lift $ do
-- deleteWhere [UserCompanyCompany ==. cid, UserCompanyUser ==. oldSup] -- remove old supervisor from company NOTE: we leave this to the oldSuperior's AVS update
-- switch supervison
-- updateWhere [UserSupervisorCompany ==. Just cid, UserSupervisorSupervisor ==. oldSup, UserSupervisorReason ==. reasonSuperior] [UserSupervisor =. supid] -- not safe, could violate uniqueness
E.update $ \usuper -> do
E.set usuper [ UserSupervisorSupervisor E.=. E.val supid ]
E.where_ $ usuper E.^. UserSupervisorSupervisor E.==. E.val oldSup
E.&&. usuper E.^. UserSupervisorCompany E.==. E.justVal cid
E.&&. usuper E.^. UserSupervisorReason E.==. E.val reasonSuperior
E.&&. E.notExists (do
newSuper <- E.from $ E.table @UserSupervisor
E.where_ $ newSuper E.^. UserSupervisorSupervisor E.==. E.val supid
E.&&. newSuper E.^. UserSupervisorUser E.==. newSuper E.^. UserSupervisorUser
)
deleteOldSuperior oldSup cid -- remove un-updateable remainders, if any
return (supChange, oldSup)
let supChange = fst <$> oldChanges
oldSup = snd <$> oldChanges
unless (supChange == Just False) $ do
-- upsert new superior company supervisor
mbMaxPrio <- E.selectOne $ do
usrCmp <- E.from $ E.table @UserCompany
E.where_ $ usrCmp E.^. UserCompanyUser E.==. E.val supid
return . E.max_ $ usrCmp E.^. UserCompanyPriority
let maxPrio = maybe 1 (fromMaybe 1 . E.unValue) mbMaxPrio
suprEnt <- upsertBy (UniqueUserCompany supid cid)
(UserCompany supid cid True False maxPrio True reasonSuperior)
[UserCompanySupervisor =. True, UserCompanyPriority =. maxPrio, UserCompanyReason =. reasonSuperior]
E.insertSelectWithConflict UniqueUserSupervisor
(do
usr <- E.from $ E.table @UserCompany
E.where_ $ usr E.^. UserCompanyCompany E.==. E.val cid
-- E.&&. E.notExists (do -- restrict to primary company only
-- othr <- E.from $ E.table @UserCompany
-- E.where_ $ othr E.^. UserCompanyPriority E.>. usr E.^. UserCompanyPriority
-- E.&&. othr E.^. UserCompanyUser E.==. usr E.^. UserCompanyUser
-- E.&&. othr E.^. UserCompanyCompany E.!=. E.val cid -- redundant due to > above, but likely performance improving
-- )
return $ UserSupervisor
E.<# E.val supid
E.<&> (usr E.^. UserCompanyUser)
E.<&> E.val (suprEnt ^. _entityVal . _userCompanySupervisorReroute)
E.<&> E.justVal cid
E.<&> E.val reasonSuperior
)
(\_old new ->
[ -- UserSupervisorSupervisor E.=. new E.^. UserSupervisorSupervisor -- this is already given in case of conflict
UserSupervisorCompany E.=. new E.^. UserSupervisorCompany
, UserSupervisorReason E.=. new E.^. UserSupervisorReason
, UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications
]
)
reportAdminProblem $ AdminProblemCompanySuperiorChange supid cid oldSup
return (cid,supid)
| Just oldSupeEmail <- mbOldAfi ^. _Just . _avsFirmEMailSuperior -- no more superior, delete old one
= do
void $ runMaybeT $ do
oldAfi <- MaybeT $ pure mbOldAfi
oldCid <- MaybeT $ getAvsCompanyId oldAfi
oldSup <- MaybeT $ guessUserByEmail $ stripCI oldSupeEmail
lift $ deleteOldSuperior oldSup oldCid
return Nothing
| otherwise -- neither new nor old superior
= return Nothing
where
reasonSuperior = Just $ tshow SupervisorReasonAvsSuperior
deleteOldSuperior oldSup oldCid =
deleteWhere [ UserSupervisorSupervisor ==. oldSup
, UserSupervisorCompany ==. Just oldCid
, UserSupervisorReason ==. reasonSuperior
]
-- | adjust superiors, assumes that CompanyUser exists for all usrs for given company; does not work otherwise
upsertCompanySuperior :: Entity Company -> AvsFirmInfo -> Maybe AvsFirmInfo -> UserId -> DB () -- may return superior (Maybe UserId), but currently not needed
upsertCompanySuperior Entity{entityKey=cid, entityVal=Company{}} newAfi oldAfi usrId =
let reasonSuperior = Just $ tshow SupervisorReasonAvsSuperior
getInsertUid eml = altM (guessUserByEmail $ stripCI eml) (catchAll2log' $ Just . entityKey <$> ldapLookupAndUpsert eml)
newAvsNo = newAfi ^. _avsFirmFirmNo
oldAvsNo = oldAfi ^? _Just . _avsFirmFirmNo
mbSupEmail = newAfi ^. _avsFirmEMailSuperior
mbOldEmail = oldAfi ^? _Just . _avsFirmEMailSuperior . _Just
getSupId = getInsertUid `traverseJoin` mbSupEmail
getOldId = (guessUserByEmail . stripCI) `traverseJoin` mbOldEmail
getSupervision :: Maybe UserId -> DB (Maybe (Entity UserSupervisor))
getSupervision = traverseJoin (getBy . flip UniqueUserSupervisor usrId)
unchangedCompany = oldAvsNo == Just newAvsNo
changedSuperior = mbSupEmail /= mbOldEmail -- beware we only have AvsFirmInfo for one user; also both could be Nothing
-- 1. not unchangedCompany: do not delete, but ensure that superior supervision is set, since it could be a just a single user company change
-- 2. unchangedCompany && not changedSuperior: superior must already been set, short-circuit
-- 3. unchangedCompany && changedSuperior: update superior for all users
in unless (unchangedCompany && not changedSuperior) $ do -- do nothing if (unchangedCompany && not changedSuperior).
mbSupId <- getSupId
mbUsrSup <- getSupervision mbSupId
-- delete old superiors, if any
when (unchangedCompany && changedSuperior) $
deleteWhere $ mcons ((UserSupervisorSupervisor !=.) <$> mbSupId)
[ UserSupervisorCompany ==. Just cid, UserSupervisorReason ==. reasonSuperior ]
unless unchangedCompany $
deleteWhere [ UserSupervisorReason ==. reasonSuperior, UserSupervisorUser ==. usrId ]
-- ensure superior supervision
case (mbSupId, mbUsrSup) of
(_ , Just _) -> return () -- supId is already supervisor for uid for any reason
(Just supId, Nothing) -> do
-- ensure association between company and superior at equal-to-top priority
prio <- getCompanyUserMaxPrio supId
void $ insertUnique (UserCompany supId cid False False prio True reasonSuperior) -- superior is not a supervisor, do not change existing user company associations
-- ensure all company associates are irregularly supervised by the superior
E.insertSelectWithConflict UniqueUserSupervisor
(do
usr <- E.from $ E.table @UserCompany
E.where_ $ usr E.^. UserCompanyCompany E.==. E.val cid
-- E.&&. E.notExists (do -- restrict to primary company only
-- othr <- E.from $ E.table @UserCompany
-- E.where_ $ othr E.^. UserCompanyPriority E.>. usr E.^. UserCompanyPriority
-- E.&&. othr E.^. UserCompanyUser E.==. usr E.^. UserCompanyUser
-- E.&&. othr E.^. UserCompanyCompany E.!=. E.val cid -- redundant due to > above, but likely performance improving
-- )
return $ UserSupervisor
E.<# E.val supId
E.<&> (usr E.^. UserCompanyUser)
E.<&> E.false
E.<&> E.justVal cid
E.<&> E.val reasonSuperior
)
(\_old _new -> [] -- do not change exisitng supervision
-- [ UserSupervisorCompany E.=. new E.^. UserSupervisorCompany
-- , UserSupervisorReason E.=. new E.^. UserSupervisorReason
-- , UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications
-- ]
)
when (unchangedCompany && changedSuperior) $ do
oldSupId <- getOldId
reportAdminProblem $ AdminProblemCompanySuperiorChange supId cid oldSupId
(Nothing, Nothing) ->
when (unchangedCompany && changedSuperior) $ do
oldSupId <- getOldId
reportAdminProblem $ AdminProblemCompanySuperiorNotFound mbSupEmail cid oldSupId
queueAvsUpdateByUID :: (MonoFoldable mono, UserId ~ Element mono) => mono -> Maybe Day -> DB Int64
queueAvsUpdateByUID uids = queueAvsUpdateAux (E.table @User) (E.^. UserId) (\usr -> usr E.^. UserId `E.in_` E.vals uids)
@ -903,30 +886,32 @@ avsLicenceDifferences2personLicences AvsLicenceDifferences{..} =
<> Set.map (AvsPersonLicence AvsLicenceRollfeld) avsLicenceDiffGrantRollfeld
computeDifferingLicences :: AvsResponseGetLicences -> Handler (Set AvsPersonLicence)
computeDifferingLicences = fmap avsLicenceDifferences2personLicences . getDifferingLicences
computeDifferingLicences = fmap (avsLicenceDifferences2personLicences . fst) . getDifferingLicences
type AvsPersonIdMapPersonCard = Map AvsPersonId (Set AvsDataPersonCard)
avsResponseStatusMap :: AvsResponseStatus -> AvsPersonIdMapPersonCard
avsResponseStatusMap (AvsResponseStatus status) = Map.fromDistinctAscList [(avsStatusPersonID,avsStatusPersonCardStatus) | AvsStatusPerson{..}<- Set.toAscList status]
retrieveDifferingLicences :: Handler AvsLicenceDifferences
retrieveDifferingLicences :: Handler (AvsLicenceDifferences, Set AvsPersonId)
retrieveDifferingLicences = fst <$> retrieveDifferingLicences' False
retrieveDifferingLicencesStatus :: Handler (AvsLicenceDifferences, AvsPersonIdMapPersonCard)
retrieveDifferingLicencesStatus :: Handler ((AvsLicenceDifferences, Set AvsPersonId), AvsPersonIdMapPersonCard)
retrieveDifferingLicencesStatus = retrieveDifferingLicences' True
retrieveDifferingLicences' :: Bool -> Handler (AvsLicenceDifferences, AvsPersonIdMapPersonCard)
retrieveDifferingLicences' :: Bool -> Handler ((AvsLicenceDifferences, Set AvsPersonId), AvsPersonIdMapPersonCard)
retrieveDifferingLicences' getStatus = do
#ifdef DEVELOPMENT
avsUsrs <- runDB $ selectList [] [LimitTo 444]
avsUsrs <- runDBRead $ selectList [] [LimitTo 444]
let allLicences = AvsResponseGetLicences $ Set.fromList $
[ AvsPersonLicence AvsLicenceVorfeld $ AvsPersonId 77 -- AVS:1 FD:2
, AvsPersonLicence AvsLicenceRollfeld $ AvsPersonId 12345678 -- AVS:2 FD:1
, AvsPersonLicence AvsLicenceVorfeld $ AvsPersonId 5 -- AVS:1 FD:0 (nichts)
, AvsPersonLicence AvsLicenceVorfeld $ AvsPersonId 2 -- AVS:1 FD:0 (ungültig)
-- , AvsPersonLicence AvsLicenceVorfeld $ AvsPersonId 4 -- AVS:1 FD:1
] ++ [AvsPersonLicence AvsLicenceVorfeld avsid | Entity _ UserAvs{userAvsPersonId = avsid} <- avsUsrs]
] ++ [AvsPersonLicence (bool AvsLicenceRollfeld AvsLicenceVorfeld $ even $ avsPersonId avsid) avsid
| Entity _ UserAvs{userAvsPersonId = avsid} <- avsUsrs
]
#else
allLicences <- avsQueryNoCache AvsQueryGetAllLicences
#endif
@ -942,7 +927,7 @@ retrieveDifferingLicences' getStatus = do
] <>
[ AvsStatusPerson avsid $ Set.singleton $ mkAdpc (even $ avsPersonId avsid) AvsCardColorGelb | Entity _ UserAvs{userAvsPersonId = avsid} <- avsUsrs ]
#else
let statQry = avsLicenceDifferences2LicenceIds lDiff
let statQry = avsLicenceDifferences2LicenceIds $ fst lDiff
lStat <- if getStatus && notNull statQry
then avsQueryNoCache (AvsQueryStatus statQry)
-- `catch` handler
@ -954,7 +939,7 @@ retrieveDifferingLicences' getStatus = do
return (lDiff, avsResponseStatusMap lStat)
getDifferingLicences :: AvsResponseGetLicences -> Handler AvsLicenceDifferences
getDifferingLicences :: AvsResponseGetLicences -> Handler (AvsLicenceDifferences, Set AvsPersonId)
getDifferingLicences (AvsResponseGetLicences licences) = do
now <- liftIO getCurrentTime
--let (vorfeld, nonvorfeld) = Set.partition (`avsPersonLicenceIs` AvsLicenceVorfeld) licences
@ -965,7 +950,7 @@ getDifferingLicences (AvsResponseGetLicences licences) = do
vorORrollfeld = Set.map avsLicencePersonID vorORrollfeld'
rollfeld = Set.map avsLicencePersonID rollfeld'
antijoinAvsLicences :: AvsLicence -> Set AvsPersonId -> DB (Set AvsPersonId,Set AvsPersonId)
antijoinAvsLicences :: AvsLicence -> Set AvsPersonId -> DBRead (Set AvsPersonId,Set AvsPersonId)
antijoinAvsLicences lic avsLics = fmap unwrapIds $
E.select $ do
((_qauli :& _qualUser :& usrAvs) :& excl) <-
@ -991,19 +976,21 @@ getDifferingLicences (AvsResponseGetLicences licences) = do
aux (E.Value(Just api), _) (l,r) = (Set.insert api l, r)
aux _ acc = acc -- should never occur
((vorfGrant, vorfRevoke), (rollGrant, rollRevoke)) <- runDB $ (,)
((vorfGrant, vorfRevoke), (rollGrant, rollRevoke)) <- runDBRead $ (,)
<$> antijoinAvsLicences AvsLicenceVorfeld vorORrollfeld
<*> antijoinAvsLicences AvsLicenceRollfeld rollfeld
let setTo0 = vorfRevoke -- revoke driving licences
setTo1up = vorfGrant Set.\\ rollGrant -- grant apron driving licence
setTo1down = rollRevoke Set.\\ vorfRevoke -- revoke maneuvering area licence, but retain apron driving licence
setTo2 = (rollGrant Set.\\ vorfRevoke) `Set.intersection` (vorfGrant `Set.union` vorORrollfeld) -- grant maneuvering driving licence
return AvsLicenceDifferences
{ 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

View File

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

View File

@ -169,6 +169,10 @@ switchAvsUserCompany usrPostEmailUpds keepOldCompanySupervs uid newCompanyId = d
usrDisplayEmailUp = toMaybe (usrPostEmailUpds && avsEmail == Just usrDisplayEmail) (UserDisplayEmail =. "") -- delete DisplayEmail, if equal to AVS Firm Email
usrUpdate = catMaybes [usrPostUp, usrPrefPostUp, usrDisplayEmailUp]
-- [UserPostAddress =. Nothing, UserPrefersPostal =. companyPrefersPostal newCompany] -- unconditional
newUserComp = UserCompany uid newCompanyId False False 1 True Nothing -- default value for new company insertion, if no update can be done
superReasonComDef = tshow SupervisorReasonCompanyDefault
-- update uid usrUpdate
-- repsertSuperiorSupervisor is not called here, since the Superior is indepentent of the actual company association
case mbUsrComp of
@ -180,7 +184,7 @@ switchAvsUserCompany usrPostEmailUpds keepOldCompanySupervs uid newCompanyId = d
| newCompanyId == oldCompanyId -> return mempty -- nothing to do
| otherwise -> do -- switch company
when (isNothing oldAssocReason) $ deleteBy $ UniqueUserCompany uid oldCompanyId
void $ upsertBy (UniqueUserCompany uid newCompanyId) newUserComp
void $ upsertBy (UniqueUserCompany uid newCompanyId) newUserComp{userCompanyPriority = succ oldPrio}
[UserCompanyPriority =. succ oldPrio, UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False, UserCompanyUseCompanyAddress =. True, UserCompanyReason =. Nothing]
-- supervised by uid
supervisees :: [(Entity UserSupervisor, E.Value Bool)] <- E.select $ do
@ -213,15 +217,13 @@ switchAvsUserCompany usrPostEmailUpds keepOldCompanySupervs uid newCompanyId = d
$ bcons isNoLongerSupervised (AdminProblemNewlyUnsupervised uid (Just oldCompanyId) newCompanyId)
newlyUnsupervised
return (usrUpdate ,problems)
where
newUserComp = UserCompany uid newCompanyId False False 1 True Nothing -- default value for new company insertion, if no update can be done
superReasonComDef = tshow SupervisorReasonCompanyDefault
defaultSupervisorReasonFilter :: [Filter UserSupervisor]
defaultSupervisorReasonFilter =
[UserSupervisorReason ==. Nothing]
||. [UserSupervisorReason ==. Just (tshow SupervisorReasonCompanyDefault)]
-- ||. [UserSupervisorReason <-. [Just $ tshow r | r <- [SupervisorReasonCompanyDefault, SupervisorReasonAvsSuperior]]]
||. [UserSupervisorReason ==. Just (tshow SupervisorReasonAvsSuperior )]
-- ||. [UserSupervisorReason <-. Nothing : [Just $ tshow r | r <- [SupervisorReasonCompanyDefault, SupervisorReasonAvsSuperior]]] -- Does <-. work with Nothing?
-- | remove supervisors for given users; maybe restricted to those linked to given companies or supervisors
deleteDefaultSupervisorsForUsers :: [CompanyId] -> [UserId] -> NonEmpty UserId -> DB Int64
@ -231,10 +233,11 @@ deleteDefaultSupervisorsForUsers cids sprs usrs =
$ bcons (notNull sprs) (UserSupervisorSupervisor <-. sprs)
$ (UserSupervisorUser <-. toList usrs) : defaultSupervisorReasonFilter
-- | deletes user company association and all company related supervision
-- WARNING: does not check for admin problems!
deleteCompanyUser :: CompanyId -> [UserId] -> DB (Int64, Int64, Int64)
deleteCompanyUser cid uids = (,,)
<$> deleteWhereCount [UserCompanyCompany ==. cid, UserCompanyUser <-. uids]
<*> deleteWhereCount ((UserSupervisorCompany ==. Just cid):(UserSupervisorSupervisor <-. uids) : defaultSupervisorReasonFilter)
<*> deleteWhereCount ((UserSupervisorCompany ==. Just cid):(UserSupervisorUser <-. uids) : defaultSupervisorReasonFilter)
-- | 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

View File

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

View File

@ -58,7 +58,7 @@ quserToNotify cutoff quser qblock = -- either recently become invalid with no pr
E.&&. qblock E.?. QualificationUserBlockFrom E.>. E.just (quser E.^. QualificationUserLastNotified)
))
-- condition to ensure that the lastest QualificationUserBlock was picked, better to be used in join-on clauses, since inside a where-clause it might not work as intended
-- | condition to ensure that the lastest QualificationUserBlock was picked, better to be used in join-on clauses, since inside a where-clause it might not work as intended
isLatestBlockBefore :: E.SqlExpr (Maybe (Entity QualificationUserBlock)) -> E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value Bool)
isLatestBlockBefore qualBlock cutoff = (cutoff E.>~. qualBlock E.?. QualificationUserBlockFrom) E.&&. E.notExists (do
newerBlock <- E.from $ E.table @QualificationUserBlock
@ -71,6 +71,20 @@ isLatestBlockBefore qualBlock cutoff = (cutoff E.>~. qualBlock E.?. Qualificatio
))
)
-- | condition to ensure that the lastest QualificationUserBlock was picked, better to be used in join-on clauses, since inside a where-clause it might not work as intended
-- variant for inner joins
isLatestBlockBefore' :: E.SqlExpr (Entity QualificationUserBlock) -> E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value Bool)
isLatestBlockBefore' qualBlock cutoff = (cutoff E.>. qualBlock E.^. QualificationUserBlockFrom) E.&&. E.notExists (do
newerBlock <- E.from $ E.table @QualificationUserBlock
E.where_ $ newerBlock E.^. QualificationUserBlockQualificationUser E.==. qualBlock E.^. QualificationUserBlockQualificationUser
E.&&. newerBlock E.^. QualificationUserBlockFrom E.<=. cutoff
E.&&. newerBlock E.^. QualificationUserBlockId E.!=. qualBlock E.^. QualificationUserBlockId
E.&&. (( newerBlock E.^. QualificationUserBlockFrom E.>. qualBlock E.^. QualificationUserBlockFrom)
E.||. ( newerBlock E.^. QualificationUserBlockUnblock -- in case of equal timestamps, any unblock wins
E.&&. (newerBlock E.^. QualificationUserBlockFrom E.==. qualBlock E.^. QualificationUserBlockFrom)
))
)
-- cutoff can be `E.val now` or even `Database.Esqueleto.PostgreSQL.now_`
quserBlockAux :: Bool -> E.SqlExpr (E.Value UTCTime) -> (E.SqlExpr (E.Value QualificationUserId) -> E.SqlExpr (E.Value Bool)) -> Maybe (E.SqlExpr (Entity QualificationUserBlock) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (E.Value Bool)
quserBlockAux negCond cutoff checkQualUserId mbBlockCondition = bool E.notExists E.exists negCond $ do

View File

@ -32,6 +32,7 @@ spacerCell = cell [whamlet|&emsp;|]
semicolonCell :: IsDBTable m a => DBCell m a
semicolonCell = cell [whamlet|;&emsp;|]
-- | 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

View File

@ -173,6 +173,23 @@ companyWidget isPrimary (csh, cname, isSupervisor)
| otherwise = text2markup corg
---------------------
-- Status Tooltips --
---------------------
-- | generate a generic colored icon to display success or failure to user
mkErrorFlag :: Handler (Maybe Bool -> Widget)
mkErrorFlag = do
-- we abuse messageTooltip for colored icons here
msgSuccessTooltip <- messageI Success MsgMessageSuccess
msgWarningTooltip <- messageI Warning MsgMessageWarning
msgErrorTooltip <- messageI Error MsgMessageError
let flagError Nothing = messageTooltip msgWarningTooltip
flagError (Just False) = messageTooltip msgErrorTooltip
flagError (Just True) = messageTooltip msgSuccessTooltip
return flagError
----------
-- HEAT --
----------

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

@ -69,7 +69,7 @@ data SupervisorReason
-- so do not change values here without a proper migration
instance Show SupervisorReason where
show SupervisorReasonCompanyDefault = "Firmenstandard"
show SupervisorReasonAvsSuperior = "Vorgesetzer"
show SupervisorReasonAvsSuperior = "Vorgesetzter"
show SupervisorReasonUnknown = "Unbekannt"

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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