diff --git a/.babelrc b/.babelrc index d2c3f85c5..175151195 100644 --- a/.babelrc +++ b/.babelrc @@ -4,10 +4,11 @@ "useBuiltIns": "usage", "targets": { "node": "current" } } - ] + ], + ["@babel/preset-typescript"] ], "plugins": [ - ["@babel/plugin-proposal-decorators", { "legacy": true }], + ["@babel/plugin-proposal-decorators", { "legacy": true, "version": "2023-11" }], ["@babel/plugin-proposal-class-properties", { "loose": true }], ["@babel/plugin-proposal-private-methods", { "loose": true }], ["@babel/plugin-proposal-private-property-in-object", { "loose": true }], diff --git a/.babelrc.license b/.babelrc.license index 3e1520e17..59a35451b 100644 --- a/.babelrc.license +++ b/.babelrc.license @@ -1,3 +1,3 @@ -SPDX-FileCopyrightText: 2022 Felix Hamann ,Sarah Vaupel ,Sarah Vaupel +SPDX-FileCopyrightText: 2022-2024 Felix Hamann ,Sarah Vaupel ,Sarah Vaupel ,David Mosbach SPDX-License-Identifier: AGPL-3.0-or-later diff --git a/CHANGELOG.md b/CHANGELOG.md index bb7fd8e96..791861f48 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,55 @@ 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.64](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.63...v27.4.64) (2024-05-27) + +## [27.4.63](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.62...v27.4.63) (2024-05-23) + + +### Bug Fixes + +* **avs:** company update checks uniques and ignores those updates if necessary ([9451d90](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/9451d90a9e00d08a2a7d169c4674d99ff1018ee9)) + +## [27.4.62](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.61...v27.4.62) (2024-05-19) + + +### Bug Fixes + +* **avs:** avs update on company shorthands working now ([ff2347b](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ff2347b1c950c7a2bb281cdcd07a52925e23b9f0)) +* **avs:** deal gracefully with empty card status results ([ccf9340](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ccf934044938277d821eb4b9ea08a8a134e84189)) + +## [27.4.61](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.60...v27.4.61) (2024-05-06) + + +### Bug Fixes + +* **avs:** fix [#76](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/76) allowing company changes and fix [#69](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/69) ([3c4a0b8](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/3c4a0b86c1e3d8a28405ab73b964ba1b988d2822)) +* **build:** add missing tex packages ([6750798](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/6750798920dc76882f4e8ef39b47018fb7b77e44)) +* **build:** workaround non modal form result handler ([2fbd281](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/2fbd28154cd7aea282eaa2604a42263ac90e3b1e)) + +## [27.4.60](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.59...v27.4.60) (2024-04-26) + + +### Bug Fixes + +* **avs:** disable caching by 0s no longer causes an exception ([d578e80](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/d578e80282c8bf6872fa6040514a9d2c85582707)) +* **avs:** fix [#152](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/152) by providing new online avs card filter throughout ([ad2375b](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ad2375b338866f37c8b7825a9eab12fa6c9abccb)) +* **avs:** fix [#36](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/36) and remove dead code ([4f8850b](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/4f8850b3b4f710f9cf59163175b27599c97ac5c0)) +* **avs:** fix [#69](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/69) by redesigning live avs status page ([697979c](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/697979c277ce7198f4573d6cea30373a1fcc17da)) +* **avs:** invalidate contact cache after licence writes ([c382be9](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/c382be9325fcc92e13cb5dc2ad7c20b198db26fc)) +* **avs:** several minor bugfixes ([a52c8a6](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/a52c8a6ad709029a8822d383370b0d2bdd25e7d7)), closes [#158](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/158) +* **build:** add import needed for production only ([724e4a0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/724e4a0bec343ab9c6d172d8e93b8040bbe3fe7d)) +* **build:** migration needs to check for table existens first ([f439ea4](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/f439ea45af9b1c4a029fc1b9b6383f3c97194ed0)) +* **build:** minor error non-development code ([66eaa4f](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/66eaa4f7dcc124b631414d4a1adbe555a4029100)) +* **build:** missing parameters added ([83afdf7](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/83afdf760f93fc1a553de3a122b444412ed84ba4)) +* **build:** simple type error ([d56a1cd](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/d56a1cdd46259418faa737b9bb0a9d9ffba442e0)) +* **build:** type error in test db fill data ([f465cc9](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/f465cc972367233a4944dd0aeb81b223a187bb85)) +* **doc:** minor haddock problems ([d4f8a6c](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/d4f8a6c77b2a4a4540935f7f0beca0d0605508c8)) +* **firm:** supervisor filter acts weird in test environment ([b566e59](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/b566e59eb1325485fe26dc4f0b5cb63165c58f74)) +* **i18n:** fix some bad plurals ([890f8ad](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/890f8ad8b60115533faa6b99f4c4504243cbfb1d)) +* **lint:** remove minor superfluous dollar ([64a1233](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/64a123387f3539b73649d02a6ecd97de577097e6)) +* **qualification:** fix [#159](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/159) by removing an misleadingly named column for user qualification table ([fd6a538](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/fd6a5384d3517958a3c7726e32eed3bad197a591)) + ## [27.4.59](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.58...v27.4.59) (2024-02-13) diff --git a/config/settings.yml b/config/settings.yml index 602c9c0e2..d6a2a948e 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -1,4 +1,4 @@ -# SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Wolfgang Witt +# SPDX-FileCopyrightText: 2022-2024 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Wolfgang Witt ,David Mosbach # # SPDX-License-Identifier: AGPL-3.0-or-later @@ -91,8 +91,8 @@ study-features-recache-relevance-within: 172800 study-features-recache-relevance-interval: 293 # Enqueue at specified hour, a few minutes later -# job-lms-qualifications-enqueue-hour: 15 -# job-lms-qualifications-dequeue-hour: 3 +job-lms-qualifications-enqueue-hour: 16 +job-lms-qualifications-dequeue-hour: 4 log-settings: detailed: "_env:DETAILED_LOGGING:false" @@ -157,10 +157,12 @@ lms-direct: deletion-days: "_env:LMSDELETIONDAYS:7" avs: - host: "_env:AVSHOST:skytest.fra.fraport.de" - port: "_env:AVSPORT:443" - user: "_env:AVSUSER:fradrive" - pass: "_env:AVSPASS:" + host: "_env:AVSHOST:skytest.fra.fraport.de" + port: "_env:AVSPORT:443" + user: "_env:AVSUSER:fradrive" + pass: "_env:AVSPASS:\"0000\"" + timeout: "_env:AVSTIMEOUT:42" + cache-expiry: "_env:AVSCACHEEXPIRY:420" lpr: host: "_env:LPRHOST:fravm017173.fra.fraport.de" @@ -337,3 +339,5 @@ bot-mitigations: volatile-cluster-settings-cache-time: 10 communication-attachments-max-size: 20971520 # 20MiB + +async-table-max-rows: 0 diff --git a/fixtest.sh b/fixtest.sh new file mode 100755 index 000000000..d59f51144 --- /dev/null +++ b/fixtest.sh @@ -0,0 +1,6 @@ +if [[ ! -d .stack-work-test ]]; then + mv -vT .stack-work .stack-work-test + [[ -d .stack-work-build ]] && mv -vT .stack-work-build .stack-work +else + echo "Directory .stack-work-test exists already." +fi diff --git a/frontend/src/app.js b/frontend/src/app.ts similarity index 100% rename from frontend/src/app.js rename to frontend/src/app.ts diff --git a/frontend/src/main.js b/frontend/src/main.ts similarity index 83% rename from frontend/src/main.js rename to frontend/src/main.ts index aae7605f3..93cd2bd3f 100644 --- a/frontend/src/main.js +++ b/frontend/src/main.ts @@ -1,10 +1,16 @@ -// SPDX-FileCopyrightText: 2022 Sarah Vaupel +// SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel ,David Mosbach // // SPDX-License-Identifier: AGPL-3.0-or-later import { App } from './app'; import { Utils } from './utils/utils'; +declare global { + interface Window { + App: any; + } +} + export const app = new App(); app.registerUtilities(Utils); diff --git a/frontend/src/utils/async-table/async-table.js b/frontend/src/utils/async-table/async-table.ts similarity index 88% rename from frontend/src/utils/async-table/async-table.js rename to frontend/src/utils/async-table/async-table.ts index 1b0b799c8..495ac4ba3 100644 --- a/frontend/src/utils/async-table/async-table.js +++ b/frontend/src/utils/async-table/async-table.ts @@ -27,10 +27,25 @@ const ASYNC_TABLE_LOADING_CLASS = 'async-table--loading'; const ASYNC_TABLE_FILTER_FORM_SELECTOR = '.table-filter-form'; -@Utility({ - selector: '[uw-async-table]', -}) -export class AsyncTable { +class FilterInputs { + search : any[]; + input: any[]; + change: any[]; + select: any[]; + + constructor() { + this.search = []; + this.input = []; + this.change = []; + this.select = []; + } + + entries() { + return this.search.concat(this.input.concat(this.change.concat(this.select))); + } + +} +abstract class TableUtil { _element; _app; @@ -48,12 +63,8 @@ export class AsyncTable { _cancelPendingUpdates = []; - _tableFilterInputs = { - search: [], - input: [], - change: [], - select: [], - }; + _tableFilterInputs = new FilterInputs(); + _ignoreRequest = false; _windowStorage; @@ -63,11 +74,11 @@ export class AsyncTable { constructor(element, app) { if (!element) { - throw new Error('Async Table utility cannot be setup without an element!'); + throw new Error('Table utility cannot be setup without an element!'); } if (!app) { - throw new Error('Async Table utility cannot be setup without an app!'); + throw new Error('Table utility cannot be setup without an app!'); } this._element = element; @@ -76,7 +87,7 @@ export class AsyncTable { this._eventManager = new EventManager(); if (this._element.classList.contains(ASYNC_TABLE_INITIALIZED_CLASS)) { - return false; + return null; } // param asyncTableDbHeader @@ -86,7 +97,7 @@ export class AsyncTable { const table = this._element.querySelector('table, .div__course-teaser'); if (!table) { - throw new Error('Async Table utility needs a or a
in its element!'); + throw new Error('Table utility needs a
or a
in its element!'); } const rawTableId = table.id; @@ -94,7 +105,7 @@ export class AsyncTable { this._asyncTableId = rawTableId.replace(this._cssIdPrefix, ''); if (!this._asyncTableId) { - throw new Error('Async Table cannot be set up without an ident!'); + throw new Error('Table cannot be set up without an ident!'); } this._windowStorage = new StorageManager([ASYNC_TABLE_STORAGE_KEY, this._asyncTableId], ASYNC_TABLE_STORAGE_VERSION, { location: LOCATION.WINDOW }); @@ -103,7 +114,7 @@ export class AsyncTable { // find scrolltable wrapper this._scrollTable = this._element.querySelector(ASYNC_TABLE_SCROLLTABLE_SELECTOR); if (!this._scrollTable) { - throw new Error('Async Table cannot be set up without a scrolltable element!'); + throw new Error('Table cannot be set up without a scrolltable element!'); } this._processStorage(); @@ -126,7 +137,7 @@ export class AsyncTable { this._element.classList.add(ASYNC_TABLE_INITIALIZED_CLASS); } - _historyListener(historyState) { + _historyListener(historyState?) { if (!this._active) return; @@ -227,7 +238,7 @@ export class AsyncTable { _gatherTableFilterInputs(tableFilterForm) { Array.from(tableFilterForm.querySelectorAll('input')).forEach((input) => { - const inputType = input.getAttribute('type'); + const inputType = (input).getAttribute('type'); if (inputType === 'search') { this._tableFilterInputs.search.push(input); } else if (['text','date','time','datetime-local'].includes(inputType)) { @@ -340,7 +351,7 @@ export class AsyncTable { this._debugLog('_serializeTableFilterToURL', Array.from(formData.entries()), url.href); - const searchParams = new URLSearchParams(Array.from(formData.entries())); + const searchParams = new URLSearchParams(Array.from(formData.entries())); url.search = searchParams.toString(); this._debugLog('_serializeTableFilterToURL', url.href); @@ -414,7 +425,7 @@ export class AsyncTable { }; // fetches new sorted element from url with params and replaces contents of current element - _updateTableFrom(url, callback, isPopState) { + _updateTableFrom(url, callback?, isPopState?) { url = new URL(url); const cancelPendingUpdates = (() => { @@ -465,12 +476,45 @@ export class AsyncTable { ).finally(() => this._element.classList.remove(ASYNC_TABLE_LOADING_CLASS)); } - _debugLog() {} + _debugLog(fName, ...args) {} //_debugLog(fName, ...args) { // console.log(`[DEBUGLOG] AsyncTable.${fName}`, { args: args, instance: this }); // } } +@Utility({ + selector: '[uw-async-table]', +}) +export class AsyncTable extends TableUtil { + + constructor(element, app) { + super(element, app); + + // remove submit button + this._element.querySelector(ASYNC_TABLE_FILTER_FORM_SELECTOR) + .querySelector("button[type='submit']") + .remove(); + } +} + +@Utility({ + selector: '[uw-sync-table]', +}) +export class SyncTable extends TableUtil { + + constructor(element, app) { + super(element, app); + + const tableFilterForm: HTMLFormElement = this._element.querySelector(ASYNC_TABLE_FILTER_FORM_SELECTOR); + toggleFormButton(tableFilterForm, true); + this._tableFilterInputs.entries().forEach((input) => { + input.addEventListener('change', _ => toggleFormButton(tableFilterForm, false)); + }); + } + + _addTableFilterEventListeners(_) {} +} + // returns any random nudged prefix found in the given id function findCssIdPrefix(id) { @@ -481,3 +525,8 @@ function findCssIdPrefix(id) { } return ''; } + +function toggleFormButton(form : HTMLFormElement, disabled : boolean) { + const btn = form.querySelector("button[type='submit']"); + disabled ? btn.setAttribute('disabled', 'null') : btn.removeAttribute('disabled'); +} diff --git a/frontend/src/utils/exam-correct/exam-correct.js b/frontend/src/utils/exam-correct/exam-correct.js index 7685c00e1..4fbcc6c48 100644 --- a/frontend/src/utils/exam-correct/exam-correct.js +++ b/frontend/src/utils/exam-correct/exam-correct.js @@ -1,4 +1,4 @@ -// SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel +// SPDX-FileCopyrightText: 2022-2024 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,David Mosbach // // SPDX-License-Identifier: AGPL-3.0-or-later @@ -301,7 +301,7 @@ export class ExamCorrect { users: [user], status: STATUS.LOADING, }; - if (results && results !== {}) rowInfo.results = results; + if (results && results != {}) rowInfo.results = results; if (result !== undefined) rowInfo.result = result; this._addRow(rowInfo); diff --git a/frontend/src/utils/utils.js b/frontend/src/utils/utils.ts similarity index 81% rename from frontend/src/utils/utils.js rename to frontend/src/utils/utils.ts index 9316a76d9..5d2f99088 100644 --- a/frontend/src/utils/utils.js +++ b/frontend/src/utils/utils.ts @@ -1,11 +1,11 @@ -// SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel +// SPDX-FileCopyrightText: 2022-2024 Gregor Kleen ,Sarah Vaupel ,David Mosbach // // SPDX-License-Identifier: AGPL-3.0-or-later import { Alerts } from './alerts/alerts'; import { AsyncForm } from './async-form/async-form'; import { ShowHide } from './show-hide/show-hide'; -import { AsyncTable } from './async-table/async-table'; +import { AsyncTable, SyncTable } from './async-table/async-table'; import { CheckAll } from './check-all/check-all'; import { FormUtils } from './form/form'; import { InputUtils } from './inputs/inputs'; @@ -23,6 +23,7 @@ export const Utils = [ Alerts, AsyncForm, AsyncTable, + SyncTable, CheckAll, ShowHide, ...FormUtils, diff --git a/messages/uniworx/categories/admin/de-de-formal.msg b/messages/uniworx/categories/admin/de-de-formal.msg index eb6cfe753..23228c525 100644 --- a/messages/uniworx/categories/admin/de-de-formal.msg +++ b/messages/uniworx/categories/admin/de-de-formal.msg @@ -1,4 +1,4 @@ -# SPDX-FileCopyrightText: 2022 Gregor Kleen ,Winnie Ros +# SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Winnie Ros ,Steffen Jost # # SPDX-License-Identifier: AGPL-3.0-or-later @@ -101,7 +101,7 @@ ProblemsHeadingDrivers: Fahrberechtigungen ProblemsHeadingNotifications: Benachrichtigungen ProblemsHeadingMisc: Allgemein ProblemsAvsProblem: Synchronisation mit AVS/MoBaKo komplett fehlgeschlagen -ProblemsDriverSynch n@Int: #{tshow n} Diskrepanzen zwischen AVS und FRADrive +ProblemsDriverSynch n@Int: #{pluralDEeN n "Diskrepanze"} zwischen AVS und FRADrive ProblemsDriverSynch0: Alle Sperrungen von Vorfeld-Fahrberechtigungen 'F' sind im AVS eingetragen ProblemsDriverSynch1down: Alle Sperrungen von Rollfeld-Fahrberechtigungen 'R' sind im AVS eingetragen ProblemsDriverSynch1up: Alle gültigen Vorfeld-Fahrberechtigungen 'F' sind im AVS eingetragen @@ -109,7 +109,7 @@ ProblemsDriverSynch2: Alle gültigen Rollfeld-Fahrberechtigungen 'R' sind im AVS ProblemsRDriversHaveFs: Alle Inhaber einer Rollfeld-Fahrberechtigung besitzen auch eine gültige Vorfeld-Fahrberechtigung ProblemsDriversHaveAvsIds: Alle Inhaber einer Fahrberechtigung konnten einer AVS Identifikationsnummer zugeordnet werden ProblemsUsersAreReachable: Für alle Benutzer ist eine E-Mail oder postalische Adresse bekannt -ProblemsNoStalePrintJobs n@Integer: Alle Briefversandaufträge der vergangenen #{show n} Tage wurden von der Druckerei bestätigt +ProblemsNoStalePrintJobs n@Integer: Alle Briefversandaufträge #{pluralDE n "des vergangenen Tages" ("der vergangenen "<> tshow n <> " Tage")} wurden von der Druckerei bestätigt 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: @@ -121,6 +121,20 @@ ProblemsAvsSynchHeading: Synchronisation AVS Fahrberechtigungen ProblemsAvsErrorHeading: Fehlermeldungen ProblemsInterfaceSince: Berücksichtigt werden nur Erfolge und Fehler seit +AdminProblemSolved: Erledigt +AdminProblemSolver: Bearbeitet von +AdminProblemCreated: Erkannt +AdminProblemInfo: Problembeschreibung +AdminProblemsSolved n@Int: #{pluralDEeN n "Admin Probleme"} als erledigt markiert +AdminProblemsReopened n@Int: #{pluralDEeN n "Admin Probleme"} erneut eröffnet +AdminProblemNewCompany: Neue Firma aus AVS automatisch erstellt; prüfen und ggf. Standardansprechpartner eintragen +AdminProblemSupervisorNewCompany b@Bool: Dieser 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 +AdminProblemNewlyUnsupervised: Fahrer hat keinen Firmenansprechpartner mehr nach AVS Firmenwechsel zu Firma +AdminProblemUser: Betroffener +ProblemTableMarkSolved: Als erledigt markieren +ProblemTableMarkUnsolved: Erledigt Markierung löschen + InterfacesOk: Schnittstellen sind ok. InterfacesFail n@Int: #{pluralDEeN n "Schnittstellenproblem"}! InterfaceStatus !ident-ok: Status diff --git a/messages/uniworx/categories/admin/en-eu.msg b/messages/uniworx/categories/admin/en-eu.msg index 13f35ed9f..34560ab2e 100644 --- a/messages/uniworx/categories/admin/en-eu.msg +++ b/messages/uniworx/categories/admin/en-eu.msg @@ -1,4 +1,4 @@ -# SPDX-FileCopyrightText: 2022 Sarah Vaupel ,Winnie Ros +# SPDX-FileCopyrightText: 2022-24 Sarah Vaupel ,Winnie Ros ,Steffen Jost # # SPDX-License-Identifier: AGPL-3.0-or-later @@ -18,10 +18,10 @@ NoNameCandidatesInferred: No new name-mappings inferred AllNameIncidencesDeleted: Successfully deleted all name observations AllParentIncidencesDeleted: Successfully deleted all parent-relation observations AllStandaloneIncidencesDeleted: Successfully deleted all standalone observations -IncidencesDeleted n: Successfully deleted #{show n} #{pluralEN n "observation" "observations"} -RedundantParentCandidatesRemoved n: Successfully removed #{n} rendundant #{pluralEN n "parent-candidate" "parent-candidates"} -RedundantStandaloneCandidatesRemoved n: Successfully removed #{n} rendundant #{pluralEN n "standalone-candidate" "standalone-candidates"} -ParentCandidatesInferred n: Successfully inferred #{n} field #{pluralEN n "parent-relation" "parent-reliations"} +IncidencesDeleted n: Successfully deleted #{pluralENsN n "observation"} +RedundantParentCandidatesRemoved n: Successfully removed #{n} rendundant #{pluralENs n "parent-candidate"} +RedundantStandaloneCandidatesRemoved n: Successfully removed #{n} rendundant #{pluralENs n "standalone-candidate"} +ParentCandidatesInferred n: Successfully inferred #{n} field #{pluralENs n "parent-relation"} NoParentCandidatesInferred: No new parent-relations inferred StudyDegreeChangeSuccess: Successfully updated degrees StudyTermsShort: Field shorthand @@ -101,7 +101,7 @@ ProblemsHeadingDrivers: Driving Licences ProblemsHeadingNotifications: User communication ProblemsHeadingMisc: Miscellaneous ProblemsAvsProblem: Synchronisation with AVS/MoBaKo failed entirely -ProblemsDriverSynch n: #{tshow n} mismatches between AVS and FRADrive +ProblemsDriverSynch n: #{tshow n} #{pluralEN n "mismatch" "mismatches"} between AVS and FRADrive ProblemsDriverSynch0: All revocations of apron driving licences 'F' were successfully registered with AVS ProblemsDriverSynch1down: All revocations of maneuvering area driving licences 'R' were successfully registered with AVS ProblemsDriverSynch1up: All valid apron driving licences 'F' were successfully registered with AVS @@ -109,7 +109,7 @@ ProblemsDriverSynch2: All valid maneuvering area driving licences 'R' were succe ProblemsRDriversHaveFs: All driving licence 'R' holders also have a valid 'F' licence ProblemsDriversHaveAvsIds: All driving licence holder could be matched with their AVS id ProblemsUsersAreReachable: Either Email or postal address is known for all users -ProblemsNoStalePrintJobs n: All requests for letter mailing within the last #{show n} days were acknowledged as printed by the airport printing center +ProblemsNoStalePrintJobs n: All requests for letter mailing within the last #{pluralENsN n "day"} were acknowledged as printed by the airport printing center 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: @@ -121,6 +121,20 @@ ProblemsAvsSynchHeading: Synchronisation AVS Driving Licences ProblemsAvsErrorHeading: Error Log ProblemsInterfaceSince: Only considering successes and errors since +AdminProblemSolved: Done +AdminProblemSolver: Solved by +AdminProblemCreated: Recognized +AdminProblemInfo: Problem +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: This 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 +AdminProblemNewlyUnsupervised: Driver has no longer a company default supervisor after AVS update at new company +AdminProblemUser: Affected +ProblemTableMarkSolved: Mark done +ProblemTableMarkUnsolved: Reopen as undone + InterfacesOk: Interfaces are ok. InterfacesFail n: #{pluralENsN n "interface problem"}! InterfaceStatus: Status diff --git a/messages/uniworx/categories/avs/de-de-formal.msg b/messages/uniworx/categories/avs/de-de-formal.msg index bd5c01716..19c6684c4 100644 --- a/messages/uniworx/categories/avs/de-de-formal.msg +++ b/messages/uniworx/categories/avs/de-de-formal.msg @@ -2,13 +2,16 @@ # # SPDX-License-Identifier: AGPL-3.0-or-later AvsPersonInfo: AVS Personendaten -AvsPersonId: AVS Personen Id +AvsPersonId: AVS Personen Id AvsPersonNo: AVS Personennummer +AvsPersonNoMismatch: AVS Personennummer hat sich geändert und wurde in FRADrive noch nicht aktualisiert AvsCardNo: Ausweiskartennummer AvsFirstName: Vorname AvsLastName: Nachname +AvsPrimaryCompany: Primäre Firma AvsInternalPersonalNo: Personalnummer (nur Fraport AG) AvsVersionNo: Versionsnummer +AvsQueryNeeded: Benötigt Verbindung zum AVS. AvsQueryEmpty: Bitte mindestens ein Anfragefeld ausfüllen! AvsQueryStatusInvalid t@Text: Nur numerische IDs eingeben, durch Komma getrennt! Erhalten: #{show t} AvsLicence: Fahrberechtigung @@ -27,13 +30,32 @@ RevokeFraDriveLicences alic@AvsLicence n@Int: _{alic} in FRADrive entzogen für RevokeUnknownLicencesOk: AVS Fahrberechtigungen unbekannter Fahrer wurden gesperrt RevokeUnknownLicencesFail: Nicht alle AVS Fahrberechtigungen unbekannter Fahrer konnten entzogen werden, siehe Log für Details AvsCommunicationError: AVS Schnittstelle lieferte einen unerwarteten Fehler. +AvsCommunicationTimeout: AVS Schnittstelle antwortete nicht. LicenceTableChangeAvs: Im AVS ändern LicenceTableGrantFDrive: In FRADrive erteilen LicenceTableRevokeFDrive: In FRADrive entziehen TableAvsActiveCards: Gültige Ausweise +TableAvsCardValid: Aktuell gültig +TableAvsCardIssueDate: Ausgestellt am +TableAvsCardValidTo: Gültig bis +AvsCardAreas: Ausweiszusätze +AvsCardColor: Ausweisfarbe AvsCardColorGreen: Grün AvsCardColorBlue: Blau AvsCardColorRed: Rot AvsCardColorYellow: Gelb LastAvsSynchronisation: Letzte AVS-Synchronisation LastAvsSynchError: Letzte AVS-Fehlermeldung + +AvsInterfaceUnavailable: AVS Schnittstelle nicht richtig konfiguriert oder antwortet nicht +AvsUserUnassociated user@UserDisplayName: AVS Id unbekannt für Nutzer #{user} +AvsUserUnknownByAvs api@AvsPersonId: AVS kennt Id #{tshow api} nicht (mehr) +AvsUserAmbiguous api@AvsPersonId: AVS Id #{tshow api} ist nicht eindeutig +AvsStatusSearchEmpty: AVS lieferte keine Ausweisinformationen +AvsPersonSearchEmpty: AVS Suche lieferte leeres Ergebnis +AvsPersonSearchAmbiguous: AVS Suche lieferte mehrere uneindeutige Ergebnisse +AvsSetLicencesFailed reason@Text: Setzen der Fahrlizenz im AVS fehlgeschlagen. Grund: #{reason} +AvsIdMismatch api1@AvsPersonId api2@AvsPersonId: AVS Suche für Id #{tshow api1} lieferte stattdessen Id #{tshow api2} +AvsUserCreationFailed api@AvsPersonId: Für AVS Id #{tshow api} konnte kein neuer Benutzer angelegt werden, da es eine gemeinsame Id (z.B. Personalnummer) mit einem existierenden, aber verschiedenen Nutzer gibt. +AvsCardsEmpty: AVS Suche lieferte keinerlei Ausweiskarten +AvsCurrentData: Alle angezeigte Daten wurden kürzlich direkt über die AVS Schnittstelle abgerufen. \ No newline at end of file diff --git a/messages/uniworx/categories/avs/en-eu.msg b/messages/uniworx/categories/avs/en-eu.msg index ec7288d7d..f42c75318 100644 --- a/messages/uniworx/categories/avs/en-eu.msg +++ b/messages/uniworx/categories/avs/en-eu.msg @@ -1,14 +1,17 @@ # SPDX-FileCopyrightText: 2022 Steffen Jost # # SPDX-License-Identifier: AGPL-3.0-or-later -AvsPersonInfo: AVS Person Info -AvsPersonId: AVS Person Id -AvsPersonNo: AVS Person Number +AvsPersonInfo: AVS person info +AvsPersonId: AVS person id +AvsPersonNo: AVS person number +AvsPersonNoMismatch: AVS person number has changed and was not yet updated in FRADrive AvsCardNo: Card number AvsFirstName: First name AvsLastName: Last name +AvsPrimaryCompany: Primary company AvsInternalPersonalNo: Personnel number (Fraport AG only) AvsVersionNo: Version number +AvsQueryNeeded: AVS connection required. AvsQueryEmpty: At least one query field must be filled! AvsQueryStatusInvalid t: Numeric IDs only, comma seperated! #{show t} AvsLicence: Driving Licence @@ -27,13 +30,32 @@ RevokeFraDriveLicences alic@AvsLicence n@Int: _{alic} revoked in FRADrive for #{ RevokeUnknownLicencesOk: AVS driving licences of unknown drivers revoked RevokeUnknownLicencesFail: Not all AVS driving licences of unknown drivers could be revoked, see log for details AvsCommunicationError: AVS interface returned an unexpected error. +AvsCommunicationTimeout: AVS interface returned no response within timeout limit. LicenceTableChangeAvs: Change in AVS LicenceTableGrantFDrive: Grant in FRADrive LicenceTableRevokeFDrive: Revoke in FRADrive TableAvsActiveCards: Valid Cards +TableAvsCardValid: Currently valid +TableAvsCardIssueDate: Issued +TableAvsCardValidTo: Valid to +AvsCardAreas: Card areas +AvsCardColor: Color AvsCardColorGreen: Green AvsCardColorBlue: Blue AvsCardColorRed: Red AvsCardColorYellow: Yellow LastAvsSynchronisation: Last AVS synchronisation -LastAvsSynchError: Last AVS Error \ No newline at end of file +LastAvsSynchError: Last AVS Error + +AvsInterfaceUnavailable: AVS interface was not configured correctly or does not respond +AvsUserUnassociated user: AVS id unknown for user #{user} +AvsUserUnknownByAvs api: AVS reports id #{tshow api} as unknown (or no longer known) +AvsUserAmbiguous api: Multiple matching users found for #{tshow api} +AvsStatusSearchEmpty: AVS returned no card information +AvsPersonSearchEmpty: AVS search returned empty result +AvsPersonSearchAmbiguous: AVS search returned more than one result +AvsSetLicencesFailed reason: Set driving licence within AVS failed. Reason: #{reason} +AvsIdMismatch api1 api2: AVS search for id #{tshow api1} returned id #{tshow api2} instead +AvsUserCreationFailed api@AvsPersonId: No new user could be created for AVS Id #{tshow api}, since an existing user shares at least one id presumed as unique +AvsCardsEmpty: AVS search returned no id cards +AvsCurrentData: All shown data has been recently received via the AVS interface. \ No newline at end of file diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index e0fee7cb8..9c72b28ee 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -25,7 +25,8 @@ TableQualificationSapExport: SAP TableQualificationSapExportTooltip: Wird die Qualifikation an das SAP übermittelt? Betrifft nur Benutzer mit Fraport Personalnummer. LmsQualificationValidUntil: Gültig bis TableQualificationLastRefresh: Zuletzt erneuert -TableQualificationLastNotified: Letzte Benachrichtigung +TableQualificationLastNotified: Letzte Benachrichtigung über erfolgte Gültigkeitsänderung +TableQualificationLastNotifiedTooltip: Hier werden ausschließlich Benachrichtigungen berücksichtigt, die über einen bereits erfolgten Ablauf/Entzug/Wiedererteilung informieren. Dies ignoriert insbesondere reguläre Verlängerung, z.B. durch E-Learning. TableQualificationFirstHeld: Erstmalig TableQualificationBlockedDue: Entzug TableQualificationBlockedTooltip: Wann wurde die Qualifikation vorübergehend außer Kraft gesetzt und warum wurde dies veranlasst? diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg index c886cb843..3779c22a0 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/messages/uniworx/categories/qualification/en-eu.msg @@ -25,7 +25,8 @@ TableQualificationSapExport: Sent to SAP TableQualificationSapExportTooltip: Is this qualification transmitted to SAP? Only applies to qualification holder having a Fraport AG personnel number. LmsQualificationValidUntil: Valid until TableQualificationLastRefresh: Last renewed -TableQualificationLastNotified: Last notified +TableQualificationLastNotified: Last notified about validity change +TableQualificationLastNotifiedTooltip: The date of the last notification about any already effective change in validity due to revocation or reissue. This does not entail regular validity extensions, e.g. due to e-learning. TableQualificationFirstHeld: First held TableQualificationBlockedDue: Revocations TableQualificationBlockedTooltip: Why and when was this qualification temporarily suspended? diff --git a/messages/uniworx/categories/user/de-de-formal.msg b/messages/uniworx/categories/user/de-de-formal.msg index a3c630c46..f2471f4dc 100644 --- a/messages/uniworx/categories/user/de-de-formal.msg +++ b/messages/uniworx/categories/user/de-de-formal.msg @@ -37,7 +37,8 @@ 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"} angestoßen +SynchroniseAvsUserQueued n@Int: AVS-Synchronisation von #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} zwingend angestoßen +SynchroniseAvsAllUsersQueued n@Int64: AVS-Synchronisation von allen #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} angestoßen, welche heute noch nicht synchronisiert wurden SynchroniseLdapUserQueued n@Int: LDAP-Synchronisation von #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} angestoßen SynchroniseLdapAllUsersQueued: LDAP-Synchronisation von allen Benutzer:innen angestoßen UserListTitle: Komprehensive Benutzerliste @@ -89,12 +90,15 @@ NewPasswordLink: Neues Passwort setzen UserAccountDeleteWarning: Achtung, dies löscht den kompletten Benutzer/die komplette Benutzerin unwiderruflich und mit allen assoziierten Daten aus der Datenbank. Prüfungsdaten müssen jedoch langfristig gespeichert bleiben! UserAvsSync: AVS-Synchronisieren UserLdapSync: LDAP-Synchronisieren -AllUsersLdapSync: Alle LDAP-Synchronisieren UserHijack: Sitzung übernehmen UserAddSupervisor: Ansprechpartner hinzufügen UserSetSupervisor: Ansprechpartner ersetzen UserRemoveSupervisor: Alle Ansprechpartner entfernen UserIsSupervisor: Ist Ansprechpartner +UserAvsSwitchCompany: Als Primärfirma verwenden +UserAvsCompanySwitched c@CompanyShorthand: Primärfirma gewechselt zu #{tshow c} +AllUsersLdapSync: Alle LDAP-Synchronisieren +AllUsersAvsSync: Alle AVS-Synchronisieren AuthKindLDAP: Fraport AG Kennung AuthKindPWHash: FRADrive Kennung AuthKindNoLogin: Kein Login möglich @@ -102,3 +106,4 @@ Name !ident-ok: Name UsersChangeSupervisorsSuccess usr@Int spr@Int: #{tshow spr} Ansprechpartner für #{tshow usr} Benutzer gesetzt. UsersChangeSupervisorsWarning usr@Int spr@Int bad@Int: Nur _{MsgUsersChangeSupervisorsSuccess usr spr} #{tshow bad} Ansprechpartner #{pluralDE bad "wurde" "wurden"} nicht gefunden! UsersRemoveSupervisors usr@Int: Alle Ansprechpartner für #{tshow usr} Benutzer gelöscht. +SupervisorReason: Begründung \ No newline at end of file diff --git a/messages/uniworx/categories/user/en-eu.msg b/messages/uniworx/categories/user/en-eu.msg index 10c42830d..fd5cde532 100644 --- a/messages/uniworx/categories/user/en-eu.msg +++ b/messages/uniworx/categories/user/en-eu.msg @@ -37,8 +37,9 @@ 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 AVS synchronisation of #{n} #{pluralEN n "user" "users"}. -SynchroniseLdapUserQueued n: Triggered LDAP synchronisation of #{n} #{pluralEN n "user" "users"}. +SynchroniseAvsUserQueued n: Triggered forced AVS synchronisation of #{n} #{pluralEN n "user" "users"} +SynchroniseAvsAllUsersQueued n: Triggered AVS synchronisation of all #{n} #{pluralEN n "user" "users"} that were not already synchronised today +SynchroniseLdapUserQueued n: Triggered LDAP synchronisation of #{n} #{pluralEN n "user" "users"} SynchroniseLdapAllUsersQueued: Triggered LDAP synchronisation of all users UserListTitle: Comprehensive list of users AccessRightsSaved: Successfully updated permissions @@ -89,16 +90,20 @@ NewPasswordLink: Set password UserAccountDeleteWarning: Caution, this permanently deletes users and all of their associated data. Exam results must be stored long term! UserAvsSync: Synchronise with AVS UserLdapSync: Synchronise with LDAP -AllUsersLdapSync: Synchronise all with LDAP UserHijack: Hijack session UserAddSupervisor: Add supervisor UserSetSupervisor: Replace supervisors UserRemoveSupervisor: Set to unsupervised UserIsSupervisor: Is supervisor +UserAvsSwitchCompany: Use as primary company +UserAvsCompanySwitched c: Primary company switched to #{tshow c} +AllUsersLdapSync: Synchronise all with LDAP +AllUsersAvsSync: Synchronise all with AVS AuthKindLDAP: Fraport AG account AuthKindPWHash: FRADrive account AuthKindNoLogin: No login Name: Name UsersChangeSupervisorsSuccess usr spr: #{pluralENsN spr "supervisor"} for #{pluralENsN usr "user"} set. UsersChangeSupervisorsWarning usr spr bad: Only _{MsgUsersChangeSupervisorsSuccess usr spr} #{pluralENsN bad "supervisors"} could not be identified! -UsersRemoveSupervisors usr: Removed all supervisors for #{pluralENsN usr "user"}. \ No newline at end of file +UsersRemoveSupervisors usr: Removed all supervisors for #{pluralENsN usr "user"}. +SupervisorReason: Reason \ No newline at end of file diff --git a/messages/uniworx/misc/de-de-formal.msg b/messages/uniworx/misc/de-de-formal.msg index 3fcd6ffe6..3ed3bd645 100644 --- a/messages/uniworx/misc/de-de-formal.msg +++ b/messages/uniworx/misc/de-de-formal.msg @@ -21,6 +21,7 @@ ClusterVolatileQuickActionsEnabled: Schnellzugriffsmenü aktiv AvsNoLicence: Keine Fahrberechtigung AvsLicenceVorfeld: Vorfeld Fahrberechtigung AvsLicenceRollfeld: Rollfeld Fahrberechtigung +AvsNoLicenceGuest: Keine Fahrberechtigung (Gast, Fahrberechtigungserwerb nicht möglich) PaginationSize: Einträge pro Seite PaginationPage: Angzeigte Seite diff --git a/messages/uniworx/misc/en-eu.msg b/messages/uniworx/misc/en-eu.msg index ed8bda4db..d652ed4ba 100644 --- a/messages/uniworx/misc/en-eu.msg +++ b/messages/uniworx/misc/en-eu.msg @@ -21,6 +21,7 @@ ClusterVolatileQuickActionsEnabled: Quick actions enabled AvsNoLicence: No driving licence AvsLicenceVorfeld: Apron driving licence AvsLicenceRollfeld: Maneuvering area driving licence +AvsNoLicenceGuest: No driving licence (Guest account, cannot acquire a diriving licence) PaginationSize: Rows per Page PaginationPage: Page to show diff --git a/messages/uniworx/utils/buttons/de-de-formal.msg b/messages/uniworx/utils/buttons/de-de-formal.msg index 8252a3a1c..b6ec6de16 100644 --- a/messages/uniworx/utils/buttons/de-de-formal.msg +++ b/messages/uniworx/utils/buttons/de-de-formal.msg @@ -1,8 +1,9 @@ -# SPDX-FileCopyrightText: 2022 Gregor Kleen ,Steffen Jost ,Winnie Ros ,Sarah Vaupel +# SPDX-FileCopyrightText: 2022-2024 Gregor Kleen ,Steffen Jost ,Winnie Ros ,Sarah Vaupel ,David Mosbach # # SPDX-License-Identifier: AGPL-3.0-or-later BtnSubmit: Senden +BtnApplyFilter: Filter Anwenden BtnAbort: Abbrechen BtnDelete: Löschen BtnRegister: Anmelden diff --git a/messages/uniworx/utils/buttons/en-eu.msg b/messages/uniworx/utils/buttons/en-eu.msg index a83a7b3aa..37228f057 100644 --- a/messages/uniworx/utils/buttons/en-eu.msg +++ b/messages/uniworx/utils/buttons/en-eu.msg @@ -1,8 +1,9 @@ -# SPDX-FileCopyrightText: 2022 Steffen Jost ,Winnie Ros ,Sarah Vaupel +# SPDX-FileCopyrightText: 2022-2024 Steffen Jost ,Winnie Ros ,Sarah Vaupel ,David Mosbach # # SPDX-License-Identifier: AGPL-3.0-or-later BtnSubmit: Submit +BtnApplyFilter: Apply Filter BtnAbort: Abort BtnDelete: Delete BtnRegister: Register diff --git a/messages/uniworx/utils/table_column/de-de-formal.msg b/messages/uniworx/utils/table_column/de-de-formal.msg index 0a67481af..43031fd5b 100644 --- a/messages/uniworx/utils/table_column/de-de-formal.msg +++ b/messages/uniworx/utils/table_column/de-de-formal.msg @@ -91,8 +91,10 @@ TableCompanyNrSupersDefault: Standard Ansprechpartner TableCompanyNrForeignSupers: Firmenfremde Ansprechpartner TableCompanyNrRerouteDefault: Standard Umleitungen TableCompanyNrRerouteActive: Aktive Umleitungen +TableRerouteActive: Umleitung TableCompanyPostalPreference: Benachrichtigungspräferenz neue Firmenangehörige TableSupervisor: Ansprechpartner +TableSupervisee: Ansprechpartner für TableCreationTime: Erstellungszeit TableJob !ident-ok: Job TableJobContent !ident-ok: Parameter diff --git a/messages/uniworx/utils/table_column/en-eu.msg b/messages/uniworx/utils/table_column/en-eu.msg index e7ae23a14..8546022d9 100644 --- a/messages/uniworx/utils/table_column/en-eu.msg +++ b/messages/uniworx/utils/table_column/en-eu.msg @@ -91,8 +91,10 @@ TableCompanyNrSupersDefault: Default supervisors TableCompanyNrForeignSupers: External Supervisors TableCompanyNrRerouteDefault: Default reroutes TableCompanyNrRerouteActive: Active reroutes +TableRerouteActive: Reroute TableCompanyPostalPreference: Default notification preference TableSupervisor: Supervisor +TableSupervisee: Supervisor for TableCreationTime: Creation TableJob !ident-ok: Job TableJobContent !ident-ok: Parameters diff --git a/models/audit.model b/models/audit.model index 3cd567a13..e61f11389 100644 --- a/models/audit.model +++ b/models/audit.model @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-23 Gregor Kleen ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -8,7 +8,7 @@ TransactionLog instance InstanceId initiator UserId Maybe -- User associated with performing this action remote IP Maybe -- Remote party that triggered this action via HTTP - info Value -- JSON-encoded `Transaction` + info Value -- JSON-encoded `Transaction`. Value allows full backwards compatibility deriving Eq Read Show Generic InterfaceLog @@ -29,3 +29,10 @@ InterfaceHealth hours Int UniqueInterfaceHealth interface subtype write !force -- Note that nullable fields must be either empty or unique deriving Eq Read Show Generic + +ProblemLog + time UTCTime default=now() + info Value -- generic JSON Value allows maximum backwards compatibility + solved UTCTime Maybe + solver UserId Maybe -- User who marked this problem as done + deriving Eq Read Show Generic \ No newline at end of file diff --git a/models/avs.model b/models/avs.model index 7a8a59cc0..ee4dd9a19 100644 --- a/models/avs.model +++ b/models/avs.model @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -16,27 +16,19 @@ UserAvs personId AvsPersonId -- unique identifier for user throughout avs; newtype for Int user UserId - noPerson Int default=0 -- only needed for manual communication with personnel from Ausweisverwaltungsstelle + noPerson Int default=0 -- only needed for manual communication with personnel from Ausweisverwaltungsstelle, redundant since needed for filtering lastSynch UTCTime default=now() lastSynchError Text Maybe + lastPersonInfo AvsPersonInfo Maybe -- just to discern field changes + lastFirmInfo AvsFirmInfo Maybe -- just to discern field changes + lastCardNo AvsFullCardNo Maybe -- just to discern changes UniqueUserAvsUser user UniqueUserAvsId personId deriving Generic Show --- Multiple UserAvsCards per UserAvs is possible and not too uncommon. --- Purpose of saving cards is to detect external changes in qualifications and postal addresses --- TODO: This table will be deleted if AVS CR3 SCF-165 is implemented -UserAvsCard - personId AvsPersonId - cardNo AvsFullCardNo - card AvsDataPersonCard - lastSynch UTCTime - -- UniqueAvsCard cardNo -- Note: cardNo is not unique; invalid cardNo may be reissued to different persons - deriving Generic - AvsSync user UserId -- Note: we need to lookup UserAvs Entity anyway, so no benefit from storing AvsPersonId here creationTime UTCTime - pause Day Maybe + pause Day Maybe -- Don't synch if last synch after this day, otherwise synch UniqueAvsSyncUser user - deriving Generic \ No newline at end of file + deriving Generic Show \ No newline at end of file diff --git a/models/company.model b/models/company.model index c022ad5f1..c123e281b 100644 --- a/models/company.model +++ b/models/company.model @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Sarah Vaupel ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Sarah Vaupel ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -6,20 +6,20 @@ Company name CompanyName -- == (CI Text) - shorthand CompanyShorthand -- == (CI Text) and CompanyKey :: CompanyShorthand -> CompanyId FUTURE TODO: a shorthand will become available through the AVS interface in the future - avsId Int default=0 -- primary key from avs + 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 - postAddress StoredMarkup Maybe -- default company postal address - email UserEmail Maybe -- Case-insensitive generic company eMail address + postAddress StoredMarkup Maybe -- default company postal address, including company name + email UserEmail Maybe -- Case-insensitive generic company eMail address UniqueCompanyName name - UniqueCompanyShorthand shorthand - -- UniqueCompanyAvsId avsId -- should be the case, unclear if enforcing works here, since we cannot query avs by company id - Primary shorthand -- newtype Key Company = CompanyKey { unCompanyKey :: CompanyShorthand } + -- UniqueCompanyShorthand shorthand -- unnecessary, since it is the primary key already + UniqueCompanyAvsId avsId + Primary shorthand -- newtype Key Company = CompanyKey { unCompanyKey :: CompanyShorthand } deriving Ord Eq Show Generic Binary --- TODO: a way to populate this table (manually) -CompanySynonym - synonym CompanyName - canonical CompanyShorthand OnDeleteCascade OnUpdateCascade - UniqueCompanySynonym synonym - deriving Ord Eq Show Generic +-- -- TODO: a way to populate this table (manually) +-- CompanySynonym +-- synonym CompanyName +-- canonical CompanyShorthand OnDeleteCascade OnUpdateCascade -- DEPRECATED: should be CompanyId +-- UniqueCompanySynonym synonym +-- deriving Ord Eq Show Generic diff --git a/models/jobs.model b/models/jobs.model index 98aa8c3b8..bc24e931f 100644 --- a/models/jobs.model +++ b/models/jobs.model @@ -20,11 +20,11 @@ CronLastExec time UTCTime -- When was the job executed instance InstanceId -- Which uni2work-instance did the work UniqueCronLastExec job - deriving Generic + deriving Generic Show TokenBucket ident TokenBucketIdent lastValue Int64 lastAccess UTCTime Primary ident - deriving Generic \ No newline at end of file + deriving Generic Show \ No newline at end of file diff --git a/models/lms.model b/models/lms.model index 9e96df730..2d3531ff8 100644 --- a/models/lms.model +++ b/models/lms.model @@ -22,7 +22,7 @@ Qualification -- across all schools, only one qualification may be a driving licence: UniqueQualificationAvsLicence avsLicence !force -- either empty or unique -- NOTE: two NULL values are not equal for the purpose of Uniqueness constraints! - deriving Eq Generic + deriving Show Eq Generic -- TODOs: -- - Enstehen Kosten, wenn Teilnehmer für KnowHow eingereiht werden, aber nicht am Kurs teilnehmen? @@ -44,7 +44,7 @@ QualificationPrecondition -- NOTE: this can only be enforc qualification QualificationId OnDeleteCascade OnUpdateCascade -- AND: not unique, ie. qualification can have multiple required preconditions required [QualificationId] -- OR : alternatives, any one will suffice continuous Bool -- expiring precondition blocks qualification - deriving Generic + deriving Generic Show -- Maybe an alternative for online qualification validity checking, transitivity through recursive CTEs? (already available in our version) -- QualificationRequirement @@ -60,7 +60,7 @@ QualificationEdit user UserId time UTCTime qualification QualificationId OnDeleteCascade OnUpdateCascade - deriving Generic + deriving Generic Show QualificationUser user UserId OnDeleteCascade OnUpdateCascade @@ -69,11 +69,11 @@ QualificationUser lastRefresh Day -- lastRefresh > validUntil possible, if Qualification^elearningOnly == False firstHeld Day -- first time the qualification was earned, should never change scheduleRenewal Bool default=true -- if false, no automatic renewal is scheduled and the qualification expires - lastNotified UTCTime default=now() -- last notficiation about being invalid + lastNotified UTCTime default=now() -- last notficiation about actual licence validity changes (does not entail e-learning notifications) -- Reasons and temporary revocations are implemented through QualificationUserBlock -- TODO: adjust SAP interface to transmit end dates UniqueQualificationUser qualification user - deriving Generic + deriving Generic Show QualificationUserBlock qualificationUser QualificationUserId OnDeleteCascade OnUpdateCascade @@ -130,7 +130,7 @@ LmsUser -- Primary ident -- newtype Key LmsUserId = LmsUserKey { unLmsUser :: Text } -- change LmsIdent -> Text. Do we want this? No. UniqueLmsIdent ident -- idents must be unique accross all qualifications, since idents are global within LMS! UniqueLmsQualificationUser qualification user -- each user may be enrolled at most once per course - deriving Generic + deriving Generic Show -- LmsUserStatus -- lmsUser LmsUserId OnDeleteCascade OnUpdateCascade @@ -148,7 +148,7 @@ LmsReport lock Bool -- (0|1) timestamp UTCTime default=now() UniqueLmsReport qualification ident -- required by DBTable - deriving Generic + deriving Generic Show -- LmsAudit removed by commit 71cde92a -- due to frequent transmit errors, a separate lms tranmission log is necessary again @@ -160,4 +160,4 @@ LmsReportLog lock Bool -- (0|1) timestamp UTCTime default=now() missing Bool default=false - deriving Generic \ No newline at end of file + deriving Generic Show \ No newline at end of file diff --git a/models/print.model b/models/print.model index ee22cf922..bdf7b5a56 100644 --- a/models/print.model +++ b/models/print.model @@ -16,16 +16,16 @@ PrintJob lmsUser LmsIdent Maybe OnDeleteSetNull OnUpdateCascade -- allows tracking if recipient has been notified; must be unique -- UniquePrintJobLmsUser lmsUser -- Note that in fact multiple print jobs per LMS user are possible! -- UniquePrintJobApcIdent apcIdent -- TODO: not yet enforced, since LmsIdent is currently used - deriving Generic + deriving Generic Show PrintAcknowledge -- just to store acknowledging requests to be evaluated by a background job later on apcIdent Text timestamp UTCTime default=now() processed Bool - deriving Generic + deriving Generic Show PrintAckIdAlias needle Text replacement Text priority Int - deriving Generic \ No newline at end of file + deriving Generic Show \ No newline at end of file diff --git a/models/users.model b/models/users.model index b23fe85b2..afe59e77a 100644 --- a/models/users.model +++ b/models/users.model @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -14,14 +14,14 @@ User json -- Each Uni2work user has a corresponding row in this table; created upon first login. surname UserSurname -- Display user names always through 'nameWidget displayName surname' displayName UserDisplayName - displayEmail UserEmail - email UserEmail -- Case-insensitive eMail address, used for sending TODO: make this nullable - ident UserIdent -- Case-insensitive user-identifier + displayEmail UserEmail -- Case-insensitive eMail address, used for sending; leave empty for using auto-update CompanyEmail via UserCompany + email UserEmail -- Case-insensitive eMail address, used for identification and fallback for sending. Defaults to "AVSNO:dddddddd" if unknown + ident UserIdent -- Case-insensitive user-identifier. Defaults to "AVSID:dddddddd" if unknown authentication AuthenticationMode -- 'AuthLDAP' or ('AuthPWHash'+password-hash) lastAuthentication UTCTime Maybe -- last login date created UTCTime default=now() lastLdapSynchronisation UTCTime Maybe - ldapPrimaryKey UserEduPersonPrincipalName Maybe + ldapPrimaryKey UserEduPersonPrincipalName Maybe -- Fraport Personnel Number or Email-Prefix for @fraport.de work here tokensIssuedAfter UTCTime Maybe -- do not accept bearer tokens issued before this time (accept all tokens if null) matrikelnummer UserMatriculation Maybe -- usually a number; AVS Personalnummer; nicht Fraport Personalnummer! firstName Text -- For export in tables, pre-split firstName from displayName @@ -44,9 +44,9 @@ User json -- Each Uni2work user has a corresponding row in this table; create mobile Text Maybe companyPersonalNumber Text Maybe -- Company will become a new table, but if company=fraport, some information is received via LDAP companyDepartment Text Maybe -- thus we store such information for ease of reference directly, if available - pinPassword Text Maybe -- used to encrypt pins within emails - postAddress StoredMarkup Maybe - postLastUpdate UTCTime Maybe -- record postal address updates + pinPassword Text Maybe -- used to encrypt pins within emails, defaults to cardno.version + postAddress StoredMarkup Maybe -- including company name, if any, but excluding username; leave empty for using auto-update CompanyPostAddress via UserCompany + postLastUpdate UTCTime Maybe -- record postal address updates prefersPostal Bool default=false -- user prefers letters by post instead of email examOfficeGetSynced Bool default=true -- whether synced status should be displayed for exam results by default examOfficeGetLabels Bool default=true -- whether labels should be displayed for exam results by default @@ -61,42 +61,46 @@ UserFunction -- Administratively assigned functions (lecturer, admin, evaluation function SchoolFunction UniqueUserFunction user school function deriving Generic -UserSystemFunction +UserSystemFunction Show user UserId function SystemFunction -- Defined in Model.Types.User manual Bool -- Inserted manually by Admin or automatic from LDAP isOptOut Bool -- User has currently deactivate the role for themselves UniqueUserSystemFunction user function - deriving Generic + deriving Generic Show UserExamOffice user UserId field StudyTermsId UniqueUserExamOffice user field - deriving Generic + deriving Generic Show UserSchool -- Managed by users themselves, encodes "schools of interest" user UserId school SchoolId isOptOut Bool -- true if this a marker, that the user manually deleted this entry; it should not be recreated automatically UniqueUserSchool user school - deriving Generic + deriving Generic Show UserGroupMember group UserGroupName user UserId primary Checkmark nullable UniquePrimaryUserGroupMember group primary !force UniqueUserGroupMember group user - deriving Generic + deriving Generic Show UserCompany user UserId company CompanyId OnDeleteCascade OnUpdateCascade supervisor Bool default=false -- should this user be made supervisor for all _new_ users associated with this company? supervisorReroute Bool default=false -- if supervisor is true, should this supervisor receive email for _new_ company users? + priority Int default=0 -- higher number, higher priority + useCompanyAddress Bool default=true -- if true, CompanyPostalAddress and CompanyEmail are used if UserPostalAddress/UserDisplayEmail are Nothing, respects priority UniqueUserCompany user company -- a user may belong to multiple companies, but to each one only once - deriving Generic + deriving Generic Show UserSupervisor - supervisor UserId -- multiple supervisor per trainee possible + supervisor UserId -- multiple supervisor per trainee possible user UserId - rerouteNotifications Bool -- User can be his own supervisor to receive notifications as well - UniqueUserSupervisor supervisor user -- each supervisor/user combination is unique (same supervisor can superviser the same user only once) - deriving Generic + rerouteNotifications Bool -- User can be his own supervisor to receive notifications as well + company CompanyId Maybe OnDeleteCascade OnUpdateCascade -- this supervisor was company default supervisor at time of entry + reason Text Maybe -- miscellaneous reason, e.g. Winterservice supervisision + UniqueUserSupervisor supervisor user -- each supervisor/user combination is unique (same supervisor can superviser the same user only once) + deriving Generic Show diff --git a/nix/docker/default.nix b/nix/docker/default.nix index 98ec639da..f01a9f3b0 100644 --- a/nix/docker/default.nix +++ b/nix/docker/default.nix @@ -31,11 +31,12 @@ let busybox # should provide a working lpr -- to be tested htop pdftk # for encrypting pdfs + roboto roboto-mono #texlive.combined.scheme-medium # too large for container in LMU build environment. (texlive.combine { inherit (texlive) scheme-basic babel-german babel-english booktabs textpos - enumitem eurosym koma-script parskip xcolor dejavu + enumitem eurosym koma-script parskip xcolor roboto xkeyval # required fro LuaTeX luatexbase lualatex-math unicode-math selnolig ; diff --git a/nix/docker/version.json b/nix/docker/version.json index 450e150fd..1b05a79f4 100644 --- a/nix/docker/version.json +++ b/nix/docker/version.json @@ -1,3 +1,3 @@ { - "version": "27.4.59" + "version": "27.4.64" } diff --git a/package-lock.json b/package-lock.json index 8baaeafcc..26f7e2f5f 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.59", + "version": "27.4.64", "lockfileVersion": 1, "requires": true, "dependencies": { @@ -405,6 +405,12 @@ "@babel/types": "^7.16.7" } }, + "@babel/helper-string-parser": { + "version": "7.24.6", + "resolved": "https://registry.npmjs.org/@babel/helper-string-parser/-/helper-string-parser-7.24.6.tgz", + "integrity": "sha512-WdJjwMEkmBicq5T9fm/cHND3+UlFa2Yj8ALLgmoSQAJZysYbBjw+azChSGPN4DSPLXOcooGRvDwZWMcF/mLO2Q==", + "dev": true + }, "@babel/helper-validator-identifier": { "version": "7.16.7", "resolved": "https://registry.npmjs.org/@babel/helper-validator-identifier/-/helper-validator-identifier-7.16.7.tgz", @@ -562,17 +568,314 @@ } }, "@babel/plugin-proposal-decorators": { - "version": "7.18.2", - "resolved": "https://registry.npmjs.org/@babel/plugin-proposal-decorators/-/plugin-proposal-decorators-7.18.2.tgz", - "integrity": "sha512-kbDISufFOxeczi0v4NQP3p5kIeW6izn/6klfWBrIIdGZZe4UpHR+QU03FAoWjGGd9SUXAwbw2pup1kaL4OQsJQ==", + "version": "7.24.7", + "resolved": "https://registry.npmjs.org/@babel/plugin-proposal-decorators/-/plugin-proposal-decorators-7.24.7.tgz", + "integrity": "sha512-RL9GR0pUG5Kc8BUWLNDm2T5OpYwSX15r98I0IkgmRQTXuELq/OynH8xtMTMvTJFjXbMWFVTKtYkTaYQsuAwQlQ==", "dev": true, "requires": { - "@babel/helper-create-class-features-plugin": "^7.18.0", - "@babel/helper-plugin-utils": "^7.17.12", - "@babel/helper-replace-supers": "^7.18.2", - "@babel/helper-split-export-declaration": "^7.16.7", - "@babel/plugin-syntax-decorators": "^7.17.12", - "charcodes": "^0.2.0" + "@babel/helper-create-class-features-plugin": "^7.24.7", + "@babel/helper-plugin-utils": "^7.24.7", + "@babel/plugin-syntax-decorators": "^7.24.7" + }, + "dependencies": { + "@babel/code-frame": { + "version": "7.24.7", + "resolved": "https://registry.npmjs.org/@babel/code-frame/-/code-frame-7.24.7.tgz", + "integrity": "sha512-BcYH1CVJBO9tvyIZ2jVeXgSIMvGZ2FDRvDdOIVQyuklNKSsx+eppDEBq/g47Ayw+RqNFE+URvOShmf+f/qwAlA==", + "dev": true, + "requires": { + "@babel/highlight": "^7.24.7", + "picocolors": "^1.0.0" + } + }, + "@babel/generator": { + "version": "7.24.7", + "resolved": "https://registry.npmjs.org/@babel/generator/-/generator-7.24.7.tgz", + "integrity": "sha512-oipXieGC3i45Y1A41t4tAqpnEZWgB/lC6Ehh6+rOviR5XWpTtMmLN+fGjz9vOiNRt0p6RtO6DtD0pdU3vpqdSA==", + "dev": true, + "requires": { + "@babel/types": "^7.24.7", + "@jridgewell/gen-mapping": "^0.3.5", + "@jridgewell/trace-mapping": "^0.3.25", + "jsesc": "^2.5.1" + } + }, + "@babel/helper-annotate-as-pure": { + "version": "7.24.7", + "resolved": "https://registry.npmjs.org/@babel/helper-annotate-as-pure/-/helper-annotate-as-pure-7.24.7.tgz", + "integrity": "sha512-BaDeOonYvhdKw+JoMVkAixAAJzG2jVPIwWoKBPdYuY9b452e2rPuI9QPYh3KpofZ3pW2akOmwZLOiOsHMiqRAg==", + "dev": true, + "requires": { + "@babel/types": "^7.24.7" + } + }, + "@babel/helper-create-class-features-plugin": { + "version": "7.24.7", + "resolved": "https://registry.npmjs.org/@babel/helper-create-class-features-plugin/-/helper-create-class-features-plugin-7.24.7.tgz", + "integrity": "sha512-kTkaDl7c9vO80zeX1rJxnuRpEsD5tA81yh11X1gQo+PhSti3JS+7qeZo9U4RHobKRiFPKaGK3svUAeb8D0Q7eg==", + "dev": true, + "requires": { + "@babel/helper-annotate-as-pure": "^7.24.7", + "@babel/helper-environment-visitor": "^7.24.7", + "@babel/helper-function-name": "^7.24.7", + "@babel/helper-member-expression-to-functions": "^7.24.7", + "@babel/helper-optimise-call-expression": "^7.24.7", + "@babel/helper-replace-supers": "^7.24.7", + "@babel/helper-skip-transparent-expression-wrappers": "^7.24.7", + "@babel/helper-split-export-declaration": "^7.24.7", + "semver": "^6.3.1" + } + }, + "@babel/helper-environment-visitor": { + "version": "7.24.7", + "resolved": "https://registry.npmjs.org/@babel/helper-environment-visitor/-/helper-environment-visitor-7.24.7.tgz", + "integrity": "sha512-DoiN84+4Gnd0ncbBOM9AZENV4a5ZiL39HYMyZJGZ/AZEykHYdJw0wW3kdcsh9/Kn+BRXHLkkklZ51ecPKmI1CQ==", + "dev": true, + "requires": { + "@babel/types": "^7.24.7" + } + }, + "@babel/helper-function-name": { + "version": "7.24.7", + "resolved": "https://registry.npmjs.org/@babel/helper-function-name/-/helper-function-name-7.24.7.tgz", + "integrity": "sha512-FyoJTsj/PEUWu1/TYRiXTIHc8lbw+TDYkZuoE43opPS5TrI7MyONBE1oNvfguEXAD9yhQRrVBnXdXzSLQl9XnA==", + "dev": true, + "requires": { + "@babel/template": "^7.24.7", + "@babel/types": "^7.24.7" + } + }, + "@babel/helper-hoist-variables": { + "version": "7.24.7", + "resolved": "https://registry.npmjs.org/@babel/helper-hoist-variables/-/helper-hoist-variables-7.24.7.tgz", + "integrity": "sha512-MJJwhkoGy5c4ehfoRyrJ/owKeMl19U54h27YYftT0o2teQ3FJ3nQUf/I3LlJsX4l3qlw7WRXUmiyajvHXoTubQ==", + "dev": true, + "requires": { + "@babel/types": "^7.24.7" + } + }, + "@babel/helper-member-expression-to-functions": { + "version": "7.24.7", + "resolved": "https://registry.npmjs.org/@babel/helper-member-expression-to-functions/-/helper-member-expression-to-functions-7.24.7.tgz", + "integrity": "sha512-LGeMaf5JN4hAT471eJdBs/GK1DoYIJ5GCtZN/EsL6KUiiDZOvO/eKE11AMZJa2zP4zk4qe9V2O/hxAmkRc8p6w==", + "dev": true, + "requires": { + "@babel/traverse": "^7.24.7", + "@babel/types": "^7.24.7" + } + }, + "@babel/helper-optimise-call-expression": { + "version": "7.24.7", + "resolved": "https://registry.npmjs.org/@babel/helper-optimise-call-expression/-/helper-optimise-call-expression-7.24.7.tgz", + "integrity": "sha512-jKiTsW2xmWwxT1ixIdfXUZp+P5yURx2suzLZr5Hi64rURpDYdMW0pv+Uf17EYk2Rd428Lx4tLsnjGJzYKDM/6A==", + "dev": true, + "requires": { + "@babel/types": "^7.24.7" + } + }, + "@babel/helper-plugin-utils": { + "version": "7.24.7", + "resolved": "https://registry.npmjs.org/@babel/helper-plugin-utils/-/helper-plugin-utils-7.24.7.tgz", + "integrity": "sha512-Rq76wjt7yz9AAc1KnlRKNAi/dMSVWgDRx43FHoJEbcYU6xOWaE2dVPwcdTukJrjxS65GITyfbvEYHvkirZ6uEg==", + "dev": true + }, + "@babel/helper-replace-supers": { + "version": "7.24.7", + "resolved": "https://registry.npmjs.org/@babel/helper-replace-supers/-/helper-replace-supers-7.24.7.tgz", + "integrity": "sha512-qTAxxBM81VEyoAY0TtLrx1oAEJc09ZK67Q9ljQToqCnA+55eNwCORaxlKyu+rNfX86o8OXRUSNUnrtsAZXM9sg==", + "dev": true, + "requires": { + "@babel/helper-environment-visitor": "^7.24.7", + "@babel/helper-member-expression-to-functions": "^7.24.7", + "@babel/helper-optimise-call-expression": "^7.24.7" + } + }, + "@babel/helper-skip-transparent-expression-wrappers": { + "version": "7.24.7", + "resolved": "https://registry.npmjs.org/@babel/helper-skip-transparent-expression-wrappers/-/helper-skip-transparent-expression-wrappers-7.24.7.tgz", + "integrity": "sha512-IO+DLT3LQUElMbpzlatRASEyQtfhSE0+m465v++3jyyXeBTBUjtVZg28/gHeV5mrTJqvEKhKroBGAvhW+qPHiQ==", + "dev": true, + "requires": { + "@babel/traverse": "^7.24.7", + "@babel/types": "^7.24.7" + } + }, + "@babel/helper-split-export-declaration": { + "version": "7.24.7", + "resolved": "https://registry.npmjs.org/@babel/helper-split-export-declaration/-/helper-split-export-declaration-7.24.7.tgz", + "integrity": "sha512-oy5V7pD+UvfkEATUKvIjvIAH/xCzfsFVw7ygW2SI6NClZzquT+mwdTfgfdbUiceh6iQO0CHtCPsyze/MZ2YbAA==", + "dev": true, + "requires": { + "@babel/types": "^7.24.7" + } + }, + "@babel/helper-string-parser": { + "version": "7.24.7", + "resolved": "https://registry.npmjs.org/@babel/helper-string-parser/-/helper-string-parser-7.24.7.tgz", + "integrity": "sha512-7MbVt6xrwFQbunH2DNQsAP5sTGxfqQtErvBIvIMi6EQnbgUOuVYanvREcmFrOPhoXBrTtjhhP+lW+o5UfK+tDg==", + "dev": true + }, + "@babel/helper-validator-identifier": { + "version": "7.24.7", + "resolved": "https://registry.npmjs.org/@babel/helper-validator-identifier/-/helper-validator-identifier-7.24.7.tgz", + "integrity": "sha512-rR+PBcQ1SMQDDyF6X0wxtG8QyLCgUB0eRAGguqRLfkCA87l7yAP7ehq8SNj96OOGTO8OBV70KhuFYcIkHXOg0w==", + "dev": true + }, + "@babel/highlight": { + "version": "7.24.7", + "resolved": "https://registry.npmjs.org/@babel/highlight/-/highlight-7.24.7.tgz", + "integrity": "sha512-EStJpq4OuY8xYfhGVXngigBJRWxftKX9ksiGDnmlY3o7B/V7KIAc9X4oiK87uPJSc/vs5L869bem5fhZa8caZw==", + "dev": true, + "requires": { + "@babel/helper-validator-identifier": "^7.24.7", + "chalk": "^2.4.2", + "js-tokens": "^4.0.0", + "picocolors": "^1.0.0" + } + }, + "@babel/parser": { + "version": "7.24.7", + "resolved": "https://registry.npmjs.org/@babel/parser/-/parser-7.24.7.tgz", + "integrity": "sha512-9uUYRm6OqQrCqQdG1iCBwBPZgN8ciDBro2nIOFaiRz1/BCxaI7CNvQbDHvsArAC7Tw9Hda/B3U+6ui9u4HWXPw==", + "dev": true + }, + "@babel/template": { + "version": "7.24.7", + "resolved": "https://registry.npmjs.org/@babel/template/-/template-7.24.7.tgz", + "integrity": "sha512-jYqfPrU9JTF0PmPy1tLYHW4Mp4KlgxJD9l2nP9fD6yT/ICi554DmrWBAEYpIelzjHf1msDP3PxJIRt/nFNfBig==", + "dev": true, + "requires": { + "@babel/code-frame": "^7.24.7", + "@babel/parser": "^7.24.7", + "@babel/types": "^7.24.7" + } + }, + "@babel/traverse": { + "version": "7.24.7", + "resolved": "https://registry.npmjs.org/@babel/traverse/-/traverse-7.24.7.tgz", + "integrity": "sha512-yb65Ed5S/QAcewNPh0nZczy9JdYXkkAbIsEo+P7BE7yO3txAY30Y/oPa3QkQ5It3xVG2kpKMg9MsdxZaO31uKA==", + "dev": true, + "requires": { + "@babel/code-frame": "^7.24.7", + "@babel/generator": "^7.24.7", + "@babel/helper-environment-visitor": "^7.24.7", + "@babel/helper-function-name": "^7.24.7", + "@babel/helper-hoist-variables": "^7.24.7", + "@babel/helper-split-export-declaration": "^7.24.7", + "@babel/parser": "^7.24.7", + "@babel/types": "^7.24.7", + "debug": "^4.3.1", + "globals": "^11.1.0" + } + }, + "@babel/types": { + "version": "7.24.7", + "resolved": "https://registry.npmjs.org/@babel/types/-/types-7.24.7.tgz", + "integrity": "sha512-XEFXSlxiG5td2EJRe8vOmRbaXVgfcBlszKujvVmWIK/UpywWljQCfzAv3RQCGujWQ1RD4YYWEAqDXfuJiy8f5Q==", + "dev": true, + "requires": { + "@babel/helper-string-parser": "^7.24.7", + "@babel/helper-validator-identifier": "^7.24.7", + "to-fast-properties": "^2.0.0" + } + }, + "@jridgewell/gen-mapping": { + "version": "0.3.5", + "resolved": "https://registry.npmjs.org/@jridgewell/gen-mapping/-/gen-mapping-0.3.5.tgz", + "integrity": "sha512-IzL8ZoEDIBRWEzlCcRhOaCupYyN5gdIK+Q6fbFdPDg6HqX6jpkItn7DFIpW9LQzXG6Df9sA7+OKnq0qlz/GaQg==", + "dev": true, + "requires": { + "@jridgewell/set-array": "^1.2.1", + "@jridgewell/sourcemap-codec": "^1.4.10", + "@jridgewell/trace-mapping": "^0.3.24" + } + }, + "@jridgewell/resolve-uri": { + "version": "3.1.2", + "resolved": "https://registry.npmjs.org/@jridgewell/resolve-uri/-/resolve-uri-3.1.2.tgz", + "integrity": "sha512-bRISgCIjP20/tbWSPWMEi54QVPRZExkuD9lJL+UIxUKtwVJA8wW1Trb1jMs1RFXo1CBTNZ/5hpC9QvmKWdopKw==", + "dev": true + }, + "@jridgewell/set-array": { + "version": "1.2.1", + "resolved": "https://registry.npmjs.org/@jridgewell/set-array/-/set-array-1.2.1.tgz", + "integrity": "sha512-R8gLRTZeyp03ymzP/6Lil/28tGeGEzhx1q2k703KGWRAI1VdvPIXdG70VJc2pAMw3NA6JKL5hhFu1sJX0Mnn/A==", + "dev": true + }, + "@jridgewell/trace-mapping": { + "version": "0.3.25", + "resolved": "https://registry.npmjs.org/@jridgewell/trace-mapping/-/trace-mapping-0.3.25.tgz", + "integrity": "sha512-vNk6aEwybGtawWmy/PzwnGDOjCkLWSD2wqvjGGAgOAwCGWySYXfYoxt00IJkTF+8Lb57DwOb3Aa0o9CApepiYQ==", + "dev": true, + "requires": { + "@jridgewell/resolve-uri": "^3.1.0", + "@jridgewell/sourcemap-codec": "^1.4.14" + }, + "dependencies": { + "@jridgewell/sourcemap-codec": { + "version": "1.4.15", + "resolved": "https://registry.npmjs.org/@jridgewell/sourcemap-codec/-/sourcemap-codec-1.4.15.tgz", + "integrity": "sha512-eF2rxCRulEKXHTRiDrDy6erMYWqNw4LPdQ8UQA4huuxaQsVeRPFl2oM8oDGxMFhJUWZf9McpLtJasDDZb/Bpeg==", + "dev": true + } + } + }, + "ansi-styles": { + "version": "3.2.1", + "resolved": "https://registry.npmjs.org/ansi-styles/-/ansi-styles-3.2.1.tgz", + "integrity": "sha512-VT0ZI6kZRdTh8YyJw3SMbYm/u+NqfsAxEpWO0Pf9sq8/e94WxxOpPKx9FR1FlyCtOVDNOQ+8ntlqFxiRc+r5qA==", + "dev": true, + "requires": { + "color-convert": "^1.9.0" + } + }, + "chalk": { + "version": "2.4.2", + "resolved": "https://registry.npmjs.org/chalk/-/chalk-2.4.2.tgz", + "integrity": "sha512-Mti+f9lpJNcwF4tWV8/OrTTtF1gZi+f8FqlyAdouralcFWFQWF2+NgCHShjkCb+IFBLq9buZwE1xckQU4peSuQ==", + "dev": true, + "requires": { + "ansi-styles": "^3.2.1", + "escape-string-regexp": "^1.0.5", + "supports-color": "^5.3.0" + } + }, + "color-convert": { + "version": "1.9.3", + "resolved": "https://registry.npmjs.org/color-convert/-/color-convert-1.9.3.tgz", + "integrity": "sha512-QfAUtd+vFdAtFQcC8CCyYt1fYWxSqAiK2cSD6zDB8N3cpsEBAvRxp9zOGg6G/SHHJYAT88/az/IuDGALsNVbGg==", + "dev": true, + "requires": { + "color-name": "1.1.3" + } + }, + "color-name": { + "version": "1.1.3", + "resolved": "https://registry.npmjs.org/color-name/-/color-name-1.1.3.tgz", + "integrity": "sha512-72fSenhMw2HZMTVHeCA9KCmpEIbzWiQsjN+BHcBbS9vr1mtt+vJjPdksIBNUmKAW8TFUDPJK5SUU3QhE9NEXDw==", + "dev": true + }, + "has-flag": { + "version": "3.0.0", + "resolved": "https://registry.npmjs.org/has-flag/-/has-flag-3.0.0.tgz", + "integrity": "sha512-sKJf1+ceQBr4SMkvQnBDNDtf4TXpVhVGateu0t918bl30FnbE2m4vNLX+VWe/dpjlb+HugGYzW7uQXH98HPEYw==", + "dev": true + }, + "semver": { + "version": "6.3.1", + "resolved": "https://registry.npmjs.org/semver/-/semver-6.3.1.tgz", + "integrity": "sha512-BR7VvDCVHO+q2xBEWskxS6DJE1qRnb7DxzUrogb71CWoSficBxYsiAGd+Kl0mmq/MprG9yArRkyrQxTO6XjMzA==", + "dev": true + }, + "supports-color": { + "version": "5.5.0", + "resolved": "https://registry.npmjs.org/supports-color/-/supports-color-5.5.0.tgz", + "integrity": "sha512-QjVjwdXIt408MIiAqCX4oUKsgU2EqAGzs2Ppkm4aQYbjm+ZEWEcW4SfFNTr4uMNZma0ey4f5lgLrkB0aX0QMow==", + "dev": true, + "requires": { + "has-flag": "^3.0.0" + } + } } }, "@babel/plugin-proposal-dynamic-import": { @@ -729,12 +1032,20 @@ } }, "@babel/plugin-syntax-decorators": { - "version": "7.17.12", - "resolved": "https://registry.npmjs.org/@babel/plugin-syntax-decorators/-/plugin-syntax-decorators-7.17.12.tgz", - "integrity": "sha512-D1Hz0qtGTza8K2xGyEdVNCYLdVHukAcbQr4K3/s6r/esadyEriZovpJimQOpu8ju4/jV8dW/1xdaE0UpDroidw==", + "version": "7.24.7", + "resolved": "https://registry.npmjs.org/@babel/plugin-syntax-decorators/-/plugin-syntax-decorators-7.24.7.tgz", + "integrity": "sha512-Ui4uLJJrRV1lb38zg1yYTmRKmiZLiftDEvZN2iq3kd9kUFU+PttmzTbAFC2ucRk/XJmtek6G23gPsuZbhrT8fQ==", "dev": true, "requires": { - "@babel/helper-plugin-utils": "^7.17.12" + "@babel/helper-plugin-utils": "^7.24.7" + }, + "dependencies": { + "@babel/helper-plugin-utils": { + "version": "7.24.7", + "resolved": "https://registry.npmjs.org/@babel/helper-plugin-utils/-/helper-plugin-utils-7.24.7.tgz", + "integrity": "sha512-Rq76wjt7yz9AAc1KnlRKNAi/dMSVWgDRx43FHoJEbcYU6xOWaE2dVPwcdTukJrjxS65GITyfbvEYHvkirZ6uEg==", + "dev": true + } } }, "@babel/plugin-syntax-dynamic-import": { @@ -773,6 +1084,23 @@ "@babel/helper-plugin-utils": "^7.8.0" } }, + "@babel/plugin-syntax-jsx": { + "version": "7.24.6", + "resolved": "https://registry.npmjs.org/@babel/plugin-syntax-jsx/-/plugin-syntax-jsx-7.24.6.tgz", + "integrity": "sha512-lWfvAIFNWMlCsU0DRUun2GpFwZdGTukLaHJqRh1JRb80NdAP5Sb1HDHB5X9P9OtgZHQl089UzQkpYlBq2VTPRw==", + "dev": true, + "requires": { + "@babel/helper-plugin-utils": "^7.24.6" + }, + "dependencies": { + "@babel/helper-plugin-utils": { + "version": "7.24.6", + "resolved": "https://registry.npmjs.org/@babel/helper-plugin-utils/-/helper-plugin-utils-7.24.6.tgz", + "integrity": "sha512-MZG/JcWfxybKwsA9N9PmtF2lOSFSEMVCpIRrbxccZFLJPrJciJdG/UhSh5W96GEteJI2ARqm5UAHxISwRDLSNg==", + "dev": true + } + } + }, "@babel/plugin-syntax-logical-assignment-operators": { "version": "7.10.4", "resolved": "https://registry.npmjs.org/@babel/plugin-syntax-logical-assignment-operators/-/plugin-syntax-logical-assignment-operators-7.10.4.tgz", @@ -845,6 +1173,23 @@ "@babel/helper-plugin-utils": "^7.14.5" } }, + "@babel/plugin-syntax-typescript": { + "version": "7.24.6", + "resolved": "https://registry.npmjs.org/@babel/plugin-syntax-typescript/-/plugin-syntax-typescript-7.24.6.tgz", + "integrity": "sha512-TzCtxGgVTEJWWwcYwQhCIQ6WaKlo80/B+Onsk4RRCcYqpYGFcG9etPW94VToGte5AAcxRrhjPUFvUS3Y2qKi4A==", + "dev": true, + "requires": { + "@babel/helper-plugin-utils": "^7.24.6" + }, + "dependencies": { + "@babel/helper-plugin-utils": { + "version": "7.24.6", + "resolved": "https://registry.npmjs.org/@babel/helper-plugin-utils/-/helper-plugin-utils-7.24.6.tgz", + "integrity": "sha512-MZG/JcWfxybKwsA9N9PmtF2lOSFSEMVCpIRrbxccZFLJPrJciJdG/UhSh5W96GEteJI2ARqm5UAHxISwRDLSNg==", + "dev": true + } + } + }, "@babel/plugin-transform-arrow-functions": { "version": "7.17.12", "resolved": "https://registry.npmjs.org/@babel/plugin-transform-arrow-functions/-/plugin-transform-arrow-functions-7.17.12.tgz", @@ -1164,6 +1509,227 @@ "@babel/helper-plugin-utils": "^7.17.12" } }, + "@babel/plugin-transform-typescript": { + "version": "7.24.6", + "resolved": "https://registry.npmjs.org/@babel/plugin-transform-typescript/-/plugin-transform-typescript-7.24.6.tgz", + "integrity": "sha512-H0i+hDLmaYYSt6KU9cZE0gb3Cbssa/oxWis7PX4ofQzbvsfix9Lbh8SRk7LCPDlLWJHUiFeHU0qRRpF/4Zv7mQ==", + "dev": true, + "requires": { + "@babel/helper-annotate-as-pure": "^7.24.6", + "@babel/helper-create-class-features-plugin": "^7.24.6", + "@babel/helper-plugin-utils": "^7.24.6", + "@babel/plugin-syntax-typescript": "^7.24.6" + }, + "dependencies": { + "@babel/code-frame": { + "version": "7.24.6", + "resolved": "https://registry.npmjs.org/@babel/code-frame/-/code-frame-7.24.6.tgz", + "integrity": "sha512-ZJhac6FkEd1yhG2AHOmfcXG4ceoLltoCVJjN5XsWN9BifBQr+cHJbWi0h68HZuSORq+3WtJ2z0hwF2NG1b5kcA==", + "dev": true, + "requires": { + "@babel/highlight": "^7.24.6", + "picocolors": "^1.0.0" + } + }, + "@babel/helper-annotate-as-pure": { + "version": "7.24.6", + "resolved": "https://registry.npmjs.org/@babel/helper-annotate-as-pure/-/helper-annotate-as-pure-7.24.6.tgz", + "integrity": "sha512-DitEzDfOMnd13kZnDqns1ccmftwJTS9DMkyn9pYTxulS7bZxUxpMly3Nf23QQ6NwA4UB8lAqjbqWtyvElEMAkg==", + "dev": true, + "requires": { + "@babel/types": "^7.24.6" + } + }, + "@babel/helper-create-class-features-plugin": { + "version": "7.24.6", + "resolved": "https://registry.npmjs.org/@babel/helper-create-class-features-plugin/-/helper-create-class-features-plugin-7.24.6.tgz", + "integrity": "sha512-djsosdPJVZE6Vsw3kk7IPRWethP94WHGOhQTc67SNXE0ZzMhHgALw8iGmYS0TD1bbMM0VDROy43od7/hN6WYcA==", + "dev": true, + "requires": { + "@babel/helper-annotate-as-pure": "^7.24.6", + "@babel/helper-environment-visitor": "^7.24.6", + "@babel/helper-function-name": "^7.24.6", + "@babel/helper-member-expression-to-functions": "^7.24.6", + "@babel/helper-optimise-call-expression": "^7.24.6", + "@babel/helper-replace-supers": "^7.24.6", + "@babel/helper-skip-transparent-expression-wrappers": "^7.24.6", + "@babel/helper-split-export-declaration": "^7.24.6", + "semver": "^6.3.1" + } + }, + "@babel/helper-environment-visitor": { + "version": "7.24.6", + "resolved": "https://registry.npmjs.org/@babel/helper-environment-visitor/-/helper-environment-visitor-7.24.6.tgz", + "integrity": "sha512-Y50Cg3k0LKLMjxdPjIl40SdJgMB85iXn27Vk/qbHZCFx/o5XO3PSnpi675h1KEmmDb6OFArfd5SCQEQ5Q4H88g==", + "dev": true + }, + "@babel/helper-function-name": { + "version": "7.24.6", + "resolved": "https://registry.npmjs.org/@babel/helper-function-name/-/helper-function-name-7.24.6.tgz", + "integrity": "sha512-xpeLqeeRkbxhnYimfr2PC+iA0Q7ljX/d1eZ9/inYbmfG2jpl8Lu3DyXvpOAnrS5kxkfOWJjioIMQsaMBXFI05w==", + "dev": true, + "requires": { + "@babel/template": "^7.24.6", + "@babel/types": "^7.24.6" + } + }, + "@babel/helper-member-expression-to-functions": { + "version": "7.24.6", + "resolved": "https://registry.npmjs.org/@babel/helper-member-expression-to-functions/-/helper-member-expression-to-functions-7.24.6.tgz", + "integrity": "sha512-OTsCufZTxDUsv2/eDXanw/mUZHWOxSbEmC3pP8cgjcy5rgeVPWWMStnv274DV60JtHxTk0adT0QrCzC4M9NWGg==", + "dev": true, + "requires": { + "@babel/types": "^7.24.6" + } + }, + "@babel/helper-optimise-call-expression": { + "version": "7.24.6", + "resolved": "https://registry.npmjs.org/@babel/helper-optimise-call-expression/-/helper-optimise-call-expression-7.24.6.tgz", + "integrity": "sha512-3SFDJRbx7KuPRl8XDUr8O7GAEB8iGyWPjLKJh/ywP/Iy9WOmEfMrsWbaZpvBu2HSYn4KQygIsz0O7m8y10ncMA==", + "dev": true, + "requires": { + "@babel/types": "^7.24.6" + } + }, + "@babel/helper-plugin-utils": { + "version": "7.24.6", + "resolved": "https://registry.npmjs.org/@babel/helper-plugin-utils/-/helper-plugin-utils-7.24.6.tgz", + "integrity": "sha512-MZG/JcWfxybKwsA9N9PmtF2lOSFSEMVCpIRrbxccZFLJPrJciJdG/UhSh5W96GEteJI2ARqm5UAHxISwRDLSNg==", + "dev": true + }, + "@babel/helper-replace-supers": { + "version": "7.24.6", + "resolved": "https://registry.npmjs.org/@babel/helper-replace-supers/-/helper-replace-supers-7.24.6.tgz", + "integrity": "sha512-mRhfPwDqDpba8o1F8ESxsEkJMQkUF8ZIWrAc0FtWhxnjfextxMWxr22RtFizxxSYLjVHDeMgVsRq8BBZR2ikJQ==", + "dev": true, + "requires": { + "@babel/helper-environment-visitor": "^7.24.6", + "@babel/helper-member-expression-to-functions": "^7.24.6", + "@babel/helper-optimise-call-expression": "^7.24.6" + } + }, + "@babel/helper-skip-transparent-expression-wrappers": { + "version": "7.24.6", + "resolved": "https://registry.npmjs.org/@babel/helper-skip-transparent-expression-wrappers/-/helper-skip-transparent-expression-wrappers-7.24.6.tgz", + "integrity": "sha512-jhbbkK3IUKc4T43WadP96a27oYti9gEf1LdyGSP2rHGH77kwLwfhO7TgwnWvxxQVmke0ImmCSS47vcuxEMGD3Q==", + "dev": true, + "requires": { + "@babel/types": "^7.24.6" + } + }, + "@babel/helper-split-export-declaration": { + "version": "7.24.6", + "resolved": "https://registry.npmjs.org/@babel/helper-split-export-declaration/-/helper-split-export-declaration-7.24.6.tgz", + "integrity": "sha512-CvLSkwXGWnYlF9+J3iZUvwgAxKiYzK3BWuo+mLzD/MDGOZDj7Gq8+hqaOkMxmJwmlv0iu86uH5fdADd9Hxkymw==", + "dev": true, + "requires": { + "@babel/types": "^7.24.6" + } + }, + "@babel/helper-validator-identifier": { + "version": "7.24.6", + "resolved": "https://registry.npmjs.org/@babel/helper-validator-identifier/-/helper-validator-identifier-7.24.6.tgz", + "integrity": "sha512-4yA7s865JHaqUdRbnaxarZREuPTHrjpDT+pXoAZ1yhyo6uFnIEpS8VMu16siFOHDpZNKYv5BObhsB//ycbICyw==", + "dev": true + }, + "@babel/highlight": { + "version": "7.24.6", + "resolved": "https://registry.npmjs.org/@babel/highlight/-/highlight-7.24.6.tgz", + "integrity": "sha512-2YnuOp4HAk2BsBrJJvYCbItHx0zWscI1C3zgWkz+wDyD9I7GIVrfnLyrR4Y1VR+7p+chAEcrgRQYZAGIKMV7vQ==", + "dev": true, + "requires": { + "@babel/helper-validator-identifier": "^7.24.6", + "chalk": "^2.4.2", + "js-tokens": "^4.0.0", + "picocolors": "^1.0.0" + } + }, + "@babel/parser": { + "version": "7.24.6", + "resolved": "https://registry.npmjs.org/@babel/parser/-/parser-7.24.6.tgz", + "integrity": "sha512-eNZXdfU35nJC2h24RznROuOpO94h6x8sg9ju0tT9biNtLZ2vuP8SduLqqV+/8+cebSLV9SJEAN5Z3zQbJG/M+Q==", + "dev": true + }, + "@babel/template": { + "version": "7.24.6", + "resolved": "https://registry.npmjs.org/@babel/template/-/template-7.24.6.tgz", + "integrity": "sha512-3vgazJlLwNXi9jhrR1ef8qiB65L1RK90+lEQwv4OxveHnqC3BfmnHdgySwRLzf6akhlOYenT+b7AfWq+a//AHw==", + "dev": true, + "requires": { + "@babel/code-frame": "^7.24.6", + "@babel/parser": "^7.24.6", + "@babel/types": "^7.24.6" + } + }, + "@babel/types": { + "version": "7.24.6", + "resolved": "https://registry.npmjs.org/@babel/types/-/types-7.24.6.tgz", + "integrity": "sha512-WaMsgi6Q8zMgMth93GvWPXkhAIEobfsIkLTacoVZoK1J0CevIPGYY2Vo5YvJGqyHqXM6P4ppOYGsIRU8MM9pFQ==", + "dev": true, + "requires": { + "@babel/helper-string-parser": "^7.24.6", + "@babel/helper-validator-identifier": "^7.24.6", + "to-fast-properties": "^2.0.0" + } + }, + "ansi-styles": { + "version": "3.2.1", + "resolved": "https://registry.npmjs.org/ansi-styles/-/ansi-styles-3.2.1.tgz", + "integrity": "sha512-VT0ZI6kZRdTh8YyJw3SMbYm/u+NqfsAxEpWO0Pf9sq8/e94WxxOpPKx9FR1FlyCtOVDNOQ+8ntlqFxiRc+r5qA==", + "dev": true, + "requires": { + "color-convert": "^1.9.0" + } + }, + "chalk": { + "version": "2.4.2", + "resolved": "https://registry.npmjs.org/chalk/-/chalk-2.4.2.tgz", + "integrity": "sha512-Mti+f9lpJNcwF4tWV8/OrTTtF1gZi+f8FqlyAdouralcFWFQWF2+NgCHShjkCb+IFBLq9buZwE1xckQU4peSuQ==", + "dev": true, + "requires": { + "ansi-styles": "^3.2.1", + "escape-string-regexp": "^1.0.5", + "supports-color": "^5.3.0" + } + }, + "color-convert": { + "version": "1.9.3", + "resolved": "https://registry.npmjs.org/color-convert/-/color-convert-1.9.3.tgz", + "integrity": "sha512-QfAUtd+vFdAtFQcC8CCyYt1fYWxSqAiK2cSD6zDB8N3cpsEBAvRxp9zOGg6G/SHHJYAT88/az/IuDGALsNVbGg==", + "dev": true, + "requires": { + "color-name": "1.1.3" + } + }, + "color-name": { + "version": "1.1.3", + "resolved": "https://registry.npmjs.org/color-name/-/color-name-1.1.3.tgz", + "integrity": "sha512-72fSenhMw2HZMTVHeCA9KCmpEIbzWiQsjN+BHcBbS9vr1mtt+vJjPdksIBNUmKAW8TFUDPJK5SUU3QhE9NEXDw==", + "dev": true + }, + "has-flag": { + "version": "3.0.0", + "resolved": "https://registry.npmjs.org/has-flag/-/has-flag-3.0.0.tgz", + "integrity": "sha512-sKJf1+ceQBr4SMkvQnBDNDtf4TXpVhVGateu0t918bl30FnbE2m4vNLX+VWe/dpjlb+HugGYzW7uQXH98HPEYw==", + "dev": true + }, + "semver": { + "version": "6.3.1", + "resolved": "https://registry.npmjs.org/semver/-/semver-6.3.1.tgz", + "integrity": "sha512-BR7VvDCVHO+q2xBEWskxS6DJE1qRnb7DxzUrogb71CWoSficBxYsiAGd+Kl0mmq/MprG9yArRkyrQxTO6XjMzA==", + "dev": true + }, + "supports-color": { + "version": "5.5.0", + "resolved": "https://registry.npmjs.org/supports-color/-/supports-color-5.5.0.tgz", + "integrity": "sha512-QjVjwdXIt408MIiAqCX4oUKsgU2EqAGzs2Ppkm4aQYbjm+ZEWEcW4SfFNTr4uMNZma0ey4f5lgLrkB0aX0QMow==", + "dev": true, + "requires": { + "has-flag": "^3.0.0" + } + } + } + }, "@babel/plugin-transform-unicode-escapes": { "version": "7.16.7", "resolved": "https://registry.npmjs.org/@babel/plugin-transform-unicode-escapes/-/plugin-transform-unicode-escapes-7.16.7.tgz", @@ -1287,6 +1853,107 @@ "esutils": "^2.0.2" } }, + "@babel/preset-typescript": { + "version": "7.24.6", + "resolved": "https://registry.npmjs.org/@babel/preset-typescript/-/preset-typescript-7.24.6.tgz", + "integrity": "sha512-U10aHPDnokCFRXgyT/MaIRTivUu2K/mu0vJlwRS9LxJmJet+PFQNKpggPyFCUtC6zWSBPjvxjnpNkAn3Uw2m5w==", + "dev": true, + "requires": { + "@babel/helper-plugin-utils": "^7.24.6", + "@babel/helper-validator-option": "^7.24.6", + "@babel/plugin-syntax-jsx": "^7.24.6", + "@babel/plugin-transform-modules-commonjs": "^7.24.6", + "@babel/plugin-transform-typescript": "^7.24.6" + }, + "dependencies": { + "@babel/helper-environment-visitor": { + "version": "7.24.6", + "resolved": "https://registry.npmjs.org/@babel/helper-environment-visitor/-/helper-environment-visitor-7.24.6.tgz", + "integrity": "sha512-Y50Cg3k0LKLMjxdPjIl40SdJgMB85iXn27Vk/qbHZCFx/o5XO3PSnpi675h1KEmmDb6OFArfd5SCQEQ5Q4H88g==", + "dev": true + }, + "@babel/helper-module-imports": { + "version": "7.24.6", + "resolved": "https://registry.npmjs.org/@babel/helper-module-imports/-/helper-module-imports-7.24.6.tgz", + "integrity": "sha512-a26dmxFJBF62rRO9mmpgrfTLsAuyHk4e1hKTUkD/fcMfynt8gvEKwQPQDVxWhca8dHoDck+55DFt42zV0QMw5g==", + "dev": true, + "requires": { + "@babel/types": "^7.24.6" + } + }, + "@babel/helper-module-transforms": { + "version": "7.24.6", + "resolved": "https://registry.npmjs.org/@babel/helper-module-transforms/-/helper-module-transforms-7.24.6.tgz", + "integrity": "sha512-Y/YMPm83mV2HJTbX1Qh2sjgjqcacvOlhbzdCCsSlblOKjSYmQqEbO6rUniWQyRo9ncyfjT8hnUjlG06RXDEmcA==", + "dev": true, + "requires": { + "@babel/helper-environment-visitor": "^7.24.6", + "@babel/helper-module-imports": "^7.24.6", + "@babel/helper-simple-access": "^7.24.6", + "@babel/helper-split-export-declaration": "^7.24.6", + "@babel/helper-validator-identifier": "^7.24.6" + } + }, + "@babel/helper-plugin-utils": { + "version": "7.24.6", + "resolved": "https://registry.npmjs.org/@babel/helper-plugin-utils/-/helper-plugin-utils-7.24.6.tgz", + "integrity": "sha512-MZG/JcWfxybKwsA9N9PmtF2lOSFSEMVCpIRrbxccZFLJPrJciJdG/UhSh5W96GEteJI2ARqm5UAHxISwRDLSNg==", + "dev": true + }, + "@babel/helper-simple-access": { + "version": "7.24.6", + "resolved": "https://registry.npmjs.org/@babel/helper-simple-access/-/helper-simple-access-7.24.6.tgz", + "integrity": "sha512-nZzcMMD4ZhmB35MOOzQuiGO5RzL6tJbsT37Zx8M5L/i9KSrukGXWTjLe1knIbb/RmxoJE9GON9soq0c0VEMM5g==", + "dev": true, + "requires": { + "@babel/types": "^7.24.6" + } + }, + "@babel/helper-split-export-declaration": { + "version": "7.24.6", + "resolved": "https://registry.npmjs.org/@babel/helper-split-export-declaration/-/helper-split-export-declaration-7.24.6.tgz", + "integrity": "sha512-CvLSkwXGWnYlF9+J3iZUvwgAxKiYzK3BWuo+mLzD/MDGOZDj7Gq8+hqaOkMxmJwmlv0iu86uH5fdADd9Hxkymw==", + "dev": true, + "requires": { + "@babel/types": "^7.24.6" + } + }, + "@babel/helper-validator-identifier": { + "version": "7.24.6", + "resolved": "https://registry.npmjs.org/@babel/helper-validator-identifier/-/helper-validator-identifier-7.24.6.tgz", + "integrity": "sha512-4yA7s865JHaqUdRbnaxarZREuPTHrjpDT+pXoAZ1yhyo6uFnIEpS8VMu16siFOHDpZNKYv5BObhsB//ycbICyw==", + "dev": true + }, + "@babel/helper-validator-option": { + "version": "7.24.6", + "resolved": "https://registry.npmjs.org/@babel/helper-validator-option/-/helper-validator-option-7.24.6.tgz", + "integrity": "sha512-Jktc8KkF3zIkePb48QO+IapbXlSapOW9S+ogZZkcO6bABgYAxtZcjZ/O005111YLf+j4M84uEgwYoidDkXbCkQ==", + "dev": true + }, + "@babel/plugin-transform-modules-commonjs": { + "version": "7.24.6", + "resolved": "https://registry.npmjs.org/@babel/plugin-transform-modules-commonjs/-/plugin-transform-modules-commonjs-7.24.6.tgz", + "integrity": "sha512-JEV8l3MHdmmdb7S7Cmx6rbNEjRCgTQMZxllveHO0mx6uiclB0NflCawlQQ6+o5ZrwjUBYPzHm2XoK4wqGVUFuw==", + "dev": true, + "requires": { + "@babel/helper-module-transforms": "^7.24.6", + "@babel/helper-plugin-utils": "^7.24.6", + "@babel/helper-simple-access": "^7.24.6" + } + }, + "@babel/types": { + "version": "7.24.6", + "resolved": "https://registry.npmjs.org/@babel/types/-/types-7.24.6.tgz", + "integrity": "sha512-WaMsgi6Q8zMgMth93GvWPXkhAIEobfsIkLTacoVZoK1J0CevIPGYY2Vo5YvJGqyHqXM6P4ppOYGsIRU8MM9pFQ==", + "dev": true, + "requires": { + "@babel/helper-string-parser": "^7.24.6", + "@babel/helper-validator-identifier": "^7.24.6", + "to-fast-properties": "^2.0.0" + } + } + } + }, "@babel/runtime": { "version": "7.18.3", "resolved": "https://registry.npmjs.org/@babel/runtime/-/runtime-7.18.3.tgz", @@ -1455,6 +2122,14 @@ "lodash": "^4.17.19", "resolve-from": "^5.0.0", "typescript": "^4.6.4" + }, + "dependencies": { + "typescript": { + "version": "4.9.5", + "resolved": "https://registry.npmjs.org/typescript/-/typescript-4.9.5.tgz", + "integrity": "sha512-1FXk9E2Hm+QzZQ7z+McJiHL4NW1F2EzMu9Nq9i3zAaGqibafqYwCVU6WyWAuyQRRzOlxou8xZSyXLEN8oKj24g==", + "dev": true + } } }, "@commitlint/message": { @@ -1805,6 +2480,59 @@ "integrity": "sha512-Ct5MqZkLGEXTVmQYbGtx9SVqD2fqwvdubdps5D3djjAkgkKwT918VNOz65pEHFaYTeWcukmJmH5SwsA9Tn2ObQ==", "dev": true }, + "@jridgewell/source-map": { + "version": "0.3.6", + "resolved": "https://registry.npmjs.org/@jridgewell/source-map/-/source-map-0.3.6.tgz", + "integrity": "sha512-1ZJTZebgqllO79ue2bm3rIGud/bOe0pP5BjSRCRxxYkEZS8STV7zN84UBbiYu7jy+eCKSnVIUgoWWE/tt+shMQ==", + "dev": true, + "requires": { + "@jridgewell/gen-mapping": "^0.3.5", + "@jridgewell/trace-mapping": "^0.3.25" + }, + "dependencies": { + "@jridgewell/gen-mapping": { + "version": "0.3.5", + "resolved": "https://registry.npmjs.org/@jridgewell/gen-mapping/-/gen-mapping-0.3.5.tgz", + "integrity": "sha512-IzL8ZoEDIBRWEzlCcRhOaCupYyN5gdIK+Q6fbFdPDg6HqX6jpkItn7DFIpW9LQzXG6Df9sA7+OKnq0qlz/GaQg==", + "dev": true, + "requires": { + "@jridgewell/set-array": "^1.2.1", + "@jridgewell/sourcemap-codec": "^1.4.10", + "@jridgewell/trace-mapping": "^0.3.24" + } + }, + "@jridgewell/resolve-uri": { + "version": "3.1.2", + "resolved": "https://registry.npmjs.org/@jridgewell/resolve-uri/-/resolve-uri-3.1.2.tgz", + "integrity": "sha512-bRISgCIjP20/tbWSPWMEi54QVPRZExkuD9lJL+UIxUKtwVJA8wW1Trb1jMs1RFXo1CBTNZ/5hpC9QvmKWdopKw==", + "dev": true + }, + "@jridgewell/set-array": { + "version": "1.2.1", + "resolved": "https://registry.npmjs.org/@jridgewell/set-array/-/set-array-1.2.1.tgz", + "integrity": "sha512-R8gLRTZeyp03ymzP/6Lil/28tGeGEzhx1q2k703KGWRAI1VdvPIXdG70VJc2pAMw3NA6JKL5hhFu1sJX0Mnn/A==", + "dev": true + }, + "@jridgewell/trace-mapping": { + "version": "0.3.25", + "resolved": "https://registry.npmjs.org/@jridgewell/trace-mapping/-/trace-mapping-0.3.25.tgz", + "integrity": "sha512-vNk6aEwybGtawWmy/PzwnGDOjCkLWSD2wqvjGGAgOAwCGWySYXfYoxt00IJkTF+8Lb57DwOb3Aa0o9CApepiYQ==", + "dev": true, + "requires": { + "@jridgewell/resolve-uri": "^3.1.0", + "@jridgewell/sourcemap-codec": "^1.4.14" + }, + "dependencies": { + "@jridgewell/sourcemap-codec": { + "version": "1.4.15", + "resolved": "https://registry.npmjs.org/@jridgewell/sourcemap-codec/-/sourcemap-codec-1.4.15.tgz", + "integrity": "sha512-eF2rxCRulEKXHTRiDrDy6erMYWqNw4LPdQ8UQA4huuxaQsVeRPFl2oM8oDGxMFhJUWZf9McpLtJasDDZb/Bpeg==", + "dev": true + } + } + } + } + }, "@jridgewell/sourcemap-codec": { "version": "1.4.13", "resolved": "https://registry.npmjs.org/@jridgewell/sourcemap-codec/-/sourcemap-codec-1.4.13.tgz", @@ -3786,12 +4514,6 @@ "remove-markdown": "^0.2.2" } }, - "charcodes": { - "version": "0.2.0", - "resolved": "https://registry.npmjs.org/charcodes/-/charcodes-0.2.0.tgz", - "integrity": "sha512-Y4kiDb+AM4Ecy58YkuZrrSRJBDQdQ2L+NyS1vHHFtNtUjgutcZfx3yp1dAONI/oPaPmyGfCLx5CxL+zauIMyKQ==", - "dev": true - }, "cheerio": { "version": "0.22.0", "resolved": "https://registry.npmjs.org/cheerio/-/cheerio-0.22.0.tgz", @@ -12181,28 +12903,83 @@ } }, "terser-webpack-plugin": { - "version": "5.3.3", - "resolved": "https://registry.npmjs.org/terser-webpack-plugin/-/terser-webpack-plugin-5.3.3.tgz", - "integrity": "sha512-Fx60G5HNYknNTNQnzQ1VePRuu89ZVYWfjRAeT5rITuCY/1b08s49e5kSQwHDirKZWuoKOBRFS98EUUoZ9kLEwQ==", + "version": "5.3.10", + "resolved": "https://registry.npmjs.org/terser-webpack-plugin/-/terser-webpack-plugin-5.3.10.tgz", + "integrity": "sha512-BKFPWlPDndPs+NGGCr1U59t0XScL5317Y0UReNrHaw9/FwhPENlq6bfgs+4yPfyP51vqC1bQ4rp1EfXW5ZSH9w==", "dev": true, "requires": { - "@jridgewell/trace-mapping": "^0.3.7", + "@jridgewell/trace-mapping": "^0.3.20", "jest-worker": "^27.4.5", "schema-utils": "^3.1.1", - "serialize-javascript": "^6.0.0", - "terser": "^5.7.2" + "serialize-javascript": "^6.0.1", + "terser": "^5.26.0" }, "dependencies": { + "@jridgewell/resolve-uri": { + "version": "3.1.2", + "resolved": "https://registry.npmjs.org/@jridgewell/resolve-uri/-/resolve-uri-3.1.2.tgz", + "integrity": "sha512-bRISgCIjP20/tbWSPWMEi54QVPRZExkuD9lJL+UIxUKtwVJA8wW1Trb1jMs1RFXo1CBTNZ/5hpC9QvmKWdopKw==", + "dev": true + }, + "@jridgewell/sourcemap-codec": { + "version": "1.4.15", + "resolved": "https://registry.npmjs.org/@jridgewell/sourcemap-codec/-/sourcemap-codec-1.4.15.tgz", + "integrity": "sha512-eF2rxCRulEKXHTRiDrDy6erMYWqNw4LPdQ8UQA4huuxaQsVeRPFl2oM8oDGxMFhJUWZf9McpLtJasDDZb/Bpeg==", + "dev": true + }, + "@jridgewell/trace-mapping": { + "version": "0.3.25", + "resolved": "https://registry.npmjs.org/@jridgewell/trace-mapping/-/trace-mapping-0.3.25.tgz", + "integrity": "sha512-vNk6aEwybGtawWmy/PzwnGDOjCkLWSD2wqvjGGAgOAwCGWySYXfYoxt00IJkTF+8Lb57DwOb3Aa0o9CApepiYQ==", + "dev": true, + "requires": { + "@jridgewell/resolve-uri": "^3.1.0", + "@jridgewell/sourcemap-codec": "^1.4.14" + } + }, + "acorn": { + "version": "8.12.0", + "resolved": "https://registry.npmjs.org/acorn/-/acorn-8.12.0.tgz", + "integrity": "sha512-RTvkC4w+KNXrM39/lWCUaG0IbRkWdCv7W/IOW9oU6SawyxulvkQy5HQPVTKxEjczcUvapcrw3cFx/60VN/NRNw==", + "dev": true + }, + "commander": { + "version": "2.20.3", + "resolved": "https://registry.npmjs.org/commander/-/commander-2.20.3.tgz", + "integrity": "sha512-GpVkmM8vF2vQUkj2LvZmD35JxeJOLCwJ9cUkugyk2nuhbv3+mJvpLYYt+0+USMxE+oj+ey/lJEnhZw75x/OMcQ==", + "dev": true + }, "schema-utils": { - "version": "3.1.1", - "resolved": "https://registry.npmjs.org/schema-utils/-/schema-utils-3.1.1.tgz", - "integrity": "sha512-Y5PQxS4ITlC+EahLuXaY86TXfR7Dc5lw294alXOq86JAHCihAIZfqv8nNCWvaEJvaC51uN9hbLGeV0cFBdH+Fw==", + "version": "3.3.0", + "resolved": "https://registry.npmjs.org/schema-utils/-/schema-utils-3.3.0.tgz", + "integrity": "sha512-pN/yOAvcC+5rQ5nERGuwrjLlYvLTbCibnZ1I7B1LaiAz9BRBlE9GMgE/eqV30P7aJQUf7Ddimy/RsbYO/GrVGg==", "dev": true, "requires": { "@types/json-schema": "^7.0.8", "ajv": "^6.12.5", "ajv-keywords": "^3.5.2" } + }, + "serialize-javascript": { + "version": "6.0.2", + "resolved": "https://registry.npmjs.org/serialize-javascript/-/serialize-javascript-6.0.2.tgz", + "integrity": "sha512-Saa1xPByTTq2gdeFZYLLo+RFE35NHZkAbqZeWNd3BpzppeVisAqpDjcp8dyf6uIvEqJRd46jemmyA4iFIeVk8g==", + "dev": true, + "requires": { + "randombytes": "^2.1.0" + } + }, + "terser": { + "version": "5.31.1", + "resolved": "https://registry.npmjs.org/terser/-/terser-5.31.1.tgz", + "integrity": "sha512-37upzU1+viGvuFtBo9NPufCb9dwM0+l9hMxYyWfBA+fbwrPqNJAhbZ6W47bBFnZHKHTUBnMvi87434qq+qnxOg==", + "dev": true, + "requires": { + "@jridgewell/source-map": "^0.3.3", + "acorn": "^8.8.2", + "commander": "^2.20.0", + "source-map-support": "~0.5.20" + } } } }, @@ -12419,6 +13196,27 @@ "integrity": "sha1-yy4SAwZ+DI3h9hQJS5/kVwTqYAM=", "dev": true }, + "ts-loader": { + "version": "9.5.1", + "resolved": "https://registry.npmjs.org/ts-loader/-/ts-loader-9.5.1.tgz", + "integrity": "sha512-rNH3sK9kGZcH9dYzC7CewQm4NtxJTjSEVRJ2DyBZR7f8/wcta+iV44UPCXc5+nzDzivKtlzV6c9P4e+oFhDLYg==", + "dev": true, + "requires": { + "chalk": "^4.1.0", + "enhanced-resolve": "^5.0.0", + "micromatch": "^4.0.0", + "semver": "^7.3.4", + "source-map": "^0.7.4" + }, + "dependencies": { + "source-map": { + "version": "0.7.4", + "resolved": "https://registry.npmjs.org/source-map/-/source-map-0.7.4.tgz", + "integrity": "sha512-l3BikUxvPOcn5E74dZiq5BGsTb5yEwhaTSzccU6t4sDOH8NWJCstKO5QT2CvtFoK6F0saL7p9xHAqHOlCPJygA==", + "dev": true + } + } + }, "ts-node": { "version": "10.8.1", "resolved": "https://registry.npmjs.org/ts-node/-/ts-node-10.8.1.tgz", @@ -12511,9 +13309,9 @@ "dev": true }, "typescript": { - "version": "4.7.3", - "resolved": "https://registry.npmjs.org/typescript/-/typescript-4.7.3.tgz", - "integrity": "sha512-WOkT3XYvrpXx4vMMqlD+8R8R37fZkjyLGlxavMc4iB8lrl8L0DeTcHbYgw/v0N/z9wAFsgBhcsF0ruoySS22mA==", + "version": "5.4.5", + "resolved": "https://registry.npmjs.org/typescript/-/typescript-5.4.5.tgz", + "integrity": "sha512-vcI4UpRgg81oIRUFwR0WSIHKt11nJ7SAVlYNIu+QpqeyXP+gpQJy/Z4+F0aGxSE4MqwjyXvW/TzgkLAx2AGHwQ==", "dev": true }, "ua-parser-js": { diff --git a/package.json b/package.json index 8c360c1e7..81e10012e 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.59", + "version": "27.4.64", "description": "", "keywords": [], "author": "", @@ -48,11 +48,12 @@ "@babel/core": "^7.18.2", "@babel/eslint-parser": "^7.18.2", "@babel/plugin-proposal-class-properties": "^7.17.12", - "@babel/plugin-proposal-decorators": "^7.18.2", + "@babel/plugin-proposal-decorators": "^7.24.7", "@babel/plugin-proposal-private-property-in-object": "^7.17.12", "@babel/plugin-transform-modules-commonjs": "^7.18.2", "@babel/plugin-transform-runtime": "^7.18.2", "@babel/preset-env": "^7.18.2", + "@babel/preset-typescript": "^7.24.6", "@commitlint/cli": "^17.0.2", "@commitlint/config-conventional": "^17.0.2", "@fortawesome/fontawesome-pro": "^6.1.1", @@ -100,11 +101,13 @@ "standard-version": "^9.5.0", "standard-version-updater-yaml": "^1.0.3", "style-loader": "^3.3.1", - "terser-webpack-plugin": "^5.3.3", + "terser-webpack-plugin": "^5.3.10", "tmp": "^0.2.1", + "ts-loader": "^9.5.1", "typeface-roboto": "1.1.13", "typeface-source-code-pro": "^1.1.13", "typeface-source-sans-pro": "1.1.13", + "typescript": "^5.4.5", "webpack": "^5.73.0", "webpack-cli": "^4.9.2", "webpack-manifest-plugin": "^5.0.0" diff --git a/package.yaml b/package.yaml index 2c242b3b3..415e0e8e9 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 27.4.59 +version: 27.4.64 dependencies: - base - yesod diff --git a/routes b/routes index 34ad73505..0585153a1 100644 --- a/routes +++ b/routes @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Wolfgang Witt +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Wolfgang Witt ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -68,9 +68,9 @@ /admin/crontab AdminCrontabR GET /admin/crontab/jobs AdminJobsR GET POST /admin/avs AdminAvsR GET POST -/admin/avs/#CryptoUUIDUser AdminAvsUserR GET +/admin/avs/#CryptoUUIDUser AdminAvsUserR GET POST /admin/ldap AdminLdapR GET POST -/admin/problems AdminProblemsR GET +/admin/problems AdminProblemsR GET POST /admin/problems/no-contact ProblemUnreachableR GET /admin/problems/no-avs-id ProblemWithoutAvsId GET /admin/problems/r-without-f ProblemFbutNoR GET diff --git a/shell.nix b/shell.nix index 42c65ae1f..fada1fae8 100644 --- a/shell.nix +++ b/shell.nix @@ -279,13 +279,14 @@ in pkgs.mkShell { # busybox # for print services, but interferes with build commands in develop-shell htop pdftk # pdftk just for testing pdf-passwords + roboto roboto-mono # texlive.combined.scheme-full # works # texlive.combined.scheme-medium # texlive.combined.scheme-small (texlive.combine { inherit (texlive) scheme-basic babel-german babel-english booktabs textpos - enumitem eurosym koma-script parskip xcolor dejavu + enumitem eurosym koma-script parskip xcolor roboto xkeyval luatexbase lualatex-math unicode-math selnolig # required for LuaTeX ; }) diff --git a/src/Application.hs b/src/Application.hs index 4b60ecb39..e7dc88b68 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -124,7 +124,7 @@ import Handler.Utils.Memcached (manageMemcachedLocalInvalidations) import qualified System.Clock as Clock -import Utils.Avs +import Utils.Avs (mkAvsQuery) -- Import all relevant handler modules here. -- (HPack takes care to add new modules to our cabal file nowadays.) @@ -746,8 +746,8 @@ shutdownApp app = do -- | Run a handler handler, handler' :: Handler a -> IO a -handler h = runResourceT $ getAppDevSettings >>= makeFoundation >>= liftIO . flip unsafeHandler h -handler' h = runResourceT $ getAppSettings >>= makeFoundation >>= liftIO . flip unsafeHandler h +handler h = runResourceT $ getAppDevSettings >>= makeFoundation >>= liftIO . flip unsafeHandler h +handler' h = runResourceT $ getAppSettings >>= makeFoundation >>= liftIO . flip unsafeHandler h -- | Run DB queries db, db' :: DB a -> IO a diff --git a/src/Audit.hs b/src/Audit.hs index 40c4a4206..06c5ca3d6 100644 --- a/src/Audit.hs +++ b/src/Audit.hs @@ -9,6 +9,7 @@ module Audit , AuditRemoteException(..) , getRemote , logInterface, logInterface' + , reportAdminProblem ) where @@ -152,7 +153,7 @@ logInterface' :: ( AuthId (HandlerSite m) ~ Key User -- ^ Log a transaction using information available from `HandlerT`, also calls `audit` logInterface' (Text.strip -> interfaceLogInterface) (Text.strip -> interfaceLogSubtype) interfaceLogWrite interfaceLogSuccess interfaceLogRows (Text.strip -> interfaceLogInfo) = do interfaceLogTime <- liftIO getCurrentTime - -- deleteBy $ UniqueInterfaceSubtypeWrite interfaceLogInterface interfaceLogSubtype interfaceLogWrite -- always replace: deleteBy & insert seems to be safest and fastest + -- deleteBy $ UniqueInterfaceSubtypeWrite interfaceLogInterface interfaceLogSubtype interfaceLogWrite -- deleteBy & insert would be justified here, leading to a new Row-ID, since the two rows are not truly connected. -- insert_ InterfaceLog{..} void $ upsertBy (UniqueInterfaceSubtypeWrite interfaceLogInterface interfaceLogSubtype interfaceLogWrite) ( InterfaceLog{..} ) @@ -169,3 +170,23 @@ logInterface' (Text.strip -> interfaceLogInterface) (Text.strip -> interfaceLogS , transactionInterfaceInfo = interfaceLogInfo , transactionInterfaceSuccess = Just interfaceLogSuccess } + +reportAdminProblem :: ( IsSqlBackend (YesodPersistBackend (HandlerSite m)) + , SqlBackendCanWrite (YesodPersistBackend (HandlerSite m)) + , MonadHandler m + -- , HasCallStack + ) + => AdminProblem -- ^ Problem to record + -> ReaderT (YesodPersistBackend (HandlerSite m)) m () +-- ^ Log a problem that needs interventions by admins +-- +-- - `problemLogTime` is now +-- - `problemSolver` is Nothing, we do not record the person who caused it +reportAdminProblem problem@(toJSON -> problemLogInfo) = do + problemLogTime <- liftIO getCurrentTime + let problemLogSolved = Nothing + problemLogSolver = Nothing + insert_ ProblemLog{..} + $logWarnS "Problem" $ Text.filter (/= '\n') $ tshow problem -- <> " - " <> pack (prettyCallStack callStack) + + diff --git a/src/Audit/Types.hs b/src/Audit/Types.hs index 976171ec4..e713b65e6 100644 --- a/src/Audit/Types.hs +++ b/src/Audit/Types.hs @@ -1,15 +1,18 @@ --- SPDX-FileCopyrightText: 2022-23 Gregor Kleen ,Sarah Vaupel ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Sarah Vaupel ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later module Audit.Types ( Transaction(..) + , AdminProblem(..) + , decodeAdminProblem ) where import ClassyPrelude.Yesod hiding (derivePersistFieldJSON) import Model.Types.TH.JSON import Model +import Data.Aeson import Data.Aeson.TH import Utils.PathPiece @@ -251,4 +254,52 @@ deriveJSON defaultOptions , sumEncoding = TaggedObject "transaction" "data" } ''Transaction -derivePersistFieldJSON ''Transaction \ No newline at end of file +derivePersistFieldJSON ''Transaction + + + +-- Datatype for raising admin awareness to certain problems +-- Database stores generic Value in table ProblemLog, such that changes do not disturb old entries +-- Note that there is no RenderMessage instance, instead see @Handler.Admin.adminProblemCell dealing with special cases instead +data AdminProblem + = AdminProblemNewCompany -- new company was noticed, presumably without supervisors + { adminProblemCompany :: CompanyId + } + | AdminProblemSupervisorNewCompany + { adminProblemUser :: UserId -- a default supervisor has changed company + , adminProblemCompany :: CompanyId -- old company where the user had default supervisor rights + , adminProblemCompanyNew :: CompanyId -- new company of the user + , adminProblemSupervisorReroute :: Bool -- reroute included? + } + | AdminProblemSupervisorLeftCompany + { adminProblemUser :: UserId -- user who had a supervisor but no longer has, due to supervisor change + , adminProblemCompany :: CompanyId -- old company + , adminProblemSupervisorReroute :: Bool -- reroute included? + } + | AdminProblemNewlyUnsupervised + { adminProblemUser :: UserId -- user who had a supervisor but no longer has, due to user company change + , adminProblemCompanyOld :: Maybe CompanyId -- old company + , adminProblemCompanyNew :: CompanyId -- new company of the user + } + | AdminProblemUnknown -- miscellanous problem, just displaying text + { adminProblemText :: Text + } + deriving (Eq, Ord, Read, Show, Generic) + +-- Columns shown in problem table: adminProblemCompany, adminProblemUser +-- For display: add clause to Handler.Admin.adminProblemCell + +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece' 2 + , fieldLabelModifier = camelToPathPiece' 2 + , tagSingleConstructors = True + , sumEncoding = TaggedObject "problem" "data" + , rejectUnknownFields = False + } ''AdminProblem + +derivePersistFieldJSON ''AdminProblem + +decodeAdminProblem :: Value -> AdminProblem +decodeAdminProblem v = case fromJSON v of + Error msg -> AdminProblemUnknown $ pack msg + Success p -> p diff --git a/src/Auth/Dummy.hs b/src/Auth/Dummy.hs index 06bf4985e..c7ae31e57 100644 --- a/src/Auth/Dummy.hs +++ b/src/Auth/Dummy.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Felix Hamann ,Gregor Kleen ,Sarah Vaupel +-- SPDX-FileCopyrightText: 2022-2024 Felix Hamann ,Gregor Kleen ,Sarah Vaupel ,David Mosbach -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -80,6 +80,7 @@ dummyLogin = AuthPlugin{..} , formEncoding = loginEnctype , formAttrs = [("uw-no-navigate-away-prompt","")] , formSubmit = FormSubmit + , formCustomBtn = Nothing :: Maybe ButtonSubmit , formAnchor = Just "login--dummy" :: Maybe Text } $(widgetFile "widgets/dummy-login-form/dummy-login-form") diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index 329bb0a29..026f5534f 100644 --- a/src/Auth/LDAP.hs +++ b/src/Auth/LDAP.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Felix Hamann ,Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-2024 Felix Hamann ,Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Steffen Jost ,David Mosbach -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -273,6 +273,7 @@ campusLogin pool mode = AuthPlugin{..} , formEncoding = loginEnctype , formAttrs = [("uw-no-navigate-away-prompt","")] , formSubmit = FormSubmit + , formCustomBtn = Nothing :: Maybe ButtonSubmit , formAnchor = Just "login--campus" :: Maybe Text } $(widgetFile "widgets/campus-login/campus-login-form") diff --git a/src/Auth/PWHash.hs b/src/Auth/PWHash.hs index e857d8dcc..84088168d 100644 --- a/src/Auth/PWHash.hs +++ b/src/Auth/PWHash.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Felix Hamann ,Gregor Kleen ,Sarah Vaupel +-- SPDX-FileCopyrightText: 2022-2024 Felix Hamann ,Gregor Kleen ,Sarah Vaupel ,David Mosbach -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -92,6 +92,7 @@ hashLogin pwHashAlgo = AuthPlugin{..} , formEncoding = loginEnctype , formAttrs = [("uw-no-navigate-away-prompt","")] , formSubmit = FormSubmit + , formCustomBtn = Nothing :: Maybe ButtonSubmit , formAnchor = Just "login--hash" :: Maybe Text } $(widgetFile "widgets/hash-login-form/hash-login-form") diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 127e0ed88..499cded08 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -32,6 +32,7 @@ module Database.Esqueleto.Utils , orderByOrd, orderByEnum , strip, lower, ciEq , selectExists, selectNotExists + , filterExists , SqlHashable , sha256 , isTrue, isFalse @@ -41,16 +42,17 @@ module Database.Esqueleto.Utils , greatest, least , abs , SqlProject(..) - , (->.), (->>.), (#>>.) + , (->.), (->>.), (->>>.), (#>>.) , fromSqlKey , unKey , subSelectCountDistinct , selectCountRows, selectCountDistinct , selectMaybe - , num2text + , num2text --, text2num , day, day', dayMaybe, interval, diffDays, diffTimes , exprLift , explicitUnsafeCoerceSqlExprValue + , truncateTable , module Database.Esqueleto.Utils.TH ) where @@ -67,6 +69,8 @@ import qualified Database.Esqueleto.PostgreSQL as E import qualified Database.Esqueleto.Internal.Internal as E import Database.Esqueleto.Utils.TH +import qualified Database.Persist.Postgresql as P + import qualified Data.Text as Text import qualified Data.Text.Lazy as Lazy (Text) import qualified Data.ByteString.Lazy as Lazy (ByteString) @@ -351,7 +355,7 @@ mkExactFilterMaybeLast' lensexists lenslike row criterias -- | generic filter creation for dbTable -- Given a lens-like function, make filter searching for needles in String-like elements -- (Keep Set here to ensure that there are no duplicates) -mkContainsFilter :: E.SqlString a +mkContainsFilter :: (E.SqlString a, Ord a) => (t -> E.SqlExpr (E.Value a)) -- ^ getter from query to searched element -> t -- ^ query row -> Set.Set a -- ^ needle collection @@ -359,7 +363,7 @@ mkContainsFilter :: E.SqlString a mkContainsFilter = mkContainsFilterWith id -- | like `mkContainsFilter` but allows for conversion; convenient in conjunction with `anyFilter` and `allFilter` -mkContainsFilterWith :: E.SqlString b +mkContainsFilterWith :: (E.SqlString b, Ord a) => (a -> b) -> (t -> E.SqlExpr (E.Value b)) -- ^ getter from query to searched element -> t -- ^ query row @@ -367,7 +371,7 @@ mkContainsFilterWith :: E.SqlString b -> E.SqlExpr (E.Value Bool) mkContainsFilterWith cast lenslike row criterias | Set.null criterias = true - | otherwise = any (hasInfix $ lenslike row) (E.val . cast <$> Set.toList criterias) + | otherwise = any (hasInfix (lenslike row) . E.val . cast) criterias -- | like `mkContainsFilterWith` but allows conversion to produce multiple needles mkContainsFilterWithSet :: (E.SqlString b, Ord b, Ord a) @@ -378,7 +382,7 @@ mkContainsFilterWithSet :: (E.SqlString b, Ord b, Ord a) -> E.SqlExpr (E.Value Bool) mkContainsFilterWithSet cast lenslike row criterias | Set.null criterias = true - | otherwise = any (hasInfix $ lenslike row) (E.val <$> Set.toList (foldMap cast criterias)) + | otherwise = any (hasInfix (lenslike row) . E.val) (foldMap cast criterias) -- | like `mkContainsFilterWithSet` but fixed to comma separated Texts mkContainsFilterWithComma :: (E.SqlString b, Ord b) @@ -389,7 +393,7 @@ mkContainsFilterWithComma :: (E.SqlString b, Ord b) -> E.SqlExpr (E.Value Bool) mkContainsFilterWithComma cast lenslike row (foldMap commaSeparatedText -> criterias) | Set.null criterias = true - | otherwise = any (hasInfix $ lenslike row) (E.val . cast <$> Set.toList criterias) + | otherwise = any (hasInfix (lenslike row) . E.val . cast) criterias -- | like `mkContainsFilterWithComma` but enforced the existence of all Texts prefixed with + mkContainsFilterWithCommaPlus :: (E.SqlString b, Ord b) @@ -405,8 +409,8 @@ mkContainsFilterWithCommaPlus cast lenslike row (foldMap commaSeparatedText -> c | otherwise = cond_compulsory E.&&. cond_optional where (Set.mapMonotonic (Text.stripStart . Text.drop 1) -> compulsories, alternatives) = Set.partition (Text.isPrefixOf "+") criterias - cond_compulsory = all (hasInfix $ lenslike row) (E.val . cast <$> Set.toList compulsories) - cond_optional = any (hasInfix $ lenslike row) (E.val . cast <$> Set.toList alternatives) + cond_compulsory = all (hasInfix (lenslike row) . E.val . cast) compulsories + cond_optional = any (hasInfix (lenslike row) . E.val . cast) alternatives mkDayFilter :: (t -> E.SqlExpr (E.Value UTCTime)) -- ^ getter from query to searched element -> t -- ^ query row @@ -451,7 +455,7 @@ mkExistsFilterWithComma :: PathPiece a -> E.SqlExpr (E.Value Bool) mkExistsFilterWithComma cast query row (foldMap commaSeparatedText -> criterias) | Set.null criterias = true - | otherwise = any (E.exists . query row) (cast <$> Set.toList criterias) + | otherwise = any (E.exists . query row . cast) criterias -- | Combine several filters, using logical or @@ -510,6 +514,13 @@ selectExists query = do _other -> error "SELECT EXISTS ... returned zero or more than one rows" selectNotExists = fmap not . selectExists +filterExists :: (MonadIO m, PersistEntity val, MonoFoldable mono, PersistField (Element mono)) + => EntityField val (Element mono) -> mono -> E.SqlReadT m [Element mono] +filterExists prj vs = fmap (fmap Ex.unValue) <$> Ex.select $ do + ent <- Ex.from Ex.table + Ex.where_ $ ent Ex.^. prj `Ex.in_` vals vs + return $ ent Ex.^. prj + class SqlHashable a instance SqlHashable Text @@ -603,7 +614,7 @@ max, min :: PersistField a max a b = bool a b $ b E.>. a min a b = bool a b $ b E.<. a --- these alternatives for max/min ought to be more efficient; note that NULL is avoided by PostgreSQL greatest/least +-- these alternatives for max/min ought to be more efficient; note that NULL is avoided by PostgreSQL greatest/least; for Bool: t > f greatest :: PersistField a => E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value a) greatest a b = E.unsafeSqlFunction "GREATEST" $ E.toArgList (a,b) @@ -642,9 +653,15 @@ infixl 8 ->. infixl 8 ->>. -(->>.) :: E.SqlExpr (E.Value a) -> Text -> E.SqlExpr (E.Value Text) +(->>.) :: E.SqlExpr (E.Value a) -> Text -> E.SqlExpr (E.Value Text) (->>.) expr t = E.unsafeSqlBinOp "->>" expr $ E.val t +infixl 8 ->>>. + +-- Unsafe variant to obtain a DB key from a JSON field. Use with caution! +(->>>.) :: (PersistField (Key entity)) => E.SqlExpr (E.Value a) -> Text -> E.SqlExpr (E.Value (Maybe (Key entity))) +(->>>.) expr t = E.unsafeSqlCastAs "int" $ E.unsafeSqlBinOp "->>" expr $ E.val t + infixl 8 #>>. (#>>.) :: E.SqlExpr (E.Value a) -> Text -> E.SqlExpr (E.Value (Maybe Text)) @@ -692,6 +709,10 @@ selectMaybe = fmap listToMaybe . E.select . (<* E.limit 1) num2text :: Num n => E.SqlExpr (E.Value n) -> E.SqlExpr (E.Value Text) num2text = E.unsafeSqlCastAs "text" +-- unsafe, use with care! +-- text2num :: E.SqlExpr (E.Value Text) -> E.SqlExpr (E.Value n) +-- text2num = E.unsafeSqlCastAs "int" + day :: E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value Day) day = E.unsafeSqlCastAs "date" @@ -750,3 +771,7 @@ instance (PersistField a1, PersistField a2, PersistField b, Finite a1, Finite a2 ] (E.else_ $ E.else_ $ E.veryUnsafeCoerceSqlExprValue (E.nothing :: E.SqlExpr (E.Value (Maybe ())))) + +truncateTable :: (MonadIO m, BackendCompatible SqlBackend backend, PersistEntity record) + => record -> ReaderT backend m () +truncateTable tbl = E.rawExecute ("TRUNCATE TABLE " <> P.tableName tbl <> " RESTART IDENTITY") [] \ No newline at end of file diff --git a/src/Foundation/I18n.hs b/src/Foundation/I18n.hs index fd2bb9479..dbfd87256 100644 --- a/src/Foundation/I18n.hs +++ b/src/Foundation/I18n.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-23 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Steffen Jost ,Winnie Ros +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Steffen Jost ,Winnie Ros ,David Mosbach -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -210,6 +210,9 @@ maybeBoolMessage Nothing n _ _ = n maybeBoolMessage (Just True) _ t _ = t maybeBoolMessage (Just False) _ _ f = f +-- | Convenience function avoiding type signatures +boolText :: Text -> Text -> Bool -> Text +boolText = bool newtype ShortTermIdentifier = ShortTermIdentifier TermIdentifier deriving stock (Eq, Ord, Read, Show) @@ -581,6 +584,7 @@ instance RenderMessage UniWorX ShortWeekDay where renderMessage _ ls (ShortWeekDay wDay) = pack . snd $ wDays (getTimeLocale' ls) !! (fromEnum wDay `mod` 7) embedRenderMessage ''UniWorX ''ButtonSubmit id +embedRenderMessage ''UniWorX ''ButtonApplyFilter id instance RenderMessage UniWorX VolatileClusterSettingsKey where renderMessage foundation ls = \case @@ -602,7 +606,7 @@ unRenderMessage = unRenderMessage' (==) unRenderMessageLenient :: forall a master. (Ord a, Finite a, RenderMessage master a) => master -> Text -> [a] unRenderMessageLenient = unRenderMessage' cmp - where cmp = (==) `on` mk . under packed (filter Char.isAlphaNum . concatMap unidecode) + where cmp = (==) `on` mk . under packed (concatMap $ filter Char.isAlphaNum . unidecode) instance Default DateTimeFormatter where diff --git a/src/Foundation/Instances/ButtonClass.hs b/src/Foundation/Instances/ButtonClass.hs index fd4ffb974..d64a58ee6 100644 --- a/src/Foundation/Instances/ButtonClass.hs +++ b/src/Foundation/Instances/ButtonClass.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Wolfgang Witt +-- SPDX-FileCopyrightText: 2022-2024 Wolfgang Witt ,David Mosbach -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -35,3 +35,6 @@ instance PathPiece (ButtonClass UniWorX) where instance Button UniWorX ButtonSubmit where btnClasses BtnSubmit = [BCIsButton, BCPrimary] + +instance Button UniWorX ButtonApplyFilter where + btnClasses BtnApplyFilter = [BCIsButton, BCPrimary] diff --git a/src/Foundation/Type.hs b/src/Foundation/Type.hs index 5c77e9863..162eb0887 100644 --- a/src/Foundation/Type.hs +++ b/src/Foundation/Type.hs @@ -43,7 +43,7 @@ import Data.Time.Clock.POSIX (POSIXTime) import GHC.Fingerprint (Fingerprint) import Handler.Sheet.PersonalisedFiles.Types (PersonalisedSheetFilesSeedKey) -import Utils.Avs (AvsQuery) +import Utils.Avs (AvsQuery()) type SMTPPool = Pool SMTPConnection diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs index efabadc80..9e9aa85c6 100644 --- a/src/Foundation/Yesod/Auth.hs +++ b/src/Foundation/Yesod/Auth.hs @@ -182,7 +182,7 @@ upsertCampusUser upsertMode ldapData = do userDefaultConf <- getsYesod $ view _appUserDefaults (newUser,userUpdate) <- decodeUser now userDefaultConf upsertMode ldapData - --TODO: newUser should be associated with a company and company supervisor through Handler.Utils.Company.upsertUserCompany, but this is called by upsertAvsUser already - conflict? + --TODO: newUser should be associated with a company and company supervisor through Handler.Utils.Company.oldUpsertUserCompany, but this is called by upsertAvsUser already - conflict? oldUsers <- for (userLdapPrimaryKey newUser) $ \pKey -> selectKeysList [ UserLdapPrimaryKey ==. Just pKey ] [] diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index fd001c768..53c5d6116 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -8,22 +8,25 @@ module Handler.Admin import Import -import Jobs -- import Data.Either import qualified Data.Set as Set +import qualified Data.Map as Map -- import qualified Data.Text.Lazy.Encoding as LBS -- import qualified Control.Monad.Catch as Catch -- import Servant.Client (ClientError(..), ResponseF(..)) -- import Text.Blaze.Html (preEscapedToHtml) +import Database.Persist.Sql (updateWhereCount) import Database.Esqueleto.Experimental ((:&)(..)) 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 Handler.Utils import Handler.Utils.Avs import Handler.Utils.Users +-- import Handler.Utils.Company import Handler.Health.Interface import Handler.Admin.Test as Handler.Admin @@ -33,12 +36,34 @@ import Handler.Admin.Crontab as Handler.Admin import Handler.Admin.Avs as Handler.Admin import Handler.Admin.Ldap as Handler.Admin +-- avoids repetition of local definitions +single :: (k,a) -> Map k a +single = uncurry Map.singleton + +-- Types and Template Haskell +data ProblemTableAction = ProblemTableMarkSolved + | ProblemTableMarkUnsolved + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) + deriving anyclass (Universe, Finite) + +nullaryPathPiece ''ProblemTableAction $ camelToPathPiece' 2 +embedRenderMessage ''UniWorX ''ProblemTableAction id + +data ProblemTableActionData = ProblemTableMarkSolvedData + | ProblemTableMarkUnsolvedData -- Placeholder, remove later + deriving (Eq, Ord, Read, Show, Generic) + + +-- Handlers getAdminR :: Handler Html getAdminR = redirect AdminProblemsR -getAdminProblemsR :: Handler Html -getAdminProblemsR = do +getAdminProblemsR, postAdminProblemsR :: Handler Html +getAdminProblemsR = handleAdminProblems Nothing + +handleAdminProblems :: Maybe Widget -> Handler Html +handleAdminProblems mbProblemTable = do now <- liftIO getCurrentTime let nowaday = utctDay now cutOffOldDays = 1 @@ -55,21 +80,22 @@ getAdminProblemsR = do flagNonZero n | n <= 0 = flagError True | otherwise = messageTooltip =<< handlerToWidget (messageI Error (MsgProblemsDriverSynch n)) - (usersAreReachable, driversHaveAvsIds, rDriversHaveFs, noStalePrintJobs, noBadAPCids, (interfaceOks, interfaceTable)) <- runDB $ (,,,,,) + (usersAreReachable, driversHaveAvsIds, rDriversHaveFs, noStalePrintJobs, noBadAPCids, (interfaceOks, interfaceTable)) <- runDB $ (,,,,,) <$> areAllUsersReachable <*> allDriversHaveAvsId now <*> allRDriversHaveFs now <*> (not <$> exists [PrintJobAcknowledged ==. Nothing, PrintJobCreated <. cutOffOldTime]) <*> (not <$> exists [PrintAcknowledgeProcessed ==. False]) - <*> mkInterfaceLogTable flagError mempty + <*> mkInterfaceLogTable flagError mempty let interfacesBadNr = length $ filter (not . snd) interfaceOks -- interfacesOk = all snd interfaceOks + diffLics <- try retrieveDifferingLicences >>= \case -- (Left (UnsupportedContentType "text/html" resp)) -> Left $ text2widget "Html received" (Left e) -> return $ Left $ text2widget $ tshow (e :: SomeException) (Right AvsLicenceDifferences{..}) -> do let problemIds = avsLicenceDiffRevokeAll <> avsLicenceDiffGrantVorfeld <> avsLicenceDiffRevokeRollfeld <> avsLicenceDiffGrantRollfeld - forM_ (take 42 $ Set.toList problemIds) $ queueJob' . flip JobSynchroniseAvsId (Just nowaday) + queueAvsUpdateByAID problemIds $ Just nowaday return $ Right ( Set.size avsLicenceDiffRevokeAll , Set.size avsLicenceDiffGrantVorfeld @@ -86,11 +112,32 @@ getAdminProblemsR = do -- ] rerouteMail <- getsYesod $ view _appMailRerouteTo + problemLogTable <- maybeM (snd <$> runDB mkProblemLogTable) return $ return mbProblemTable -- formResult only processed in POST-Handler siteLayoutMsg MsgProblemsHeading $ do setTitleI MsgProblemsHeading $(widgetFile "admin-problems") +postAdminProblemsR = do + (problemLogRes, problemLogTable) <- runDB mkProblemLogTable + formResult problemLogRes procProblems + handleAdminProblems $ Just problemLogTable + where + procProblems :: (ProblemTableActionData, Set ProblemLogId) -> Handler () + procProblems (ProblemTableMarkSolvedData , pids) = actUpdate True pids + procProblems (ProblemTableMarkUnsolvedData, pids) = actUpdate False pids + + actUpdate markdone pids = do + mauid <- maybeAuthId + now <- liftIO getCurrentTime + let (pls_fltr,newv,msg) | markdone = (ProblemLogSolved ==. Nothing, Just now, MsgAdminProblemsSolved) + | otherwise = (ProblemLogSolved !=. Nothing, Nothing , MsgAdminProblemsReopened) + (fromIntegral -> oks) <- runDB $ updateWhereCount [pls_fltr, ProblemLogId <-. toList pids] + [ProblemLogSolved =. newv, ProblemLogSolver =. mauid] + let no_req = Set.size pids + mkind = if oks < no_req || no_req <= 0 then Warning else Success + addMessageI mkind $ msg oks + when (oks > 0) $ reloadKeepGetParams AdminProblemsR -- reload to update all tables getProblemUnreachableR :: Handler Html getProblemUnreachableR = do @@ -168,9 +215,9 @@ retrieveUnreachableUsers = do E.where_ $ E.isNothing (user E.^. UserPostAddress) E.&&. (E.isNothing (user E.^. UserCompanyDepartment) E.||. user E.^. UserCompanyPersonalNumber `E.ilike` E.justVal "E%") return user - return $ filter hasInvalidEmail emailOnlyUsers + filterM hasInvalidEmail emailOnlyUsers where - hasInvalidEmail = isNothing . getEmailAddress . entityVal + hasInvalidEmail = fmap isNothing . getUserEmail allDriversHaveAvsId :: UTCTime -> DB Bool @@ -238,3 +285,118 @@ retrieveDriversRWithoutF now = do E.where_ $ E.exists (hasValidQual AvsLicenceRollfeld) E.&&. E.notExists (hasValidQual AvsLicenceVorfeld) return usr + + + +type ProblemLogTableExpr = E.SqlExpr (Entity ProblemLog) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User)) +queryProblem :: ProblemLogTableExpr -> E.SqlExpr (Entity ProblemLog) +queryProblem = $(E.sqlLOJproj 3 1) + +querySolver :: ProblemLogTableExpr -> E.SqlExpr (Maybe (Entity User)) +querySolver = $(E.sqlLOJproj 3 2) + +queryUser :: ProblemLogTableExpr -> E.SqlExpr (Maybe (Entity User)) +queryUser = $(E.sqlLOJproj 3 3) + +type ProblemLogTableData = DBRow (Entity ProblemLog, Maybe (Entity User), Maybe (Entity User)) +resultProblem :: Lens' ProblemLogTableData (Entity ProblemLog) +resultProblem = _dbrOutput . _1 + +resultSolver :: Traversal' ProblemLogTableData (Entity User) +resultSolver = _dbrOutput . _2 . _Just + +resultUser :: Traversal' ProblemLogTableData (Entity User) +resultUser = _dbrOutput . _3 . _Just + +mkProblemLogTable :: DB (FormResult (ProblemTableActionData, Set ProblemLogId), Widget) +mkProblemLogTable = over _1 postprocess <$> dbTable validator DBTable{..} + where + dbtIdent = "problem-log" :: Text + dbtSQLQuery = \(problem `E.LeftOuterJoin` solver `E.LeftOuterJoin` usr) -> do + -- EL.on (usr E.?. UserId E.==. E.text2num (problem E.^. ProblemLogInfo E.->>. "user")) -- works + EL.on (usr E.?. UserId E.==. problem E.^. ProblemLogInfo E.->>>. "user") + EL.on (solver E.?. UserId E.==. problem E.^. ProblemLogSolver) + return (problem, solver, usr) + dbtRowKey = queryProblem >>> (E.^. ProblemLogId) + dbtProj = dbtProjId + dbtColonnade = formColonnade $ mconcat + [ dbSelect (applying _2) id $ return . view (resultProblem . _entityKey) + , sortable (Just "time") (i18nCell MsgAdminProblemCreated) $ \( view $ resultProblem . _entityVal . _problemLogTime -> t) -> dateTimeCell t + , sortable (Just "info") (i18nCell MsgAdminProblemInfo) $ \( view $ resultProblem . _entityVal . _problemLogAdminProblem -> p) -> adminProblemCell p + -- , sortable (Just "firm") (i18nCell MsgTableCompany) $ \(preview $ resultProblem . _entityVal . _problemLogAdminProblem . _adminProblemCompany -> c) -> cellMaybe companyIdCell c + , sortable (Just "firm") (i18nCell MsgTableCompany) $ \( view $ resultProblem . _entityVal . _problemLogAdminProblem -> p) -> cellMaybe companyIdCell $ join (p ^? _adminProblemCompanyOld) <|> (p ^? _adminProblemCompany) + , sortable (Just "user") (i18nCell MsgAdminProblemUser) $ \(preview resultUser -> u) -> maybeCell u $ cellHasUserLink AdminUserR + , sortable (Just "solved") (i18nCell MsgAdminProblemSolved) $ \( view $ resultProblem . _entityVal . _problemLogSolved -> t) -> cellMaybe dateTimeCell t + , sortable (Just "solver") (i18nCell MsgAdminProblemSolver) $ \(preview resultSolver -> u) -> maybeCell u $ cellHasUserLink AdminUserR + ] + dbtSorting = mconcat + [ single ("time" , SortColumn $ queryProblem >>> (E.^. ProblemLogTime)) + , single ("info" , SortColumn $ queryProblem >>> (E.^. ProblemLogInfo)) + -- , single ("firm" , SortColumn ((E.->>. "company" ).(queryProblem >>> (E.^. ProblemLogInfo)))) + , single ("firm" , SortColumn $ \r -> queryProblem r E.^. ProblemLogInfo E.->>. "company") + , single ("user" , sortUserNameBareM queryUser) + , single ("solved", SortColumn $ queryProblem >>> (E.^. ProblemLogSolved)) + , single ("solver", sortUserNameBareM querySolver) + ] + dbtFilter = mconcat + [ single ("solved" , FilterColumn . E.mkExactFilterLast $ views (to queryProblem) (E.isJust . (E.^. ProblemLogSolved))) + ] + dbtFilterUI mPrev = mconcat + [ prismAForm (singletonFilter "solved" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgAdminProblemSolved) + ] + acts :: Map ProblemTableAction (AForm Handler ProblemTableActionData) + acts = mconcat + [ singletonMap ProblemTableMarkSolved $ pure ProblemTableMarkSolvedData + , singletonMap ProblemTableMarkUnsolved $ pure ProblemTableMarkUnsolvedData + ] + dbtParams = DBParamsForm + { dbParamsFormMethod = POST + , dbParamsFormAction = Nothing + , dbParamsFormAttrs = [] + , dbParamsFormSubmit = FormSubmit + , dbParamsFormAdditional + = renderAForm FormStandard + $ (, mempty) . First . Just + <$> multiActionA acts (fslI MsgTableAction) (Just ProblemTableMarkSolved) + , dbParamsFormEvaluate = liftHandler . runFormPost + , dbParamsFormResult = id + , dbParamsFormIdent = def + } + dbtCsvEncode = noCsvEncode + dbtCsvDecode = Nothing + dbtExtraReps = [] + dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } + validator = def & defaultSorting [SortAscBy "time"] + & defaultFilter (singletonMap "solved" [toPathPiece False]) + postprocess :: FormResult (First ProblemTableActionData, DBFormResult ProblemLogId Bool ProblemLogTableData) + -> FormResult ( ProblemTableActionData, Set ProblemLogId) + postprocess inp = do + (First (Just act), usrMap) <- inp + let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap + return (act, usrSet) + +-- adminProblemCell :: IsDBTable m a => AdminProblem -> DBCell m a +-- -- note that adminProblemCompany/adminProblemCompanyOld and adminProblemUser are automatically displayed within their own columns +-- adminProblemCell AdminProblemNewCompany{} +-- = i18nCell MsgAdminProblemNewCompany +-- adminProblemCell AdminProblemSupervisorNewCompany{adminProblemCompanyNew, adminProblemSupervisorReroute} +-- = i18nCell (MsgAdminProblemSupervisorNewCompany adminProblemSupervisorReroute) <> companyIdCell adminProblemCompanyNew +-- adminProblemCell AdminProblemSupervisorLeftCompany{adminProblemSupervisorReroute} +-- = i18nCell (MsgAdminProblemSupervisorLeftCompany adminProblemSupervisorReroute) +-- adminProblemCell AdminProblemNewlyUnsupervised{adminProblemCompanyNew} +-- = i18nCell MsgAdminProblemNewlyUnsupervised <> companyIdCell adminProblemCompanyNew +-- adminProblemCell AdminProblemUnknown{adminProblemText} +-- = textCell $ "Problem: " <> adminProblemText + + +-- msgAdminProblem :: AdminProblem -> DB (SomeMessages UniWorX) +-- msgAdminProblem AdminProblemNewCompany{adminProblemCompany=comp} = return $ +-- SomeMessages [SomeMessage MsgAdminProblemNewCompany, text2message ": ", company2msg comp] +-- msgAdminProblem AdminProblemSupervisorNewCompany{adminProblemCompany=comp, adminProblemCompanyNew=newComp} = return $ +-- SomeMessages [SomeMessage MsgAdminProblemSupervisorNewCompany, text2message ": ", company2msg comp, text2message " -> ", company2msg newComp] +-- msgAdminProblem AdminProblemSupervisorLeftCompany{adminProblemCompany=comp} = return $ +-- SomeMessages [SomeMessage MsgAdminProblemSupervisorLeftCompany, text2message ": ", company2msg comp] +-- msgAdminProblem AdminProblemNewlyUnsupervised{adminProblemCompanyOld=comp, adminProblemCompanyNew=newComp} = return $ +-- SomeMessages [SomeMessage MsgAdminProblemNewlyUnsupervised, text2message ": ", maybe (text2message "???") company2msg comp, text2message " -> ", company2msg newComp] +-- msgAdminProblem AdminProblemUnknown{adminProblemText=err} = return $ +-- someMessages ["Problem: ", err] \ No newline at end of file diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index 9521912c9..82d739bb8 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -9,7 +9,7 @@ module Handler.Admin.Avs ( getAdminAvsR, postAdminAvsR - , getAdminAvsUserR + , getAdminAvsUserR, postAdminAvsUserR , getProblemAvsSynchR, postProblemAvsSynchR , getProblemAvsErrorR ) where @@ -17,7 +17,7 @@ module Handler.Admin.Avs import Import import qualified Control.Monad.State.Class as State -- import Data.Aeson (encode) -import qualified Data.Aeson.Encode.Pretty as Pretty +-- import qualified Data.Aeson.Encode.Pretty as Pretty import qualified Data.Text as Text import qualified Data.CaseInsensitive as CI import qualified Data.Set as Set @@ -27,9 +27,8 @@ import qualified Data.Map as Map import Handler.Utils import Handler.Utils.Avs -- import Handler.Utils.Qualification - -import Utils.Avs - +import Handler.Utils.Users (getUserPrimaryCompany) +import Handler.Utils.Company (switchAvsUserCompany) import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Legacy as E @@ -43,6 +42,13 @@ import qualified Database.Esqueleto.Utils as E single :: (k,a) -> Map k a single = uncurry Map.singleton +exceptionWgt :: SomeException -> Widget +exceptionWgt (SomeException e) = [whamlet|

Error:

#{tshow e}|] + +tryShow :: MonadCatch m => m Widget -> m Widget +tryShow act = try act >>= \case + Left err -> return $ exceptionWgt err + Right res -> return res -- Button only needed in AVS TEST; further buttons see below data ButtonAvsTest = BtnCheckLicences -- | BtnSynchLicences @@ -140,173 +146,167 @@ postAdminAvsR = do mbAvsConf <- getsYesod $ view _appAvsConf let avsWgt = [whamlet| $maybe avsConf <- mbAvsConf - AVS Konfiguration ist #{decodeUtf8 (avsUser avsConf)}@#{avsHost avsConf}:#{avsPort avsConf} +

+ AVS Konfiguration +

+ + + + $forall c <- Set.toDescList crds + $with AvsDataPersonCard{avsDataValid,avsDataCardColor,avsDataCardAreas,avsDataFirm,avsDataIssueDate,avsDataValidTo} <- c + +
_{MsgAvsCardNo} + _{MsgTableAvsCardValid} + _{MsgAvsCardColor} + _{MsgAvsCardAreas} + $if hasIssueDate + _{MsgTableAvsCardIssueDate} + $if hasValidToDate + _{MsgTableAvsCardValidTo} + $if hasCompany + _{MsgTableCompany} + _{MsgAvsPrimaryCompany} +
+ #{tshowAvsFullCardNo (getFullCardNo c)} + + #{boolSymbol avsDataValid} + + _{avsDataCardColor} + + $forall a <- avsDataCardAreas + #{a} # + $if hasIssueDate + + $maybe d <- avsDataIssueDate + ^{formatTimeW SelFormatDate d} + $if hasValidToDate + + $maybe d <- avsDataValidTo + ^{formatTimeW SelFormatDate d} + $if hasCompany + + $maybe f <- avsDataFirm + #{f} + + $maybe f <- avsDataFirm + $with fci <- stripCI f + $maybe primName <- mbPrimName + $if (primName == fci) + _{MsgAvsPrimaryCompany} +

+ ^{swForm} |] - let heading = [whamlet|_{MsgAvsPersonNo} #{userAvsNoPerson}|] - siteLayout heading $ do - setTitle $ toHtml $ show userAvsNoPerson - resWgt + + instance HasEntity (DBRow (Entity UserAvs, Entity User)) User where hasEntity = _dbrOutput . _2 @@ -740,7 +892,7 @@ getProblemAvsErrorR = do dbtSQLQuery (usravs `E.InnerJoin` user) = do E.on $ usravs E.^. UserAvsUser E.==. user E.^. UserId E.where_ $ E.isJust $ usravs E.^. UserAvsLastSynchError - return (usravs, user) + return (usravs, user) -- , E.substring (usravs E.^. UserAvsLastSynchError) (E.val ("'#\"%#\" %'") (E.val "#")) -- needs a different type on substring qerryUsrAvs :: (E.SqlExpr (Entity UserAvs) `E.InnerJoin` E.SqlExpr (Entity User)) -> E.SqlExpr (Entity UserAvs) qerryUsrAvs = $(E.sqlIJproj 2 1) qerryUser :: (E.SqlExpr (Entity UserAvs) `E.InnerJoin` E.SqlExpr (Entity User)) -> E.SqlExpr (Entity User) @@ -748,7 +900,7 @@ getProblemAvsErrorR = do reserrUsrAvs :: Lens' (DBRow (Entity UserAvs, Entity User)) (Entity UserAvs) reserrUsrAvs = _dbrOutput . _1 -- reserrUser :: Lens' (DBRow (Entity UserAvs, Entity User)) (Entity User) - -- reserrUser = _dbrOutput . _2 + -- reserrUser = _dbrOutput . _2 dbtRowKey = qerryUsrAvs >>> (E.^. UserAvsId) dbtProj = dbtProjId dbtColonnade = dbColonnade $ mconcat diff --git a/src/Handler/Admin/Test.hs b/src/Handler/Admin/Test.hs index 1969f8717..f8f99e770 100644 --- a/src/Handler/Admin/Test.hs +++ b/src/Handler/Admin/Test.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-2024 Gregor Kleen ,Steffen Jost ,David Mosbach -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -112,7 +112,7 @@ postAdminTestR = do let emailWidget' = wrapForm emailWidget def { formAction = Just . SomeRoute $ AdminTestR , formEncoding = emailEnctype - , formAttrs = [("uw-async-form", "")] + , formAttrs = [asyncSubmitAttr] -- equivalent to [("uw-async-form", "")] } now <- liftIO getCurrentTime @@ -249,6 +249,7 @@ postAdminTestR = do , formEncoding = formEnctype , formAttrs = [] , formSubmit = FormSubmit + , formCustomBtn = Nothing :: Maybe ButtonSubmit , formAnchor = Just FIDAdminDemo } showDemoResult @@ -260,6 +261,7 @@ postAdminTestR = do , formEncoding = miEnc , formAttrs = [] , formSubmit = FormSubmit + , formCustomBtn = Nothing :: Maybe ButtonSubmit , formAnchor = Just miIdent } [whamlet| @@ -283,6 +285,7 @@ postAdminTestR = do , formEncoding = i18nEnc , formAttrs = [] , formSubmit = FormSubmit + , formCustomBtn = Nothing :: Maybe ButtonSubmit , formAnchor = Just i18nIdent } [whamlet| @@ -354,7 +357,7 @@ getAdminTestPdfR = do , isReminder = False } apcIdent <- letterApcIdent letter encRecipient now - renderLetterPDF usr letter apcIdent >>= \case + renderLetterPDF usr letter apcIdent Nothing >>= \case Left err -> sendResponseStatus internalServerError500 $ "PDF generation failed: \n" <> err Right pdf -> do liftIO $ LBS.writeFile "/tmp/generated.pdf" pdf diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs index ae88bb64c..c1d5a580b 100644 --- a/src/Handler/Course/Edit.hs +++ b/src/Handler/Course/Edit.hs @@ -291,9 +291,9 @@ getCourseNewR = do } [] -> do (tidOk,sshOk,cshOk) <- runDB $ (,,) - <$> ifMaybeM mbTid True existsKey - <*> ifMaybeM mbSsh True existsKey - <*> ifMaybeM mbCsh True (\csh -> not . null <$> selectKeysList [CourseShorthand ==. csh] [LimitTo 1]) + <$> ifNothingM mbTid True existsKey + <*> ifNothingM mbSsh True existsKey + <*> ifNothingM mbCsh True (\csh -> not . null <$> selectKeysList [CourseShorthand ==. csh] [LimitTo 1]) unless tidOk $ addMessageI Warning $ MsgNoSuchTerm $ fromJust mbTid -- safe, since tidOk==True otherwise unless sshOk $ addMessageI Warning $ MsgNoSuchSchool $ fromJust mbSsh -- safe, since sshOk==True otherwise unless cshOk $ addMessageI Warning $ MsgNoSuchCourseShorthand $ fromJust mbCsh diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index 53eff795d..8eb29f112 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/src/Handler/Course/ParticipantInvite.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-23 Sarah Vaupel , Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Sarah Vaupel , Steffen Jost ,David Mosbach -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -292,6 +292,7 @@ handleAddUserR tid ssh csh tdesc ttyp = do , formEncoding = confirmEnctype , formAttrs = [] , formSubmit = FormNoSubmit + , formCustomBtn = Nothing :: Maybe ButtonSubmit , formAnchor = Nothing :: Maybe Text } $(widgetFile "course/add-user/confirmation-wrapper") diff --git a/src/Handler/Course/User.hs b/src/Handler/Course/User.hs index b7e54719c..fce40d718 100644 --- a/src/Handler/Course/User.hs +++ b/src/Handler/Course/User.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Winnie Ros +-- SPDX-FileCopyrightText: 2022-2024 Gregor Kleen ,Winnie Ros ,David Mosbach -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -9,12 +9,11 @@ module Handler.Course.User import Import import Utils.Form +import Utils.Mail (pickValidUserEmail) import Handler.Utils import Handler.Utils.SheetType -import Handler.Utils.Profile (pickValidEmail) import Handler.Utils.StudyFeatures import Handler.Submission.List - import Handler.Course.Register import Jobs.Queue @@ -119,6 +118,7 @@ courseUserProfileSection course@(Entity cid Course{..}) (Entity uid User{ userSh , formEncoding = regButtonEnctype , formAttrs = [] , formSubmit = FormSubmit + , formCustomBtn = Nothing :: Maybe ButtonSubmit , formAnchor = Just registrationButtonFrag } formResult regButtonRes $ \case @@ -194,6 +194,7 @@ courseUserNoteSection (Entity cid Course{..}) (Entity uid _) = do , formEncoding = noteEnctype , formAttrs = [] , formSubmit = FormSubmit + , formCustomBtn = Nothing :: Maybe ButtonSubmit , formAnchor = Just noteFrag } formResult noteRes $ \mbNote -> do diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 596ea40c9..e04ccdb78 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2023 Steffen Jost +-- SPDX-FileCopyrightText: 2023-2024 Steffen Jost ,David Mosbach -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -28,7 +28,8 @@ import qualified Data.Map as Map -- import qualified Data.Text as T import qualified Data.CaseInsensitive as CI -- import qualified Data.Conduit.List as C -import Database.Persist.Sql (deleteWhereCount, updateWhereCount) +-- import Database.Persist.Sql (deleteWhereCount, updateWhereCount) +import Database.Persist.Postgresql import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma import qualified Database.Esqueleto.Legacy as EL (on) @@ -161,7 +162,9 @@ firmActionHandler route isAdmin = flip formResult faHandler addMessageI Warning MsgFirmActAddSupersEmpty reloadKeepGetParams route runDB $ do - putMany [UserCompany uid cid True firmActAddSupervisorReroute | uid <- usersFound] + -- putMany [UserCompany uid cid True firmActAddSupervisorReroute 0 False | uid <- usersFound] -- putMany always overwrites existing records, which would destroy priority and useCompanyAddress here + -- upsertManyWhere [UserCompany uid cid True firmActAddSupervisorReroute 0 False | uid <- usersFound] [copyField UserCompanySupervisor, copyField UserCompanySupervisorReroute] [] [] -- overwrite Supervisor and SupervisorReroute, keep priority and useCompanyAddress + upsertManyWhere [UserCompany uid cid True firmActAddSupervisorReroute 0 False | uid <- usersFound] [] [UserCompanySupervisor =. True, UserCompanySupervisorReroute =. firmActAddSupervisorReroute] [] -- identical to previous line, but perhaps more clear? whenIsJust firmActAddSupervisorPostal $ \prefPostal -> updateWhere [UserId <-. usersFound] [UserPrefersPostal =. prefPostal] addMessageI Success $ MsgFirmActAddSupersSet (fromIntegral $ length usersFound) firmActAddSupervisorPostal @@ -174,7 +177,7 @@ firmActionHandler route isAdmin = flip formResult faHandler , (CompanyPrefersPostal =.) <$> firmActCCFPostalPref ] in unless (null changes) $ do - runDB $ updateBy (UniqueCompanyShorthand $ unCompanyKey cid) changes + runDB $ update cid changes addMessageI Success MsgFirmActChangeContactFirmResult reloadKeepGetParams route @@ -208,6 +211,7 @@ runFirmActionFormPost cid route isAdmin acts = do , formEncoding = faEnctype , formAttrs = [] , formSubmit = FormSubmit + , formCustomBtn = Nothing :: Maybe ButtonSubmit , formAnchor = Just faAnchor } firmActionHandler route isAdmin faRes @@ -229,14 +233,16 @@ runFirmActionFormPost cid route isAdmin acts = do --- remove supervisors: -deleteSupervisors :: NonEmpty UserId -> DB Int64 -deleteSupervisors usrs = deleteWhereCount [UserSupervisorUser <-. toList usrs] +-- | remove supervisors for given users; maybe restricted to those linked to a given companies +deleteSupervisors :: NonEmpty UserId -> [CompanyId] -> DB Int64 +deleteSupervisors usrs cids = deleteWhereCount $ (UserSupervisorUser <-. toList usrs) : restrictByCompany + where + restrictByCompany = guardMonoid (notNull cids) [UserSupervisorCompany <-. (Just <$> cids)] --- reset supervisors given employees of a company to default company supervision, deleting all other supervisors +-- reset supervisors given employees of a company to default company supervision, deleting all previous company-related supervisors resetSupervisors :: CompanyId -> NonEmpty UserId -> DB Int64 resetSupervisors cid employees = do - nr_del <- deleteSupervisors employees + nr_del <- deleteSupervisors employees [cid] nr_add <- addDefaultSupervisors cid employees return $ max nr_del nr_add @@ -252,8 +258,14 @@ addDefaultSupervisors cid employees = do E.<# (spr E.^. UserCompanyUser) E.<&> usr E.<&> (spr E.^. UserCompanySupervisorReroute) + E.<&> E.justVal cid + E.<&> E.nothing ) - (\_old new -> [UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications]) + (\_old new -> + [ UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications + , UserSupervisorCompany E.=. E.justVal cid + -- , UserSupervisorReason E.=. new E.^. UserSupervisorReason -- keep any existing reason + ]) -- like `addDefaultSupervisors`, but selects all employees of given companies from database, optionally filtered by being under supervision of a given individual addDefaultSupervisorsFor :: (CompanyId ~ Element mono, MonoFoldable mono) => Maybe UserId -> Bool -> mono -> DB Int64 @@ -276,8 +288,14 @@ addDefaultSupervisorsFor mbSuperId mutualSupervision cids = do E.<# (spr E.^. UserCompanyUser) E.<&> (usr E.^. UserCompanyUser) E.<&> (spr E.^. UserCompanySupervisorReroute) + E.<&> E.just (spr E.^. UserCompanyCompany) + E.<&> E.nothing ) - (\_old new -> [UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications] ) + (\_old new -> + [ UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications + , UserSupervisorCompany E.=. new E.^. UserSupervisorCompany + -- , UserSupervisorReason E.=. new E.^. UserSupervisorReason -- keep any existing reaon + ] ) -- like `addDefaultSupervisors`, but selects all employees of given companies from database addDefaultSupervisorsAll :: (CompanyId ~ Element mono, MonoFoldable mono) => Bool -> mono -> DB Int64 @@ -295,8 +313,14 @@ addDefaultSupervisorsAll mutualSupervision cids = do E.<# (spr E.^. UserCompanyUser) E.<&> (usr E.^. UserCompanyUser) E.<&> (spr E.^. UserCompanySupervisorReroute) + E.<&> E.just (spr E.^. UserCompanyCompany) + E.<&> E.nothing ) - (\_old new -> [UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications] ) + (\_old new -> + [ UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications + , UserSupervisorCompany E.=. new E.^. UserSupervisorCompany + -- , UserSupervisorReason E.=. new E.^. UserSupervisorReason -- keep any existing reaon + ] ) ------------------------------ @@ -599,7 +623,7 @@ mkFirmAllTable isAdmin uid = do case criterion of Nothing -> return True :: DB Bool (Just (crit::Text)) -> do - critFirms <- memcachedBy (Just . Right $ 5 * diffMinute) ("svr:"<>crit) $ fmap (Set.fromAscList . fmap E.unValue) $ E.select $ E.distinct $ do + critFirms <- memcachedBy (Just . Right $ 3 * diffMinute) ("SVR:"<>crit) $ fmap (Set.fromList . fmap E.unValue) $ E.select $ E.distinct $ do (usr :& cmp) <- E.from $ E.table @User `E.innerJoin` E.table @Company `E.on` (\(usr :& cmp) -> E.exists (do usrCmp <- E.from $ E.table @UserCompany @@ -612,13 +636,13 @@ mkFirmAllTable isAdmin uid = do E.&&. E.exists (do usrSub <- E.from $ E.table @UserCompany E.where_ $ usrSub E.^. UserCompanyUser E.==. usrSpr E.^. UserSupervisorUser - E.&&. usrSub E.^. UserCompanyCompany E.==. cmp E.^. CompanyId + E.&&. usrSub E.^. UserCompanyCompany E.==. cmp E.^. CompanyId ) )) - E.where_ $ (usr E.^. UserDisplayName `E.hasInfix` E.val crit) + E.where_ $ (usr E.^. UserDisplayName `E.hasInfix` E.val crit ) E.||. (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk crit)) - E.||. (usr E.^. UserSurname `E.hasInfix` E.val crit) - E.orderBy [E.asc $ cmp E.^. CompanyId] + E.||. (usr E.^. UserSurname `E.hasInfix` E.val crit ) + -- E.orderBy [E.asc $ cmp E.^. CompanyId] return $ cmp E.^. CompanyId let cid = dbr ^. resultAllCompanyEntity . _entityKey return $ Set.member cid critFirms @@ -1006,7 +1030,7 @@ postFirmUsersR fsh = do (FirmUserActResetSupervisionData{..}, set2NonEmpty (error "Unexpected empty user list in getFirmUserR action handler.") -> uids) -> do -- set guaranteed to be non-empty due to first case clause runDB $ do delSupers <- if firmUserActResetKeepOldSupers == Just False - then deleteSupervisors uids + then deleteSupervisors uids [] else return 0 newSupers <- addDefaultSupervisors cid uids addMessageI Info $ MsgFirmResetSupervision delSupers newSupers @@ -1027,8 +1051,8 @@ postFirmUsersR fsh = do |] in addMessageModal Error (i18n . MsgCourseParticipantsRegisterNotFoundInAvs $ length usersNotFound) (Right msgContent) delSupers <- runDB - $ bool (deleteSupervisors uids) (return 0) firmUserActSetSuperKeep - <* putMany [UserSupervisor s u firmUserActSetSuperReroute | u <- toList uids, s <- newSupers] + $ bool (deleteSupervisors uids [cid]) (return 0) firmUserActSetSuperKeep + <* putMany [UserSupervisor s u firmUserActSetSuperReroute (Just cid) Nothing | u <- toList uids, s <- newSupers] addMessageI Success $ MsgFirmSetSupersReport nrUsers nrSupers delSupers reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index abc8d8bd6..944e8321e 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -499,13 +499,7 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId E.&&. testcrit ) - , single ("avs-card" , FilterColumn $ \(queryUser -> user) (criterion :: Set.Set Text) -> case readAvsFullCardNo =<< Set.lookupMin criterion of - Nothing -> E.false - Just cardNo -> E.exists $ E.from $ \(avsCard `E.InnerJoin` usrAvs) -> do - E.on $ usrAvs E.^. UserAvsPersonId E.==. avsCard E.^. UserAvsCardPersonId - E.where_ $ usrAvs E.^. UserAvsUser E.==. user E.^. UserId - E.&&. (avsCard E.^. UserAvsCardCardNo E.==. E.val cardNo) - ) + , fltrAVSCardNos queryUser , single ("personal-number", FilterColumn $ \(queryUser -> user) (criteria :: Set.Set Text) -> if | Set.null criteria -> E.true | otherwise -> E.any (\c -> user E.^. UserCompanyPersonalNumber `E.hasInfix` E.val c) criteria @@ -515,7 +509,7 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do [ fltrUserNameEmailHdrUI MsgLmsUser mPrev , prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany) , prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumber) - , prismAForm (singletonFilter "avs-card" ) mPrev $ aopt textField (fslI MsgAvsCardNo) + , fltrAVSCardNosUI mPrev , prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo) , prismAForm (singletonFilter "ident" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent) , prismAForm (singletonFilter "validity" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid) diff --git a/src/Handler/LMS/Fake.hs b/src/Handler/LMS/Fake.hs index cd7392760..d1b876db6 100644 --- a/src/Handler/LMS/Fake.hs +++ b/src/Handler/LMS/Fake.hs @@ -71,11 +71,11 @@ fakeQualificationUsers (Entity qid Qualification{qualificationRefreshWithin}) (u theSupervisor <- selectKeysList [UserSurname ==. "Jost", UserFirstName ==. "Steffen"] [Asc UserCreated, LimitTo 1] let addSupervisor = case theSupervisor of [s] -> \suid k -> case k of - 1 -> void $ insertBy $ UserSupervisor s suid True + 1 -> void $ insertBy $ UserSupervisor s suid True Nothing Nothing 2 -> do - void $ insertBy $ UserSupervisor s suid True - void $ insertBy $ UserSupervisor suid suid True - 3 -> void $ insertBy $ UserSupervisor s suid True + void $ insertBy $ UserSupervisor s suid True Nothing (Just "Test") + void $ insertBy $ UserSupervisor suid suid True Nothing Nothing + 3 -> void $ insertBy $ UserSupervisor s suid True Nothing Nothing _ -> return () _ -> \_ _ -> return () expiryOffsets = concatMap (replicate usersPerDay) [0..(diffDays dto dfrom)] diff --git a/src/Handler/PrintCenter.hs b/src/Handler/PrintCenter.hs index 084cc74d6..6616ee91b 100644 --- a/src/Handler/PrintCenter.hs +++ b/src/Handler/PrintCenter.hs @@ -25,7 +25,8 @@ import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH -import Utils.Print +import Utils.Print hiding (LetterRenewQualificationF) +import Utils.Print.RenewQualification import qualified Data.Aeson as Aeson -- import qualified Data.Text as Text @@ -82,7 +83,7 @@ lrqf2letter LRQF{..} usr <- getUser lrqfUser rcvr <- mapM getUser lrqfSuper now <- liftIO getCurrentTime - let letter = LetterRenewQualificationF + let letter = LetterRenewQualification { lmsLogin = lrqfIdent , lmsPin = lrqfPin , qualHolderID = usr ^. _entityKey diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 3a0103c58..68264c79f 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -1,7 +1,9 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Winnie Ros +-- SPDX-FileCopyrightText: 2022-2024 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Winnie Ros ,David Mosbach -- -- SPDX-License-Identifier: AGPL-3.0-or-later +{-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity and HasUser instances + module Handler.Profile ( getProfileR, postProfileR , getForProfileR, postForProfileR @@ -18,6 +20,7 @@ import Import import Handler.Utils import Handler.Utils.Profile +import Handler.Utils.Users import Utils.Print (validCmdArgument) @@ -548,6 +551,7 @@ serveProfileR (uid, user@User{..}) = do , formEncoding = formEnctype , formAttrs = [] , formSubmit = FormSubmit + , formCustomBtn = Nothing :: Maybe ButtonSubmit , formAnchor = Just ProfileSettings } tokenForm = @@ -557,6 +561,7 @@ serveProfileR (uid, user@User{..}) = do , formEncoding = tokenEnctype , formAttrs = [] , formSubmit = FormNoSubmit + , formCustomBtn = Nothing :: Maybe ButtonSubmit , formAnchor = Just ProfileResetTokens } tokenExplanation = $(i18nWidgetFile "profile/tokenExplanation") @@ -581,10 +586,12 @@ getForProfileDataR cID = do dataWidget makeProfileData :: Entity User -> DB Widget -makeProfileData (Entity uid User{..}) = do +makeProfileData usrEnt@(Entity uid User{..}) = do now <- liftIO getCurrentTime avsId <- entityVal <<$>> getBy (UniqueUserAvsUser uid) - -- avsCards <- maybe (pure mempty) (\a -> selectList [UserAvsCardPersonId ==. userAvsPersonId a] []) avsId + (actualPrefersPostal, actualPostAddress, actualDisplayEmail) <- getPostalPreferenceAndAddress' usrEnt + let postalAutomatic = isJust actualPostAddress && isNothing userPostAddress -- address is either from company or department + emailAutomatic = isJust actualDisplayEmail && not (validEmail' userDisplayEmail) functions <- Map.fromListWith Set.union . map (\(Entity _ UserFunction{..}) -> (userFunctionFunction, Set.singleton userFunctionSchool)) <$> selectList [UserFunctionUser ==. uid] [] lecture_corrector <- E.select $ E.distinct $ E.from $ \(sheet `E.InnerJoin` corrector `E.InnerJoin` course) -> do E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId @@ -622,12 +629,14 @@ makeProfileData (Entity uid User{..}) = do (\(usr, E.Value reroutCom) -> linkUserWidget ForProfileDataR usr <> bool mempty icnReroute reroutCom) <$> supervisees' -- icnReroute = text2widget " " <> toWgt (icon IconLetter) --Tables - (hasRows, ownedCoursesTable) <- mkOwnedCoursesTable uid -- Tabelle mit eigenen Kursen + (hasRowsOwnedCourses, ownedCoursesTable) <- mkOwnedCoursesTable uid -- Tabelle mit eigenen Kursen enrolledCoursesTable <- mkEnrolledCoursesTable uid -- Tabelle mit allen Teilnehmer: Kurs (link), Datum submissionTable <- mkSubmissionTable uid -- Tabelle mit allen Abgaben und Abgabe-Gruppen submissionGroupTable <- mkSubmissionGroupTable uid -- Tabelle mit allen Abgabegruppen correctionsTable <- mkCorrectionsTable uid -- Tabelle mit allen Korrektor-Aufgaben qualificationsTable <- mkQualificationsTable now uid -- Tabelle mit allen Qualifikationen + supervisorsTable <- mkSupervisorsTable uid -- Tabelle mit allen Supervisors + superviseesTable <- mkSuperviseesTable uid -- Tabelle mit allen Supervisees let examTable, ownTutorialTable, tutorialTable :: Widget examTable = i18n MsgPersonalInfoExamAchievementsWip ownTutorialTable = i18n MsgPersonalInfoOwnTutorialsWip @@ -1006,6 +1015,106 @@ mkQualificationsTable = } +-- Types & Definitions used for both mkSupervisorsTable and mkSuperviseeTable +type TblSupervisorExpr = E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity UserSupervisor) -- `E.LeftOuterJoin` E.SqlExpr (Entity Company) +type TblSupervisorData = DBRow (Entity User, Entity UserSupervisor) + +queryUser :: TblSupervisorExpr -> E.SqlExpr (Entity User) +queryUser = $(E.sqlIJproj 2 1) +queryUserSupervisor :: TblSupervisorExpr -> E.SqlExpr (Entity UserSupervisor) +queryUserSupervisor = $(E.sqlIJproj 2 2) +resultUser :: Lens' TblSupervisorData (Entity User) +resultUser = _dbrOutput . _1 +resultUserSupervisor :: Lens' TblSupervisorData (Entity UserSupervisor) +resultUserSupervisor = _dbrOutput . _2 + +instance HasEntity TblSupervisorData User where + hasEntity = _dbrOutput . _1 +instance HasUser TblSupervisorData where + hasUser = _dbrOutput . _1 . _entityVal + +-- | Table listing all supervisor of the given user +mkSupervisorsTable :: UserId -> DB Widget +mkSupervisorsTable uid = dbTableWidget' validator DBTable{..} + where + dbtIdent = "userSupervisedBy" :: Text + dbtStyle = def + + dbtSQLQuery (usr `E.InnerJoin` spr) = do + E.on $ spr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId + E.where_ $ spr E.^. UserSupervisorUser E.==. E.val uid + return (usr, spr) + dbtRowKey (_ `E.InnerJoin` spr) = spr E.^. UserSupervisorId + dbtProj = dbtProjId + + dbtColonnade = mconcat + [ colUserNameModalHdr MsgTableSupervisor ForProfileDataR + , colUserEmail + , sortable (Just "postal-pref") (i18nCell MsgPrefersPostal) $ \(view $ resultUser . _userPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b + , sortable (Just "rerouted") (i18nCell MsgTableRerouteActive) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorRerouteNotifications -> b) -> tickmarkCell b + , sortable (Just "cshort") (i18nCell MsgTableCompany) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorCompany -> mc) -> maybeCell mc (\(unCompanyKey -> c) -> anchorCell (FirmUsersR c) $ citext2widget c) + , sortable (Just "reason") (i18nCell MsgSupervisorReason) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorReason -> mr) -> maybeCell mr textCell + ] + validator = def & defaultSorting [ SortAscBy "cshort", SortAscBy "user-name" ] + dbtSorting = mconcat + [ singletonMap & uncurry $ sortUserNameLink queryUser + , singletonMap & uncurry $ sortUserEmail queryUser + , singletonMap "postal-pref" $ SortColumn $ queryUser >>> (E.^. UserPrefersPostal) + , singletonMap "rerouted" $ SortColumn $ queryUserSupervisor >>> (E.^. UserSupervisorRerouteNotifications) + , singletonMap "cshort" $ SortColumn $ queryUserSupervisor >>> (E.^. UserSupervisorCompany) + , singletonMap "reason" $ SortColumn $ queryUserSupervisor >>> (E.^. UserSupervisorReason) + ] + dbtFilter = mconcat + [ singletonMap & uncurry $ fltrUserNameEmail queryUser + ] + dbtFilterUI = mempty + dbtParams = def + dbtCsvEncode = noCsvEncode + dbtCsvDecode = Nothing + dbtExtraReps = [] + + +-- | Table listing all persons supervised by the given user +mkSuperviseesTable :: UserId -> DB Widget +mkSuperviseesTable uid = dbTableWidget' validator DBTable{..} + where + dbtIdent = "userSupervisedBy" :: Text + dbtStyle = def + + dbtSQLQuery (usr `E.InnerJoin` spr) = do + E.on $ spr E.^. UserSupervisorUser E.==. usr E.^. UserId + E.where_ $ spr E.^. UserSupervisorSupervisor E.==. E.val uid + return (usr, spr) + dbtRowKey (_ `E.InnerJoin` spr) = spr E.^. UserSupervisorId + dbtProj = dbtProjId + + dbtColonnade = mconcat + [ colUserNameModalHdr MsgTableSupervisee ForProfileDataR + -- , colUserEmail + -- , sortable (Just "postal-pref") (i18nCell MsgPrefersPostal) $ \(view $ resultUser . _userPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b + , sortable (Just "rerouted") (i18nCell MsgTableRerouteActive) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorRerouteNotifications -> b) -> tickmarkCell b + , sortable (Just "cshort") (i18nCell MsgTableCompany) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorCompany -> mc) -> maybeCell mc (\(unCompanyKey -> c) -> anchorCell (FirmUsersR c) $ citext2widget c) + , sortable (Just "reason") (i18nCell MsgSupervisorReason) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorReason -> mr) -> maybeCell mr textCell + ] + validator = def & defaultSorting [ SortAscBy "cshort", SortAscBy "user-name" ] + dbtSorting = mconcat + [ singletonMap & uncurry $ sortUserNameLink queryUser + , singletonMap & uncurry $ sortUserEmail queryUser + , singletonMap "postal-pref" $ SortColumn $ queryUser >>> (E.^. UserPrefersPostal) + , singletonMap "rerouted" $ SortColumn $ queryUserSupervisor >>> (E.^. UserSupervisorRerouteNotifications) + , singletonMap "cshort" $ SortColumn $ queryUserSupervisor >>> (E.^. UserSupervisorCompany) + , singletonMap "reason" $ SortColumn $ queryUserSupervisor >>> (E.^. UserSupervisorReason) + ] + dbtFilter = mconcat + [ singletonMap & uncurry $ fltrUserNameEmail queryUser + ] + dbtFilterUI = mempty + dbtParams = def + dbtCsvEncode = noCsvEncode + dbtCsvDecode = Nothing + dbtExtraReps = [] + + getAuthPredsR, postAuthPredsR :: Handler Html getAuthPredsR = postAuthPredsR postAuthPredsR = do diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 5b2c315af..27fad1bb1 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -19,7 +19,6 @@ import Handler.Utils import Handler.Utils.Users import Handler.Utils.LMS - import qualified Data.Set as Set import qualified Data.Map as Map import qualified Data.Csv as Csv @@ -404,19 +403,13 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do -- , single ("validity", SortColumn $ queryQualUser >>> validQualification now) ] dbtFilter = mconcat - [ single $ fltrUserNameEmail queryUser + [ single $ fltrUserNameEmail queryUser , single ("avs-number" , FilterColumn . E.mkExistsFilter $ \row criterion -> E.from $ \usrAvs -> -- do E.where_ $ usrAvs E.^. UserAvsUser E.==. queryUser row E.^. UserId E.&&. ((E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.==. (E.explicitUnsafeCoerceSqlExprValue "citext" (usrAvs E.^. UserAvsNoPerson) :: E.SqlExpr (E.Value (CI Text))) )) - , single ("avs-card" , FilterColumn $ \(queryUser -> user) (criterion :: Set.Set Text) -> case readAvsFullCardNo =<< Set.lookupMin criterion of - Nothing -> E.false - Just cardNo -> E.exists $ E.from $ \(avsCard `E.InnerJoin` usrAvs) -> do - E.on $ usrAvs E.^. UserAvsPersonId E.==. avsCard E.^. UserAvsCardPersonId - E.where_ $ usrAvs E.^. UserAvsUser E.==. user E.^. UserId - E.&&. (avsCard E.^. UserAvsCardCardNo E.==. E.val cardNo) - ) + , fltrAVSCardNos queryUser , single ("personal-number", FilterColumn $ \(queryUser -> user) (criteria :: Set.Set Text) -> if | Set.null criteria -> E.true | otherwise -> E.any (\c -> user E.^. UserCompanyPersonalNumber `E.hasInfix` E.val c) criteria @@ -447,7 +440,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do [ fltrUserNameEmailHdrUI MsgLmsUser mPrev , prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany) , prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumber) - , prismAForm (singletonFilter "avs-card" ) mPrev $ aopt textField (fslI MsgAvsCardNo) + , fltrAVSCardNosUI mPrev , prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo) , prismAForm (singletonFilter "validity" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid) , if isNothing mbRenewal then mempty @@ -602,7 +595,10 @@ postQualificationR sid qsh = do ) $ \( view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification , sortable (Just "lms-status-plus")(i18nCell MsgTableLmsStatus & cellTooltipWgt Nothing (lmsStatusInfoCell isAdmin auditMonths)) $ \(preview $ resultLmsUser . _entityVal -> lu) -> foldMap (lmsStatusCell isAdmin linkLmsUser) lu - , sortable (Just "last-notified") (i18nCell MsgTableQualificationLastNotified) $ \( view $ resultQualUser . _entityVal . _qualificationUserLastNotified -> d) -> dateTimeCell d + -- QualificationUserLastNotified is about notification on actual validity changes. If a user's licence is about to expire and renewed before expiry via e-learning, this value does not change. + -- NOTE: If this column is reinstatiated, header and tooltip were already updated to avoid any confusion! + -- , sortable (Just "last-notified") (i18nCell MsgTableQualificationLastNotified & cellTooltip MsgTableQualificationLastNotifiedTooltip) + -- $ \( view $ resultQualUser . _entityVal . _qualificationUserLastNotified -> d) -> dateTimeCell d ] psValidator = def & defaultSorting [SortDescBy "last-refresh"] tbl <- mkQualificationTable isAdmin qent acts colChoices psValidator diff --git a/src/Handler/School.hs b/src/Handler/School.hs index 48693c517..c8a45c026 100644 --- a/src/Handler/School.hs +++ b/src/Handler/School.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Winnie Ros +-- SPDX-FileCopyrightText: 2022-2024 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Winnie Ros ,David Mosbach -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -171,6 +171,7 @@ postSchoolEditR ssh = do , formEncoding = sfEnctype , formAttrs = [] , formSubmit = FormSubmit + , formCustomBtn = Nothing :: Maybe ButtonSubmit , formAnchor = Nothing :: Maybe Text } @@ -232,6 +233,7 @@ postSchoolNewR = do , formEncoding = sfEnctype , formAttrs = [] , formSubmit = FormSubmit + , formCustomBtn = Nothing :: Maybe ButtonSubmit , formAnchor = Nothing :: Maybe Text } diff --git a/src/Handler/Sheet/PersonalisedFiles.hs b/src/Handler/Sheet/PersonalisedFiles.hs index 2d521aca4..ed580d256 100644 --- a/src/Handler/Sheet/PersonalisedFiles.hs +++ b/src/Handler/Sheet/PersonalisedFiles.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Winnie Ros +-- SPDX-FileCopyrightText: 2022-2024 Gregor Kleen ,Sarah Vaupel ,Winnie Ros ,David Mosbach -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -425,7 +425,7 @@ getPersonalFilesR cId mbsid = do { formMethod = GET , formAction = SomeRoute <$> cRoute , formEncoding = psfEnctype - , formAttrs = formAttrs def <> bool mempty [("uw-no-navigate-away-prompt", ""), ("target", "_blank")] isModal + , formAttrs = formAttrs (def @(FormSettings UniWorX)) <> bool mempty [("uw-no-navigate-away-prompt", ""), ("target", "_blank")] isModal } getSPersonalFilesR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler TypedContent diff --git a/src/Handler/SystemMessage.hs b/src/Handler/SystemMessage.hs index 05b327e00..0cc34a96e 100644 --- a/src/Handler/SystemMessage.hs +++ b/src/Handler/SystemMessage.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-2024 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,David Mosbach -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -135,6 +135,7 @@ postMessageR cID = do , formEncoding = modifyEnctype , formAttrs = [] , formSubmit = FormSubmit + , formCustomBtn = Nothing :: Maybe ButtonSubmit , formAnchor = Nothing :: Maybe Text } translationAddModal = modal [whamlet|_{MsgSystemMessageAddTranslation}|] . Right $ @@ -144,6 +145,7 @@ postMessageR cID = do , formEncoding = addTransEnctype , formAttrs = [] , formSubmit = FormSubmit + , formCustomBtn = Nothing :: Maybe ButtonSubmit , formAnchor = Nothing :: Maybe Text } translationsEditModal @@ -154,6 +156,7 @@ postMessageR cID = do , formEncoding = transEnctype , formAttrs = [] , formSubmit = FormNoSubmit + , formCustomBtn = Nothing :: Maybe ButtonSubmit , formAnchor = Nothing :: Maybe Text } [whamlet| diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 2af62ef7d..912e614ac 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -3,6 +3,7 @@ -- SPDX-License-Identifier: AGPL-3.0-or-later {-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE TypeApplications #-} module Handler.Users ( module Handler.Users @@ -25,8 +26,13 @@ import qualified Data.Set as Set import qualified Data.Map as Map import qualified Database.Esqueleto.Legacy as E +-- import Database.Esqueleto.Experimental ((:&)(..)) +import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma +import qualified Database.Esqueleto.PostgreSQL as E import qualified Database.Esqueleto.Utils as E + + import Handler.Profile (makeProfileData) import qualified Yesod.Auth.Util.PasswordStore as PWStore @@ -64,8 +70,8 @@ embedRenderMessage ''UniWorX ''UserAction id data UserActionData = UserLdapSyncData | UserHijack - | UserAddSupervisorData { getActionSupervisors :: Set Text, getActionRerouteNotifications :: Bool } - | UserSetSupervisorData { getActionSupervisors :: Set Text, getActionRerouteNotifications :: Bool } + | UserAddSupervisorData { getActionSupervisors :: Set Text, getActionRerouteNotifications :: Bool, getActionSupervisorReason :: Maybe Text } + | UserSetSupervisorData { getActionSupervisors :: Set Text, getActionRerouteNotifications :: Bool, getActionSupervisorReason :: Maybe Text } | UserRemoveSupervisorData | UserAvsSyncData deriving (Eq, Ord, Read, Show, Generic) @@ -80,7 +86,7 @@ isActionSupervisor UserSetSupervisorData{} = True isActionSupervisor _ = False -data AllUsersAction = AllUsersLdapSync +data AllUsersAction = AllUsersLdapSync | AllUsersAvsSync deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) deriving anyclass (Universe, Finite) @@ -192,9 +198,11 @@ postUsersR = do , singletonMap UserAddSupervisor $ UserAddSupervisorData <$> apopt (textField & cfAnySeparatedSet) (fslI MsgTableSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing <*> apopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just True) + <*> aopt textField (fslI MsgSupervisorReason) Nothing , singletonMap UserSetSupervisor $ UserSetSupervisorData <$> apopt (textField & cfAnySeparatedSet) (fslI MsgTableSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing <*> apopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just True) + <*> aopt textField (fslI MsgSupervisorReason) Nothing , singletonMap UserRemoveSupervisor $ pure UserRemoveSupervisorData ] @@ -368,10 +376,10 @@ postUsersR = do addMessageI Success . MsgSynchroniseLdapUserQueued $ Set.size userSet redirectKeepGetParams UsersR (UserAvsSyncData, userSet) -> do - forM_ userSet $ \uid -> queueJob' $ JobSynchroniseAvsUser uid Nothing - addMessageI Success . MsgSynchroniseAvsUserQueued $ Set.size userSet + queueAvsUpdateByUID userSet Nothing + addMessageI Success . MsgSynchroniseAvsUserQueued $ Set.size userSet redirectKeepGetParams UsersR - (UserHijack, Set.minView -> Just (uid, _)) -> + (UserHijack, Set.lookupMin -> Just uid) -> hijackUser uid >>= sendResponse (UserRemoveSupervisorData, userSet) -> do runDB $ deleteWhere [UserSupervisorUser <-. Set.toList userSet] @@ -385,7 +393,7 @@ postUsersR = do nrSuperNotFound = length supersNotFound runDB $ do unless (isNotSetSupervisor act) $ deleteWhere [UserSupervisorUser <-. users] - putMany [UserSupervisor s u r + putMany [UserSupervisor s u r Nothing (getActionSupervisorReason act) | let r = getActionRerouteNotifications act , (_, Just s) <- supersFound , u <- users @@ -403,6 +411,20 @@ postUsersR = do runDBJobs . runConduit $ selectSource [] [] .| C.mapM_ (queueDBJob . JobSynchroniseLdapUser . entityKey) addMessageI Success MsgSynchroniseLdapAllUsersQueued redirect UsersR + AllUsersAvsSync -> do + nowaday <- liftIO getCurrentTime <&> utctDay + n <- runDB $ Ex.insertSelectCount $ do + usr <- Ex.from $ Ex.table @User + return (AvsSync + Ex.<# (usr Ex.^. UserId) + Ex.<&> E.now_ + -- Ex.<&> Ex.just (E.day E.now_) -- don't use DB time here, since job handler compares with FRADrive clock + Ex.<&> E.justVal nowaday + ) + queueJob' JobSynchroniseAvsQueue + addMessageI Success $ MsgSynchroniseAvsAllUsersQueued n + redirect UsersR + let allUsersWgt' = wrapForm allUsersWgt def { formSubmit = FormNoSubmit , formAction = Just $ SomeRoute UsersR diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index 4648cf647..8043737de 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -161,4 +161,33 @@ reloadKeepGetParams r = liftHandler $ do redirectKeepGetParams :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route (HandlerSite m) -> m a redirectKeepGetParams route = liftHandler $ do getps <- reqGetParams <$> getRequest - redirect (route, getps) \ No newline at end of file + redirect (route, getps) + + +adminProblemCell :: IsDBTable m a => AdminProblem -> DBCell m a +-- note that adminProblemCompany/adminProblemCompanyOld and adminProblemUser are automatically displayed within their own columns +adminProblemCell AdminProblemNewCompany{} + = i18nCell MsgAdminProblemNewCompany +adminProblemCell AdminProblemSupervisorNewCompany{adminProblemCompanyNew, adminProblemSupervisorReroute} + = i18nCell (MsgAdminProblemSupervisorNewCompany adminProblemSupervisorReroute) <> companyIdCell adminProblemCompanyNew +adminProblemCell AdminProblemSupervisorLeftCompany{adminProblemSupervisorReroute} + = i18nCell (MsgAdminProblemSupervisorLeftCompany adminProblemSupervisorReroute) +adminProblemCell AdminProblemNewlyUnsupervised{adminProblemCompanyNew} + = i18nCell MsgAdminProblemNewlyUnsupervised <> companyIdCell adminProblemCompanyNew +adminProblemCell AdminProblemUnknown{adminProblemText} + = textCell $ "Problem: " <> adminProblemText + +company2msg :: CompanyId -> SomeMessage UniWorX +company2msg = text2message . ciOriginal . unCompanyKey + +msgAdminProblem :: AdminProblem -> DB (SomeMessages UniWorX) +msgAdminProblem AdminProblemNewCompany{adminProblemCompany=comp} = return $ + SomeMessages [SomeMessage MsgAdminProblemNewCompany, text2message ": ", company2msg comp] +msgAdminProblem AdminProblemSupervisorNewCompany{adminProblemCompany=comp, adminProblemCompanyNew=newComp, adminProblemSupervisorReroute=rer} = return $ + SomeMessages [SomeMessage $ MsgAdminProblemSupervisorNewCompany rer, text2message ": ", company2msg comp, text2message " -> ", company2msg newComp] +msgAdminProblem AdminProblemSupervisorLeftCompany{adminProblemCompany=comp, adminProblemSupervisorReroute=rer} = return $ + SomeMessages [SomeMessage $ MsgAdminProblemSupervisorLeftCompany rer, text2message ": ", company2msg comp] +msgAdminProblem AdminProblemNewlyUnsupervised{adminProblemCompanyOld=comp, adminProblemCompanyNew=newComp} = return $ + SomeMessages [SomeMessage MsgAdminProblemNewlyUnsupervised, text2message ": ", maybe (text2message "???") company2msg comp, text2message " -> ", company2msg newComp] +msgAdminProblem AdminProblemUnknown{adminProblemText=err} = return $ + someMessages ["Problem: ", err] \ No newline at end of file diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 42275f139..0d5efb874 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -1,26 +1,36 @@ --- SPDX-FileCopyrightText: 2022-23 Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeApplications, ExistentialQuantification #-} +{-# OPTIONS_GHC -fno-warn-unused-top-binds #-} -- Module for functions directly related to the AVS interface, -- for utilities dealing with FraDrive Qualification types see Handler.Utils.Qualification +-- NOTE: Several ifdef DEVELOPMENT used, so UNSET DEVELOPMENT and build before comitting. module Handler.Utils.Avs ( guessAvsUser - , upsertAvsUser, upsertAvsUserById, upsertAvsUserByCard + , upsertAvsUserByCard + , upsertAvsUserById + , updateAvsUserByIds + , linktoAvsUserByUIDs + , queueAvsUpdateByUID, queueAvsUpdateByAID -- , getLicence, getLicenceDB, getLicenceByAvsId -- not supported by interface , AvsLicenceDifferences(..) , setLicence, setLicenceAvs, setLicencesAvs , retrieveDifferingLicences, retrieveDifferingLicencesStatus , computeDifferingLicences - , synchAvsLicences - , lookupAvsUser, lookupAvsUsers + -- , synchAvsLicences + , queryAvsFullStatus + -- , lookupAvsUser, lookupAvsUsers , AvsException(..) , updateReceivers , AvsPersonIdMapPersonCard + -- CR3 + , SomeAvsQuery(..) + , queryAvsCardNo, queryAvsCardNos ) where import Import @@ -28,24 +38,32 @@ import Import -- import Handler.Utils -- import qualified Database.Esqueleto.Legacy as E -import Utils.Avs -import Utils.Users import qualified Data.Set as Set import qualified Data.Map as Map import qualified Data.Text as Text -import qualified Data.CaseInsensitive as CI +-- import qualified Data.CaseInsensitive as CI + +import qualified Control.Monad.Catch as Catch + -- import Auth.LDAP (ldapUserPrincipalName) import Foundation.Yesod.Auth (ldapLookupAndUpsert) -- , CampusUserConversionException()) +import Jobs.Queue + +import Utils.Avs +import Utils.Users +import Handler.Utils.Users import Handler.Utils.Company import Handler.Utils.Qualification +import Handler.Utils.Memcached import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma import qualified Database.Esqueleto.Utils as E +-- import qualified Database.Esqueleto.PostgreSQL as E - +import Servant.Client.Core.ClientError (ClientError) @@ -55,71 +73,646 @@ import qualified Database.Esqueleto.Utils as E data AvsException = AvsInterfaceUnavailable -- Interface to AVS was not configured at startup or does not respond - | AvsUserUnassociated UserId -- Manipulating AVS Data for a user that is not linked to AVS yet - | AvsUserUnknownByAvs AvsPersonId -- AvsPersonId not (or no longer) found in AVS DB - | AvsUserAmbiguous AvsPersonId -- Multiple matching existing users found in our DB + | AvsUserUnassociated Text -- Manipulating AVS Data for a user that is not linked to AVS yet + | AvsUserUnknownByAvs AvsPersonId -- AvsPersonId not (or no longer) found in AVS + | AvsUserAmbiguous AvsPersonId -- Multiple matching existing users found for a query in AVS or DB + | AvsStatusSearchEmpty -- AvsStatusSearch returned empty result | AvsPersonSearchEmpty -- AvsPersonSearch returned empty result | AvsPersonSearchAmbiguous -- AvsPersonSearch returned more than one result | AvsSetLicencesFailed Text -- AvsSetLicence total failure + | AvsIdMismatch AvsPersonId AvsPersonId -- First AVS Id was requested, but second one was returned for that query + | AvsUserCreationFailed AvsPersonId deriving (Show, Eq, Ord, Generic) instance Exception AvsException +embedRenderMessage ''UniWorX ''AvsException id -- display as feedback for user initiated actions -- moved to Foundation.I18n {- Error Handling: in Addition to AvsException, Servant.ClientError must be expected. Maybe we should wrap it within an AvsException? -} +-- | Catch AVS exceptions and display them as messages +catchAVS2message :: (MonadHandler m, MonadCatch m, RenderMessage (HandlerSite m) AvsException) => m (Maybe a) -> m (Maybe a) +-- catchAVS2message :: Handler (Maybe a) -> Handler (Maybe a) +catchAVS2message = catchAVShandler False False True Nothing + +-- | Catch AVS exceptions and ignore them, but display them as messages +catchAVS2log :: (MonadHandler m, MonadCatch m, RenderMessage (HandlerSite m) AvsException) => m (Maybe a) -> m (Maybe a) +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' :: (MonadHandler m, MonadCatch m, RenderMessage (HandlerSite m) AvsException, Monoid a) => m a -> m () +-- catchAll2log' = voidMaybe $ catchAVShandler True True False mempty + +catchAVShandler :: (MonadHandler m, MonadCatch m, RenderMessage (HandlerSite m) AvsException) => Bool -> Bool -> Bool -> a -> m a -> m a +catchAVShandler allEx toLog toMsg dft act = act `catches` (avsHandlers <> allHandlers) + where + avsHandlers = + [ Catch.Handler (\(exc::AvsException) -> liftHandler $ do + let txt = "AVS exception ignored: " <> tshow exc + when toLog $ $logErrorS "AVS" txt + when toMsg $ addMessageI Warning exc + return dft + ) + + , Catch.Handler (\(exc::ClientError ) -> liftHandler $ do + let txt = "AVS fatal communicaton failure: " <> tshow exc + when toLog $ $logErrorS "AVS" txt + when toMsg $ addMessage Warning $ toHtml txt + return dft + ) + ] + allHandlers = guardMonoid allEx + [ Catch.Handler (\(exc::SomeException) -> liftHandler $ do + let txt = "AVS fatal unknown failure: " <> tshow exc + when toLog $ $logErrorS "AVS" txt + when toMsg $ addMessage Error $ toHtml txt + return dft + ) + ] ------------------ -- AVS Handlers -- ------------------ -{- - TODOs - Connect AVS query to LDAP queries for automatic synchronisation: - - add query to Auth.LDAP.campusUserMatr - - add query to Auth.LDAP.campusLogin - - jobs.Handler.dispatchJobSynchroniseLdap --} +-- convenience wrapper for easy replacement with true status query +queryAvsFullStatus :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) => AvsPersonId -> m AvsResponseStatus +queryAvsFullStatus api = + lookupAvsUser api <&> \case + Just AvsDataPerson{avsPersonPersonCards=cards} + | notNull cards -> AvsResponseStatus $ Set.singleton $ AvsStatusPerson api cards + _otherwise -> AvsResponseStatus mempty -{- AVS interface only allows collecting all licences at once, thus getLicence should be avoided, see getLicenceByAvsId including a workaround --- Do we need this? --- getLicence :: UserId -> Handler (Maybe AvsLicence) -- with runDB -getLicence :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, WithRunDB SqlReadBackend (HandlerFor UniWorX) m ) => UserId -> m (Maybe AvsLicence) -getLicence uid = do - AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery - Entity _ UserAvs{..} <- maybeThrowM (AvsUserUnassociated uid) $ useRunDB $ getBy $ UniqueUserAvsUser uid - AvsResponseGetLicences licences <- throwLeftM $ avsQueryGetLicences $ AvsQueryGetLicences $ Set.singleton $ AvsObjPersonId userAvsPersonId - let ulicence = Set.lookupMax $ Set.filter ((userAvsPersonId ==) . avsLicencePersonID) licences - return (avsLicenceRampLicence <$> ulicence) +-- TODO: delete deprecated Utility Functions from Utils.Avs as well -- still needed, since avsStatusQuery does not deliver company names tied to cards +lookupAvsUser :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) => + AvsPersonId -> m (Maybe AvsDataPerson) +lookupAvsUser api = Map.lookup api <$> lookupAvsUsers (Set.singleton api) -getLicenceDB :: UserId -> DB (Maybe AvsLicence) -getLicenceDB uid = do - AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ liftHandler $ getsYesod $ view _appAvsQuery - Entity _ UserAvs{..} <- maybeThrowM (AvsUserUnassociated uid) $ getBy $ UniqueUserAvsUser uid - AvsResponseGetLicences licences <- throwLeftM $ avsQueryGetLicences $ AvsQueryGetLicences $ Set.singleton $ AvsObjPersonId userAvsPersonId - let ulicence = Set.lookupMax $ Set.filter ((userAvsPersonId ==) . avsLicencePersonID) licences - return (avsLicenceRampLicence <$> ulicence) +-- | retrieves complete avs user records for given AvsPersonIds. +-- Note that this requires several AVS-API queries, since +-- - avsQueryPerson does not support querying an AvsPersonId directly +-- - avsQueryStatus only provides limited information +-- avsQuery is used to obtain all card numbers, which are then queried separately an merged +-- May throw Servant.ClientError or AvsExceptions +-- Does not write to our own DB! +lookupAvsUsers :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) => + Set AvsPersonId -> m (Map AvsPersonId AvsDataPerson) +lookupAvsUsers apis = do + AvsResponseStatus statuses <- avsQuery $ AvsQueryStatus apis + let forFoldlM = $(permuteFun [3,2,1]) foldlM + forFoldlM statuses mempty $ \acc1 AvsStatusPerson{avsStatusPersonCardStatus=cards} -> + forFoldlM cards acc1 $ \acc2 AvsDataPersonCard{avsDataCardNo, avsDataVersionNo} -> do + AvsResponsePerson adps <- avsQuery $ def{avsPersonQueryCardNo = Just avsDataCardNo, avsPersonQueryVersionNo = Just avsDataVersionNo} + return $ mergeByPersonId adps acc2 --- | Should be avoided, since all licences must be requested at once. -getLicenceByAvsId :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => - Set AvsPersonId -> m (Set AvsPersonLicence) -getLicenceByAvsId aids = do - AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ liftHandler $ getsYesod $ view _appAvsQuery - AvsResponseGetLicences licences <- throwLeftM avsQueryGetAllLicences - return $ Set.filter (\x -> avsLicencePersonID x `Set.member` aids) licences --} +-- | Like `Handler.Utils.getReceivers`, but calls upsertAvsUserById on each user to ensure that postal address is up-to-date +updateReceivers :: UserId -> Handler (Entity User, [Entity User], Bool) +updateReceivers uid = do + -- First perform AVS update for receiver + runDB (getBy (UniqueUserAvsUser uid)) >>= \case + Just Entity{entityVal=UserAvs{userAvsPersonId = apid}} -> catchAll2log $ upsertAvsUserById apid + Nothing -> return () + -- Retrieve updated user and supervisors now + (underling :: Entity User, avsSupers :: [(E.Value UserId, E.Value (Maybe AvsPersonId))]) <- runDB $ (,) + <$> getJustEntity uid + <*> (E.select $ do + (usrSuper :& usrAvs) <- + E.from $ E.table @UserSupervisor + `E.leftJoin` E.table @UserAvs + `E.on` (\(usrSuper :& userAvs) -> usrSuper E.^. UserSupervisorSupervisor E.=?. userAvs E.?. UserAvsUser) + E.where_ $ (usrSuper E.^. UserSupervisorUser E.==. E.val uid) + E.&&. (usrSuper E.^. UserSupervisorRerouteNotifications) + pure (usrSuper E.^. UserSupervisorSupervisor, usrAvs E.?. UserAvsPersonId) + ) + let (superVs, avsIds) = unzip avsSupers + receiverIDs :: [UserId] = E.unValue <$> superVs + toUpdate = Set.fromList $ mapMaybe E.unValue avsIds + directResult = return (underling, pure underling, True) -- already contains updated address + forM_ toUpdate (catchAll2log . upsertAvsUserById) -- attempt to update postaddress from AVS + if null receiverIDs + then directResult + else do + receivers <- runDB $ selectList [UserId <-. receiverIDs] [] -- due to possible address updates, we must runDB once more and cannot join above + if null receivers + then directResult + else return (underling, receivers, uid `elem` (entityKey <$> receivers)) --- setLicence :: (MonadHandler m, MonadThrow m, HandlerSite m ~ UniWorX) => UserId -> AvsLicence -> m Bool + +------------------ +-- CR3 Functions + + +-- | `SomeAvsQuery` is an umbrella to unify usage of all AVS queries, since Servant required separate types to fit the existing AVS-VSM API +class SomeAvsQuery q where + type SomeAvsResponse q :: Type + pickQuery :: (MonadIO m) => AvsQuery -> q -> m (Either ClientError (SomeAvsResponse q)) + -- | send query to AVS or maybe look it up within cache, depending on the type of the query + avsQuery :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m) => q -> m (SomeAvsResponse q) + avsQuery = avsQueryNoCache + -- | send query to AVS directly, never cached + avsQueryNoCache :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m) => q -> m (SomeAvsResponse q) + avsQueryNoCache = avsQueryNoCacheDefault + +avsQueryNoCacheDefault :: (SomeAvsQuery q + , MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m) => q -> m (SomeAvsResponse q) +avsQueryNoCacheDefault qry = do + qfun <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ preview (_appAvsQuery . _Just . to pickQuery) + throwLeftM $ qfun qry + +avsQueryCached :: (SomeAvsQuery q, Binary q, Binary (SomeAvsResponse q), Typeable (SomeAvsResponse q), NFData (SomeAvsResponse q) + , MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m) => q -> m (SomeAvsResponse q) +avsQueryCached qry = + getsYesod (preview $ _appAvsConf . _Just . _avsCacheExpiry) >>= \case + Just t | t > 1 -> memcachedBy (Just $ Right t) qry $ avsQueryNoCache qry + _ -> avsQueryNoCache qry + +instance SomeAvsQuery AvsQueryPerson where + type SomeAvsResponse AvsQueryPerson = AvsResponsePerson + pickQuery = avsQueryPerson + avsQuery = avsQueryCached + +instance SomeAvsQuery AvsQueryStatus where + type SomeAvsResponse AvsQueryStatus = AvsResponseStatus + pickQuery = avsQueryStatus + avsQuery = avsQueryCached + +instance SomeAvsQuery AvsQueryContact where + type SomeAvsResponse AvsQueryContact = AvsResponseContact + pickQuery = avsQueryContact + avsQuery = avsQueryCached + +instance SomeAvsQuery AvsQuerySetLicences where + type SomeAvsResponse AvsQuerySetLicences = AvsResponseSetLicences + pickQuery = avsQuerySetLicences + -- NOTE: avsQuery = avsQueryCached -- should not and indeed does not compile + avsQueryNoCache qry = avsQueryNoCacheDefault qry + <* memcachedInvalidate (Proxy @AvsResponseContact) -- invalidate all AvsResponseContact which may contain RampLicence info, since keys may comprise several ids + +instance SomeAvsQuery AvsQueryGetAllLicences where + type SomeAvsResponse AvsQueryGetAllLicences = AvsResponseGetLicences + pickQuery = const . avsQueryGetAllLicences + + + +queryAvsCardNos :: Foldable t => t (Either AvsCardNo AvsFullCardNo) -> Handler (Set AvsPersonId) +queryAvsCardNos = foldMapM queryAvsCardNo + +queryAvsCardNo :: Either AvsCardNo AvsFullCardNo -> Handler (Set AvsPersonId) +queryAvsCardNo crd = do + AvsResponsePerson adps <- avsQuery $ qry crd + return $ Set.map avsPersonPersonID adps + where + qry (Left acno) = def{ avsPersonQueryCardNo = Just acno } + qry (Right AvsFullCardNo{..}) = def{ avsPersonQueryCardNo = Just avsFullCardNo + , avsPersonQueryVersionNo = Just avsFullCardVersion + } + +-- | Queries AVS Status to retrieve primary card (heursitic) +queryAvsPrimaryCard :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m) => AvsPersonId -> m (Maybe AvsDataPersonCard) +queryAvsPrimaryCard api = runMaybeT $ do + AvsResponseStatus res <- MaybeT . catchAVS2log . fmap Just . avsQuery . AvsQueryStatus $ Set.singleton api + pstatus <- hoistMaybe $ Set.lookupMax $ Set.filter ((api ==) . avsStatusPersonID) res + hoistMaybe $ Set.lookupMax $ avsStatusPersonCardStatus pstatus + +-- | Queries AVS to retrieve CardNo from primary card (heursitic) +queryAvsFullCardNo :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m) => AvsPersonId -> m (Maybe AvsFullCardNo) +queryAvsFullCardNo = fmap (fmap getFullCardNo) . queryAvsPrimaryCard + + + + +-- | Like `updateAvsUserByIds`, but exceptions are not caught here to allow rollbacks +updateAvsUserById :: AvsPersonId -> DB (Maybe UserId) +updateAvsUserById apid = do + AvsResponseContact adcs <- avsQuery $ AvsQueryContact $ Set.singleton $ AvsObjPersonId apid + let res = Set.filter ((== apid) . avsContactPersonID) adcs + snd <<$>> traverseJoin updateAvsUserByADC (Set.lookupMax res) + +-- | Variant of `updateAvsUserByIds'` that catches and logs all exceptions +updateAvsUserByIds :: Set AvsPersonId -> Handler (Set (AvsPersonId, UserId)) +updateAvsUserByIds = catchAVShandler True True False mempty . updateAvsUserByIds' + +-- | Update given AvsPersonIds by querying AVS for each; update only, no insertion! Uses batch mechanism and should not throw. Each user dealt within own runDB, i.e. own DB transaction +updateAvsUserByIds' :: Set AvsPersonId -> Handler (Set (AvsPersonId, UserId)) +updateAvsUserByIds' apids = do + -- apids <- Set.fromList <$> E.filterExists UserAvsPersonId apids0 --not needed anymore, we expect the set to be linked + AvsResponseContact adcs <- avsQuery $ AvsQueryContact $ Set.mapMonotonic AvsObjPersonId apids -- automatically batched + let requestedAnswers = Set.filter (view (_avsContactPersonID . to (`Set.member` apids))) adcs -- should not occur, neither should one apid occur multiple times within the response (if so, all responses processed here in random order) + (oks,bad) <- foldlM procResp mempty requestedAnswers + let missing = Set.toList $ Set.difference (Set.difference apids $ Set.map fst oks) bad + unless (null missing) $ do + now <- liftIO getCurrentTime + runDB $ updateWhere [UserAvsPersonId <-. missing] [UserAvsLastSynch =. now, UserAvsLastSynchError =. Just "Avs contact info unknown for AvsPersonId"] -- all others were already marked as updated + return oks + where + procResp :: (Set (AvsPersonId, UserId), Set AvsPersonId) -> AvsDataContact -> Handler (Set (AvsPersonId, UserId), Set AvsPersonId) + procResp (accOk, accBad) adc = do + let errHandler e = runDB $ do + let apid = avsContactPersonID adc + now <- liftIO getCurrentTime + updateBy (UniqueUserAvsId apid) [UserAvsLastSynch =. now, UserAvsLastSynchError =. Just (tshow e)] + return (accOk, Set.insert apid accBad) + updateAvsUserByADC' :: DB (Set (AvsPersonId, UserId), Set AvsPersonId) + updateAvsUserByADC' = do + res <- updateAvsUserByADC adc + return (maybeInsert res accOk, accBad) + catchAll (runDB updateAvsUserByADC') errHandler + + +updateAvsUserByADC :: AvsDataContact -> DB (Maybe (AvsPersonId, UserId)) +updateAvsUserByADC (AvsDataContact apid newAvsPersonInfo newAvsFirmInfo) = runMaybeT $ do + (Entity uaId usravs) <- MaybeT $ getBy $ UniqueUserAvsId apid + let usrId = userAvsUser usravs + usr <- MaybeT $ get usrId + lift $ do -- maybeT no longer needed from here onwards + newAvsCardNo <- queryAvsFullCardNo apid -- Nothing os ok here, does not throw + now <- liftIO getCurrentTime + let oldAvsPersonInfo = userAvsLastPersonInfo usravs -- Nothing is ok here + oldAvsFirmInfo = userAvsLastFirmInfo usravs -- Nothing is ok here + oldAvsCardNo = userAvsLastCardNo usravs & fmap Just + per_ups = mapMaybe (mkUpdate' usr newAvsPersonInfo oldAvsPersonInfo) + [ CheckUpdate UserFirstName _avsInfoFirstName + , CheckUpdate UserSurname _avsInfoLastName + , CheckUpdate UserDisplayName _avsInfoDisplayName + , CheckUpdate UserBirthday _avsInfoDateOfBirth + , CheckUpdate UserMobile _avsInfoPersonMobilePhoneNo + , CheckUpdate UserMatrikelnummer $ _avsInfoPersonNo . re _Just -- Maybe im User, aber nicht im AvsInfo; also: `re _Just` work like `to Just` + , CheckUpdate UserCompanyPersonalNumber $ _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just -- Maybe im User und im AvsInfo + ] + em_p_up = mkUpdate' usr newAvsPersonInfo oldAvsPersonInfo $ + CheckUpdate UserDisplayEmail $ _avsInfoPersonEMail . to (fromMaybe mempty) . from _CI -- Maybe im AvsInfo, aber nicht im User + em_f_up = mkUpdate' usr newAvsFirmInfo oldAvsFirmInfo $ -- Email updates erfolgen nur, wenn identisch. Für Firmen-Email leer lassen. + CheckUpdate UserDisplayEmail $ _avsFirmPrimaryEmail . to (fromMaybe mempty) . from _CI + eml_up = em_p_up <|> em_f_up -- ensure that only one email update is produced; there is no Eq instance for the Update type + frm_up = mkUpdate' usr newAvsFirmInfo oldAvsFirmInfo $ -- Legacy, if company postal is stored in user; should no longer be true for new users, + CheckUpdate UserPostAddress _avsFirmPostAddress -- since company address should now be referenced with UserCompany instead + pin_up = mkUpdate' usr newAvsCardNo oldAvsCardNo $ -- Maybe update PDF pin to latest card + CheckUpdate UserPinPassword $ to $ fmap avsFullCardNo2pin -- _Just . to avsFullCardNo2pin . re _Just + usr_up1 = eml_up `mcons` (frm_up `mcons` (pin_up `mcons` per_ups)) + avs_ups = ((UserAvsNoPerson =.) <$> readMay (avsInfoPersonNo newAvsPersonInfo)) `mcons` + [ UserAvsLastSynch =. now + , UserAvsLastSynchError =. Nothing + , UserAvsLastPersonInfo =. Just newAvsPersonInfo + , UserAvsLastFirmInfo =. Just newAvsFirmInfo + , UserAvsLastCardNo =. newAvsCardNo + ] + -- update company association & supervision + Entity{entityKey=newCompanyId} <- upsertAvsCompany newAvsFirmInfo oldAvsFirmInfo + oldCompanyEnt <- getAvsCompany `traverseJoin` oldAvsFirmInfo + primaryCompanyId <- userCompanyCompany <<$>> getUserPrimaryCompany usrId + let oldCompanyId = entityKey <$> oldCompanyEnt + -- oldCompanyMb = entityVal <$> oldCompanyEnt + -- pst_up = if + -- -- | isNothing oldCompanyMb || oldCompanyId == primaryCompanyId -- refactor could replace next 4 lines + -- -- -> mkUpdate' usr newCompany oldCompanyMb $ CheckUpdate UserPrefersPostal _companyPrefersPostal -- always update if company association is fresh (case should not occur in practice though) + -- | isNothing oldCompanyMb + -- -> mkUpdateDirect usr newCompany $ CheckUpdate UserPrefersPostal _companyPrefersPostal -- always update if company association is fresh (case should not occur in practice though) + -- | oldCompanyId == primaryCompanyId -- && isJust oldCompanyId -- is ensured by previous line + -- -> mkUpdate usr newCompany oldCompanyMb $ CheckUpdate UserPrefersPostal _companyPrefersPostal -- possibly change postal preference + -- | otherwise + -- -> Nothing + superReasonComDef = tshow SupervisorReasonCompanyDefault + newUserComp = UserCompany usrId newCompanyId False False 1 True -- default value for new company insertion, if no update can be done + + + usr_up2 <- case oldAvsFirmInfo of + _ | Just newCompanyId == oldCompanyId -- company unchanged entirely + -> return mempty -- => do nothing + (Just oafi) | ((==) `on` view _avsFirmPostAddressSimple) oafi newAvsFirmInfo -- company address unchanged OR + || ((==) `on` view _avsFirmPrimaryEmail) oafi newAvsFirmInfo -- company primary email unchanged + -> do -- => just update user company association, keeping supervision privileges + case oldCompanyId of + Nothing -> void $ insertUnique newUserComp -- it's ok if this already exists + Just ocid -> do + void $ upsertBySafe (UniqueUserCompany usrId ocid) newUserComp (_userCompanyCompany .~ newCompanyId) -- keep default supervisor settings + void $ updateWhere [ UserSupervisorSupervisor ==. usrId -- update company-related supervisions + , UserSupervisorCompany ==. Just ocid -- to new company, regardless of + , UserSupervisorReason ==. Just superReasonComDef] -- user + [ UserSupervisorCompany =. Just newCompanyId] + return mempty + _ | Just newCompanyId == primaryCompanyId -- old primaryCompany is now also AVS-company + -> do + whenIsJust oldCompanyId $ \oldCid -> do + deleteBy $ UniqueUserCompany usrId oldCid + deleteWhere $ (UserSupervisorUser ==. usrId):(UserSupervisorCompany ==. oldCompanyId):(UserSupervisorReason ~=. superReasonComDef) + return mempty + _ -- company changed completely + -> do + (pst_up, problems) <- switchAvsUserCompany False False usrId newCompanyId + mapM_ reportAdminProblem problems + -- Following line does not type, hence additional parameter needed + -- return [ u | u@Update{updateField=f} <- pst_up, f /= UserPostAddress ] -- already computed in frm_up above, duplicate update must be prevented (version above accounts for legacy updates) + return pst_up + -- SPECIALISED CODE, PROBABLY DEPRECATED + -- switch user company, keeping old priority + -- (getBy . UniqueUserCompany usrId) `traverseJoin` oldCompanyId >>= \case + -- Nothing -> + -- void $ insertUnique newUserComp + -- Just Entity{entityKey=ucidOld, entityVal=UserCompany{userCompanyCompany, userCompanySupervisor, userCompanySupervisorReroute, userCompanyPriority}} -> do + -- when userCompanySupervisor $ reportAdminProblem $ AdminProblemSupervisorNewCompany usrId userCompanyCompany newCompanyId userCompanySupervisorReroute + -- delete ucidOld + -- void $ insertUnique newUserComp{userCompanyPriority} -- keep priority, if insert succeeds + -- -- adjust supervison + -- let oldCompDefSuperFltr = mconcat [UserSupervisorCompany ~~. oldCompanyId, UserSupervisorReason ~=. superReasonComDef] + -- deleteWhere $ (UserSupervisorSupervisor ==. usrId) : oldCompDefSuperFltr + -- oldAPs <- deleteWhereCount $ (UserSupervisorUser ==. usrId) : oldCompDefSuperFltr + -- addCompanySupervisors newCompanyId usrId + -- newAPs <- count $ (UserSupervisorUser ==. usrId) : (UserSupervisorCompany ==. Just newCompanyId) : (UserSupervisorReason ~=. superReasonComDef) + -- when (oldAPs > 0 && newAPs <= 0) $ reportAdminProblem $ AdminProblemNewlyUnsupervised usrId oldCompanyId newCompanyId + -- return pst_up + repsertSuperiorSupervisor (Just newCompanyId) newAvsFirmInfo usrId -- ensure firmInfo superior is at least normal supervisor, must be executed after updating company default supervisors + update usrId $ usr_up2 <> usr_up1 -- update user eventually + update uaId avs_ups -- update stored avsinfo for future updates + return (apid, usrId) + + +linktoAvsUserByUIDs :: Set UserId -> Handler () +linktoAvsUserByUIDs uids = do + ips <- runDB $ E.select $ do + usr <- E.from $ E.table @User + let uid = usr E.^. UserId + ipn = usr E.^. UserCompanyPersonalNumber + E.where_ $ E.isJust ipn + E.&&. uid `E.in_` E.vals uids + E.&&. E.notExists (do + usrAvs <- E.from $ E.table @UserAvs + E.where_ $ uid E.==. usrAvs E.^. UserAvsUser + ) + return (uid, ipn) + mapM_ procUsr ips + where + procUsr (E.Value uid, E.Value (Just ipn)) = catchAll2log $ linktoAvsUserByUID uid $ mkAvsInternalPersonalNo ipn + procUsr _ = return () + +-- | similar to 'upsertAvsUserByCard', but accounts for the known UserId +linktoAvsUserByUID :: UserId -> AvsInternalPersonalNo -> Handler () +linktoAvsUserByUID uid aipn = do + AvsResponsePerson adps <- avsQuery $ def{avsPersonQueryInternalPersonalNo = Just aipn} + case Set.elems adps of + [] -> throwM AvsPersonSearchEmpty + (_:_:_) -> throwM AvsPersonSearchAmbiguous + [AvsDataPerson{avsPersonPersonID=api}] -> + void $ createAvsUserById (Just uid) api + +-- createAvsUserById :: Set AvsPersonId -> Handler (Set (AvsPersonId, UserId)) ??? +-- | Create new user from AVS-Id. Will throw an AvsException if this is not possible, e.g. due to Uniqueness Constraints +createAvsUserById :: Maybe UserId -> AvsPersonId -> Handler UserId +createAvsUserById muid api = do + AvsResponseContact contactRes <- avsQuery $ AvsQueryContact $ Set.singleton $ AvsObjPersonId api + case Set.toList contactRes of + [] -> throwM $ AvsUserUnknownByAvs api + (_:_:_) -> throwM $ AvsUserAmbiguous api + [AvsDataContact{avsContactPersonInfo=cpi, avsContactFirmInfo=firmInfo, avsContactPersonID}] + | avsContactPersonID /= api -> throwM $ AvsIdMismatch api avsContactPersonID + | otherwise -> do + -- check for matching existing user + let internalPersNo :: Maybe Text = cpi ^? _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo + persMail :: Maybe UserEmail = cpi ^? _avsInfoPersonEMail . _Just . from _CI + oldUsr <- runDB $ do + mbUid <- if isJust muid + then return muid + else firstJustM $ catMaybes + [ internalPersNo <&> (\ipn -> getKeyByFilter [UserCompanyPersonalNumber ==. Just ipn]) -- must ensure filter isnt ==. Nothing + , persMail <&> guessUserByEmail + ] + mbUAvs <- (getBy . UniqueUserAvsUser) `traverseJoin` mbUid + return (mbUid, mbUAvs) + usrCardNo <- queryAvsFullCardNo api + now <- liftIO getCurrentTime + let usrAvs uid mbFirmInfo = UserAvs + { userAvsPersonId = api + , userAvsUser = uid + , userAvsNoPerson = fromMaybe (negate $ avsPersonId api) $ readMay $ cpi ^. _avsInfoPersonNo -- negative personId as fallback, but readMay should never fail + , userAvsLastSynch = now + , userAvsLastSynchError = Nothing + , userAvsLastPersonInfo = Just cpi + , userAvsLastFirmInfo = mbFirmInfo + , userAvsLastCardNo = usrCardNo + } + case oldUsr of + (Nothing , Just _) -> throwM $ AvsUserUnknownByAvs api -- this case should never occur + (Just uid, Just Entity{entityVal=UserAvs{userAvsPersonId=api',userAvsUser=uid'}}) + | api /= api' -> throwM $ AvsIdMismatch api api' + | uid /= uid' -> throwM $ AvsUserAmbiguous api + | otherwise -> return uid -- nothing to do + (Just uid, Nothing) -> runDB $ do -- link with matching exisitng user + insert_ $ usrAvs uid Nothing -- company info should cause the user to be associated with the company during the update + updRes <- updateAvsUserById api -- no loop, since updateAvsUserById does not call createAvsUserById + case updRes of + Nothing -> throwM $ AvsUserUnknownByAvs api + Just uid' + | uid /= uid' -> throwM $ AvsUserAmbiguous api + | otherwise -> return uid + (Nothing, Nothing) -> do -- create fresh user + Entity{entityKey=cid, entityVal=cmp} <- runDB $ upsertAvsCompany firmInfo Nothing -- individual runDB, since no need to rollback + let pinPass = avsFullCardNo2pin <$> usrCardNo + newUserData = AddUserData + { audTitle = Nothing + , audFirstName = cpi ^. _avsInfoFirstName & Text.strip + , audSurname = cpi ^. _avsInfoLastName & Text.strip + , audDisplayName = cpi ^. _avsInfoDisplayName + , audDisplayEmail = persMail & fromMaybe mempty + , audEmail = persMail & fromMaybe ("AVSNO:" <> cpi ^. _avsInfoPersonNo . from _CI) + , audIdent = persMail & fromMaybe ("AVSID:" <> ciShow api ) + , audAuth = maybe AuthKindNoLogin (const AuthKindLDAP) internalPersNo + , audMatriculation = cpi ^. _avsInfoPersonNo & Just . tshow + , audSex = Nothing + , audBirthday = cpi ^. _avsInfoDateOfBirth + , audMobile = cpi ^. _avsInfoPersonMobilePhoneNo + , audTelephone = Nothing + , audFPersonalNumber = internalPersNo + , audFDepartment = toMaybe (isJust internalPersNo) (cmp ^. _companyShorthand . _CI) + , audPostAddress = Nothing -- always use company address indirectly + , audPrefersPostal = cmp ^. _companyPrefersPostal + , audPinPassword = pinPass + } + runDB $ do -- any failure must rollback all DB write transactions here + uid <- maybeThrowM (AvsUserCreationFailed api) $ addNewUserDB newUserData + let userComp = UserCompany uid cid False False 1 True -- default value for new company insertion, if no update can be done + void $ insertUnique userComp -- Nothing indicates that the user is already linked to the company (which is unlikely here) + -- Supervision + addCompanySupervisors cid uid + repsertSuperiorSupervisor (Just cid) firmInfo uid + -- Save AVS data for future updates + insert_ $ usrAvs uid $ Just firmInfo -- unlikely that uid cannot be linked with avsid, but throw if it is not possible + return uid + + +-- | upsert superior by eMail through LDAP only (currently no email search available in AVS) +repsertSuperiorSupervisor :: Maybe CompanyId -> AvsFirmInfo -> UserId -> DB () +repsertSuperiorSupervisor cid afi uid = + whenIsJust (afi ^. _avsFirmEMailSuperior) $ \supemail -> forMM_ + (altM (guessUserByEmail $ stripCI supemail) + (catchAVShandler True True False Nothing $ Just . entityKey <$> ldapLookupAndUpsert supemail) + ) $ \supid -> do + let reasonSuperior = Just $ tshow SupervisorReasonAvsSuperior + deleteWhere [UserSupervisorUser ==. uid, UserSupervisorSupervisor !=. supid, UserSupervisorReason ==. reasonSuperior] + void $ insertUnique $ UserSupervisor supid uid False cid reasonSuperior + + +-- | 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)) +getAvsCompany afi = + let compName :: CompanyName + compName = afi ^. _avsFirmFirm . from _CI + compShorthand :: CompanyShorthand + compShorthand = afi ^. _avsFirmAbbreviation . from _CI + compAvsId = afi ^. _avsFirmFirmNo + in firstJustM $ + bcons (compAvsId > 0) + ( getBy $ UniqueCompanyAvsId compAvsId ) + [ getBy $ UniqueCompanyName compName + , getEntity $ CompanyKey compShorthand + ] + +-- | 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 mbOldAvsFirmInfo = do + mbFirmEnt <- getAvsCompany newAvsFirmInfo -- primarily by AvsId, then Shorthand, then name + $logInfoS "AVS" [st|upsertAvsCompany: old #{tshow mbFirmEnt} new #{tshow newAvsFirmInfo}|] + case (mbFirmEnt, mbOldAvsFirmInfo) of + (Nothing, _) -> do -- insert new company, neither AvsId, Shorthand or Name are known to exist + let upd = flip updateRecord newAvsFirmInfo + dmy = Company -- mostly dummy, values are actually prodcued through firmInfo2company below for consistency + { companyName = newAvsFirmInfo ^. _avsFirmFirm . from _CI + , companyShorthand = newAvsFirmInfo ^. _avsFirmAbbreviation . from _CI + , companyAvsId = newAvsFirmInfo ^. _avsFirmFirmNo + , companyPrefersPostal = True + , companyPostAddress = newAvsFirmInfo ^. _avsFirmPostAddress + , companyEmail = newAvsFirmInfo ^? _avsFirmPrimaryEmail . _Just . from _CI + } + cmp = foldl' upd dmy $ firmInfo2key : firmInfo2companyUniques <> firmInfo2company + $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 + key_ups = mkUpdate' firm newAvsFirmInfo oldAvsFirmInfo firmInfo2key + uniq_ups <- maybeMapM (mkUpdateCheckUnique' firm newAvsFirmInfo oldAvsFirmInfo) firmInfo2companyUniques + $logInfoS "AVS" [st|Update company #{companyShorthand firm}: #{tshow (length cmp_ups)}, #{tshow (length key_ups)}, #{tshow (length uniq_ups)} for #{tshow newAvsFirmInfo}|] + res_cmp <- updateGetEntity firmid $ cmp_ups <> uniq_ups + case key_ups of + Nothing -> do + $logInfoS "AVS" "Update new company completed." + return res_cmp + Just key_up -> do + let compId = res_cmp ^. _entityVal . _companyAvsId + uniq_cmp = if compId > 0 then UniqueCompanyAvsId compId + else UniqueCompanyName $ res_cmp ^. _entityVal . _companyName + updateBy uniq_cmp [key_up] -- this is ok, since we have OnUpdateCascade on all CompanyId entries + $logInfoS "AVS" "Update new company completed." + maybeM (return res_cmp) return $ getBy uniq_cmp + + where + firmInfo2key = + CheckUpdate CompanyShorthand $ _avsFirmAbbreviation . from _CI -- Updating primary key works in principle thanks to OnUpdateCascade, but fails due to update get + firmInfo2companyUniques = + [ CheckUpdate CompanyName $ _avsFirmFirm . from _CI -- Updating unique turned out to be problematic, who would have thought! + , CheckUpdate CompanyAvsId _avsFirmFirmNo -- Updating unique turned out to be problematic, who would have thought! + ] + firmInfo2company = + [ CheckUpdate CompanyPostAddress _avsFirmPostAddress + , CheckUpdate CompanyEmail $ _avsFirmPrimaryEmail . _Just . from _CI . re _Just + -- , CheckUpdate CompanyPrefersPostal _avsFirmPrefersPostal -- Guessing here is not useful, since postal preference is ignored anyway when there is only one option available + ] + + + +queueAvsUpdateByUID :: (MonoFoldable mono, UserId ~ Element mono) => mono -> Maybe Day -> Handler () +queueAvsUpdateByUID uids pause = do + now <- liftIO getCurrentTime + runDB $ putMany [AvsSync uid now pause | uid <- toList uids] + queueJob' JobSynchroniseAvsQueue + +queueAvsUpdateByAID :: (MonoFoldable mono, AvsPersonId ~ Element mono) => mono -> Maybe Day -> Handler () +queueAvsUpdateByAID aids pause = do + now <- liftIO getCurrentTime + runDB $ do + uids <- E.select $ do + usrAvs <- E.from $ E.table @UserAvs + E.where_ $ usrAvs E.^. UserAvsPersonId `E.in_` E.vals aids + -- E.&&. (E.isNothing pause E.||. pause E.>. E.dayMaybe (usrAvs E.?. UserAvsLastSynch)) -- pause is checked later on in JobSynchroniseAvsQueue + return $ usrAvs E.^. UserAvsUser + putMany [AvsSync uid now pause | E.Value uid <- uids] + queueJob' JobSynchroniseAvsQueue + + +-- | Find or upsert User by AvsCardId (with dot), Fraport PersonalNumber, Fraport Email-Address or by prefixed AvsId or prefixed AvsNo; +-- fail-safe, may or may not update existing users, may insert new users +-- If an existing User with internal number is found, an AVS update query is executed +guessAvsUser :: Text -> Handler (Maybe UserId) +guessAvsUser (Text.splitAt 6 -> (Text.toUpper -> prefix, readMay -> Just nr)) + | prefix=="AVSID:" = + let avsid = AvsPersonId nr in + runDB (getBy $ UniqueUserAvsId avsid) >>= \case + (Just Entity{entityVal=UserAvs{userAvsUser=uid}}) -> return $ Just uid + Nothing -> catchAVS2message $ Just <$> upsertAvsUserById avsid + | prefix=="AVSNO:" = + runDB (view (_entityVal . _userAvsUser) <<$>> getByFilter [UserAvsNoPerson ==. nr]) +guessAvsUser someid@(discernAvsCardPersonalNo -> Just someavsid) = + catchAVS2message $ upsertAvsUserByCard someavsid >>= \case + Nothing | Left{} <- someavsid -> -- attempt to find PersonalNumber in DB + runDB (getKeyByFilter [UserCompanyPersonalNumber ==. Just someid]) + other -> return other +guessAvsUser someid = do + try (runDB $ ldapLookupAndUpsert someid) >>= \case + Right Entity{entityKey=uid, entityVal=User{userCompanyPersonalNumber=Just persNo}} -> do -- ensure internal user is linked to avs, if possible + let ldapUid = Just uid + avsUid <- catchAVS2message $ upsertAvsUserByCard $ Left $ mkAvsInternalPersonalNo persNo + unless (ldapUid == avsUid) $ addMessageI Warning MsgAvsPersonSearchAmbiguous + return ldapUid + Right Entity{entityKey=uid} -> return $ Just uid + other -> do -- attempt to recover by trying other ids + whenIsLeft other (\(err::SomeException) -> $logInfoS "AVS" $ "upsertAvsUser LDAP error " <> tshow err) -- this line primarily forces exception type to catch-all + runDB . runMaybeT $ + MaybeT (guessUserByEmail $ stripCI someid) -- recall that monadic actions are only executed until first success here + <|> MaybeT (getKeyByFilter [UserDisplayName ==. someid]) + + +-- | Given CardNo or internal Number, retrieve UserId. Create non-existing users, if possible. Always update. +-- Throws errors if the avsInterface in unavailable or the user is non-unique within external AVS DB. +upsertAvsUserByCard :: Either AvsInternalPersonalNo AvsFullCardNo -> Handler (Maybe UserId) +upsertAvsUserByCard persNo = do + let qry = case persNo of + Left fpn + -> def{ avsPersonQueryInternalPersonalNo = Just fpn } -- recall: default has all fields set to nothing + Right AvsFullCardNo{..} + -> def{ avsPersonQueryCardNo = Just avsFullCardNo, avsPersonQueryVersionNo = Just avsFullCardVersion } + -- NOTE: card validity might be outdated, so we must always check diretcly with avs and not within our DB! + AvsResponsePerson adps <- avsQuery qry + case Set.elems adps of + [] -> return Nothing -- throwM AvsPersonSearchEmpty -- since return a Maybe, there is no need to throw here + (_:_:_) -> throwM AvsPersonSearchAmbiguous + [AvsDataPerson{avsPersonPersonID=api}] -> Just <$> upsertAvsUserById api -- always triggers an update + + +-- | Retrieve and _always_ update user by AvsPersonId. Non-existing users are created. Ignore AVS licence status. Updates company, address, PinPassword +-- Throws errors if the avsInterface in unavailable or new user would violate uniqueness constraints +upsertAvsUserById :: AvsPersonId -> Handler UserId +upsertAvsUserById api = do + upd <- runDB (updateAvsUserById api) + case upd of + Nothing -> createAvsUserById Nothing api -- attempts to link to exisiting user vie UserCompanyPersonalNumber + (Just uid) -> return uid + +-- Licences setLicence :: (PersistUniqueRead backend, MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BaseBackend backend ~ SqlBackend) => UserId -> AvsLicence -> ReaderT backend m Bool -setLicence uid lic = do - Entity _ UserAvs{..} <- maybeThrowM (AvsUserUnassociated uid) $ getBy $ UniqueUserAvsUser uid - setLicenceAvs userAvsPersonId lic +setLicence uid lic = + getBy (UniqueUserAvsUser uid) >>= \case + Just Entity{entityVal=UserAvs{userAvsPersonId=api}} -> setLicenceAvs api lic + Nothing -> do + uname <- userDisplayName <<$>> get uid + throwM $ AvsUserUnassociated $ fromMaybe "user id unknown" uname setLicenceAvs :: (MonadHandler m, MonadThrow m, HandlerSite m ~ UniWorX) => AvsPersonId -> AvsLicence -> m Bool @@ -131,15 +724,13 @@ setLicenceAvs apid lic = do --setLicencesAvs :: Set AvsPersonLicence -> Handler Bool setLicencesAvs :: (MonadHandler m, MonadThrow m, HandlerSite m ~ UniWorX) => Set AvsPersonLicence -> m Int -setLicencesAvs persLics = do -- exceptT (return 0 <$ addMessage Error . text2Html . tshow) return $ do - AvsQuery{avsQuerySetLicences=aqsl} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery - aux aqsl 0 persLics +setLicencesAvs = aux 0 where - aux aqsl batch0_ok pls + aux batch0_ok pls | Set.null pls = return batch0_ok | otherwise = do let (batch1, batch2) = Set.splitAt avsMaxSetLicenceAtOnce pls - response <- throwLeftM $ aqsl $ AvsQuerySetLicences batch1 + response <- avsQueryNoCache $ AvsQuerySetLicences batch1 case response of AvsResponseSetLicencesError{..} -> do let msg = "Set AVS licences failed utterly: " <> avsResponseSetLicencesStatus <> ". Details: " <> cropText avsResponseSetLicencesMessage @@ -152,18 +743,15 @@ setLicencesAvs persLics = do -- exceptT (return 0 <$ addMessage Error . text2Htm bad = Map.withoutKeys (setToMap avsResponsePersonID bad') ok_ids -- it is possible to receive an id multiple times, with only one success, but this is sufficient batch1_ok = Set.size ok forM_ bad $ \AvsLicenceResponse { avsResponsePersonID=api, avsResponseMessage=msg} -> - $logErrorS "AVS" $ "Set AVS Licence failed for " <> tshow api <> " due to " <> cropText msg - -- TODO: Admin Error page - aux aqsl (batch0_ok + batch1_ok) batch2 -- yay for tail recursion (TODO: maybe refactor?) + $logErrorS "AVS" $ "Set AVS Licence failed for " <> tshow api <> " due to " <> cropText msg + aux (batch0_ok + batch1_ok) batch2 -- yay for tail recursion (TODO: maybe refactor?) - --- | Retrieve all currently valid driving licences and check against our database +{- NOT USED ANYWHERE: +-- Retrieve all currently valid driving licences and check against our database -- Only react to changes as compared to last seen status in avs.model --- TODO: run in a background job, once the interface is actually available synchAvsLicences :: Handler Bool synchAvsLicences = do - AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery - allLicences <- throwLeftM avsQueryGetAllLicences + allLicences <- avsQueryNoCache AvsQueryGetAllLicences deltaLicences <- computeDifferingLicences allLicences setResponse <- setLicencesAvs deltaLicences let setOk = setResponse == Set.size deltaLicences @@ -171,6 +759,8 @@ synchAvsLicences = do then $logInfoS "AVS" "FRADrive Licences written to AVS successfully." else $logWarnS "AVS" "Writing FRADrive Licences to AVS incomplete." return setOk +-} + data AvsLicenceDifferences = AvsLicenceDifferences { avsLicenceDiffRevokeAll :: Set AvsPersonId -- revoke all driving licences in AVS (set 0) @@ -180,9 +770,8 @@ data AvsLicenceDifferences = AvsLicenceDifferences } deriving (Show) -#ifdef DEVELOPMENT +#ifndef DEVELOPMENT -- avsLicenceDifferences2LicenceIds is not used in DEVELOPMENT build -#else avsLicenceDifferences2LicenceIds :: AvsLicenceDifferences -> Set AvsPersonId avsLicenceDifferences2LicenceIds AvsLicenceDifferences{..} = Set.unions [ avsLicenceDiffRevokeAll @@ -224,9 +813,8 @@ retrieveDifferingLicences' getStatus = do , 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] -#else - AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery - allLicences <- throwLeftM avsQueryGetAllLicences +#else + allLicences <- avsQuery AvsQueryGetAllLicences #endif lDiff <- getDifferingLicences allLicences #ifdef DEVELOPMENT @@ -242,12 +830,11 @@ retrieveDifferingLicences' getStatus = do #else let statQry = avsLicenceDifferences2LicenceIds lDiff lStat <- if getStatus && notNull statQry - then -- throwLeftM $ avsQueryStatus $ AvsQueryStatus statQry -- don't throw up here, licence differences are too important! TODO: Warn in Problem-Handler - avsQueryStatus (AvsQueryStatus statQry) >>= \case - Left err -> do - addMessage Error $ toHtml $ "avsQueryStatus failed for " <> tshow (length statQry) <> " requests with: \n" <> tshow err <> "\nREQUEST:\n" <> tshow statQry - return $ AvsResponseStatus mempty - Right res -> return res + then avsQueryNoCache (AvsQueryStatus statQry) + -- `catch` handler + -- let handler _exception = do + -- addMessage Error $ toHtml $ "avsQueryStatus failed for " <> tshow (length statQry) <> " requests with: \n" <> tshow err <> "\nREQUEST:\n" <> tshow statQry + -- return $ AvsResponseStatus mempty else return $ AvsResponseStatus mempty -- avoid unnecessary avs calls #endif return (lDiff, avsResponseStatusMap lStat) @@ -323,245 +910,3 @@ getDifferingLicences (AvsResponseGetLicences licences) = do set to 1: vorfeld-set && nicht in rollfeld-set || rollfeld-unset && nicht in vorfeld-unset set to 2: rollfeld-set && nicht in vorfeld-unset && (in vorfeld-set || AVS_Licence>0 == vorORrollfeld) -} - --- | Find or upsert User by AvsCardId (with dot), Fraport PersonalNumber, Fraport Email-Address or by prefixed AvsId or prefixed AvsNo; fail-safe, may or may not update existing users, may insert new users --- If an existing User with internal number is found, an AVS query is executed -guessAvsUser :: Text -> Handler (Maybe UserId) -guessAvsUser (Text.splitAt 6 -> ("AVSID:", avsidTxt)) = ifMaybeM (readMay avsidTxt) Nothing $ \avsidNr -> - let avsid = AvsPersonId avsidNr - maybeAvsUpsert = maybeCatchAll $ upsertAvsUserById avsid - extractUid (Entity _ UserAvs{userAvsUser=uid}) = return $ Just uid - in maybeM maybeAvsUpsert extractUid $ runDB $ getBy $ UniqueUserAvsId avsid -guessAvsUser (Text.splitAt 6 -> ("AVSNO:", avsnoTxt)) = ifMaybeM (readMay avsnoTxt) Nothing $ \avsno -> - runDB (selectList [UserAvsNoPerson ==. avsno] []) <&> \case - [Entity _ UserAvs{userAvsUser=uid}] -> Just uid - _ -> Nothing -guessAvsUser someid = do - let maybeUpsertAvsUserByCard = maybeCatchAll . upsertAvsUserByCard - case discernAvsCardPersonalNo someid of - Just cid@(Left _cardNo) -> maybeUpsertAvsUserByCard cid - -- NOTE: card validity might be outdated, so we must always check with avs - -- maybeM (maybeUpsertAvsUserByCard cid) extractUid $ runDB $ do - -- let extractUid (Entity _ UserAvs{userAvsUser=uid}) = return $ Just uid - -- extractUidCard UserAvsCard{userAvsCardPersonId=avid} = getBy $ UniqueUserAvsId avid - -- cards <- selectList [UserAvsCardCardNo ==. cardNo] [] - -- case [c | cent <- cards, let c = entityVal cent, avsDataValid (userAvsCardCard c)] of - -- [justOneCard] -> maybeM (return Nothing) extractUidCard (return $ Just justOneCard) - -- _ -> return Nothing - Just cid@(Right _wholeNumber) -> - maybeUpsertAvsUserByCard cid >>= \case - Nothing -> - runDB (selectList [UserCompanyPersonalNumber ==. Just someid] []) >>= \case - [Entity uid _] -> return $ Just uid - _ -> return Nothing - uid -> return uid - Nothing -> try (runDB $ ldapLookupAndUpsert someid) >>= \case - Right Entity{entityKey=uid, entityVal=User{userCompanyPersonalNumber=Just persNo}} -> - maybeM (return $ Just uid) (return . Just) (maybeUpsertAvsUserByCard (Right $ mkAvsInternalPersonalNo persNo)) - Right Entity{entityKey=uid} -> return $ Just uid - other -> do -- attempt to recover by trying other ids - whenIsLeft other (\(err::SomeException) -> $logInfoS "AVS" $ "upsertAvsUser LDAP error " <> tshow err) -- this line primarily forces exception type to catch-all - runDB . runMaybeT $ - let someIdent = stripCI someid - in MaybeT (getKeyBy $ UniqueEmail someIdent) - <|> MaybeT (getKeyBy $ UniqueAuthentication someIdent) - --- | Always update AVS Data, accepts AvsCardId (with dot), Fraport PersonalNumber or Fraport Email-Address -upsertAvsUser :: Text -> Handler (Maybe UserId) -- TODO: change to Entity -upsertAvsUser (discernAvsCardPersonalNo -> Just someid) = maybeCatchAll $ upsertAvsUserByCard someid -- Note: Right case is any number; it could be AvsCardNumber or AvsInternalPersonalNumber; we cannot know, but the latter is much more likely and useful to users! -upsertAvsUser otherId = -- attempt LDAP lookup to find by eMail - try (runDB $ ldapLookupAndUpsert otherId) >>= \case - Right Entity{entityVal=User{userCompanyPersonalNumber=Just persNo}} -> maybeCatchAll $ upsertAvsUserByCard (Right $ mkAvsInternalPersonalNo persNo) - other -> do -- attempt to recover by trying other ids - whenIsLeft other (\(err::SomeException) -> $logInfoS "AVS" $ "upsertAvsUser LDAP error " <> tshow err) -- this line primarily forces exception type to catch-all - apid <- runDB . runMaybeT $ do - let someIdent = stripCI otherId - uid <- MaybeT (getKeyBy $ UniqueEmail someIdent) - <|> MaybeT (getKeyBy $ UniqueAuthentication someIdent) - MaybeT $ view (_entityVal . _userAvsPersonId) <<$>> getBy (UniqueUserAvsUser uid) - ifMaybeM apid Nothing upsertAvsUserById - - --- | Given CardNo or internal Number, retrieve UserId. Create non-existing users, if possible. Always update. --- Throws errors if the avsInterface in unavailable or the user is non-unique within external AVS DB. -upsertAvsUserByCard :: Either AvsFullCardNo AvsInternalPersonalNo -> Handler (Maybe UserId) -- Idee: Eingabe ohne Punkt is AvsInternalPersonalNo mit Punkt is Ausweisnummer?! -upsertAvsUserByCard persNo = do - let qry = case persNo of - Left AvsFullCardNo{..} -> def{ avsPersonQueryCardNo = Just avsFullCardNo, avsPersonQueryVersionNo = Just avsFullCardVersion } - Right fpn -> def{ avsPersonQueryInternalPersonalNo = Just fpn } - AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery - AvsResponsePerson adps <- throwLeftM $ avsQueryPerson qry - case Set.elems adps of - [] -> throwM AvsPersonSearchEmpty - (_:_:_) -> throwM AvsPersonSearchAmbiguous - [AvsDataPerson{avsPersonPersonID=api}] -> upsertAvsUserById api -- always trigger an update - -- do - -- mbuid <- runDB $ getBy $ UniqueUserAvsId api - -- case mbuid of - -- (Just (Entity _ UserAvs{userAvsUser=uau})) -> return $ Just uau - -- Nothing -> upsertAvsUserById api - - - --- | Retrieve and _always_ update user by AvsPersonId. Non-existing users are created. Ignore AVS Licence status! Updates Company, Address, PinPassword --- Throws errors if the avsInterface in unavailable or the user is non-unique within external AVS DB (should never happen). -upsertAvsUserById :: AvsPersonId -> Handler (Maybe UserId) -upsertAvsUserById api = do - mbapd <- lookupAvsUser api - now <- liftIO getCurrentTime - mbuid <- runDB $ do - mbuid <- getBy (UniqueUserAvsId api) - case (mbuid, mbapd) of - (Nothing, Just AvsDataPerson{..}) -- FRADriver User does not exist yet, but found in AVS and has Internal Personal Number - | Just (avsInternalPersonalNo -> persNo) <- canonical avsPersonInternalPersonalNo -> do - $logInfoS "AVS" $ "Creating new user with avsInternalPersonalNo " <> tshow persNo - candidates <- selectKeysList [UserCompanyPersonalNumber ==. Just persNo] [] - case candidates of - [uid] -> $logInfoS "AVS" "Matching user found, linking." >> insertUniqueEntity (UserAvs api uid avsPersonPersonNo now Nothing) - (_:_) -> throwM $ AvsUserAmbiguous api - [] -> do - upsRes :: Either SomeException (Entity User) - <- try $ ldapLookupAndUpsert persNo - $logInfoS "AVS" $ "No matching existing user found. Attempted LDAP upsert returned: " <> tshow upsRes - case upsRes of - Right Entity{entityKey=uid} -> insertUniqueEntity $ UserAvs api uid avsPersonPersonNo now Nothing -- pin/addr are updated in next step anyway - Left err -> do - $logWarnS "AVS" $ "AVS user with avsInternalPersonalNo " <> tshow persNo <> " not found in LDAP: " <> tshow err - return mbuid -- == Nothing -- user could not be created somehow - (Just Entity{ entityKey = uaid }, _) -> do - update uaid [ UserAvsLastSynch =. now, UserAvsLastSynchError =. Nothing ] -- mark as updated early, to prevent failed users to clog the synch - return mbuid - _other -> return mbuid - $logInfoS "AVS" $ "upsert prestep result: " <> tshow mbuid <> " --- " <> tshow mbapd - case (mbuid, mbapd) of - ( _ , Nothing ) -> throwM $ AvsUserUnknownByAvs api -- User not found in AVS at all, i.e. no valid card exists yet - (Nothing, Just AvsDataPerson{avsPersonFirstName= Text.strip -> avsFirstName, avsPersonLastName= Text.strip -> avsSurname, ..}) -> do -- No LDAP User, but found in AVS; create new user - let (mbCompany, mbCoFirmAddr, _) = guessLicenceAddress avsPersonPersonCards - userFirmAddr= plaintextToStoredMarkup <$> mbCoFirmAddr - pinCard = Set.lookupMax avsPersonPersonCards - userPin = personCard2pin <$> pinCard - fakeIdent = CI.mk $ "AVSID:" <> tshow api - fakeNo = CI.mk $ "AVSNO:" <> tshow avsPersonPersonNo - newUsr = AddUserData - { audTitle = Nothing - , audFirstName = avsFirstName - , audSurname = avsSurname - , audDisplayName = avsFirstName <> Text.cons ' ' avsSurname - , audDisplayEmail = "" -- Email is unknown in this version of the avs query, to be updated later (FUTURE TODO) - , audMatriculation = Just $ tshow avsPersonPersonNo - , audSex = Nothing - , audBirthday = Nothing - , audMobile = Nothing - , audTelephone = Nothing - , audFPersonalNumber = avsInternalPersonalNo <$> canonical avsPersonInternalPersonalNo - , audFDepartment = Nothing - , audPostAddress = userFirmAddr - , audPrefersPostal = True - , audPinPassword = userPin - , audEmail = fakeNo -- Email is unknown in this version of the avs query, to be updated later (FUTURE TODO) - , audIdent = fakeIdent -- use AvsPersonId instead - , audAuth = maybe AuthKindNoLogin (const AuthKindLDAP) avsPersonInternalPersonalNo -- FUTURE TODO: if email is known, use AuthKinfPWHash for email invite, if no internal personnel number is known - } - mbUid <- addNewUser newUsr -- triggers JobSynchroniseLdapUser, JobSendPasswordReset and NotificationUserAutoModeUpdate -- TODO: check if these are failsafe - whenIsJust mbUid $ \uid -> runDB $ do - insert_ $ UserAvs avsPersonPersonID uid avsPersonPersonNo now Nothing - forM_ avsPersonPersonCards $ -- save all cards for later comparisons whether an update occurred - -- let cs :: Set AvsDataPersonCard = Set.fromList $ catMaybes [pinCard, addrCard] - -- forM_ cs $ -- only save used cards for the postal address update detection - \avsCard -> insert_ $ UserAvsCard avsPersonPersonID (getFullCardNo avsCard) avsCard now - upsertUserCompany uid mbCompany userFirmAddr - return mbUid - - (Just (Entity _ UserAvs{userAvsUser=uid}) - , Just AvsDataPerson{avsPersonPersonCards, avsPersonInternalPersonalNo, avsPersonPersonNo, avsPersonFirstName= Text.strip -> avsFirstName, avsPersonLastName= Text.strip -> avsSurname}) -> do -- known user, update address and pinPassword - let (mbCompany, mbCoFirmAddr, _) = guessLicenceAddress avsPersonPersonCards - userFirmAddr = plaintextToStoredMarkup <$> mbCoFirmAddr - pinCard = Set.lookupMax avsPersonPersonCards - userPin = personCard2pin <$> pinCard - runDB $ do - update uid [ UserFirstName =. avsFirstName -- update in case of name changes via AVS; might be changed again through LDAP - , UserSurname =. avsSurname - , UserDisplayName =. avsFirstName <> Text.cons ' ' avsSurname - , UserMatrikelnummer =. Just (tshow avsPersonPersonNo) -- TODO: Deactivate this update after Q2/2023; this is only needed since UserMatrikelnummer was used for AVSNO later - , UserCompanyPersonalNumber =. avsInternalPersonalNo <$> canonical avsPersonInternalPersonalNo - ] - oldCards <- selectList [UserAvsCardPersonId ==. api] [] - let oldAddrs = Set.fromList $ mapMaybe (snd3 . getCompanyAddress . userAvsCardCard . entityVal) oldCards - unless (maybe True (`Set.member` oldAddrs) mbCoFirmAddr) $ do -- update postal address, unless the exact address had been seen before - encRecipient :: CryptoUUIDUser <- encrypt uid - $logInfoS "AVS" $ "Postal address updated for" <> tshow encRecipient - updateWhere [UserId ==. uid] [UserPostAddress =. userFirmAddr, UserPostLastUpdate =. Just now] - whenIsJust pinCard $ \pCard -> -- update pin, but only if it was unset or set to the value of an old card - unlessM (exists [UserAvsCardCardNo ==. getFullCardNo pCard]) $ do - let oldPins = Just . personCard2pin . userAvsCardCard . entityVal <$> oldCards - updateWhere [UserId ==. uid, UserPinPassword !=. userPin, UserPinPassword <-. oldPins] -- check for old pin ensures that unset/manually set passwords remain unchanged - [UserPinPassword =. userPin] - insert_ $ UserAvsCard api (getFullCardNo pCard) pCard now - upsertUserCompany uid mbCompany userFirmAddr - forM_ avsPersonPersonCards $ \aCard -> do - let fcn = getFullCardNo aCard - -- probably not efficient, but fixes the problem that AvsCardNo is not unique as assumed before and may get reused - deleteWhere [UserAvsCardCardNo ==. fcn] - insert_ $ UserAvsCard - { userAvsCardPersonId = api - , userAvsCardCardNo = fcn - , userAvsCardCard = aCard - , userAvsCardLastSynch = now - } - return $ Just uid - - -lookupAvsUser :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) => - AvsPersonId -> m (Maybe AvsDataPerson) -lookupAvsUser api = Map.lookup api <$> lookupAvsUsers (Set.singleton api) - --- | retrieves complete avs user records for given AvsPersonIds. --- Note that this requires several AVS-API queries, since --- - avsQueryPerson does not support querying an AvsPersonId directly --- - avsQueryStatus only provides limited information --- avsQuery is used to obtain all card numbers, which are then queried separately an merged --- May throw Servant.ClientError or AvsExceptions --- Does not write to our own DB! -lookupAvsUsers :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) => - Set AvsPersonId -> m (Map AvsPersonId AvsDataPerson) -lookupAvsUsers apis = do - AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery - AvsResponseStatus statuses <- throwLeftM . avsQueryStatus $ AvsQueryStatus apis - let forFoldlM = $(permuteFun [3,2,1]) foldlM - forFoldlM statuses mempty $ \acc1 AvsStatusPerson{avsStatusPersonCardStatus=cards} -> - forFoldlM cards acc1 $ \acc2 AvsDataPersonCard{avsDataCardNo, avsDataVersionNo} -> do - AvsResponsePerson adps <- throwLeftM . avsQueryPerson $ def{avsPersonQueryCardNo = Just avsDataCardNo, avsPersonQueryVersionNo = Just avsDataVersionNo} - return $ mergeByPersonId adps acc2 - - --- | Like `Handler.Utils.getReceivers`, but calls upsertAvsUserById on each user to ensure that postal address is up-to-date -updateReceivers :: UserId -> Handler (Entity User, [Entity User], Bool) -updateReceivers uid = do - -- First perform AVS update for receiver - runDB (getBy (UniqueUserAvsUser uid)) >>= \case - Just Entity{entityVal=UserAvs{userAvsPersonId = apid}} -> void . maybeCatchAll $ upsertAvsUserById apid - Nothing -> return () - -- Retrieve updated user and supervisors now - (underling :: Entity User, avsSupers :: [(E.Value UserId, E.Value (Maybe AvsPersonId))]) <- runDB $ (,) - <$> getJustEntity uid - <*> (E.select $ do - (usrSuper :& usrAvs) <- - E.from $ E.table @UserSupervisor - `E.leftJoin` E.table @UserAvs - `E.on` (\(usrSuper :& userAvs) -> usrSuper E.^. UserSupervisorSupervisor E.=?. userAvs E.?. UserAvsUser) - E.where_ $ (usrSuper E.^. UserSupervisorUser E.==. E.val uid) - E.&&. (usrSuper E.^. UserSupervisorRerouteNotifications) - pure (usrSuper E.^. UserSupervisorSupervisor, usrAvs E.?. UserAvsPersonId) - ) - let (superVs, avsIds) = unzip avsSupers - receiverIDs :: [UserId] = E.unValue <$> superVs - toUpdate = Set.fromList $ mapMaybe E.unValue avsIds - directResult = return (underling, pure underling, True) -- already contains updated address - forM_ toUpdate (void . maybeCatchAll . upsertAvsUserById) -- attempt to update postaddress from AVS - if null receiverIDs - then directResult - else do - receivers <- runDB $ selectList [UserId <-. receiverIDs] [] -- due to possible address updates, we must runDB once more and cannot join above - if null receivers - then directResult - else return (underling, receivers, uid `elem` (entityKey <$> receivers)) diff --git a/src/Handler/Utils/Communication.hs b/src/Handler/Utils/Communication.hs index 3783ba0aa..7e5a60004 100644 --- a/src/Handler/Utils/Communication.hs +++ b/src/Handler/Utils/Communication.hs @@ -102,7 +102,7 @@ crJobsCourseCommunication jCourse 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 - (userAddress . entityVal) <<$>> selectList [UserId <-. 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 -> @@ -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 - (userAddress . entityVal) <<$>> selectList [UserId <-. 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 -> diff --git a/src/Handler/Utils/Company.hs b/src/Handler/Utils/Company.hs index 440f6c8fa..a5d90c0cb 100644 --- a/src/Handler/Utils/Company.hs +++ b/src/Handler/Utils/Company.hs @@ -4,57 +4,112 @@ module Handler.Utils.Company where + import Import --- import Utils.PathPiece -- import Data.CaseInsensitive (CI) -import qualified Data.CaseInsensitive as CI -import qualified Data.Char as Char -import qualified Data.Text as Text - +-- import qualified Data.CaseInsensitive as CI +-- import qualified Data.Char as Char +-- import qualified Data.Text as Text import Database.Persist.Postgresql --- | Ensure that the given user is linked to the given company -upsertUserCompany :: UserId -> Maybe Text -> Maybe StoredMarkup -> DB () -upsertUserCompany uid (Just cName) cAddr | notNull cName = do - cid <- upsertCompany cName cAddr - void $ upsertBy (UniqueUserCompany uid cid) - (UserCompany uid cid False False) - [] - superVs <- selectList [UserCompanyCompany ==. cid, UserCompanySupervisor ==. True] [] - upsertManyWhere [ UserSupervisor super uid reroute - | Entity{entityVal=UserCompany{userCompanyUser=super, userCompanySupervisorReroute=reroute, userCompanySupervisor=True}} <- superVs - ] [] [] [] -upsertUserCompany uid _ _ = - deleteWhere [ UserCompanyUser ==. uid ] -- maybe also delete company supervisors? +-- import Database.Esqueleto.Experimental ((:&)(..)) +import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma +import qualified Database.Esqueleto.Utils as E +import qualified Database.Esqueleto.PostgreSQL as E --- | Does not update company address for now --- TODO: update company address, maybe?! -upsertCompany :: Text -> Maybe StoredMarkup -> DB CompanyId -upsertCompany cName cAddr = - let cName' = CI.mk cName in - getBy (UniqueCompanyName cName') >>= \case - Just ent -> return $ entityKey ent - Nothing -> getBy (UniqueCompanySynonym cName') >>= \case - Just ent -> return . CompanyKey . companySynonymCanonical $ entityVal ent - Nothing -> do - let cShort = companyShorthandFromName cName - cShort' <- findShort cName' $ CI.mk cShort - let compy = Company cName' cShort' 0 False cAddr Nothing -- TODO: Fix this once AVS CR3 SCF-165 is implemented - either entityKey id <$> insertBy compy +import Handler.Utils.Users + + +company2msg :: CompanyId -> SomeMessage UniWorX +company2msg = text2message . ciOriginal . unCompanyKey + + +-- TODO: use this function in company view Handler.Firm #157 +-- | add all company supervisors for a given users +addCompanySupervisors :: (MonadIO m, BackendCompatible SqlBackend backend, PersistQueryWrite backend, PersistUniqueWrite backend) + => Key Company -> Key User -> ReaderT backend m () +addCompanySupervisors cid uid = + E.insertSelectWithConflict + UniqueUserSupervisor + ( do + userCompany <- E.from $ E.table @UserCompany + E.where_ $ userCompany E.^. UserCompanyCompany E.==. E.val cid + E.&&. userCompany E.^. UserCompanySupervisor + return $ UserSupervisor + E.<# (userCompany E.^. UserCompanyUser) + E.<&> E.val uid + E.<&> (userCompany E.^. UserCompanySupervisorReroute) + E.<&> E.justVal cid + E.<&> E.justVal (tshow SupervisorReasonCompanyDefault) + ) + (\current excluded -> -- Supervision between chosen individuals exists already; keep old reason and company, if exists + [ UserSupervisorCompany E.=. E.coalesce [current E.^. UserSupervisorCompany, excluded E.^. UserSupervisorCompany] -- do we want this? Ok, since we delete unconditionally first?! + , UserSupervisorReason E.=. E.coalesce [current E.^. UserSupervisorReason , excluded E.^. UserSupervisorReason ] + ] + ) + + +-- | removes user supervisorship on switch. WARNING: problems are not yet written to DB via reportProblem yet +switchAvsUserCompany :: Bool -> Bool -> UserId -> CompanyId -> DB ([Update User], [AdminProblem]) +switchAvsUserCompany usrPostAddrUpd keepOldCompanySupervs uid newCompanyId = do + usrRec <- get404 uid + newCompany <- get404 newCompanyId + mbUsrComp <- getUserPrimaryCompany uid + mbOldComp <- (get . userCompanyCompany) `traverseJoin` mbUsrComp + mbUsrAvs <- if usrPostAddrUpd then getBy (UniqueUserAvsUser uid) else return Nothing + let usrPostAddr :: Maybe StoredMarkup = userPostAddress usrRec + avsPostAddr :: Maybe StoredMarkup = mbUsrAvs ^? _Just . _entityVal . _userAvsLastFirmInfo . _Just . _avsFirmPostAddress . _Just + usrPostUp = toMaybe (usrPostAddrUpd && fromMaybe False (liftA2 isSimilarMarkup usrPostAddr avsPostAddr)) + (UserPostAddress =. Nothing) -- use company address indirectyl instead + usrPrefPost = userPrefersPostal usrRec + usrPrefPostUp = toMaybe (Just usrPrefPost == (mbOldComp ^? _Just . _companyPrefersPostal)) + (UserPrefersPostal =. companyPrefersPostal newCompany) + usrUpdate = catMaybes [usrPostUp, usrPrefPostUp] + -- [UserPostAddress =. Nothing, UserPrefersPostal =. companyPrefersPostal newCompany] -- unconditional + -- update uid usrUpdate + -- repsertSuperiorSupervisor is not called here, since the Superior is indepentent of the actual company association + case mbUsrComp of + Nothing -> do -- create company user + void $ insertUnique newUserComp + addCompanySupervisors newCompanyId uid + return (usrUpdate, mempty) + Just UserCompany{userCompanyCompany=oldCompanyId, userCompanyPriority=oldPrio, userCompanySupervisor=oldSuper, userCompanySupervisorReroute=oldSuperReroute} + | newCompanyId == oldCompanyId -> return mempty -- nothing to do + | otherwise -> do -- switch company + void $ upsertBy (UniqueUserCompany uid newCompanyId) newUserComp + [UserCompanyPriority =. succ oldPrio, UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False, UserCompanyUseCompanyAddress =. True] + -- supervised by uid + supervisees :: [(Entity UserSupervisor, E.Value Bool)] <- E.select $ do + usrSup <- E.from $ E.table @UserSupervisor + E.where_ $ usrSup E.^. UserSupervisorSupervisor E.==. E.val uid + E.&&. usrSup E.^. UserSupervisorCompany E.~=. E.val oldCompanyId + E.&&. usrSup E.^. UserSupervisorReason E.~=. E.val superReasonComDef + let singleSup = E.notExists $ do + othSup <- E.from $ E.table @UserSupervisor + E.where_ $ usrSup E.^. UserSupervisorUser E.==. othSup E.^. UserSupervisorUser + E.&&. othSup E.^. UserSupervisorCompany E.~=. E.val oldCompanyId + E.&&. othSup E.^. UserSupervisorReason E.~=. E.val superReasonComDef + return (usrSup, singleSup) + newlyUnsupervised <- guardMonoidM (notNull supervisees) $ do + E.delete $ do + usrSup <- E.from $ E.table @UserSupervisor + E.where_ $ usrSup E.^. UserSupervisorId `E.in_` E.vals (fmap (entityKey . fst) supervisees) + return $ [ AdminProblemSupervisorLeftCompany subid oldCompanyId oldSuperReroute + | (Entity{entityVal=UserSupervisor{userSupervisorUser=subid}}, E.Value True) <- supervisees ] + -- supervisors of uid + let superDeftFltr = (UserSupervisorUser ==. uid) : (UserSupervisorReason ~=. superReasonComDef) + oldSubFltr = (UserSupervisorCompany ~=. oldCompanyId) <> superDeftFltr + oldAPs <- if keepOldCompanySupervs + then updateWhereCount oldSubFltr [UserSupervisorReason =. Nothing] + else deleteWhereCount oldSubFltr + addCompanySupervisors newCompanyId uid + newAPs <- count $ (UserSupervisorCompany ==. Just newCompanyId) : superDeftFltr + let isNoLongerSupervised = not keepOldCompanySupervs && oldAPs > 0 && newAPs <= 0 + problems = bcons oldSuper (AdminProblemSupervisorNewCompany uid oldCompanyId newCompanyId oldSuperReroute) + $ bcons isNoLongerSupervised (AdminProblemNewlyUnsupervised uid (Just oldCompanyId) newCompanyId) + newlyUnsupervised + return (usrUpdate ,problems) where - findShort :: CompanyName -> CompanyShorthand -> DB CompanyShorthand - findShort fna fsh = aux 0 - where - aux n = let fsh' = if n==0 then fsh else fsh <> CI.mk (tshow n) in - checkUnique (Company fna fsh' 0 False Nothing Nothing) >>= \case - Nothing -> return fsh' - _other -> aux (n+1) - --- | Just a cheap heuristic, needs manual intervention anyway -companyShorthandFromName :: Text -> Text -companyShorthandFromName cName = - let cpats = splitCamel cName - strip = Text.filter Char.isAlphaNum . Text.take 3 - spats = strip <$> cpats - in Text.concat spats + newUserComp = UserCompany uid newCompanyId False False 1 True -- default value for new company insertion, if no update can be done + superReasonComDef = tshow SupervisorReasonCompanyDefault \ No newline at end of file diff --git a/src/Handler/Utils/Concurrent.hs b/src/Handler/Utils/Concurrent.hs index 1faaff498..3328cced4 100644 --- a/src/Handler/Utils/Concurrent.hs +++ b/src/Handler/Utils/Concurrent.hs @@ -13,6 +13,12 @@ import UnliftIO.Concurrent as Handler.Utils.Concurrent hiding (yield) +maybeTimeoutHandler :: Maybe Int -> HandlerFor site a -> HandlerFor site (Maybe a) +maybeTimeoutHandler Nothing = fmap Just +maybeTimeoutHandler (Just secs) = timeoutHandler $ bool maxBound micro (micro > 0) + where + micro = 1000000 * secs + -- | Run a handler action until it finishes or if it exceeds a given number of microseconds via `registerDelay` timeoutHandler :: Int -> HandlerFor site a -> HandlerFor site (Maybe a) timeoutHandler maxWait act = do diff --git a/src/Handler/Utils/Mail.hs b/src/Handler/Utils/Mail.hs index 851928033..cbac6b337 100644 --- a/src/Handler/Utils/Mail.hs +++ b/src/Handler/Utils/Mail.hs @@ -3,9 +3,7 @@ -- SPDX-License-Identifier: AGPL-3.0-or-later module Handler.Utils.Mail - ( addRecipientsDB - , userAddress, userAddress' - , userAddressFrom + ( addRecipientsDB , userMailT, userMailTdirect , addFileDB , addHtmlMarkdownAlternatives @@ -16,7 +14,7 @@ import Import import Handler.Utils.Pandoc import Handler.Utils.Files import Handler.Utils.Widgets (nameHtml') -- TODO: how to use name widget here? -import Handler.Utils.Users (getReceivers) +import Handler.Utils.Users (getReceivers, getUserEmail) import Handler.Utils.Profile import qualified Data.CaseInsensitive as CI @@ -37,44 +35,49 @@ addRecipientsDB :: ( MonadMail m addRecipientsDB uFilter = runConduit $ transPipe (liftHandler . runDB) (selectSource uFilter [Asc UserDisplayName]) .| C.mapM_ addRecipient where addRecipient (Entity _ User{userEmail, userDisplayEmail, userDisplayName}) = do - let addr = Address (Just userDisplayName) $ CI.original $ pickValidEmail userDisplayEmail userEmail + let addr = Address (Just userDisplayName) $ CI.original $ pickValidUserEmail userDisplayEmail userEmail _mailTo %= flip snoc addr -userAddressFrom :: User -> Address +-- -- These pure functions may no longer be used, since they ignore company emails address indirections via UserCompany es +-- +-- userAddressFrom :: User -> Address -- ^ Format an e-mail address suitable for usage in a @From@-header -- -- Uses `userDisplayEmail` only -userAddressFrom User{userDisplayEmail, userDisplayName} = Address (Just userDisplayName) $ CI.original userDisplayEmail +-- userAddressFrom User{userDisplayEmail, userDisplayName} = Address (Just userDisplayName) $ CI.original userDisplayEmail -userAddress :: User -> Address --- ^ Format an e-mail address suitable for usage as a recipient --- --- Like userAddressFrom, but prefers `userDisplayEmail` (if valid) and otherwise uses `userEmail`. Unlike Uni2work, userEmail from LDAP is untrustworthy. -userAddress User{userEmail, userDisplayEmail, userDisplayName} - = Address (Just userDisplayName) $ CI.original $ pickValidEmail userDisplayEmail userEmail +-- userAddress :: User -> Address +-- -- ^ Format an e-mail address suitable for usage as a recipient +-- -- +-- -- Like userAddressFrom, but prefers `userDisplayEmail` (if valid) and otherwise uses `userEmail`. Unlike Uni2work, userEmail from LDAP is untrustworthy. +-- userAddress User{userEmail, userDisplayEmail, userDisplayName} +-- = Address (Just userDisplayName) $ CI.original $ pickValidUserEmail userDisplayEmail userEmail -userAddress' :: UserEmail -> UserEmail -> UserDisplayName -> Address --- Like userAddress', but does not require a complete entity -userAddress' userEmail userDisplayEmail userDisplayName - = Address (Just userDisplayName) $ CI.original $ pickValidEmail userDisplayEmail userEmail +-- userAddress' :: UserEmail -> UserEmail -> UserDisplayName -> Address +-- -- Like userAddress', but does not require a complete entity +-- userAddress' userEmail userDisplayEmail userDisplayName +-- = Address (Just userDisplayName) $ CI.original $ pickValidUserEmail userDisplayEmail userEmail -userAddressError :: (MonadHandler m, HandlerSite m ~ UniWorX) => User -> m (Bool, Address) -userAddressError User{userEmail, userDisplayEmail, userDisplayName} - | Just okEmail <- pickValidEmail' userDisplayEmail userEmail = pure (True, Address (Just userDisplayName) $ CI.original okEmail) - | otherwise = do + +userAddressError :: (MonadHandler m, HandlerSite m ~ UniWorX, m ~ HandlerFor UniWorX) => Entity User -> m (Bool, Address) +userAddressError usr@Entity{entityVal=User{userEmail, userDisplayEmail, userDisplayName}} = + runDB (getUserEmail usr) >>= \case + Just okEmail -> pure (True, Address (Just userDisplayName) $ CI.original okEmail) + Nothing -> do $logErrorS "Mail" $ "Attempt to email invalid address: " <> tshow userDisplayEmail <> " / " <> tshow userEmail <> ". Sent to support instead." -- <> " with subject " <> tshow failedSubject (False,) <$> getsYesod (view _appMailSupport) -- | Send an email to the given UserId or to all registered Supervisor with rerouteNotifications == True userMailT :: ( MonadHandler m , HandlerSite m ~ UniWorX + , m ~ HandlerFor UniWorX , MonadThrow m , MonadUnliftIO m ) => UserId -> MailT m () -> m () userMailT uid mAct = do (underling, receivers, undercopy) <- liftHandler . runDB $ getReceivers uid let undername = underling ^. _userDisplayName -- nameHtml' underling - undermail = CI.original $ pickValidEmail (underling ^. _userDisplayEmail) (underling ^. _userEmail) + undermail = CI.original $ pickValidUserEmail (underling ^. _userDisplayEmail) (underling ^. _userEmail) infoSupervised :: Hamlet.HtmlUrlI18n UniWorXSendMessage (Route UniWorX) = [ihamlet|

_{MsgMailSupervisedNote}

@@ -84,7 +87,7 @@ userMailT uid mAct = do

  • #{nameHtml' svr} |] - forM_ receivers $ \Entity + forM_ receivers $ \svrEnt@Entity { entityKey = svr , entityVal = supervisor@User{ userLanguages , userDateTimeFormat @@ -111,7 +114,7 @@ userMailT uid mAct = do $else _{MsgMailSupervisorNoCopy} |] - (mailOk, mailtoAddr) <- userAddressError supervisor -- ensures a valid email, logs error and sends to support otherwise + (mailOk, mailtoAddr) <- userAddressError svrEnt -- ensures a valid email, logs error and sends to support otherwise mailT ctx $ do _mailTo .= pure mailtoAddr @@ -126,6 +129,7 @@ userMailT uid mAct = do -- | like userMailT, but always sends a single mail to the given UserId, ignoring supervisors userMailTdirect :: ( MonadHandler m , HandlerSite m ~ UniWorX + , m ~ HandlerFor UniWorX , MonadThrow m , MonadUnliftIO m ) => UserId -> MailT m a -> m a @@ -138,6 +142,7 @@ userMailTdirect uid mAct = do , userCsvOptions } <- liftHandler . runDB $ getJust uid let + usrEnt = Entity {entityKey = uid, entityVal = user} ctx = MailContext { mcLanguages = fromMaybe def userLanguages , mcDateTimeFormat = \case @@ -146,7 +151,7 @@ userMailTdirect uid mAct = do SelFormatTime -> userTimeFormat , mcCsvOptions = userCsvOptions } - (mailOk, mailtoAddr) <- userAddressError user -- ensures a valid email, logs error and sends to support otherwise + (mailOk, mailtoAddr) <- userAddressError usrEnt -- ensures a valid email, logs error and sends to support otherwise mailT ctx $ do -- failedSubject <- lookupMailHeader "Subject" -- unless (validEmail $ addressEmail mailtoAddr) ($logErrorS "Mail" $ "Attempt to email invalid address: " <> tshow mailtoAddr <> " with subject " <> tshow failedSubject) diff --git a/src/Handler/Utils/Pandoc.hs b/src/Handler/Utils/Pandoc.hs index 797bcf625..c138f0a76 100644 --- a/src/Handler/Utils/Pandoc.hs +++ b/src/Handler/Utils/Pandoc.hs @@ -1,17 +1,18 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen , Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later module Handler.Utils.Pandoc - ( htmlField, htmlFieldSmall - , renderMarkdownWith, parseMarkdownWith - , htmlReaderOptions, markdownReaderOptions - , markdownWriterOptions, htmlWriterOptions + ( module Utils.Pandoc + , htmlField, htmlFieldSmall + , renderMarkdownWith, parseMarkdownWith ) where import Import.NoFoundation +import Utils.Pandoc import Handler.Utils.I18n + import qualified Data.Text as Text import qualified Data.Text.Lazy as LT @@ -86,20 +87,3 @@ plaintextToMarkdownWith writerOptions text = where logPandocError = $logErrorS "renderMarkdown" . tshow pandoc = P.Pandoc mempty [P.Plain [P.Str text]] - - -htmlReaderOptions, markdownReaderOptions :: P.ReaderOptions -htmlReaderOptions = markdownReaderOptions -markdownReaderOptions = def - { P.readerExtensions = P.pandocExtensions - & P.enableExtension P.Ext_hard_line_breaks - & P.enableExtension P.Ext_autolink_bare_uris - , P.readerTabStop = 2 - } - -markdownWriterOptions, htmlWriterOptions :: P.WriterOptions -markdownWriterOptions = def - { P.writerExtensions = P.readerExtensions markdownReaderOptions - , P.writerTabStop = P.readerTabStop markdownReaderOptions - } -htmlWriterOptions = markdownWriterOptions diff --git a/src/Handler/Utils/Profile.hs b/src/Handler/Utils/Profile.hs index 4f8e87546..782cd02b1 100644 --- a/src/Handler/Utils/Profile.hs +++ b/src/Handler/Utils/Profile.hs @@ -1,31 +1,24 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later -- TODO: why is this Handler.Utils.Profile instead of Utils.Profile? -- TODO: consider merging with Handler.Utils.Users? module Handler.Utils.Profile - ( validDisplayName, checkDisplayName, fixDisplayName - , validPostAddress - , validEmail, validEmail', pickValidEmail, pickValidEmail' + ( module Utils.Mail + , module Utils.Postal + , validDisplayName, checkDisplayName, fixDisplayName , validFraportPersonalNumber ) where import Import.NoFoundation -import Data.Char import qualified Data.Text as Text -import qualified Data.Text.Lazy as LT -import qualified Data.CaseInsensitive as CI - import qualified Data.MultiSet as MultiSet import qualified Data.Set as Set -import qualified Text.Email.Validate as Email - --- | Instead of CI.mk, this still allows use of Text.isInfixOf, etc. -stripFold :: Text -> Text -stripFold = Text.toCaseFold . Text.strip +import Utils.Mail +import Utils.Postal -- | remove last comma and swap order of the two parts, ie. transforming "surname, givennames" into "givennames surname". -- Input "givennames surname" is left unchanged, except for removing excess whitespace @@ -67,42 +60,6 @@ validDisplayName (fmap stripFold -> mTitle) (stripFold -> fName) (stripFold -> s splitAdd = Text.split isAdd makeMultiSet = MultiSet.fromList . filter (not . Text.null) . splitAdd - --- | Primitive postal address requires at least one alphabetic character, one digit and a line break -validPostAddress :: Maybe StoredMarkup -> Bool -validPostAddress (Just StoredMarkup {markupInput = addr}) - | Just _ <- LT.find isLetter addr - , Just _ <- LT.find isNumber addr - -- , Just _ <- LT.find ((LineSeparator ==) . generalCategory) addr -- THIS DID NOT WORK - , 1 < length (LT.lines addr) - = True -validPostAddress _ = False - --- also see `Handler.Utils.Users.getEmailAddress` for Tests accepting User Type -validEmail :: Email -> Bool -- Email = Text -validEmail email = validRFC5322 && not invalidFraport - where - validRFC5322 = Email.isValid $ encodeUtf8 email - invalidFraport = case Text.stripSuffix "@fraport.de" (foldCase email) of - Just fralogin -> all isDigit $ drop 1 fralogin - Nothing -> False - -validEmail' :: UserEmail -> Bool -- UserEmail = CI Text -validEmail' = validEmail . CI.original - --- | returns first argument, if it is a valid email address; returns second argument untested otherwise; convenience function -pickValidEmail :: UserEmail -> UserEmail -> UserEmail -pickValidEmail x y - | validEmail' x = x - | otherwise = y - --- | returns first valid email address or none if none are valid -pickValidEmail' :: UserEmail -> UserEmail -> Maybe UserEmail -pickValidEmail' x y - | validEmail' x = Just x - | validEmail' y = Just y - | otherwise = Nothing - validFraportPersonalNumber :: Maybe Text -> Bool validFraportPersonalNumber Nothing = False validFraportPersonalNumber (Just t) diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 3994b81f0..48c2e4444 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Felix Hamann ,Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Winnie Ros +-- SPDX-FileCopyrightText: 2022-24 Felix Hamann ,Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Winnie Ros ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -79,6 +79,7 @@ ifCell decision cTrue cFalse x linkEmptyCell :: IsDBTable m a => Route UniWorX -> Widget -> DBCell m a linkEmptyCell = anchorCell +-- not to be confused with i18nCell msgCell :: (ToMessage t, IsDBTable m a) => t -> DBCell m a msgCell = textCell . toMessage @@ -356,14 +357,18 @@ courseCell Course{..} = anchorCell link name `mappend` desc |] companyCell :: IsDBTable m a => CompanyShorthand -> CompanyName -> Bool -> DBCell m a -companyCell cid cname isSupervisor = anchorCell link name +companyCell csh cname isSupervisor = anchorCell link name where - link = FirmUsersR cid + link = FirmUsersR csh corg = ciOriginal cname - name + name | isSupervisor = text2markup (corg <> " ") <> icon IconSupervisor | otherwise = text2markup corg +companyIdCell :: IsDBTable m a => CompanyId -> DBCell m a +companyIdCell cid = companyCell csh csh False + where + csh = unCompanyKey cid qualificationCell :: (IsDBTable m c, HasQualification a) => a -> DBCell m c qualificationCell (view hasQualification -> Qualification{..}) = anchorCell link name diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs index c0f768e99..b8f3cfff6 100644 --- a/src/Handler/Utils/Table/Columns.hs +++ b/src/Handler/Utils/Table/Columns.hs @@ -8,6 +8,8 @@ module Handler.Utils.Table.Columns where import Import hiding (link) +import qualified Data.Map as Map + import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E hiding ((->.)) import Database.Esqueleto.Utils (mkExactFilter, mkExactFilterWith, mkContainsFilter, mkContainsFilterWith, mkContainsFilterWithComma, mkContainsFilterWithCommaPlus, anyFilter) @@ -21,6 +23,8 @@ import Handler.Utils.Form import Handler.Utils.Widgets import Handler.Utils.DateTime import Handler.Utils.StudyFeatures +import Handler.Utils.Avs (queryAvsCardNos) +import Handler.Utils.Concurrent import qualified Data.CaseInsensitive as CI @@ -801,6 +805,41 @@ fltrCompanyNameNrHdrUI msg mPrev = prismAForm (singletonFilter "company-name-number") mPrev $ aopt textField (fslI msg & setTooltip MsgTableFilterCommaNameNr) +--------- +-- AVS -- +--------- + + +fltrAVSCardNos :: (IsFilterColumnHandler t ([Text] -> Handler (a -> E.SqlExpr (E.Value Bool))), IsString k) + => (a -> E.SqlExpr (Entity User)) -> Map k (FilterColumn t fs) +fltrAVSCardNos queryUser = Map.singleton "avs-card" fch + where + fch = FilterColumnHandler $ \case + [] -> return (const E.true) + cs -> do + let crds = mapMaybe parseAvsCardNo $ foldMap anySeparatedText cs + toutsecs <- getsYesod $ preview $ _appAvsConf . _Just . _avsTimeout + maybeTimeoutHandler toutsecs (try $ queryAvsCardNos crds) >>= \case + Nothing -> addMessageI Error MsgAvsCommunicationTimeout + >> return (const E.false) + (Just (Left err)) -> addMessage Error (someExc2Html err) + >> return (const E.false) + (Just (Right (null -> True))) -> return (const E.false) + (Just (Right apids)) -> return $ + \(queryUser -> user) -> + E.exists $ E.from $ \usrAvs -> + E.where_ $ usrAvs E.^. UserAvsUser E.==. user E.^. UserId + E.&&. usrAvs E.^. UserAvsPersonId `E.in_` E.vals apids + someExc2Html :: SomeException -> Html + someExc2Html (SomeException e) = text2Html $ tshow e + +fltrAVSCardNosUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text]) +fltrAVSCardNosUI mPrev = + prismAForm (singletonFilter "avs-card" ) mPrev $ + aopt textField (fslI MsgAvsCardNo & setTooltip (SomeMessages [SomeMessage MsgTableFilterComma, SomeMessage MsgAvsQueryNeeded])) + + + ---------------------------- -- Colonnade manipulation -- ---------------------------- diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 0bca321ac..cb2e0f656 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-23 Felix Hamann ,Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Steffen Jost ,Winnie Ros ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Felix Hamann ,Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Steffen Jost ,Winnie Ros ,Steffen Jost ,David Mosbach -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -22,7 +22,7 @@ module Handler.Utils.Table.Pagination , SortColumn(..), SortDirection(..) , SortingSetting(..) , pattern SortAscBy, pattern SortDescBy - , FilterColumn(..), IsFilterColumn, IsFilterProjected + , FilterColumn(..), IsFilterColumn, IsFilterColumnHandler, IsFilterProjected , mkFilterProjectedPost , DBTProjFilterPost(..) , DBRow(..), _dbrOutput, _dbrCount @@ -262,12 +262,18 @@ instance Monoid (DBTProjFilterPost r') where data FilterColumn t fs = forall a. IsFilterColumn t a => FilterColumn a + | forall a. IsFilterColumnHandler t a => FilterColumnHandler a | forall a. IsFilterProjected fs a => FilterProjected a + filterColumn :: FilterColumn t fs -> Maybe ([Text] -> t -> E.SqlExpr (E.Value Bool)) filterColumn (FilterColumn f) = Just $ filterColumn' f filterColumn _ = Nothing +filterColumnHandler :: FilterColumn t fs -> Maybe ([Text] -> Handler (t -> E.SqlExpr (E.Value Bool))) +filterColumnHandler (FilterColumnHandler f) = Just $ filterColumnHandler' f +filterColumnHandler _ = Nothing + filterProjected :: FilterColumn t fs -> [Text] -> (fs -> fs) filterProjected (FilterProjected f) = filterProjected' f filterProjected _ = const id @@ -287,6 +293,12 @@ instance IsFilterColumn t cont => IsFilterColumn t (t -> cont) where instance {-# OVERLAPPABLE #-} (PathPiece (Element l), IsFilterColumn t cont, MonoPointed l, Monoid l) => IsFilterColumn t (l -> cont) where filterColumn' cont is' = filterColumn' (cont $ is' ^. mono' _PathPiece) is' +class IsFilterColumnHandler t a where + filterColumnHandler' :: a -> [Text] -> Handler (t -> E.SqlExpr (E.Value Bool)) + +instance IsFilterColumnHandler t ([Text] -> Handler (t -> E.SqlExpr (E.Value Bool))) where + filterColumnHandler' fin args = fin args + class IsFilterProjected fs a where filterProjected' :: a -> [Text] -> (fs -> fs) @@ -631,12 +643,13 @@ defaultDBSFilterLayout filterWdgt filterEnctype filterAction scrolltable = $(widgetFile "table/layout-filter-default") where filterForm = wrapForm filterWdgt FormSettings - { formMethod = GET - , formAction = Just filterAction - , formEncoding = filterEnctype - , formAttrs = [("class", "table-filter-form"), ("autocomplete", "off")] - , formSubmit = FormAutoSubmit - , formAnchor = Nothing :: Maybe Text + { formMethod = GET + , formAction = Just filterAction + , formEncoding = filterEnctype + , formAttrs = [("class", "table-filter-form"), ("autocomplete", "off")] + , formSubmit = FormSubmit --FormSubmit --FormAutoSubmit --TODO not for sync-tables + , formCustomBtn = Just BtnApplyFilter + , formAnchor = Nothing :: Maybe Text } @@ -1005,6 +1018,7 @@ dbParamsFormWrap DBTable{ dbtIdent } DBParamsForm{..} tableForm frag = do , formEncoding = enctype , formAttrs = dbParamsFormAttrs , formSubmit = dbParamsFormSubmit + , formCustomBtn = Nothing :: Maybe ButtonSubmit , formAnchor = Just $ WithIdent dbtIdent ("form" :: Text) } @@ -1172,6 +1186,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db , formEncoding = csvExportEnctype , formAttrs = [] , formSubmit = FormSubmit + , formCustomBtn = Nothing :: Maybe ButtonSubmit , formAnchor = Just $ wIdent "csv-export" } csvImportWdgt' = wrapForm csvImportWdgt FormSettings @@ -1180,6 +1195,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db , formEncoding = csvImportEnctype , formAttrs = [] , formSubmit = FormNoSubmit + , formCustomBtn = Nothing :: Maybe ButtonSubmit , formAnchor = Just $ wIdent "csv-import" } csvImportExplanation :: Widget @@ -1198,13 +1214,17 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db sortSql :: _ -> [E.SqlExpr E.OrderBy] sortSql t = concatMap (\(f, d) -> f d t) $ mapMaybe (\(c, d) -> (, d) <$> sqlSortDirection c) psSorting' - filterSql :: Map FilterKey (Maybe (_ -> E.SqlExpr (E.Value Bool))) + filterSql :: Map FilterKey (Maybe (_ -> E.SqlExpr (E.Value Bool))) -- could there be any reason not to remove Nothing values from the map already here? filterSql = map (\(fc, args) -> ($ args) <$> filterColumn fc) $ psFilter' -- selectPagesize = primarySortSql -- && all (is _Just) filterSql -- psLimit' = bool PagesizeAll psLimit selectPagesize + + filterHandler <- case csvMode of + FormSuccess DBCsvImport{} -> return mempty -- don't execute Handler actions for unneeded filters upon csv _import_ + _other -> liftHandler $ forM psFilter' $ \(fc,args) -> mapM ($ args) $ filterColumnHandler fc rows' <- E.select . E.from $ \t -> do res <- dbtSQLQuery t @@ -1221,9 +1241,11 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db -> do E.limit l E.offset $ psPage * l - Just ps -> E.where_ $ dbtRowKey t `E.sqlIn` ps + Just ps -> E.where_ $ dbtRowKey t `E.sqlIn` ps -- Note that multiple where_ are indeed concatenated _other -> return () - Map.foldr (\fc expr -> maybe (return ()) (E.where_ . ($ t)) fc >> expr) (return ()) filterSql + let filterAppT = Map.foldr (\fc expr -> maybe expr ((: expr) . ($ t)) fc) [] + sqlFilters = filterAppT filterHandler <> filterAppT filterSql -- Note that <> on the maps won't work as intended, since keys are present in both + unless (null sqlFilters) $ E.where_ $ E.and sqlFilters return (E.unsafeSqlValue "count(*) OVER ()" :: E.SqlExpr (E.Value Int64), dbtRowKey t, res) let mapMaybeM' f = mapMaybeM $ \(k, v) -> (,) <$> pure k <*> f v @@ -1364,6 +1386,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db , formEncoding = csvImportConfirmEnctype , formAttrs = [] , formSubmit = FormNoSubmit + , formCustomBtn = Nothing :: Maybe ButtonSubmit , formAnchor = Nothing :: Maybe Text } @@ -1576,6 +1599,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db , formEncoding = pagesizeEnc , formAttrs = [("class", "pagesize"), ("autocomplete", "off")] , formSubmit = FormAutoSubmit + , formCustomBtn = Nothing :: Maybe ButtonSubmit , formAnchor = Just $ wIdent "pagesize-form" } showPagesizeWdgt = toEnum (fromIntegral rowCount) > minimum (pagesizeOptions referencePagesize) @@ -1624,13 +1648,23 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db redirect $ tblLink id (act, _) -> act + AppSettings{..} <- getsYesod appSettings' + let + maxRows = fromIntegral @Natural @Int $ fromMaybe 0 appAsyncTableMaxRows + isSync = length rows >= maxRows wrapLayout :: DBResult m x -> DB (DBResult m x) wrapLayout = dbHandler (Proxy @m) (Proxy @x) $ (\table -> $(widgetFile "table/layout-wrapper")) . uiLayout + selector :: (Text, Text) + selector + | null rows && (dbsEmptyStyle == DBESNoHeading) = ("","") + | isSync = ("uw-sync-table","") + | otherwise = ("uw-async-table","") shortcircuit :: forall void. DBResult m x -> DB void shortcircuit res = do addCustomHeader HeaderDBTableCanonicalURL =<< toTextUrl (tblLink substPi) sendResponse =<< tblLayout . uiLayout =<< dbWidget (Proxy @m) (Proxy @x) res + $logErrorS "\a\27[31mTABLE\27[0m" (tshow (fst selector) <> " || row size: " <> tshow (length rows)) dbInvalidateResult' <=< bool wrapLayout shortcircuit psShortcircuit <=< runDBTable dbtable paginationInput currentKeys . fmap swap $ runWriterT table' where tblLayout :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => Widget -> m' Html @@ -1671,7 +1705,7 @@ widgetColonnade :: Colonnade h r (DBCell (HandlerFor UniWorX) x) -> Colonnade h r (DBCell (HandlerFor UniWorX) x) widgetColonnade = id --- | force the column list type for tables that cotain forms, especially those constructed with dbSelect, avoids explicit type signatures +-- | force the column list type for tables that contain forms, especially those constructed with dbSelect, avoids explicit type signatures formColonnade :: Colonnade h r (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) (FormResult a)) -> Colonnade h r (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) (FormResult a)) formColonnade = id diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index e281c7fcf..686dc8692 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -12,12 +12,15 @@ module Handler.Utils.Users , NameMatchQuality(..) , matchesName , GuessUserInfo(..) - , guessUser + , guessUser, guessUserByEmail , UserAssimilateException(..), UserAssimilateExceptionReason(..) , assimilateUser - , userPrefersEmail, userPrefersLetter - , getEmailAddress - , getPostalAddress, getPostalPreferenceAndAddress + , getUserPrimaryCompany, getUserPrimaryCompanyAddress + , getUserEmail + , getEmailAddress, getJustEmailAddress + , getEmailAddressFor, getJustEmailAddressFor + , getPostalAddress, getPostalAddress' + , getPostalPreferenceAndAddress, getPostalPreferenceAndAddress' , abbrvName , getReceivers, getReceiversFor , getSupervisees @@ -55,6 +58,12 @@ import Handler.Utils.Profile import Jobs.Types(Job, JobChildren) +data ExceptionUserHandling + = ExceptionUserHasNoEmail + deriving (Eq, Ord, Read, Show, Generic) -- Enum, Bounded, +instance Exception ExceptionUserHandling + + abbrvName :: User -> Text abbrvName User{userDisplayName, userFirstName, userSurname} = if | (lastDisplayName : tsrif) <- reverse nameParts @@ -67,36 +76,97 @@ abbrvName User{userDisplayName, userFirstName, userSurname} = assemble = Text.intercalate "." --- deprecated, used getPostalPreferenceAndAddress -userPrefersLetter :: User -> Bool -userPrefersLetter = fst . getPostalPreferenceAndAddress +-- Note: Entity can be recovered, since CompanyShort is also the key +getUserPrimaryCompany :: UserId -> DB (Maybe UserCompany) +getUserPrimaryCompany uid = entityVal <<$>> + selectFirst [UserCompanyUser ==. uid] + [Desc UserCompanyPriority, Desc UserCompanySupervisorReroute, Desc UserCompanySupervisor, Asc UserCompanyCompany] --- deprecated, used getPostalPreferenceAndAddress -userPrefersEmail :: User -> Bool -userPrefersEmail = not . userPrefersLetter +getUserPrimaryCompanyAddress :: UserId -> (Company -> Maybe a) -> DB (Maybe a) +getUserPrimaryCompanyAddress uid prj = runMaybeT $ do + UserCompany{userCompanyCompany=cid, userCompanyUseCompanyAddress=True} <- MaybeT $ getUserPrimaryCompany uid -- return Nothing if company address is not to be used + company <- MaybeT $ get cid + -- hoistMaybe $ prj company + MaybeT $ pure $ prj company + --- | result (True, Nothing) indicates that neither userEmail nor userPostAddress is known -getPostalPreferenceAndAddress :: User -> (Bool, Maybe [Text]) -getPostalPreferenceAndAddress usr@User{userPrefersPostal} = - ((userPrefersPostal && postPossible) || not emailPossible, pa) - -- (((userPrefersPostal || isNothing userPinPassword) && postPossible) || not emailPossible, pa) -- ignore email/post preference if no pinPassword is set - where - pa = getPostalAddress usr - postPossible = isJust pa - emailPossible = isJust $ getEmailAddress usr +-- | result (True, Nothing, Nothing) indicates that neither userEmail nor userPostAddress is known +getPostalPreferenceAndAddress :: Entity User -> DB (Bool, Maybe [Text], Maybe UserEmail) +getPostalPreferenceAndAddress usr = do + pa <- getPostalAddress usr + em <- getUserEmail usr + let usrPrefPost = usr ^. _entityVal . _userPrefersPostal + finalPref = (usrPrefPost && isJust pa) || isNothing em + -- finalPref = isJust pa && (usrPrefPost || isNothing em) + return (finalPref, pa, em) + +-- | result (True, Nothing, Nothing) indicates that neither userEmail nor userPostAddress is known +-- primed variant returns storedMarkup without prefixed userDisplayName +getPostalPreferenceAndAddress' :: Entity User -> DB (Bool, Maybe StoredMarkup, Maybe UserEmail) +getPostalPreferenceAndAddress' usr = do + pa <- getPostalAddress' usr + em <- getUserEmail usr + let usrPrefPost = usr ^. _entityVal . _userPrefersPostal + finalPref = (usrPrefPost && isJust pa) || isNothing em + -- finalPref = isJust pa && (usrPrefPost || isNothing em) + return (finalPref, pa, em) + +getEmailAddressFor :: UserId -> DB (Maybe Address) +getEmailAddressFor = maybeM (return Nothing) getEmailAddress . getEntity + +getJustEmailAddressFor :: UserId -> DB Address +getJustEmailAddressFor = maybeThrowM ExceptionUserHasNoEmail . getEmailAddressFor -getEmailAddress :: User -> Maybe UserEmail -getEmailAddress User{userDisplayEmail, userEmail} = pickValidEmail' userDisplayEmail userEmail +getJustEmailAddress :: Entity User -> DB Address +getJustEmailAddress = maybeThrowM ExceptionUserHasNoEmail . getEmailAddress -getPostalAddress :: User -> Maybe [Text] -getPostalAddress User{..} - | Just pa <- userPostAddress - = Just $ userDisplayName : html2textlines pa - | Just abt <- userCompanyDepartment - = Just $ if | "BVD" `isPrefixOf` abt -> [userDisplayName, abt, "Bodenverkehrsdienste"] - | otherwise -> [userDisplayName, abt, "Hausbriefkasten" ] +getEmailAddress :: Entity User -> DB (Maybe Address) +getEmailAddress usr@Entity{entityVal=User{userDisplayName}} = toAddress <<$>> getUserEmail usr + where toAddress = Address (Just userDisplayName) . CI.original + +getUserEmail :: Entity User -> DB (Maybe UserEmail) +getUserEmail Entity{entityKey=uid, entityVal=User{userDisplayEmail, userEmail}} + | validEmail' userDisplayEmail + = return $ Just userDisplayEmail | otherwise - = Nothing + = do + compEmailMb <- getUserPrimaryCompanyAddress uid companyEmail + return $ pickValidEmail' $ mcons compEmailMb [userEmail] + +-- address is prefixed with userDisplayName +getPostalAddress :: Entity User -> DB (Maybe [Text]) +getPostalAddress Entity{entityKey=uid, entityVal=User{..}} + | Just pa <- userPostAddress + = prefixMarkupName pa + | otherwise + = do + getUserPrimaryCompanyAddress uid companyPostAddress >>= \case + (Just pa) + -> prefixMarkupName pa + Nothing + | Just abt <- userCompanyDepartment + -> return $ Just $ if | "BVD" `isPrefixOf` abt -> [userDisplayName, abt, "Bodenverkehrsdienste"] + | otherwise -> [userDisplayName, abt, "Hausbriefkasten" ] + | otherwise -> return Nothing + where + prefixMarkupName = return . Just . (userDisplayName :) . html2textlines + +-- primed variant returns storedMarkup without prefixed userDisplayName +getPostalAddress' :: Entity User -> DB (Maybe StoredMarkup) +getPostalAddress' Entity{entityKey=uid, entityVal=User{..}} + | res@(Just _) <- userPostAddress + = return res + | otherwise + = do + getUserPrimaryCompanyAddress uid companyPostAddress >>= \case + res@(Just _) + -> return res + Nothing + | Just abt <- userCompanyDepartment + -> return $ Just $ plaintextToStoredMarkup $ textUnlines $ + if | "BVD" `isPrefixOf` abt -> [userDisplayName, abt, "Bodenverkehrsdienste"] + | otherwise -> [userDisplayName, abt, "Hausbriefkasten" ] + | otherwise -> return Nothing -- | Consider using Handler.Utils.Avs.updateReceivers instead -- Return Entity User and all Supervisors with rerouteNotifications as well as @@ -134,6 +204,17 @@ getSupervisees = do computeUserAuthenticationDigest :: AuthenticationMode -> Digest SHA3_256 computeUserAuthenticationDigest = hashlazy . JSON.encode +-- guessUserByCompanyPersonalNumber :: Text -> Text -> DB (Maybe UserId) +-- guessUserByCompanyPersonalNumber surname ipn = getKeyByFilter [UserCompanyPersonalNumber ==. Just ipn, UserSurname ==. surname] + +guessUserByEmail :: UserEmail -> DB (Maybe UserId) +guessUserByEmail eml = firstJustM $ + [ getKeyBy $ UniqueEmail eml + , getKeyBy $ UniqueAuthentication eml -- aka UserIdent + , getKeyByFilter [UserDisplayEmail ==. eml] + ] <> maybeEmpty (getFraportLogin (CI.original eml)) (\lgi -> + [ getKeyBy $ UniqueLdapPrimaryKey $ Just lgi + ]) data GuessUserInfo = GuessUserMatrikelnummer @@ -275,7 +356,7 @@ guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria) , Just True == matchesMatriculation x || didLdap -> return $ Just $ Left $ NonEmpty.fromList xs | not didLdap - , userMatrs <- (Set.toList . Set.fromList . catMaybes) $ getTermMatr <$> criteria + , userMatrs <- ((Set.toList . Set.fromList) (mapMaybe getTermMatr criteria)) -> mapM doLdap userMatrs >>= maybe (go True) (return . Just) . convertLdapResults . catMaybes | otherwise -> return Nothing @@ -859,9 +940,15 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do return $ UserSupervisor E.<# E.val newUserId E.<&> (userSupervisor E.^. UserSupervisorUser) - E.<&> (userSupervisor E.^. UserSupervisorRerouteNotifications) + E.<&> (userSupervisor E.^. UserSupervisorRerouteNotifications) + E.<&> (userSupervisor E.^. UserSupervisorCompany) + E.<&> (userSupervisor E.^. UserSupervisorReason) ) - (\current excluded -> [ UserSupervisorRerouteNotifications E.=. (current E.^. UserSupervisorRerouteNotifications E.||. excluded E.^. UserSupervisorRerouteNotifications) ] ) + (\current excluded -> + [ UserSupervisorRerouteNotifications E.=. (current E.^. UserSupervisorRerouteNotifications E.||. excluded E.^. UserSupervisorRerouteNotifications) + , UserSupervisorCompany E.=. E.coalesce [current E.^. UserSupervisorCompany, excluded E.^. UserSupervisorCompany] + , UserSupervisorReason E.=. E.coalesce [current E.^. UserSupervisorReason , excluded E.^. UserSupervisorReason] + ] ) deleteWhere [ UserSupervisorSupervisor ==. oldUserId] E.insertSelectWithConflict @@ -872,8 +959,14 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.<# (userSupervisor E.^. UserSupervisorSupervisor) E.<&> E.val newUserId E.<&> (userSupervisor E.^. UserSupervisorRerouteNotifications) + E.<&> (userSupervisor E.^. UserSupervisorCompany) + E.<&> (userSupervisor E.^. UserSupervisorReason) ) - (\current excluded -> [ UserSupervisorRerouteNotifications E.=. (current E.^. UserSupervisorRerouteNotifications E.||. excluded E.^. UserSupervisorRerouteNotifications) ] ) + (\current excluded -> + [ UserSupervisorRerouteNotifications E.=. (current E.^. UserSupervisorRerouteNotifications E.||. excluded E.^. UserSupervisorRerouteNotifications) + , UserSupervisorCompany E.=. E.coalesce [current E.^. UserSupervisorCompany, excluded E.^. UserSupervisorCompany] + , UserSupervisorReason E.=. E.coalesce [current E.^. UserSupervisorReason , excluded E.^. UserSupervisorReason] + ] ) deleteWhere [ UserSupervisorUser ==. oldUserId] -- Companies, in conflict, keep the newUser-Company as is @@ -886,8 +979,15 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.<&> (userCompany E.^. UserCompanyCompany) E.<&> (userCompany E.^. UserCompanySupervisor) E.<&> (userCompany E.^. UserCompanySupervisorReroute) + E.<&> (userCompany E.^. UserCompanyPriority) + E.<&> (userCompany E.^. UserCompanyUseCompanyAddress) + ) + (\current excluded -> + [ UserCompanySupervisor E.=. E.greatest (current E.^. UserCompanySupervisor) (excluded E.^. UserCompanySupervisor) -- t > f + , UserCompanyPriority E.=. E.greatest (current E.^. UserCompanyPriority) (excluded E.^. UserCompanyPriority) + , UserCompanyUseCompanyAddress E.=. E.greatest (current E.^. UserCompanyUseCompanyAddress) (excluded E.^. UserCompanyUseCompanyAddress) + ] ) - (\current _excluded -> [ UserCompanySupervisor E.=. (current E.^. UserCompanySupervisor)] ) deleteWhere [ UserCompanyUser ==. oldUserId] mbOldAvsId <- getBy $ UniqueUserAvsUser oldUserId @@ -896,10 +996,9 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do (Nothing, _) -> return () (Just Entity{entityVal=UserAvs{userAvsPersonId=oldAvsId}}, Just _) - -> deleteWhere [UserAvsCardPersonId ==. oldAvsId] >> deleteBy (UniqueUserAvsUser oldUserId) + -> deleteBy (UniqueUserAvsId oldAvsId) (Just Entity{entityVal=oldUserAvs}, Nothing) - -> -- deleteBy $ UniqueUserAvsUser oldUserId -- maybe we need this due to double uniqueness?! - void $ upsertBy (UniqueUserAvsId (oldUserAvs ^. _userAvsPersonId)) oldUserAvs{userAvsUser=newUserId} [UserAvsUser =. newUserId] + -> void $ upsertBySafe (UniqueUserAvsId (oldUserAvs ^. _userAvsPersonId)) oldUserAvs{userAvsUser=newUserId} (_userAvsUser .~ newUserId) -- merge some optional / incomplete user fields let mergeBy :: forall a . PersistField a => (a -> a -> Bool) -> EntityField User a -> Maybe (Update User) diff --git a/src/Handler/Utils/avs_callgraph.md b/src/Handler/Utils/avs_callgraph.md new file mode 100644 index 000000000..0b5c56281 --- /dev/null +++ b/src/Handler/Utils/avs_callgraph.md @@ -0,0 +1,47 @@ +# Demo +## Mermaid Flowcharts + +```mermaid +flowchart LR; + gau([guessAvsUser]) + %% uau([XupsertAvsUser]) + uaubi[upsertAvsUserById] + uaubis[upsertAvsUserByIds] + uaubc[upsertAvsUserByCard] + ldap[[ldapLookupAndUpsert]] + lau[lookupAvsUser] + laus[lookupAvsUsers - DEPRECATED?] + gla[guessLicenceAddress - DEPRECATED] + ur([?updateReceivers]) + caubi[createAvsUserById] + ucomp[upsertAvsCompany] + + aqc{{AvsQueryContact}} + aqp{{AvsQueryPerson}} + aqs{{AvsQueryStatus}} + + + uaubc-->uaubi + uaubc-->aqp + + gau-->uaubi + gau-->uaubc + gau-->ldap + + %% uau-..->uaubi + %% uau-..->uaubc + + uaubi-->uaubis + uaubi-->caubi-->uaubis + uaubis-->aqc + caubi-->aqs + caubi-->aqc + + caubi-->ucomp + uaubis-->ucomp + + lau-->laus + laus-->aqs + + ur-->uaubi +``` \ No newline at end of file diff --git a/src/Jobs/Handler/ChangeUserDisplayEmail.hs b/src/Jobs/Handler/ChangeUserDisplayEmail.hs index ec735be34..ccdc2b65d 100644 --- a/src/Jobs/Handler/ChangeUserDisplayEmail.hs +++ b/src/Jobs/Handler/ChangeUserDisplayEmail.hs @@ -9,6 +9,7 @@ module Jobs.Handler.ChangeUserDisplayEmail import Import import Handler.Utils.Mail +import Handler.Utils.Users import qualified Data.HashSet as HashSet import qualified Data.HashMap.Strict as HashMap import qualified Data.CaseInsensitive as CI @@ -24,10 +25,13 @@ dispatchJobChangeUserDisplayEmail jUser jDisplayEmail = JobHandlerException $ do setDisplayEmailUrl = SomeRoute (SetDisplayEmailR, [(toPathPiece GetBearer, toPathPiece jwt)]) setDisplayEmailUrl' <- toTextUrl setDisplayEmailUrl - user@User{..} <- runDB $ getJust jUser + (Entity{entityVal=User{..}}, userAddress) <- runDB $ do + usrEnt <- getJustEntity jUser -- error aborts job + usrAdr <- getJustEmailAddress usrEnt + return (usrEnt, usrAdr) userMailT jUser $ do - _mailTo .= pure (userAddress user & _addressEmail .~ CI.original jDisplayEmail) + _mailTo .= pure (userAddress & _addressEmail .~ CI.original jDisplayEmail) replaceMailHeader "Auto-Submitted" $ Just "auto-generated" setSubjectI MsgMailSubjectChangeUserDisplayEmail addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/changeUserDisplayEmail.hamlet") :: HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX)) diff --git a/src/Jobs/Handler/Invitation.hs b/src/Jobs/Handler/Invitation.hs index 783b035dd..ad6cb7dc9 100644 --- a/src/Jobs/Handler/Invitation.hs +++ b/src/Jobs/Handler/Invitation.hs @@ -8,6 +8,7 @@ module Jobs.Handler.Invitation import Import import Handler.Utils.Mail +import Handler.Utils.Users import qualified Data.CaseInsensitive as CI import Text.Hamlet @@ -20,12 +21,15 @@ dispatchJobInvitation :: Maybe UserId -> Html -> JobHandler UniWorX dispatchJobInvitation jInviter jInvitee jInvitationUrl jInvitationSubject jInvitationExplanation = JobHandlerException $ do - mInviter <- join <$> traverse (runDB . get) jInviter + (mInviter, mInviterAddress) <- ifNothingM jInviter (Nothing,Nothing) $ \uid -> runDB $ do + usrEnt <- getEntity uid + usrAdr <- join <$> traverse getEmailAddress usrEnt + return (usrEnt ^? _Just . _entityVal, usrAdr) mailT def $ do _mailTo .= [Address Nothing $ CI.original jInvitee] - whenIsJust mInviter $ \jInviter' -> - replaceMailHeader "Reply-To" . Just . renderAddress $ userAddressFrom jInviter' + whenIsJust mInviterAddress $ \jInviterAddress -> + replaceMailHeader "Reply-To" . Just $ renderAddress jInviterAddress replaceMailHeader "Auto-Submitted" $ Just "auto-generated" replaceMailHeader "Subject" $ Just jInvitationSubject addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/invitation.hamlet") :: HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX)) diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 136ea518e..b2440e73e 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -60,7 +60,7 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act act = do quali <- getJust qid -- may throw an error, aborting the job let qshort = CI.original $ qualificationShorthand quali - $logInfoS "LMS" $ "Notifying about exipiring qualification " <> qshort + $logInfoS "LMS" $ "Notifying about expiring qualification " <> qshort now <- liftIO getCurrentTime case qualificationRefreshWithin quali of Nothing -> return () -- TODO: no renewal period, no reminders currently @@ -92,7 +92,7 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act } _ -> return () -- send second reminders first, before enqueing even more - ifMaybeM (qualificationRefreshReminder quali) () sendReminders + ifNothingM (qualificationRefreshReminder quali) () sendReminders renewalUsers <- E.select $ do quser <- E.from $ E.table @QualificationUser @@ -129,7 +129,6 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act qprefix = fst <$> Text.uncons (Text.toLower qshort) identsInUseVs <- E.select $ do lui <- E.from $ - ( (E.^. LmsUserIdent) <$> E.from (E.table @LmsUser ) ) -- no filter by Qid, since LmsIdents must be unique across all `E.union_` ( (E.^. LmsReportIdent) <$> E.from (E.table @LmsReport ) ) -- V2 diff --git a/src/Jobs/Handler/QueueNotification.hs b/src/Jobs/Handler/QueueNotification.hs index a4a407afa..12abd0c4d 100644 --- a/src/Jobs/Handler/QueueNotification.hs +++ b/src/Jobs/Handler/QueueNotification.hs @@ -16,7 +16,8 @@ import Jobs.Queue import qualified Data.Set as Set -import Handler.Utils.Profile (pickValidEmail') +-- import Utils.Mail (pickValidUserEmail') +import Handler.Utils.Users (getUserEmail) import Handler.Utils.ExamOffice.Exam import Handler.Utils.ExamOffice.ExternalExam @@ -27,8 +28,8 @@ dispatchJobQueueNotification :: Notification -> JobHandler UniWorX dispatchJobQueueNotification jNotification = JobHandlerAtomic $ runConduit $ yield jNotification .| transPipe (hoist lift) determineNotificationCandidates - .| C.filterM (\(notification', override, Entity _ User{userNotificationSettings,userDisplayEmail,userEmail}) -> - and2M (return $ isJust $ pickValidEmail' userDisplayEmail userEmail) $ + .| C.filterM (\(notification', override, usr@(Entity _ User{userNotificationSettings})) -> + and2M (isJust <$> hoist lift (getUserEmail usr)) $ or2M (return override) $ notificationAllowed userNotificationSettings <$> hoist lift (classifyNotification notification')) .| C.map (\(notification', _, Entity uid _) -> JobSendNotification uid notification') .| sinkDBJobs diff --git a/src/Jobs/Handler/SendCourseCommunication.hs b/src/Jobs/Handler/SendCourseCommunication.hs index 1a065726c..cd5badf96 100644 --- a/src/Jobs/Handler/SendCourseCommunication.hs +++ b/src/Jobs/Handler/SendCourseCommunication.hs @@ -12,6 +12,7 @@ import Import import Text.Hamlet import Handler.Utils +import Handler.Utils.Users import qualified Data.CaseInsensitive as CI import Handler.Utils.Csv (partIsAttachmentCsv) @@ -28,14 +29,17 @@ dispatchJobSendCourseCommunication :: Either UserEmail UserId -> CommunicationContent -> JobHandler UniWorX dispatchJobSendCourseCommunication jRecipientEmail jAllRecipientAddresses jCourse jSender jMailObjectUUID CommunicationContent{..} = JobHandlerException $ do - (sender, Course{..}) <- runDB $ (,) - <$> getJust jSender - <*> getJust jCourse + (Course{..}, senderAddress) <- runDB $ do + crs <- getJust jCourse + usr <- getJustEntity jSender + adr <- getJustEmailAddress usr + return (crs, adr) + either (\email -> mailT def . (assign _mailTo (pure . Address Nothing $ CI.original email) *>)) userMailT jRecipientEmail $ do -- userMailT obeys reroutes, userMailT direct does not MsgRenderer mr <- getMailMsgRenderer void $ setMailObjectUUID jMailObjectUUID - _mailFrom .= userAddressFrom sender + _mailFrom .= senderAddress addMailHeader "Cc" [st|#{mr MsgCommUndisclosedRecipients}:;|] addMailHeader "Auto-Submitted" "no" setSubjectI . prependCourseTitle courseTerm courseSchool courseShorthand $ maybe (SomeMessage MsgUtilCommCourseSubject) SomeMessage ccSubject @@ -55,15 +59,13 @@ dispatchJobSendFirmCommunication :: Either UserEmail UserId -> CommunicationContent -> JobHandler UniWorX dispatchJobSendFirmCommunication jRecipientEmail jAllRecipientAddresses _jCompanies jSender jMailObjectUUID CommunicationContent{..} = JobHandlerException $ do - -- (sender,mbComp) <- runDB $ (,) - -- <$> getJust jSender - -- <*> ifMaybeM jCompany Nothing get - sender <- runDB $ getJust jSender + senderAddress <- runDB $ getJustEmailAddressFor jSender + either (\email -> mailT def . (assign _mailTo (pure . Address Nothing $ CI.original email) *>)) userMailT jRecipientEmail $ do -- userMailT obeys reroutes, userMailT direct does not MsgRenderer mr <- getMailMsgRenderer void $ setMailObjectUUID jMailObjectUUID - _mailFrom .= userAddressFrom sender + _mailFrom .= senderAddress addMailHeader "Cc" [st|#{mr MsgCommUndisclosedRecipients}:;|] addMailHeader "Auto-Submitted" "no" setSubjectI $ maybe (SomeMessage MsgUtilCommFirmSubject) SomeMessage ccSubject diff --git a/src/Jobs/Handler/SendNotification/SubmissionEdited.hs b/src/Jobs/Handler/SendNotification/SubmissionEdited.hs index 94679e01a..854a519e2 100644 --- a/src/Jobs/Handler/SendNotification/SubmissionEdited.hs +++ b/src/Jobs/Handler/SendNotification/SubmissionEdited.hs @@ -13,6 +13,7 @@ module Jobs.Handler.SendNotification.SubmissionEdited import Import import Handler.Utils +import Handler.Utils.Users import Jobs.Handler.SendNotification.Utils import Text.Hamlet @@ -36,10 +37,11 @@ dispatchNotificationSubmissionEdited nInitiator nSubmission jRecipient = userMai E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val nSubmission E.&&. user E.^. UserId E.!=. E.val jRecipient return user + coSubmittorsAddrs <- maybeMapM getEmailAddress coSubmittors - return (course, sheet, submission, initiator, coSubmittors) + return (course, sheet, submission, initiator, coSubmittorsAddrs) - let allCoSubmittors = Text.intercalate ", " $ map (renderAddress . userAddressFrom . entityVal) coSubmittors + let allCoSubmittors = Text.intercalate ", " $ map renderAddress coSubmittors addMailHeader "Reply-To" allCoSubmittors replaceMailHeader "Auto-Submitted" $ Just "auto-generated" @@ -69,14 +71,15 @@ dispatchNotificationSubmissionUserCreated nUser nSubmission jRecipient = userMai E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val nSubmission E.&&. user E.^. UserId E.!=. E.val jRecipient return user + coSubmittorsAddrs <- maybeMapM getEmailAddress coSubmittors user <- getJust nUser - return (user, course, sheet, submission, coSubmittors) + return (user, course, sheet, submission, coSubmittorsAddrs) let isSelf = nUser == jRecipient - let allCoSubmittors = Text.intercalate ", " $ map (renderAddress . userAddressFrom . entityVal) coSubmittors + let allCoSubmittors = Text.intercalate ", " $ map renderAddress coSubmittors addMailHeader "Reply-To" allCoSubmittors replaceMailHeader "Auto-Submitted" $ Just "auto-generated" @@ -99,7 +102,7 @@ dispatchNotificationSubmissionUserCreated nUser nSubmission jRecipient = userMai dispatchNotificationSubmissionUserDeleted :: UserId -> SheetId -> SubmissionId -> UserId -> Handler () dispatchNotificationSubmissionUserDeleted nUser nSheet nSubmission jRecipient = userMailT jRecipient $ do - (User{..}, Course{..}, Sheet{..}, mSubmission, coSubmittors) <- liftHandler . runDB $ do + (User{..}, Course{..}, Sheet{..}, mSubmission, coSubmittors, coSubmittorsAddrs) <- liftHandler . runDB $ do submission <- get nSubmission sheet <- maybe (getJust nSheet) (belongsToJust submissionSheet) submission @@ -110,15 +113,15 @@ dispatchNotificationSubmissionUserDeleted nUser nSheet nSubmission jRecipient = E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val nSubmission E.&&. user E.^. UserId E.!=. E.val jRecipient return user - + coSubmittorsAddrs <- maybeMapM getEmailAddress coSubmittors user <- getJust nUser - return (user, course, sheet, submission, coSubmittors) + return (user, course, sheet, submission, coSubmittors, coSubmittorsAddrs) let isSelf = nUser == jRecipient unless (null coSubmittors) $ do - let allCoSubmittors = Text.intercalate ", " $ map (renderAddress . userAddressFrom . entityVal) coSubmittors + let allCoSubmittors = Text.intercalate ", " $ map renderAddress coSubmittorsAddrs addMailHeader "Reply-To" allCoSubmittors replaceMailHeader "Auto-Submitted" $ Just "auto-generated" diff --git a/src/Jobs/Handler/SendNotification/SubmissionRated.hs b/src/Jobs/Handler/SendNotification/SubmissionRated.hs index efbb0a5fc..fd04a4b92 100644 --- a/src/Jobs/Handler/SendNotification/SubmissionRated.hs +++ b/src/Jobs/Handler/SendNotification/SubmissionRated.hs @@ -11,6 +11,7 @@ module Jobs.Handler.SendNotification.SubmissionRated import Import import Handler.Utils +import Handler.Utils.Users import Jobs.Handler.SendNotification.Utils import Text.Hamlet @@ -19,22 +20,25 @@ import qualified Data.CaseInsensitive as CI dispatchNotificationSubmissionRated :: SubmissionId -> UserId -> Handler () dispatchNotificationSubmissionRated nSubmission jRecipient = maybeT_ $ do - (Course{..}, Sheet{..}, Submission{..}, corrector, sheetTypeDesc, hasAccess, csid) <- lift . runDB $ do + (Course{..}, Sheet{..}, Submission{..}, corrector, correctorAddr, sheetTypeDesc, hasAccess, csid) <- lift . runDB $ do submission@Submission{submissionRatingBy} <- getJust nSubmission sheet@Sheet{sheetName} <- belongsToJust submissionSheet submission course@Course{..} <- belongsToJust sheetCourse sheet - corrector <- traverse getJust submissionRatingBy + correctorEnt <- traverse getJustEntity submissionRatingBy + correctorAddr <- join <$> traverse getEmailAddress correctorEnt + let corrector = correctorEnt ^? _Just . _entityVal + sheetTypeDesc <- sheetTypeDescription (sheetCourse sheet) (sheetType sheet) csid <- encrypt nSubmission hasAccess <- is _Authorized <$> evalAccessForDB (Just jRecipient) (CSubmissionR courseTerm courseSchool courseShorthand sheetName csid CorrectionR) False - return (course, sheet, submission, corrector, sheetTypeDesc, hasAccess, csid) + return (course, sheet, submission, corrector, correctorAddr, sheetTypeDesc, hasAccess, csid) guard hasAccess lift . userMailT jRecipient $ do - whenIsJust corrector $ \corrector' -> - addMailHeader "Reply-To" . renderAddress $ userAddressFrom corrector' + whenIsJust correctorAddr $ \correctorAddr' -> + addMailHeader "Reply-To" $ renderAddress correctorAddr' replaceMailHeader "Auto-Submitted" $ Just "auto-generated" setSubjectI $ MsgMailSubjectSubmissionRated courseShorthand diff --git a/src/Jobs/Handler/SynchroniseAvs.hs b/src/Jobs/Handler/SynchroniseAvs.hs index 0b393f0e2..503ee3ee9 100644 --- a/src/Jobs/Handler/SynchroniseAvs.hs +++ b/src/Jobs/Handler/SynchroniseAvs.hs @@ -4,29 +4,34 @@ module Jobs.Handler.SynchroniseAvs ( dispatchJobSynchroniseAvs - , dispatchJobSynchroniseAvsId - , dispatchJobSynchroniseAvsUser - , dispatchJobSynchroniseAvsNext + -- , dispatchJobSynchroniseAvsId + -- , dispatchJobSynchroniseAvsUser , dispatchJobSynchroniseAvsQueue ) where import Import +import qualified Data.Set as Set +import qualified Data.Conduit.List as C + +import Database.Esqueleto.Experimental ((:&)(..)) +import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma -- import qualified Database.Esqueleto.Legacy as E hiding (upsert) -- import qualified Database.Esqueleto.PostgreSQL as E --- import qualified Database.Esqueleto.Utils as E +import qualified Database.Esqueleto.Utils as E -import qualified Data.Conduit.List as C import Jobs.Queue import Handler.Utils.Avs +-- 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 dispatchJobSynchroniseAvs numIterations epoch iteration pause = JobHandlerException . runDB $ do now <- liftIO getCurrentTime todos <- runConduit $ readUsers .| filterIteration now .| sinkList putMany todos + $logInfoS "SynchronisAvs" [st|AVS synch summary for #{tshow numIterations}/#{tshow epoch}/#{tshow iteration}: #{length todos}|] void $ queueJob JobSynchroniseAvsQueue where readUsers :: ConduitT () UserId _ () @@ -38,70 +43,86 @@ dispatchJobSynchroniseAvs numIterations epoch iteration pause userIteration, currentIteration :: Integer userIteration = toInteger (hash epoch `hashWithSalt` userId) `mod` toInteger numIterations currentIteration = toInteger iteration `mod` toInteger numIterations - -- $logDebugS "SynchronisAvs" [st|User ##{tshow (fromSqlKey userId)}: sync on #{tshow userIteration}/#{tshow numIterations}, now #{tshow currentIteration}|] + $logDebugS "SynchronisAvs" [st|User ##{tshow (fromSqlKey userId)}: AVS sync on #{tshow userIteration}/#{tshow numIterations}, now #{tshow currentIteration}|] guard $ userIteration == currentIteration return $ AvsSync userId now pause --- dispatchJobSynchroniseAvs' :: Natural -> Natural -> Natural -> Maybe Day -> JobHandler UniWorX --- dispatchJobSynchroniseAvs' numIterations epoch iteration pause = JobHandlerAtomic $ do +-- dispatchJobSynchroniseAvsId :: AvsPersonId -> Maybe Day -> JobHandler UniWorX +-- dispatchJobSynchroniseAvsId apid pause = JobHandlerException $ +-- maybeM insertUnknown processKnown $ runDB $ getBy (UniqueUserAvsId apid) +-- where +-- processKnown Entity{entityVal=UserAvs{userAvsUser=uid}} = workJobSychronizeAvs uid pause +-- insertUnknown = void $ maybeCatchAll $ Just <$> upsertAvsUserById apid + +-- dispatchJobSynchroniseAvsUser :: UserId -> Maybe Day -> JobHandler UniWorX +-- dispatchJobSynchroniseAvsUser uid pause = JobHandlerException $ workJobSychronizeAvs uid pause + +-- workJobSychronizeAvs :: UserId -> Maybe Day -> Handler () +-- workJobSychronizeAvs uid pause = do +-- now <- liftIO getCurrentTime +-- -- void $ E.upsert +-- -- AvsSync { avsSyncUser = uid +-- -- , avsSyncCreationTime = now +-- -- , avsSyncPause = pause +-- -- } +-- -- [ \oldSync -> (AvsSyncPause E.=. E.greatest (E.val pause) (oldSync E.^. AvsSyncPause)) oldSync ] -- causes Esqueleto to call undefined at Database.Esqueleto.Internal.Internal.renderUpdates:1308 +-- runDB $ maybeM +-- (insert_ AvsSync{avsSyncUser=uid, avsSyncCreationTime=now, avsSyncPause=pause}) +-- (\Entity{entityKey=asid, entityVal=AvsSync{avsSyncPause=oldPause}} -> +-- update asid [AvsSyncPause =. max pause oldPause, AvsSyncCreationTime =. now]) +-- (getBy $ UniqueAvsSyncUser uid) +-- void $ queueJob JobSynchroniseAvsQueue -dispatchJobSynchroniseAvsId :: AvsPersonId -> Maybe Day -> JobHandler UniWorX -dispatchJobSynchroniseAvsId apid pause = JobHandlerException $ do - ok <- runDB $ getBy (UniqueUserAvsId apid) >>= - \case - (Just Entity{entityVal=UserAvs{userAvsUser=uid}}) -> do -- known user - workJobSychronizeAvs uid pause - return True - _ -> -- unknown avsPersonId, attempt to create user - return False - unless ok $ void $ maybeCatchAll $ upsertAvsUserById apid - - -dispatchJobSynchroniseAvsUser :: UserId -> Maybe Day -> JobHandler UniWorX -dispatchJobSynchroniseAvsUser uid pause = JobHandlerException $ runDB $ workJobSychronizeAvs uid pause - -workJobSychronizeAvs :: UserId -> Maybe Day -> DB () -workJobSychronizeAvs uid pause = do - now <- liftIO getCurrentTime - -- void $ E.upsert - -- AvsSync { avsSyncUser = uid - -- , avsSyncCreationTime = now - -- , avsSyncPause = pause - -- } - -- [ \oldSync -> (AvsSyncPause E.=. E.greatest (E.val pause) (oldSync E.^. AvsSyncPause)) oldSync ] -- causes Esqueleto to call undefined at Database.Esqueleto.Internal.Internal.renderUpdates:1308 - maybeM - (insert_ AvsSync{avsSyncUser=uid, avsSyncCreationTime=now, avsSyncPause=pause}) - (\Entity{entityKey=asid, entityVal=AvsSync{avsSyncPause=oldPause}} -> - update asid [AvsSyncPause =. max pause oldPause, AvsSyncCreationTime =. now]) - (getBy $ UniqueAvsSyncUser uid) - queueJob' JobSynchroniseAvsQueue - +-- dispatchJobSynchroniseAvsQueue :: JobHandler UniWorX +-- dispatchJobSynchroniseAvsQueue = JobHandlerException $ do +-- (unlinked,linked) <- runDB $ do +-- jobs <- E.select (do +-- (avsSync :& usrAvs) <- E.from $ E.table @AvsSync +-- `E.leftJoin` E.table @UserAvs +-- `E.on` (\(avsSync :& usrAvs) -> avsSync E.^. AvsSyncUser E.=?. usrAvs E.?. UserAvsUser) +-- let pause = avsSync E.^. AvsSyncPause +-- lastSync = usrAvs E.?. UserAvsLastSynch +-- E.where_ $ E.isNothing pause +-- E.||. E.isNothing lastSync +-- E.||. pause E.>. E.dayMaybe lastSync +-- return (avsSync E.^. AvsSyncId, avsSync E.^. AvsSyncUser, usrAvs E.?. UserAvsPersonId) +-- ) +-- let (syncIds, unlinked, linked) = foldl' discernJob mempty jobs +-- E.deleteWhere [AvsSyncId <-. syncIds] +-- return (unlinked, linked) + +-- void $ updateAvsUserByIds linked +-- void $ linktoAvsUserByUIDs unlinked +-- -- we do not reschedule failed synchs here in order to avoid a loop +-- where +-- discernJob (accSync, accUid, accApi) (E.Value k, _, E.Value (Just api)) = (k:accSync, accUid, Set.insert api accApi) +-- discernJob (accSync, accUid, accApi) (E.Value k, E.Value uid, E.Value Nothing ) = (k:accSync, Set.insert uid accUid, accApi) + dispatchJobSynchroniseAvsQueue :: JobHandler UniWorX -dispatchJobSynchroniseAvsQueue = JobHandlerException $ do - syncJob <- runDB $ - selectFirst [] [Asc AvsSyncCreationTime] >>= \case - Nothing -> return Nothing -- nothing more to do - Just Entity{entityKey=asid, entityVal=AvsSync{..}} -> do - delete asid - getBy (UniqueUserAvsUser avsSyncUser) >>= \case - Just uae@Entity{entityVal=UserAvs{userAvsLastSynch} } - | maybe True (utctDay userAvsLastSynch <) avsSyncPause -> return $ Just uae - _other -> return Nothing -- we just updated this one within the given limit or the entity does not exist - - ifMaybeM syncJob () $ \Entity{entityKey=avsKey, entityVal=UserAvs{userAvsPersonId=apid}} -> do - void $ queueJob JobSynchroniseAvsNext - catch (void $ upsertAvsUserById apid) -- already updates UserAvsLastSynch - (\exc -> do - now <- liftIO getCurrentTime - let excMsg = tshow exc <> " at " <> tshow now - runDB (update avsKey [UserAvsLastSynchError =. Just excMsg, UserAvsLastSynch =. now]) - case exc of - AvsInterfaceUnavailable -> return () -- ignore and retry later - AvsUserUnknownByAvs _ -> return () -- ignore for users no longer listed in AVS - otherExc -> throwM otherExc - ) - --- needed, since JobSynchroniseAvsQueue cannot requeue itself due to JobNoQueueSame (and having no parameters) -dispatchJobSynchroniseAvsNext :: JobHandler UniWorX -dispatchJobSynchroniseAvsNext = JobHandlerException $ void $ queueJob JobSynchroniseAvsQueue +dispatchJobSynchroniseAvsQueue = JobHandlerException $ do + jobs <- runDB $ do + jobs <- E.select (do + (avsSync :& usrAvs) <- E.from $ E.table @AvsSync + `E.leftJoin` E.table @UserAvs + `E.on` (\(avsSync :& usrAvs) -> avsSync E.^. AvsSyncUser E.=?. usrAvs E.?. UserAvsUser) + let pause = avsSync E.^. AvsSyncPause + lastSync = usrAvs E.?. UserAvsLastSynch + E.where_ $ E.isNothing pause + E.||. E.isNothing lastSync + E.||. pause E.>. E.dayMaybe lastSync + return (avsSync E.^. AvsSyncUser, usrAvs E.?. UserAvsPersonId) + ) + now <- liftIO getCurrentTime + 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|] + void $ updateAvsUserByIds linked + void $ linktoAvsUserByUIDs unlinked + $logInfoS "SynchronisAvs" [st|AVS synch performed for #{length linked} AVS linked users and #{length unlinked} unlinked users|] + -- we do not reschedule failed synchs here in order to avoid a loop + where + discernJob (accUid, accApi) ( _ , E.Value (Just api)) = ( accUid, Set.insert api accApi) + discernJob (accUid, accApi) (E.Value uid, E.Value Nothing ) = (Set.insert uid accUid, accApi) + \ No newline at end of file diff --git a/src/Jobs/Handler/SynchroniseLdap.hs b/src/Jobs/Handler/SynchroniseLdap.hs index 52572d879..c0fc5758a 100644 --- a/src/Jobs/Handler/SynchroniseLdap.hs +++ b/src/Jobs/Handler/SynchroniseLdap.hs @@ -37,7 +37,7 @@ dispatchJobSynchroniseLdap numIterations epoch iteration userIteration, currentIteration :: Integer userIteration = toInteger (hash epoch `hashWithSalt` userId) `mod` toInteger numIterations currentIteration = toInteger iteration `mod` toInteger numIterations - $logDebugS "SynchroniseLdap" [st|User ##{tshow (fromSqlKey userId)}: sync on #{tshow userIteration}/#{tshow numIterations}, now #{tshow currentIteration}|] + $logDebugS "SynchroniseLdap" [st|User ##{tshow (fromSqlKey userId)}: LDAP sync on #{tshow userIteration}/#{tshow numIterations}, now #{tshow currentIteration}|] guard $ userIteration == currentIteration return $ JobSynchroniseLdapUser userId diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index 69ad6b4d6..1c865a328 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -102,14 +102,13 @@ data Job , jIteration :: Natural , jSynchAfter :: Maybe Day } - | JobSynchroniseAvsUser { jUser :: UserId - , jSynchAfter :: Maybe Day - } - | JobSynchroniseAvsId { jAvsId :: AvsPersonId - , jSynchAfter :: Maybe Day - } - | JobSynchroniseAvsQueue - | JobSynchroniseAvsNext + -- | JobSynchroniseAvsUser { jUser :: UserId + -- , jSynchAfter :: Maybe Day + -- } + -- | JobSynchroniseAvsId { jAvsId :: AvsPersonId + -- , jSynchAfter :: Maybe Day + -- } + | JobSynchroniseAvsQueue | JobChangeUserDisplayEmail { jUser :: UserId , jDisplayEmail :: UserEmail } @@ -351,10 +350,9 @@ jobNoQueueSame = \case JobSynchroniseLdap{} -> Just JobNoQueueSame JobSynchroniseLdapUser{} -> Just JobNoQueueSame JobSynchroniseAvs{} -> Just JobNoQueueSame - JobSynchroniseAvsUser{} -> Just JobNoQueueSame - JobSynchroniseAvsId{} -> Just JobNoQueueSame - JobSynchroniseAvsQueue{} -> Just JobNoQueueSame - JobSynchroniseAvsNext{} -> Just JobNoQueueSame + -- JobSynchroniseAvsUser{} -> Just JobNoQueueSame + -- JobSynchroniseAvsId{} -> Just JobNoQueueSame + JobSynchroniseAvsQueue{} -> Just JobNoQueueSame JobChangeUserDisplayEmail{} -> Just JobNoQueueSame JobPruneSessionFiles{} -> Just JobNoQueueSameTag JobPruneUnreferencedFiles{} -> Just JobNoQueueSameTag diff --git a/src/Model/Migration/Definitions.hs b/src/Model/Migration/Definitions.hs index ab0147ff4..6a0f3eb4b 100644 --- a/src/Model/Migration/Definitions.hs +++ b/src/Model/Migration/Definitions.hs @@ -48,8 +48,9 @@ import qualified Data.Time.Zones as TZ data ManualMigration = Migration20230524QualificationUserBlock - | Migration20230703LmsUserStatus + | Migration20230703LmsUserStatus | Migration20240212InitInterfaceHealth -- create table interface_health and fill with default values + | Migration20240224UniquenessCompanyAvsNr deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic) deriving anyclass (Universe, Finite) @@ -94,11 +95,10 @@ migrateManual = do , ("idx_qualification_user_block_quser" ,"CREATE INDEX idx_qualification_user_block_quser ON \"qualification_user_block\" (\"qualification_user\")") , ("idx_qualification_user_block_unblock","CREATE INDEX idx_qualification_user_block_unblock ON \"qualification_user_block\" (\"unblock\")") , ("idx_qualification_user_block_from" ,"CREATE INDEX idx_qualification_user_block_from ON \"qualification_user_block\" (\"from\")") - , ("idx_print_job_apc_ident" ,"CREATE INDEX idx_print_job_apc_ident ON \"print_job\" (\"apc_ident\")") - , ("idx_user_avs_card_person_id" ,"CREATE INDEX idx_user_avs_card_person_id ON \"user_avs_card\" (\"person_id\")") + , ("idx_print_job_apc_ident" ,"CREATE INDEX idx_print_job_apc_ident ON \"print_job\" (\"apc_ident\")") , ("idx_lms_report_log_q_ident_time" ,"CREATE INDEX idx_lms_report_log_q_ident_time ON \"lms_report_log\" (\"qualification\",\"ident\",\"timestamp\")") , ("idx_user_company_company" ,"CREATE INDEX idx_user_company_company ON \"user_company\" (\"company\")") -- composed index from unique cannot be used for frequently used filters on company - , ("idx_user_supervisor_user" ,"CREATE INDEX idx_user_supervisor_user ON \"user_supervisor\" (\"user\")") -- composed index from unique cannot be used for frequently used filters on user + , ("idx_user_supervisor_user" ,"CREATE INDEX idx_user_supervisor_user ON \"user_supervisor\" (\"user\")") -- composed index from unique cannot be used for frequently used filters on user ] where addIndex :: Text -> Sql -> Migration @@ -197,6 +197,13 @@ customMigrations = mapF $ \case ON CONFLICT DO NOTHING; |] + Migration20240224UniquenessCompanyAvsNr -> + whenM (tableExists "company" `and2M` notM (indexExists "unique_company_avs_id")) $ do -- companies with avs_id == 0 can be deleted; company users are deleted automatically by cascade + [executeQQ| + DELETE FROM "company" WHERE avs_id = 0; + ALTER TABLE "company" DROP CONSTRAINT IF EXISTS "unique_company_shorthand"; + |] + tableExists :: MonadIO m => Text -> ReaderT SqlBackend m Bool tableExists table = do @@ -238,3 +245,10 @@ columnNotExists :: MonadIO m -> Text -- ^ Column -> ReaderT SqlBackend m Bool columnNotExists table column = and2M (tableExists table) (not <$> columnExists table column) + +indexExists :: MonadIO m => Text -> ReaderT SqlBackend m Bool +indexExists ixName = do + res <- [sqlQQ|SELECT EXISTS (SELECT 1 FROM pg_indexes WHERE schemaname = current_schema() AND indexname = #{ixName})|] + return $ case res of + [Single e] -> e + _other -> True diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs index 997fa6588..0b0145ef0 100644 --- a/src/Model/Types/Avs.hs +++ b/src/Model/Types/Avs.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -12,6 +12,9 @@ module Model.Types.Avs ) where import Import.NoModel hiding ((.=)) + +import Model.Types.Markup + import Database.Persist.Sql import qualified Database.Esqueleto.Experimental as E import qualified Data.Csv as Csv @@ -25,7 +28,10 @@ import qualified Data.Set as Set -- import qualified Data.HashMap.Lazy as HM import Data.Aeson -import Data.Aeson.Types +import Data.Aeson.Types as Aeson + +import Utils.Postal (validPostAddressText) +import Utils.Mail (pickValidEmail) {- @@ -77,13 +83,29 @@ instance FromJSON SloppyBool where parseJSON invalid = prependFailure "parsing SloppyBool failed, " $ fail $ "expected Bool or String encoding boolean. Found " ++ show invalid +------------------------ +-- Specific Utilities -- +------------------------ + +composeAddress :: Maybe Text -> Maybe Text -> Maybe Text -> Maybe Text -> Maybe Text +composeAddress street zipcode city country = toMaybe (notNull compAddr) compAddr + where + compAddr = textUnlines $ stripList [street, zipCity, country'] + zipCity = Just $ Text.unwords $ stripList [zipcode, city] + country' = case country of + (Just "Deutschland") -> Nothing -- letters sent by APC originate in Germany + other -> other + + stripList xs = [y | Just x <- xs, let y = Text.strip x, notNull y] + + ------------------- -- AVS Datatypes -- ------------------- newtype AvsInternalPersonalNo = AvsInternalPersonalNo { avsInternalPersonalNo :: Text } -- ought to be all digits deriving (Eq, Ord, Show, Generic) - deriving newtype (NFData, PathPiece, PersistField, PersistFieldSql, Csv.ToField, Csv.FromField) + deriving newtype (NFData, PathPiece, PersistField, PersistFieldSql, Csv.ToField, Csv.FromField, Binary) instance E.SqlString AvsInternalPersonalNo -- AvsInternalPersonalNo is an untagged Text with respect to FromJSON/ToJSON, as needed by AVS API @@ -94,12 +116,15 @@ mkAvsInternalPersonalNo :: Text -> AvsInternalPersonalNo mkAvsInternalPersonalNo = AvsInternalPersonalNo . normalizeAvsInternalPersonalNo instance Canonical AvsInternalPersonalNo where - canonical (AvsInternalPersonalNo ipn) = AvsInternalPersonalNo $ Text.dropWhile (\c -> '0' == c || Char.isSpace c) ipn + canonical (AvsInternalPersonalNo ipn) = AvsInternalPersonalNo $ normalizeAvsInternalPersonalNo ipn instance FromJSON AvsInternalPersonalNo where parseJSON x = AvsInternalPersonalNo . normalizeAvsInternalPersonalNo <$> parseJSON x instance ToJSON AvsInternalPersonalNo where toJSON (AvsInternalPersonalNo ipn) = toJSON $ normalizeAvsInternalPersonalNo ipn +_avsInternalPersonalNo :: Lens' AvsInternalPersonalNo Text +_avsInternalPersonalNo = lens (normalizeAvsInternalPersonalNo . avsInternalPersonalNo) (const mkAvsInternalPersonalNo) + type instance Element AvsInternalPersonalNo = Char instance MonoFoldable AvsInternalPersonalNo where ofoldMap f = ofoldr (mappend . f) mempty . avsInternalPersonalNo @@ -140,7 +165,7 @@ instance {-# OVERLAPS #-} Canonical (Maybe AvsInternalPersonalNo) where type AvsVersionNo = Text -- always 1 digit newtype AvsCardNo = AvsCardNo { avsCardNo :: Text } -- always 8 digits -- TODO: Create Smart Constructor deriving (Eq, Ord, Show, Generic) - deriving newtype (NFData, PathPiece, Csv.ToField, Csv.FromField) + deriving newtype (NFData, PathPiece, Csv.ToField, Csv.FromField, Binary) -- No longer needed: -- deriving newtype (PersistField, PersistFieldSql) -- instance E.SqlString AvsCardNo @@ -183,15 +208,22 @@ instance PersistField AvsFullCardNo where instance PersistFieldSql AvsFullCardNo where sqlType _ = SqlString -discernAvsCardPersonalNo :: Text -> Maybe (Either AvsFullCardNo AvsInternalPersonalNo) -- Just implies it is a whole number or decimal with one digit after the point -discernAvsCardPersonalNo (Text.span Char.isDigit -> (c, pv)) +parseAvsCardNo :: Text -> Maybe (Either AvsCardNo AvsFullCardNo) +parseAvsCardNo = splitDigitsByDot AvsCardNo (AvsFullCardNo . AvsCardNo) + +discernAvsCardPersonalNo :: Text -> Maybe (Either AvsInternalPersonalNo AvsFullCardNo) +discernAvsCardPersonalNo = splitDigitsByDot mkAvsInternalPersonalNo (AvsFullCardNo . AvsCardNo) + +-- | Just implies that argument is a whole number or decimal with one single digit after the point. Helper functions receive digit-parts without dot +splitDigitsByDot :: (Text -> a) -> (Text -> Text -> b) -> Text -> Maybe (Either a b) +splitDigitsByDot fl fr (Text.span Char.isDigit -> (c, pv)) + | Text.null c = Nothing | Text.null pv - = Just $ Right $ mkAvsInternalPersonalNo c - | not $ Text.null c - , Just ('.', v) <- Text.uncons pv + = Just $ Left $ fl c + | Just ('.', v) <- Text.uncons pv , Just (Char.isDigit -> True, "") <- Text.uncons v - = Just $ Left $ AvsFullCardNo (AvsCardNo c) v -discernAvsCardPersonalNo _ = Nothing + = Just $ Right $ fr c v +splitDigitsByDot _ _ _ = Nothing -- The AVS API requires PersonIds sometimes as as mere numbers `AvsPersonId` and sometimes as tagged objects `AvsObjPersonId` newtype AvsPersonId = AvsPersonId { avsPersonId :: Int } -- untagged Int @@ -220,7 +252,8 @@ avsPersonIdZero = AvsPersonId 0 -- this mus be zero acording to VSM specificatio newtype AvsObjPersonId = AvsObjPersonId -- tagged object { avsObjPersonID :: AvsPersonId } - deriving (Eq, Ord, Show, Generic) + deriving (Show, Generic) + deriving newtype (Eq, Ord, NFData, Binary) deriveJSON defaultOptions { fieldLabelModifier = dropCamel 2 , omitNothingFields = True @@ -281,9 +314,13 @@ licence2char AvsNoLicence = '0' licence2char AvsLicenceVorfeld = 'F' licence2char AvsLicenceRollfeld = 'R' +parseAvsLicence :: Int -> Maybe AvsLicence +parseAvsLicence (fromJSON . Number . fromIntegral -> Aeson.Success lic) = Just lic +parseAvsLicence _ = Nothing + data AvsDataCardColor = AvsCardColorMisc Text | AvsCardColorGrün | AvsCardColorBlau | AvsCardColorRot | AvsCardColorGelb - deriving (Eq, Ord, Read, Show, Generic) + deriving (Eq, Ord, Read, Show, Generic, Binary) deriving anyclass (NFData) -- instance RenderMessage declared in Foundation.I18n @@ -317,7 +354,7 @@ data AvsDataPersonCard = AvsDataPersonCard , avsDataCardNo :: AvsCardNo -- always 8 digits number, prefixed with 0 , avsDataVersionNo :: AvsVersionNo -- always 1 digit number } - deriving (Eq, Ord, Show, Generic) + deriving (Eq, Ord, Show, Generic,Binary) deriving anyclass (NFData) {- Automatically derived Ord instance should prioritize avsDataValid and avsDataValidTo. Checked in test/Model.TypesSpec @@ -386,15 +423,22 @@ derivePersistFieldJSON ''AvsDataPersonCard getFullCardNo :: AvsDataPersonCard -> AvsFullCardNo getFullCardNo AvsDataPersonCard{avsDataCardNo, avsDataVersionNo} = AvsFullCardNo avsDataCardNo avsDataVersionNo +avsFullCardNo2pin :: AvsFullCardNo -> Text +avsFullCardNo2pin = Text.dropWhile ('0'==) . tshowAvsFullCardNo + -- | like `tshowAvsFullCardNo` but without leading zeroes for use as pdf pin personCard2pin :: AvsDataPersonCard -> Text -personCard2pin = Text.dropWhile ('0'==) . tshowAvsFullCardNo . getFullCardNo +personCard2pin = avsFullCardNo2pin . getFullCardNo + +-- DEPRECATED, use Handler.Utils.Avs.queryAvsPin instead +-- personCards2pin :: Set AvsDataPersonCard -> Maybe Text +-- personCards2pin = fmap personCard2pin . Set.lookupMax data AvsStatusPerson = AvsStatusPerson { avsStatusPersonID :: AvsPersonId , avsStatusPersonCardStatus :: Set AvsDataPersonCard -- only delivers non-Maybe fields, all Maybe-fields are Nothing } - deriving (Eq, Ord, Show, Generic) + deriving (Eq, Ord, Show, Generic, NFData, Binary) deriveJSON defaultOptions { fieldLabelModifier = \case { "avsStatusPersonCardStatus" -> "personCardStatus"; others -> dropCamel 2 others } @@ -403,6 +447,9 @@ deriveJSON defaultOptions , rejectUnknownFields = False } ''AvsStatusPerson +makeLenses_ ''AvsStatusPerson + + data AvsDataPerson = AvsDataPerson { avsPersonFirstName :: Text -- WARNING: name stored as is, but AVS does contain weird whitespaces , avsPersonLastName :: Text -- WARNING: name stored as is, but AVS does contain weird whitespaces @@ -411,7 +458,7 @@ data AvsDataPerson = AvsDataPerson , avsPersonPersonID :: AvsPersonId -- Eindeutige PersonenID, wichtig für die Schnittstelle! , avsPersonPersonCards :: Set AvsDataPersonCard } - deriving (Eq, Ord, Show, Generic) + deriving (Eq, Ord, Show, Generic, NFData, Binary) makeLenses_ ''AvsDataPerson @@ -485,15 +532,24 @@ data AvsPersonInfo = AvsPersonInfo { avsInfoPersonNo :: Text -- Int -- AVS Personennummer, zum Gebrauch in menschlicher Kommunikation , avsInfoFirstName :: Text -- WARNING: name stored as is, but AVS does contain weird whitespaces , avsInfoLastName :: Text -- WARNING: name stored as is, but AVS does contain weird whitespaces - , avsInfoRampLicence :: Int -- AvsLicence -- unlike other queries, may return -1 for guest unable to hold a licence; currently not distinquished from no licence + , avsInfoRampLicence :: Int -- AvsLicence -- unlike other queries, may return -1 for a guest unable to hold a licence; currently not distinquished from no licence , avsInfoDateOfBirth :: Maybe Day , avsInfoPersonEMail :: Maybe Text , avsInfoPersonMobilePhoneNo :: Maybe Text , avsInfoInternalPersonalNo :: Maybe AvsInternalPersonalNo -- Fraport Personalnummer - } deriving (Eq, Ord, Show, Generic) + } deriving (Eq, Ord, Show, Generic, NFData, Binary) makeLenses_ ''AvsPersonInfo +-- | Lens for a virtual DisplayName field. WARNING when used as Setter: Ambiguously the split into First- and LastName will always on the last word given. +_avsInfoDisplayName :: Lens' AvsPersonInfo Text +_avsInfoDisplayName = lens g s + where + g AvsPersonInfo{avsInfoFirstName, avsInfoLastName} = Text.append avsInfoFirstName $ Text.cons ' ' avsInfoLastName + s api dn = let (Text.strip -> fn, Text.strip -> ln) = Text.breakOnEnd " " dn + in api{avsInfoFirstName = fn, avsInfoLastName = ln} + + instance FromJSON AvsPersonInfo where parseJSON = withObject "AvsPersonInfo" $ \o -> AvsPersonInfo <$> o .: "PersonsNo" -- NOTE: PersonsNo, not PersonNo as elsewhere @@ -518,7 +574,7 @@ instance ToJSON AvsPersonInfo where , "LastName" .= avsInfoLastName , "RampLicence" .= avsInfoRampLicence ] --- derivePersistFieldJSON ''AvsPersonInfo +derivePersistFieldJSON ''AvsPersonInfo data AvsFirmCommunication = AvsFirmCommunication @@ -527,7 +583,7 @@ data AvsFirmCommunication = AvsFirmCommunication , avsCommunicationCountry :: Maybe Text , avsCommunicationStreetANDHouseNo :: Maybe Text , avsCommunicationEMail :: Maybe Text - } deriving (Eq, Ord, Show, Generic) + } deriving (Eq, Ord, Show, Generic, NFData, Binary) instance {-# OVERLAPS #-} Canonical (Maybe AvsFirmCommunication) where canonical (Just AvsFirmCommunication{..}) @@ -540,6 +596,10 @@ instance {-# OVERLAPS #-} Canonical (Maybe AvsFirmCommunication) where canonical other = other makeLenses_ ''AvsFirmCommunication +_avsCommunicationAddress :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmCommunication (Maybe Text) +_avsCommunicationAddress = to mkAddr + where + mkAddr AvsFirmCommunication{..} = composeAddress avsCommunicationStreetANDHouseNo avsCommunicationZIPCode avsCommunicationCity avsCommunicationCountry instance FromJSON AvsFirmCommunication where parseJSON = withObject "AvsFirmCommunication" $ \o -> AvsFirmCommunication @@ -557,11 +617,12 @@ instance ToJSON AvsFirmCommunication where , ("StreetANDHouseNo" .=) <$> avsCommunicationStreetANDHouseNo & canonical , ("EMail" .=) <$> avsCommunicationEMail & canonical ] +derivePersistFieldJSON ''AvsFirmCommunication data AvsFirmInfo = AvsFirmInfo - { avsFirmFirm :: Text - , avsFirmFirmNo :: Int - , avsFirmAbbreviation :: Text -- enthält manchmal Leerzeichen! + { avsFirmFirm :: Text -- enthält manchmal Leerzeichen an Anfang oder Ende! + , avsFirmFirmNo :: Int -- bei Verwendung ohne AVS: negative Zahl einsetzen + , avsFirmAbbreviation :: Text -- enthält manchmal Leerzeichen an Anfang oder Ende! , avsFirmZIPCode :: Maybe Text , avsFirmCity :: Maybe Text , avsFirmCountry :: Maybe Text @@ -569,22 +630,66 @@ data AvsFirmInfo = AvsFirmInfo , avsFirmEMail :: Maybe Text , avsFirmEMailSuperior :: Maybe Text , avsFirmCommunication :: Maybe AvsFirmCommunication - } deriving (Eq, Ord, Show, Generic) + } deriving (Eq, Ord, Show, Generic, NFData, Binary) makeLenses_ ''AvsFirmInfo +-- additional convenience lenses: + +_avsFirmPostAddress :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe StoredMarkup) +_avsFirmPostAddress = to mkPost + where + mkPost afi@AvsFirmInfo{avsFirmFirm} = + let someAddr = afi ^. _avsFirmPostAddressSimple + prefAddr = plaintextToStoredMarkup . (avsFirmFirm <>) . Text.cons '\n' + in prefAddr <$> someAddr + +-- | company post address without company name, better suited for comparisons +_avsFirmPostAddressSimple :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe Text) +_avsFirmPostAddressSimple = to mkPost + where + mkPost AvsFirmInfo{..} = + let firmAddr = composeAddress avsFirmStreetANDHouseNo avsFirmZIPCode avsFirmCity avsFirmCountry + commAddr = avsFirmCommunication ^. _Just . _avsCommunicationAddress + in asum $ [res | res@(Just addr) <- [commAddr, firmAddr], validPostAddressText addr] + +_avsFirmPrimaryEmail :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe Text) +_avsFirmPrimaryEmail = to mkEmail + where + mkEmail afi = + let candidates = catMaybes + [ afi ^. _avsFirmCommunication . _Just . _avsCommunicationEMail + , afi ^. _avsFirmEMailSuperior + , afi ^. _avsFirmEMail + ] + in pickValidEmail candidates -- should we return an invalid email rather than none? + +-- | Not sure this is useful, since postal is ignored if there is no post address anyway +_avsFirmPrefersPostal :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo Bool +_avsFirmPrefersPostal = to mkPostPref + where + mkPostPref afi = isJust (afi ^. _avsFirmPostAddress) || isNothing (afi ^. _avsFirmPrimaryEmail) + +-- Note _avsFirmAddress is never empty; always includes the company name; consider using user _avsFirmPostAddress instead +-- _avsFirmAddress :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo Text +-- _avsFirmAddress = to mkAddr +-- where +-- mkAddr AvsFirmInfo{..} = +-- let firmAddr = composeAddress avsFirmStreetANDHouseNo avsFirmZIPCode avsFirmCity avsFirmCountry +-- commAddr = avsFirmCommunication ^. _Just . _avsCommunicationAddress +-- in textUnlines $ avsFirmFirm : catMaybes [commAddr <|> firmAddr] instance FromJSON AvsFirmInfo where parseJSON = withObject "AvsFirmInfo" $ \o -> AvsFirmInfo - <$> o .: "Firm" - <*> o .: "FirmNo" - <*> o .: "Abbreviation" - <*> o .:?! "ZIPCode" - <*> o .:?! "City" - <*> o .:?! "Country" - <*> o .:?! "StreetANDHouseNo" - <*> o .:?! "EMail" - <*> o .:?! "EMailSuperior" - <*> o .:?! "Communication" + <$> (o .: "Firm" <&> Text.strip) -- AVS often contains leading/trailing whitespace + <*> o .: "FirmNo" + <*> (o .: "Abbreviation" <&> Text.strip) + <*> (o .:?! "ZIPCode" <&> fmap Text.strip) + <*> (o .:?! "City" <&> fmap Text.strip) + <*> (o .:?! "Country" <&> fmap Text.strip) + <*> (o .:?! "StreetANDHouseNo" <&> fmap Text.strip) + <*> (o .:?! "EMail" <&> fmap Text.strip) + <*> (o .:?! "EMailSuperior" <&> fmap Text.strip) + <*> o .:?! "Communication" instance ToJSON AvsFirmInfo where toJSON AvsFirmInfo{..} = object $ catMaybes @@ -600,14 +705,14 @@ instance ToJSON AvsFirmInfo where , "FirmNo" .= avsFirmFirmNo , "Abbreviation" .= avsFirmAbbreviation ] --- derivePersistFieldJSON ''AvsFirmInfo +derivePersistFieldJSON ''AvsFirmInfo data AvsDataContact = AvsDataContact { avsContactPersonID :: AvsPersonId , avsContactPersonInfo :: AvsPersonInfo , avsContactFirmInfo :: AvsFirmInfo - } deriving (Eq, Ord, Show, Generic) + } deriving (Eq, Ord, Show, Generic, NFData, Binary) makeLenses_ ''AvsDataContact @@ -630,7 +735,8 @@ deriveJSON defaultOptions type AvsResponseStatus :: Type newtype AvsResponseStatus = AvsResponseStatus (Set AvsStatusPerson) - deriving (Eq, Ord, Show, Generic) + deriving (Show, Generic) + deriving newtype (Eq, Ord, NFData, Binary) makeWrapped ''AvsResponseStatus deriveJSON defaultOptions { fieldLabelModifier = dropCamel 2 @@ -642,7 +748,8 @@ instance Semigroup AvsResponseStatus where (AvsResponseStatus a) <> (AvsResponseStatus b) = AvsResponseStatus (a <> b) newtype AvsResponsePerson = AvsResponsePerson (Set AvsDataPerson) - deriving (Eq, Ord, Show, Generic) + deriving (Show, Generic) + deriving newtype (Eq, Ord, NFData, Binary) -- makeWrapped ''AvsResponsePerson deriveJSON defaultOptions { fieldLabelModifier = dropCamel 2 @@ -652,7 +759,8 @@ deriveJSON defaultOptions } ''AvsResponsePerson newtype AvsResponseContact = AvsResponseContact (Set AvsDataContact) - deriving (Eq, Ord, Show, Generic) + deriving (Show, Generic) + deriving newtype (Eq, Ord, NFData, Binary) makeWrapped ''AvsResponseContact deriveJSON defaultOptions { fieldLabelModifier = dropCamel 2 @@ -688,6 +796,7 @@ deriveJSON defaultOptions ------------- -- Queries -- ------------- + data AvsQueryPerson = AvsQueryPerson { avsPersonQueryCardNo :: Maybe AvsCardNo , avsPersonQueryVersionNo :: Maybe AvsVersionNo @@ -695,7 +804,7 @@ data AvsQueryPerson = AvsQueryPerson , avsPersonQueryLastName :: Maybe Text , avsPersonQueryInternalPersonalNo :: Maybe AvsInternalPersonalNo } - deriving (Eq, Ord, Show, Generic) + deriving (Eq, Ord, Show, Generic, NFData, Binary) instance Default AvsQueryPerson where def = AvsQueryPerson Nothing Nothing Nothing Nothing Nothing @@ -708,19 +817,27 @@ deriveJSON defaultOptions } ''AvsQueryPerson newtype AvsQueryStatus = AvsQueryStatus (Set AvsPersonId) - deriving (Eq, Ord, Show, Generic) + deriving (Show, Generic) + deriving newtype (Eq, Ord, NFData, Binary) deriveJSON defaultOptions ''AvsQueryStatus makeWrapped ''AvsQueryStatus newtype AvsQueryContact = AvsQueryContact (Set AvsObjPersonId) -- note the difference to AvsQueryStatus, which receives a list of id, whereas here we sent a list of single-field object - deriving (Eq, Ord, Show, Generic) + deriving (Show, Generic) + deriving newtype (Eq, Ord, NFData, Binary) deriveJSON defaultOptions ''AvsQueryContact makeWrapped ''AvsQueryContact -newtype AvsQueryGetLicences = AvsQueryGetLicences AvsObjPersonId -- this should have been a set, but the specification was implemented differently +newtype AvsQueryGetLicences = AvsQueryGetLicences AvsObjPersonId -- this should have been a set, but the specification was implemented differently; also currently only allows to ask for all licences with ID 0 deriving (Eq, Ord, Show, Generic) deriveJSON defaultOptions ''AvsQueryGetLicences +data AvsQueryGetAllLicences = AvsQueryGetAllLicences -- for convenience, encoding AvsQueryGetLicences (AvsObjPersonId avsPersonIdZero) + deriving (Eq, Ord, Show, Generic) + newtype AvsQuerySetLicences = AvsQuerySetLicences (Set AvsPersonLicence) deriving (Eq, Ord, Show, Generic) deriveJSON defaultOptions ''AvsQuerySetLicences + +-- Note that separate types were need for Servant to fit the existing AVS/VSM-API. +-- See Handler.Utils.Avs.SomeAvsQuery for a type class to provide a uniform interface to all queries. \ No newline at end of file diff --git a/src/Model/Types/Markup.hs b/src/Model/Types/Markup.hs index 0715b65b5..a250927c4 100644 --- a/src/Model/Types/Markup.hs +++ b/src/Model/Types/Markup.hs @@ -11,6 +11,7 @@ module Model.Types.Markup , I18nStoredMarkup , markupIsSmallish , html2textlines + , isSimilarMarkup ) where import Import.NoModel @@ -32,6 +33,7 @@ import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Internal.Internal as E import Database.Persist.Sql +import Utils.Pandoc data MarkupFormat = MarkupMarkdown @@ -50,6 +52,11 @@ data StoredMarkup = StoredMarkup deriving (Read, Show, Generic) deriving anyclass (Binary, Hashable, NFData) +isSimilarMarkup :: StoredMarkup -> StoredMarkup -> Bool +isSimilarMarkup StoredMarkup{markupInputFormat=af, markupInput=ai} + StoredMarkup{markupInputFormat=bf, markupInput=bi} + = af==bf && ai == bi + instance Canonical (Maybe StoredMarkup) where canonical Nothing = Nothing canonical r@(Just s@StoredMarkup{..}) = let mi' = LT.strip markupInput in if @@ -67,7 +74,7 @@ plaintextToStoredMarkup :: Textual t => t -> StoredMarkup plaintextToStoredMarkup (repack -> t) = StoredMarkup { markupInputFormat = MarkupPlaintext , markupInput = t - , markupOutput = toMarkup t + , markupOutput = plaintextToHtml $ LT.toStrict t } preEscapedToStoredMarkup :: Textual t => t -> StoredMarkup preEscapedToStoredMarkup (repack -> t) = StoredMarkup @@ -79,7 +86,7 @@ markdownToStoredMarkup :: Textual t => t -> StoredMarkup markdownToStoredMarkup (repack -> t) = StoredMarkup { markupInputFormat = MarkupMarkdown , markupInput = t - , markupOutput = toMarkup t -- not sure here + , markupOutput = plaintextToHtml $ LT.toStrict t } diff --git a/src/Model/Types/Misc.hs b/src/Model/Types/Misc.hs index d686c8e0a..10fa045b6 100644 --- a/src/Model/Types/Misc.hs +++ b/src/Model/Types/Misc.hs @@ -58,6 +58,19 @@ $(deriveSimpleWith ''ToMessage 'toMessage (over Text.packed $ Text.intercalate " derivePersistField "Theme" +data SupervisorReason + = SupervisorReasonCompanyDefault + | SupervisorReasonAvsSuperior + | SupervisorReasonUnknown + deriving (Eq, Ord, Enum, Bounded, Generic) + deriving anyclass (Universe, Finite, NFData) + +instance Show SupervisorReason where + show SupervisorReasonCompanyDefault = "Firmenstandard" + show SupervisorReasonAvsSuperior = "Vorgesetzer" + show SupervisorReasonUnknown = "Unbekannt" + + data FavouriteReason = FavouriteVisited | FavouriteParticipant diff --git a/src/Settings.hs b/src/Settings.hs index e3fcc6105..89513f5c4 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-2024 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,David Mosbach -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -251,6 +251,8 @@ data AppSettings = AppSettings , appFileChunkingParams :: FastCDCParameters , appLegalExternal :: Set LegalExternal + + , appAsyncTableMaxRows :: Maybe Natural } deriving Show @@ -330,6 +332,8 @@ data AvsConf = AvsConf , avsPort :: Int , avsUser :: ByteString , avsPass :: ByteString + , avsTimeout :: Int -- Seconds; wait time for some online user queries + , avsCacheExpiry :: DiffTime -- Seconds, only for non-licence related queries } deriving (Show) data LprConf = LprConf @@ -529,12 +533,16 @@ makeLenses_ ''LmsConf instance FromJSON AvsConf where parseJSON = withObject "AvsConf" $ \o -> do - avsHost <- o .: "host" - avsPort <- o .: "port" - avsUser <- o .: "user" - avsPass <- o .:? "pass" .!= "" + avsHost <- o .: "host" + avsPort <- o .: "port" + avsUser <- o .: "user" + avsPass <- o .:? "pass" .!= "" + avsTimeout <- o .: "timeout" + avsCacheExpiry <- o .: "cache-expiry" return AvsConf{..} +makeLenses_ ''AvsConf + instance FromJSON LprConf where parseJSON = withObject "LprConf" $ \o -> do lprHost <- o .: "host" @@ -811,6 +819,8 @@ instance FromJSON AppSettings where appLegalExternal <- o .: "legal-external" + appAsyncTableMaxRows <- o .: "async-table-max-rows" + return AppSettings{..} where isValidARCConf ARCConf{..} = arccMaximumWeight > 0 diff --git a/src/Utils.hs b/src/Utils.hs index c47f29992..21685f564 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-23 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Winnie Ros ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Winnie Ros ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -11,7 +11,7 @@ import ClassyPrelude.Yesod hiding (foldlM, Proxy, handle, catch, bracket) -- import Data.Double.Conversion.Text -- faster implementation for textPercent? import qualified Data.Foldable as Fold -import qualified Data.Traversable as Trav +import qualified Data.Traversable as Trav import Data.Foldable as Utils (foldlM, foldrM) import Data.Monoid (First, Sum(..), Endo) import Data.Proxy @@ -23,7 +23,7 @@ import qualified Data.CaseInsensitive as CI import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as CBS --- import qualified Data.Char as Char +import qualified Data.Char as Char import qualified Data.Text as Text import qualified Data.Text.Encoding as Text @@ -305,10 +305,18 @@ tshowCrop = cropText . tshow stripCI :: Text -> CI Text stripCI = CI.mk . Text.strip +-- | Instead of CI.mk, this still allows use of Text.isInfixOf, etc. +stripFold :: Text -> Text +stripFold = Text.toCaseFold . Text.strip + + -- | just to avoid adding an import for this ciOriginal :: CI Text -> Text ciOriginal = CI.original +ciShow :: Show a => a -> CI Text +ciShow = CI.mk . tshow + citext2lower :: CI Text -> Text citext2lower = Text.toLower . CI.original @@ -520,10 +528,20 @@ snakecase2camelcase t = Text.concat $ map textToCapital words words = Text.splitOn '_' t -} +-- | Unlike @Data.Text.unlines, there is no trailing LF at the end +textUnlines :: [Text] -> Text +textUnlines = Text.intercalate $ Text.singleton '\n' + -- also see Utils.Form.cfCommaSeparatedSet commaSeparatedText :: Text -> Set Text commaSeparatedText = Set.fromList . mapMaybe (assertM' (not . Text.null) . Text.strip) . Text.split (==',') +-- also see Utils.Form.cfAnySeparatedSet +anySeparatedText :: Text -> [Text] +anySeparatedText = mapMaybe (assertM' (not . Text.null) . Text.strip) . Text.split anySeparator + where anySeparator :: Char -> Bool + anySeparator c = Char.isSeparator c || c == ',' || c == ';' + ----------- -- Fixed -- @@ -688,6 +706,10 @@ zipMaybes (Just x:xs) (Just y:ys) = (x,y) : zipMaybes xs ys zipMaybes (_:xs) (_:ys) = zipMaybes xs ys zipMaybes _ _ = [] +bcons :: Bool -> a -> [a] -> [a] +bcons False _ = id +bcons True x = (x:) + -- | Merge/Add any attribute-value pair to an existing list of such pairs. -- If the attribute exists, the new valu will be prepended, separated by a single empty space insertAttr :: Text -> Text -> [(Text,Text)] -> [(Text,Text)] @@ -900,20 +922,22 @@ deepAlt altFst _ = altFst maybeEmpty :: Monoid m => Maybe a -> (a -> m) -> m maybeEmpty = flip foldMap - -- The more general `find :: Foldable t => (a -> Bool) -> t a -> Maybe a` filterMaybe :: (a -> Bool) -> Maybe a -> Maybe a filterMaybe c r@(Just x) | c x = r filterMaybe _ _ = Nothing -- | also referred to as whenJust and forM_ +-- also see `foldMapM` if a Monoid value is to be returned +-- also see `forMM_` if the maybe is produced by a monadic action whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m () whenIsJust (Just x) f = f x whenIsJust Nothing _ = return () -ifMaybeM :: Monad m => Maybe a -> b -> (a -> m b) -> m b -- more convenient argument order as compared to maybeM -ifMaybeM Nothing dft _ = return dft -ifMaybeM (Just x) _ act = act x +-- ifNothingM m d a = maybe (return d) a m +ifNothingM :: Monad m => Maybe a -> b -> (a -> m b) -> m b -- more convenient argument order as compared to maybeM +ifNothingM Nothing dft _ = return dft +ifNothingM (Just x) _ act = act x maybePositive :: (Num a, Ord a) => a -> Maybe a -- convenient for Shakespeare: one $maybe instead of $with & $if maybePositive a | a > 0 = Just a @@ -925,6 +949,10 @@ positiveSum = maybePositive . getSum maybeM :: Monad m => m b -> (a -> m b) -> m (Maybe a) -> m b maybeM dft act mb = mb >>= maybe dft act +-- maybeEmptyM, maybeNotingM +traverseJoin :: (Applicative m, Traversable maybe, Monad maybe) => (a -> m (maybe b)) -> maybe a -> m (maybe b) +traverseJoin f x = join <$> (f `traverse` x) + maybeT :: Monad m => m a -> MaybeT m a -> m a maybeT x m = runMaybeT m >>= maybe x return @@ -982,10 +1010,14 @@ formResultToMaybe _ = empty maybeThrow :: (MonadThrow m, Exception e) => e -> Maybe a -> m a maybeThrow exc = maybe (throwM exc) return --- | Monadic version of 'fromMaybe' +-- | Throw an exception upon receiving Nothing maybeThrowM :: (Exception e, MonadThrow m) => e -> m (Maybe a) -> m a maybeThrowM = fromMaybeM . throwM +maybeMapM :: Applicative m => (a -> m (Maybe b)) -> [a] -> m [b] +maybeMapM f = foldr go (pure []) + where + go = liftA2 (maybe id (:)) . f mapMaybeM :: ( Monad m , MonoFoldable (f a) @@ -1001,18 +1033,44 @@ forMaybeM :: ( Monad m ) => f a -> (Element (f a) -> MaybeT m (Element (f b))) -> m (f b) forMaybeM = flip mapMaybeM -{- --- Takes computations returnings @Maybes@; tries each one in order. +-- | Only execute second action if the first does not produce a result +altM :: Monad m => m (Maybe a) -> m (Maybe a) -> m (Maybe a) +altM ma mb = ma >>= \case + Nothing -> mb + res -> return res + +-- | Map f and get the first Just +firstJust :: MonoFoldable mono => (Element mono -> Maybe a) -> mono -> Maybe a +firstJust f = foldr go Nothing + where + -- go :: a -> Maybe b -> Maybe b + go x Nothing = f x + go _ res = res + +-- Takes computations returnings @Maybe@; tries each one in order. -- The first one to return a @Just@ wins. Returns @Nothing@ if all computations -- return @Nothing@. -- Copied from GHC.Data.Maybe, which could not be imported somehow. -firstJustsM :: (Monad m, Foldable f) => f (m (Maybe a)) -> m (Maybe a) -firstJustsM = foldlM go Nothing +-- HOWEVER, this function counterintuitively forces the entire foldable! +-- firstJustM :: (Monad m, Foldable f) => f (m (Maybe a)) -> m (Maybe a) +-- firstJustM = foldlM go Nothing +-- where +-- go :: Monad m => Maybe a -> m (Maybe a) -> m (Maybe a) +-- go Nothing action = action +-- go result@(Just _) _action = return result + +-- | executes actions until the first one returns Just, the remaining actions are not computed; container not required to be finite +firstJustM :: (Monad m, Foldable f) => f (m (Maybe a)) -> m (Maybe a) +firstJustM = Fold.foldr go (return Nothing) where - go :: Monad m => Maybe a -> m (Maybe a) -> m (Maybe a) - go Nothing action = action - go result@(Just _) _action = return result --} + go :: Monad m => m (Maybe a) -> m (Maybe a) -> m (Maybe a) + go n p = n >>= \case {Nothing -> p; res -> return res} + +-- firstJustM1 :: (Monad m, MonoFoldable mono, Element mono ~ m (Maybe a)) => mono -> m (Maybe a) +-- firstJustM1 = foldr go (return Nothing) +-- where +-- go n p = n >>= \case {Nothing -> p; res -> return res} + -- | Run the maybe computation repeatedly until the first Just is returned -- or the number of maximum retries is exhausted. @@ -1138,6 +1196,10 @@ infixl 4 <<$>> (<<$>>) :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b) (<<$>>) f x = fmap f <$> x +-- useful for using `maybeCatchall` +voidMaybe :: Functor f => (f (Maybe a) -> f (Maybe a)) -> f a -> f () +voidMaybe trf = void . trf . fmap Just + ------------ -- Monads -- @@ -1150,10 +1212,13 @@ shortCircuitM sc binOp mx my = do | sc x -> return x | otherwise -> binOp x <$> my - guardM :: MonadPlus m => m Bool -> m () guardM f = guard =<< f +guardMonoidM :: (Applicative f, Monoid m) => Bool -> f m -> f m +guardMonoidM False _ = pure mempty +guardMonoidM True x = x + assertM :: MonadPlus m => (a -> Bool) -> m a -> m a assertM f x = x >>= assertM' f @@ -1193,6 +1258,9 @@ ifM c x y = c >>= bool y x ifNotM :: Monad m => m Bool -> m a -> m a -> m a ifNotM c = flip $ ifM c +notM :: Functor f => f Bool -> f Bool +notM = fmap not + -- | Short-circuiting monadic boolean function, copied from Andreas Abel's utility function and2M, or2M :: Monad m => m Bool -> m Bool -> m Bool and2M ma mb = ifM ma mb (return False) @@ -1220,6 +1288,18 @@ ofoldl1M _ _ = error "otoList of NonNull is empty" foldMapM :: (Foldable f, Monad m, Monoid b) => (a -> m b) -> f a -> m b foldMapM f = foldrM (\x xs -> (<> xs) <$> f x) mempty +{- left as a remineder: if you need these, use MaybeT instead! +-- convenient synonym for `flip foldMapM` +continueJust :: (Applicative m, Monoid b) => Maybe a -> (a -> m b) -> m b +continueJust (Just x) f = f x +continueJust Nothing _ = pure mempty + +maybeContinue :: (Monoid b, Monad m) => m (Maybe a) -> (a -> m b) -> m b +maybeContinue mx f = mx >>= \case + Nothing -> return mempty + Just x -> f x +-} + ifoldMapM :: (FoldableWithIndex i f, Monad m, Monoid b) => (i -> a -> m b) -> f a -> m b ifoldMapM f = ifoldrM (\i x xs -> (<> xs) <$> f i x) mempty @@ -1682,6 +1762,8 @@ emptyHash = TH.liftTyped $ Crypto.hashFinalize Crypto.hashInit -- Caching -- ------------- +-- Note: uses yesod's cachedBy which is per-request caching only; use memcached instead for caching across multiple requests + cachedByBinary :: (Binary a, Typeable b, MonadHandler m) => a -> m b -> m b cachedByBinary k = cachedBy (toStrict $ Binary.encode k) diff --git a/src/Utils/Avs.hs b/src/Utils/Avs.hs index c351243e8..c54b80864 100644 --- a/src/Utils/Avs.hs +++ b/src/Utils/Avs.hs @@ -1,7 +1,8 @@ --- SPDX-FileCopyrightText: 2022 Sarah Vaupel ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Sarah Vaupel ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later + module Utils.Avs where import Import.NoModel @@ -13,9 +14,10 @@ import qualified Data.Text as Text import Servant import Servant.Client -#ifdef DEVELOPMENT -#else + +#ifndef DEVELOPMENT import Servant.Client.Core (requestPath) +import UnliftIO.Concurrent (threadDelay) #endif import Model.Types.Avs @@ -35,7 +37,10 @@ avsMaxSetLicenceAtOnce :: Int avsMaxSetLicenceAtOnce = 80 -- maximum input set size for avsQuerySetLicences as enforced by AVS avsMaxQueryAtOnce :: Int -avsMaxQueryAtOnce = 500 -- maximum input set size for avsQueryStatus as enforced by AVS +avsMaxQueryAtOnce = 500 -- maximum input set size for avsQueryStatus and avsQueryContact as enforced by AVS + +avsMaxQueryDelay :: Int +avsMaxQueryDelay = 300000 -- microsecond to wait before sending another AVS query avsApi :: Proxy AVS @@ -62,7 +67,8 @@ data AvsQuery = AvsQuery makeLenses_ ''AvsQuery --- | To query all active licences, a special constant argument must be prepared + +-- | AVS/VSM-interface currently only allows GetLicences with query argument ID 0, which means all licences; all other queries yield an empty response avsQueryAllLicences :: AvsQueryGetLicences avsQueryAllLicences = AvsQueryGetLicences $ AvsObjPersonId avsPersonIdZero @@ -70,18 +76,51 @@ avsQueryAllLicences = AvsQueryGetLicences $ AvsObjPersonId avsPersonIdZero mkAvsQuery :: BaseUrl -> BasicAuthData -> ClientEnv -> AvsQuery #ifdef DEVELOPMENT mkAvsQuery _ _ _ = AvsQuery - { avsQueryPerson = \_ -> return . Right $ AvsResponsePerson mempty - , avsQueryStatus = \_ -> return . Right $ AvsResponseStatus mempty - , avsQueryContact = \_ -> return . Right $ AvsResponseContact $ Set.singleton $ AvsDataContact (AvsPersonId 1234567) (AvsPersonInfo "123123123" "Heribert" "Sumpfmeier" (-1) Nothing Nothing Nothing Nothing) (AvsFirmInfo "Lange Firma" 7 "Kurz" Nothing Nothing Nothing Nothing Nothing Nothing Nothing) + { avsQueryPerson = return . Right . fakePerson + , avsQueryStatus = return . Right . fakeStatus + , avsQueryContact = return . Right . fakeContact , avsQuerySetLicences = \_ -> return . Right $ AvsResponseSetLicences mempty , avsQueryGetAllLicences = return . Right $ AvsResponseGetLicences mempty } + where + fakePerson :: AvsQueryPerson -> AvsResponsePerson + fakePerson = + let + sarah = Set.singleton $ AvsDataPerson "Sarah" "Vaupel" Nothing 2 (AvsPersonId 2) mempty + stephan = Set.singleton $ AvsDataPerson "Stephan" "Barth" Nothing 4 (AvsPersonId 4) mempty + steffen = Set.singleton $ AvsDataPerson "Steffen" "Jost" (Just $ mkAvsInternalPersonalNo "47138") 12345678 (AvsPersonId 12345678) mempty + sumpfi1 = Set.singleton $ AvsDataPerson "Heribert" "Sumpfmeier" Nothing 12345678 (AvsPersonId 12345678) mempty + sumpfi2 = Set.singleton $ AvsDataPerson "Heribert" "Sumpfmeier" Nothing 12345678 (AvsPersonId 604387) mempty + sumpfi3 = Set.singleton $ AvsDataPerson "Heribert" "Sumpfmeier" Nothing 12345678 (AvsPersonId 604591) mempty + in \case + AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "00001234"), avsPersonQueryVersionNo=Just "4"} -> AvsResponsePerson steffen + AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "00001234")} -> AvsResponsePerson steffen + AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "00009944"), avsPersonQueryVersionNo=Just "4"} -> AvsResponsePerson stephan + AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "00003344"), avsPersonQueryVersionNo=Just "1"} -> AvsResponsePerson sarah + AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "34")} -> AvsResponsePerson $ steffen <> sarah + AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "4") , avsPersonQueryVersionNo=Just "4"} -> AvsResponsePerson $ steffen <> stephan + AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "00006666"), avsPersonQueryVersionNo=Just "4"} -> AvsResponsePerson $ sumpfi1 <> sumpfi2 <> sumpfi3 + AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "00007777"), avsPersonQueryVersionNo=Just "4"} -> AvsResponsePerson $ sumpfi1 <> sumpfi2 <> sumpfi3 + AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "00008888"), avsPersonQueryVersionNo=Just "4"} -> AvsResponsePerson $ sumpfi1 <> sumpfi2 <> sumpfi3 + _ -> AvsResponsePerson mempty + + fakeStatus :: AvsQueryStatus -> AvsResponseStatus + fakeStatus (AvsQueryStatus (Set.toList -> (api:_))) = AvsResponseStatus $ Set.singleton $ AvsStatusPerson api $ Set.fromList + [ AvsDataPersonCard True (Just $ fromGregorian 2026 5 1) Nothing AvsCardColorGelb (Set.fromList ['F','R','C']) Nothing Nothing Nothing (Just "Fraport AG") (AvsCardNo "6666") "4" + , AvsDataPersonCard False (Just $ fromGregorian 2025 6 2) Nothing AvsCardColorRot (Set.fromList ['F','A' ]) Nothing Nothing Nothing (Just "N*ICE Aircraft Services & Support GmbH") (AvsCardNo "7777") "4" + , AvsDataPersonCard True (Just $ fromGregorian 2028 7 3) Nothing AvsCardColorBlau mempty Nothing Nothing Nothing (Just "Fraport Facility Services GmbH") (AvsCardNo "8888") "4" + ] + fakeStatus _ = AvsResponseStatus mempty + fakeContact :: AvsQueryContact -> AvsResponseContact + fakeContact (AvsQueryContact (Set.toList -> ((AvsObjPersonId api):_))) = AvsResponseContact $ Set.singleton $ AvsDataContact api (AvsPersonInfo "123123123" "Heribert" "Sumpfmeier" (-1) Nothing Nothing Nothing Nothing) (AvsFirmInfo "Fraport AG" 7 "Fraport" Nothing Nothing Nothing Nothing Nothing Nothing Nothing) + fakeContact _ = AvsResponseContact mempty #else mkAvsQuery baseUrl basicAuth cliEnv = AvsQuery - { avsQueryPerson = \q -> liftIO $ catch404toEmpty <$> runClientM (rawQueryPerson q) cliEnv + { avsQueryPerson = \q -> if q == def then return $ Right $ AvsResponsePerson mempty else -- prevent empty queries + liftIO $ catch404toEmpty <$> runClientM (rawQueryPerson q) cliEnv , avsQueryStatus = \q -> liftIO $ runClientM (splitQuery rawQueryStatus q) cliEnv , avsQueryContact = \q -> liftIO $ runClientM (splitQuery rawQueryContact q) cliEnv - , avsQuerySetLicences = \q -> liftIO $ runClientM (rawQuerySetLicences q) cliEnv -- TODO: currently uses setLicencesAvs for splitting to ensure return of correctly set licences + , avsQuerySetLicences = \q -> liftIO $ runClientM (rawQuerySetLicences q) cliEnv -- NOTE: currently uses setLicencesAvs for splitting to ensure return of correctly set licences -- , avsQueryGetLicences = \q -> liftIO $ runClientM (rawQueryGetLicences q) cliEnv , avsQueryGetAllLicences = liftIO $ runClientM (rawQueryGetLicences avsQueryAllLicences) cliEnv } @@ -104,6 +143,7 @@ splitQuery rawQuery q -- logInfoS "AVS" $ "Splitting large query for input Set " <> tshow (Set.size s) -- would require MonadLogger ClientM let (avsid1, avsid2) = Set.splitAt avsMaxQueryAtOnce s res1 <- rawQuery $ view _Unwrapped' avsid1 + liftIO $ threadDelay avsMaxQueryDelay res2 <- splitQuery rawQuery $ view _Unwrapped' avsid2 return $ view _Unwrapped' (res1 ^. _Wrapped' <> res2 ^. _Wrapped') where @@ -111,73 +151,73 @@ splitQuery rawQuery q #endif ----------------------- --- Utility Functions -- +-- Utility Functions -- DEPRECTATED ----------------------- --- | retrieve AvsDataPersonCard with longest validity for a given licence, +-- retrieve AvsDataPersonCard with longest validity for a given licence, -- first argument is a lower bound for avsDataValidTo, usually current day -- Note that avsDataValidTo is Nothing if retrieved via AvsResponseStatus (simply use isJust on result in this case) -getValidLicence :: Maybe Day -> AvsLicence -> Set AvsDataPersonCard -> Maybe AvsDataPersonCard -getValidLicence cutoff licence' cards = Set.lookupMax validLicenceCards - where - licence = licence2char licence' - validLicenceCards = Set.filter cardMatch cards - cardMatch AvsDataPersonCard{..} = - avsDataValid && (avsDataValidTo >= cutoff) && (licence `Set.member` avsDataCardAreas) +-- getValidLicence :: Maybe Day -> AvsLicence -> Set AvsDataPersonCard -> Maybe AvsDataPersonCard +-- getValidLicence cutoff licence' cards = Set.lookupMax validLicenceCards +-- where +-- licence = licence2char licence' +-- validLicenceCards = Set.filter cardMatch cards +-- cardMatch AvsDataPersonCard{..} = +-- avsDataValid && (avsDataValidTo >= cutoff) && (licence `Set.member` avsDataCardAreas) +-- | DEPRECTATED +-- getCompanyAddress :: AvsDataPersonCard -> (Maybe Text, Maybe Text, Maybe AvsDataPersonCard) +-- getCompanyAddress card@AvsDataPersonCard{..} +-- | Just street <- avsDataStreet +-- , Just pcode <- avsDataPostalCode +-- , Just city <- avsDataCity +-- = (avsDataFirm, Just $ Text.unlines $ mcons avsDataFirm [street, Text.unwords [pcode, city]], Just card) +-- | isJust avsDataFirm = (avsDataFirm, Nothing, Just card) +-- | otherwise = (Nothing, Nothing, Nothing) -getCompanyAddress :: AvsDataPersonCard -> (Maybe Text, Maybe Text, Maybe AvsDataPersonCard) -getCompanyAddress card@AvsDataPersonCard{..} - | Just street <- avsDataStreet - , Just pcode <- avsDataPostalCode - , Just city <- avsDataCity - = (avsDataFirm, Just $ Text.unlines $ mcons avsDataFirm [street, Text.unwords [pcode, city]], Just card) - | isJust avsDataFirm = (avsDataFirm, Nothing, Just card) - | otherwise = (Nothing, Nothing, Nothing) +-- -- | From a set of card, choose the one with the most complete postal address. +-- -- Returns company, postal address and the associated card where the address was taken from +-- guessLicenceAddress :: Set AvsDataPersonCard -> (Maybe Text, Maybe Text, Maybe AvsDataPersonCard) +-- guessLicenceAddress cards +-- | Just c <- Set.lookupMax cards +-- , card <- Set.foldr pickLicenceAddress c cards +-- = getCompanyAddress card +-- | otherwise = (Nothing, Nothing, Nothing) --- | From a set of card, choose the one with the most complete postal address. --- Returns company, postal address and the associated card where the address was taken from -guessLicenceAddress :: Set AvsDataPersonCard -> (Maybe Text, Maybe Text, Maybe AvsDataPersonCard) -guessLicenceAddress cards - | Just c <- Set.lookupMax cards - , card <- Set.foldr pickLicenceAddress c cards - = getCompanyAddress card - | otherwise = (Nothing, Nothing, Nothing) +-- hasAddress :: AvsDataPersonCard -> Bool +-- hasAddress AvsDataPersonCard{..} = isJust avsDataStreet && isJust avsDataCity && isJust avsDataPostalCode -hasAddress :: AvsDataPersonCard -> Bool -hasAddress AvsDataPersonCard{..} = isJust avsDataStreet && isJust avsDataCity && isJust avsDataPostalCode +-- pickLicenceAddress :: AvsDataPersonCard -> AvsDataPersonCard -> AvsDataPersonCard +-- pickLicenceAddress a b +-- | Just r <- pickBetter' hasAddress = r -- prefer card with complete address +-- | Just r <- pickBetter' avsDataValid = r -- prefer valid cards +-- | Just r <- pickBetter' (Set.member licenceRollfeld . avsDataCardAreas) = r -- prefer 'R' cards +-- | Just r <- pickBetter' (Set.member licenceVorfeld . avsDataCardAreas) = r -- prefer 'F' cards +-- | avsDataCardColor a > avsDataCardColor b = a -- prefer Yellow over Green, etc. +-- | avsDataCardColor a < avsDataCardColor b = b +-- | avsDataIssueDate a > avsDataIssueDate b = a -- prefer later issue date +-- | avsDataIssueDate a < avsDataIssueDate b = b +-- | avsDataValidTo a > avsDataValidTo b = a -- prefer later validto date +-- | avsDataValidTo a < avsDataValidTo b = b +-- | Just r <- pickBetter' (isJust . avsDataFirm) = r -- prefer having a firm +-- | a <= b = b -- respect natural Ord instance +-- | otherwise = a +-- where +-- pickBetter' :: (AvsDataPersonCard -> Bool) -> Maybe AvsDataPersonCard +-- pickBetter' = pickBetter a b +-- licenceRollfeld = licence2char AvsLicenceRollfeld +-- licenceVorfeld = licence2char AvsLicenceVorfeld -pickLicenceAddress :: AvsDataPersonCard -> AvsDataPersonCard -> AvsDataPersonCard -pickLicenceAddress a b - | Just r <- pickBetter' hasAddress = r -- prefer card with complete address - | Just r <- pickBetter' avsDataValid = r -- prefer valid cards - | Just r <- pickBetter' (Set.member licenceRollfeld . avsDataCardAreas) = r -- prefer 'R' cards - | Just r <- pickBetter' (Set.member licenceVorfeld . avsDataCardAreas) = r -- prefer 'F' cards - | avsDataCardColor a > avsDataCardColor b = a -- prefer Yellow over Green, etc. - | avsDataCardColor a < avsDataCardColor b = b - | avsDataIssueDate a > avsDataIssueDate b = a -- prefer later issue date - | avsDataIssueDate a < avsDataIssueDate b = b - | avsDataValidTo a > avsDataValidTo b = a -- prefer later validto date - | avsDataValidTo a < avsDataValidTo b = b - | Just r <- pickBetter' (isJust . avsDataFirm) = r -- prefer having a firm - | a <= b = b -- respect natural Ord instance - | otherwise = a - where - pickBetter' :: (AvsDataPersonCard -> Bool) -> Maybe AvsDataPersonCard - pickBetter' = pickBetter a b - licenceRollfeld = licence2char AvsLicenceRollfeld - licenceVorfeld = licence2char AvsLicenceVorfeld - -{- Note: -For Semigroup Ordering, (<>) ignores the righthand side except for EQ; this could conveniently be used like so -bestAddress :: AvsDataPersonCard -> AvsDataPersonCard -> Ordering - compare a b = compareBy avsDataValid - <> compareBy avsDataValidTo - <> compareBy avsDataIssueDate - ... - where - compareBy f = compare `on` f a b --} +-- {- Note: +-- For Semigroup Ordering, (<>) ignores the righthand side except for EQ; this could conveniently be used like so +-- bestAddress :: AvsDataPersonCard -> AvsDataPersonCard -> Ordering +-- compare a b = compareBy avsDataValid +-- <> compareBy avsDataValidTo +-- <> compareBy avsDataIssueDate +-- ... +-- where +-- compareBy f = compare `on` f a b +-- -} -- Merges several answers by AvsPersonId, preserving all AvsPersonCards mergeByPersonId :: Set AvsDataPerson -> Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson diff --git a/src/Utils/DB.hs b/src/Utils/DB.hs index de9608a4d..e624ef497 100644 --- a/src/Utils/DB.hs +++ b/src/Utils/DB.hs @@ -1,16 +1,17 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later +-- also see Utils.Persist + module Utils.DB where -import ClassyPrelude.Yesod +import ClassyPrelude.Yesod hiding (addMessageI) import qualified Data.List as List import qualified Data.Map as Map import qualified Data.Set as Set import qualified Database.Esqueleto.Legacy as E --- import Database.Persist -- currently not needed here import Utils import Control.Lens @@ -20,7 +21,7 @@ import Control.Monad.Catch hiding (bracket) import qualified Utils.Pool as Custom -import Database.Persist.Sql (runSqlConn) +import Database.Persist.Sql (runSqlConn) -- , updateWhereCount) import GHC.Stack (HasCallStack, CallStack, callStack) @@ -29,6 +30,24 @@ import GHC.Stack (HasCallStack, CallStack, callStack) -- import Control.Monad.Trans.Reader (withReaderT) +-- | Obtain a record projection from an EntityField +getFieldEnt :: PersistEntity record => EntityField record typ -> Entity record -> typ +getFieldEnt = view . fieldLens + +getField :: PersistEntity record => EntityField record typ -> record -> typ +getField = view . fieldLensVal + +-- | Obtain a lens from an EntityField +fieldLensVal :: PersistEntity record => EntityField record typ -> Lens' record typ +fieldLensVal f = entityLens . fieldLens f + where + entityLens :: Lens' record (Entity record) + entityLens = lens getVal setVal + getVal :: record -> Entity record + getVal = Entity (error "fieldLensVal unexpectectly required an entity key") -- this is safe, since the lens is only used locally + setVal :: record -> Entity record -> record + setVal _ = entityVal + emptyOrIn :: PersistField typ => E.SqlExpr (E.Value typ) -> Set typ -> E.SqlExpr (E.Value Bool) @@ -88,12 +107,29 @@ existsKey404 :: (PersistRecordBackend record backend, PersistQueryRead backend, => Key record -> ReaderT backend m () existsKey404 = bool notFound (return ()) <=< existsKey +-- | given filter criteria like `selectList` this function returns Just if and only if there is precisely one result +getByFilter :: (PersistRecordBackend record backend, PersistQueryRead backend, MonadIO m) + => [Filter record] -> ReaderT backend m (Maybe (Entity record)) +getByFilter crit = + selectList crit [LimitTo 2] <&> \case + [singleEntity] -> Just singleEntity + _ -> Nothing -- not existing or not unique + +getKeyByFilter :: (PersistRecordBackend record backend, PersistQueryRead backend, MonadIO m) + => [Filter record] -> ReaderT backend m (Maybe (Key record)) +getKeyByFilter crit = + selectKeysList crit [LimitTo 2] <&> \case + [singleKey] -> Just singleKey + _ -> Nothing -- not existing or not unique + + updateBy :: (PersistUniqueRead backend, PersistStoreWrite backend, MonadIO m, PersistRecordBackend record backend ) => Unique record -> [Update record] -> ReaderT backend m () updateBy uniq updates = do key <- getKeyBy uniq for_ key $ flip update updates +-- | update and retrieve an entity. Will throw an error if the key is updaded updateGetEntity :: (PersistStoreWrite backend, MonadIO m, PersistRecordBackend record backend) => Key record -> [Update record] -> ReaderT backend m (Entity record) updateGetEntity k = fmap (Entity k) . updateGet k @@ -142,6 +178,24 @@ replaceEntity :: ( MonadIO m => Entity record -> ReaderT backend m () replaceEntity Entity{..} = replace entityKey entityVal +-- Notes on upsertBy: +-- * Unique denotes old record +-- * Changes to fields involved in uniqueness work, but may throw an error if updated record already exists + +-- | Safe version of upsertBy which does nothing if the new or updated record would violate a uniqueness constraint +upsertBySafe :: ( MonadIO m + , PersistEntity record + , PersistUniqueWrite backend + , PersistEntityBackend record ~ BaseBackend backend + ) + => Unique record -> record -> (record -> record) -> ReaderT backend m (Maybe (Key record)) +upsertBySafe uniq newr upd = maybeM (insertUnique newr) do_upd (getBy uniq) + where + do_upd Entity{entityKey = oid, entityVal = oldr} = do + delete oid + insertUnique $ upd oldr + + checkUniqueKeys :: ( MonadIO m , PersistUniqueRead backend , PersistRecordBackend record backend @@ -201,6 +255,25 @@ class WithRunDB backend m' m | m -> backend m' where instance WithRunDB backend m (ReaderT backend m) where useRunDB = id +-- Could be used at Handler.Admin.postAdminProblemsR, but not yet elsewhere, thus inlined for now, as it may be too special: +-- updateWithMessage +-- :: ( YesodPersist site, PersistEntity val, BackendCompatible SqlBackend (YesodPersistBackend site), PersistEntityBackend val ~ SqlBackend +-- , Num a, Ord a, RenderMessage site msg, RedirectUrl site (url,[(Text,Text)])) +-- => url -- where to redirect, if changes were mage +-- -> [Filter val] -- update filter +-- -> [Update val] -- actual update +-- -> a -- expected updates +-- -> (a -> msg) -- message to add with number of actual changes +-- -> HandlerFor site () +-- updateWithMessage route flt upd no_req msg = do +-- (fromIntegral -> oks) <- runDB $ updateWhereCount flt upd +-- let mkind = if oks < no_req || no_req <= 0 then Warning else Success +-- addMessageI mkind $ msg oks +-- when (oks > 0) $ do -- reload to ensure updates are displayed +-- getps <- reqGetParams <$> getRequest +-- redirect (route, getps) + + -- newtype DBRunner' backend m = DBRunner' { runDBRunner' :: forall b. ReaderT backend m b -> m b } -- _DBRunner' :: Iso' (DBRunner site) (DBRunner' (YesodPersistBackend site) (HandlerFor site)) @@ -254,3 +327,65 @@ instance WithRunDB backend m (ReaderT backend m) where -- getRunnerNoLock = maybe getRunner return =<< atomically (tryReadTMVar runnerTMVar) -- runCachedDBRunnerUsing act getRunnerNoLock + + + +-- A datatype for a specific heterogeneous list to compute DB updates, consisting of a persistent record field and a fitting lens +data CheckUpdate record iraw = forall typ. (Eq typ, PersistField typ) => CheckUpdate (EntityField record typ) (Getting typ iraw typ) -- A persistent record field and fitting getting + + +-- | Compute necessary updates. Given a database record, the new and old raw data, and a pair consisting of a getter from raw data to a value and an EntityField of the same value, +-- an update is returned, if the current value is identical to the old value, which changed in the new raw data +mkUpdate :: PersistEntity record => record -> iraw -> Maybe iraw -> CheckUpdate record iraw -> Maybe (Update record) +mkUpdate ent new (Just old) (CheckUpdate up l) + | let newval = new ^. l + , let oldval = old ^. l + , let entval = ent ^. fieldLensVal up + , newval /= entval + , oldval == entval + = Just (up =. newval) +mkUpdate _ _ _ _ = Nothing + +-- | Like `mkUpdate` but performs the update even if there was no old value to check if the value had been edited +mkUpdate' :: PersistEntity record => record -> iraw -> Maybe iraw -> CheckUpdate record iraw -> Maybe (Update record) +mkUpdate' ent new Nothing = mkUpdateDirect ent new +mkUpdate' ent new just = mkUpdate ent new just + +mkUpdateDirect :: PersistEntity record => record -> iraw -> CheckUpdate record iraw -> Maybe (Update record) +mkUpdateDirect ent new (CheckUpdate up l) + | let newval = new ^. l + , let entval = ent ^. fieldLensVal up + , newval /= entval + = Just (up =. newval) +mkUpdateDirect _ _ _ = Nothing + +-- | Unconditionally update a record through ChecUpdate +updateRecord :: PersistEntity record => record -> iraw -> CheckUpdate record iraw -> record +updateRecord ent new (CheckUpdate up l) = + let newval = new ^. l + lensRec = fieldLensVal up + in ent & lensRec .~ newval + +-- | like mkUpdate' but only returns the update if the new value would be unique +-- mkUpdateCheckUnique' :: PersistEntity record => record -> iraw -> Maybe iraw -> CheckUpdate record iraw -> DB (Maybe (Update record)) + +mkUpdateCheckUnique' :: (MonadIO m, PersistQueryRead backend, PersistEntity record, PersistEntityBackend record ~ BaseBackend backend) + => record -> a -> Maybe a -> CheckUpdate record a -> ReaderT backend m (Maybe (Update record)) + +mkUpdateCheckUnique' ent new Nothing (CheckUpdate up l) + | let newval = new ^. l + , let entval = ent ^. fieldLensVal up + , newval /= entval + = do + newval_exists <- exists [up ==. newval] + return $ toMaybe (not newval_exists) (up =. newval) +mkUpdateCheckUnique' ent new (Just old) (CheckUpdate up l) + | let newval = new ^. l + , let oldval = old ^. l + , let entval = ent ^. fieldLensVal up + , newval /= entval + , oldval == entval + = do + newval_exists <- exists [up ==. newval] + return $ toMaybe (not newval_exists) (up =. newval) +mkUpdateCheckUnique' _ _ _ _ = return Nothing diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 18c96c289..19e8f2135 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2023 Felix Hamann ,Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Steffen Jost ,Wolfgang Witt +-- SPDX-FileCopyrightText: 2023-2024 Felix Hamann ,Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Steffen Jost ,Wolfgang Witt ,David Mosbach -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -398,6 +398,16 @@ instance Finite ButtonSubmit nullaryPathPiece ''ButtonSubmit $ camelToPathPiece' 1 +-- | Filter button +data ButtonApplyFilter = BtnApplyFilter + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) + +instance Universe ButtonApplyFilter +instance Finite ButtonApplyFilter + +nullaryPathPiece ''ButtonApplyFilter $ camelToPathPiece' 2 + + buttonField :: forall a m. ( Button (HandlerSite m) a , MonadHandler m @@ -1123,23 +1133,25 @@ data FormSubmitType = FormNoSubmit | FormSubmit | FormDualSubmit | FormAutoSubmi instance Universe FormSubmitType instance Finite FormSubmitType -data FormSettings site = forall p. PathPiece p => FormSettings +data FormSettings site = forall p b. (PathPiece p, Button site b) => FormSettings { formMethod :: StdMethod , formAction :: Maybe (SomeRoute site) , formEncoding :: Enctype , formAttrs :: [(Text, Text)] , formSubmit :: FormSubmitType + , formCustomBtn :: Maybe b , formAnchor :: Maybe p } -instance Default (FormSettings site) where +instance (Button site ButtonSubmit) => Default (FormSettings site) where def = FormSettings - { formMethod = POST - , formAction = Nothing - , formEncoding = UrlEncoded - , formAttrs = [] - , formSubmit = FormSubmit - , formAnchor = Nothing :: Maybe Text + { formMethod = POST + , formAction = Nothing + , formEncoding = UrlEncoded + , formAttrs = [] + , formSubmit = FormSubmit + , formCustomBtn = Nothing :: Maybe ButtonSubmit + , formAnchor = Nothing :: Maybe Text } wrapForm :: Button site ButtonSubmit => WidgetT site IO () -> FormSettings site -> WidgetT site IO () @@ -1152,6 +1164,19 @@ wrapForm' btn formWidget FormSettings{..} = do let hasAction = isJust formActionUrl $(widgetFile "widgets/form/form") +buttonViewFallback :: forall site a b. (Button site a, Button site b) + => Maybe b + -> a + -> WidgetT site IO () +buttonViewFallback Nothing btn = buttonView btn +buttonViewFallback (Just btn) _ = buttonView btn + +btnLabelFallback :: forall site a b. (Button site a, Button site b) + => Maybe b + -> a + -> WidgetT site IO () +btnLabelFallback Nothing btn = btnLabel btn +btnLabelFallback (Just btn) _ = btnLabel btn ------------------- -- Form Renderer -- diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs index 07804c015..0ec91a144 100644 --- a/src/Utils/Icon.hs +++ b/src/Utils/Icon.hs @@ -118,6 +118,7 @@ data Icon | IconCompany | IconEdit | IconUserEdit + | IconMagic -- indicates automatic updates deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic) deriving anyclass (Universe, Finite, NFData) @@ -214,6 +215,7 @@ iconText = \case IconCompany -> "building" IconEdit -> "edit" IconUserEdit -> "user-edit" + IconMagic -> "wand-magic" nullaryPathPiece ''Icon $ camelToPathPiece' 1 deriveLift ''Icon @@ -291,11 +293,16 @@ isBad :: Bool -> Markup isBad True = icon IconProblem isBad False = mempty --- ^ Maybe display an icon that denotes that something™ is bad +-- ^ Maybe display an icon that denotes that something™ is new isNew :: Bool -> Markup isNew True = icon IconNew isNew False = mempty +-- ^ Maybe display an icon that denotes that something™ is automagically updated or derived +isAutomatic :: Bool -> Markup +isAutomatic True = icon IconMagic +isAutomatic False = mempty + boolSymbol :: Bool -> Markup boolSymbol True = icon IconOK boolSymbol False = icon IconNotOK diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index adcba7262..55228823d 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -13,6 +13,8 @@ import Model import Model.Rating import qualified ClassyPrelude.Yesod as Yesod (HasHttpManager(..)) +import Audit.Types (AdminProblem(..), decodeAdminProblem) + import Control.Lens as Utils.Lens hiding ( (<.>) , universe @@ -113,6 +115,8 @@ makeClassyFor_ ''User -- _user... -- +makeClassyFor_ ''UserSupervisor + makeClassyFor_ ''StudyFeatures makeClassyFor_ ''StudyDegree @@ -127,7 +131,6 @@ makeClassyFor_ ''LmsUser -- makeClassyFor_ ''LmsUserStatus makeClassyFor_ ''LmsReport makeClassyFor_ ''UserAvs -makeClassyFor_ ''UserAvsCard makeLenses_ ''UserCompany makeLenses_ ''Company @@ -310,7 +313,11 @@ makeLenses_ ''AuthorshipStatementDefinition makeLenses_ ''PrintJob makeLenses_ ''InterfaceLog --- makeLenses_ ''InterfaceLog -- not needed +makeLenses_ ''AdminProblem +makeLenses_ ''ProblemLog + +_problemLogAdminProblem :: Getter ProblemLog AdminProblem +_problemLogAdminProblem = _problemLogInfo . to decodeAdminProblem -------------------------- -- Fields for `UniWorX` -- diff --git a/src/Utils/Mail.hs b/src/Utils/Mail.hs new file mode 100644 index 000000000..a59498e39 --- /dev/null +++ b/src/Utils/Mail.hs @@ -0,0 +1,64 @@ +-- SPDX-FileCopyrightText: 2024 Steffen Jost +-- +-- SPDX-License-Identifier: AGPL-3.0-or-later + +module Utils.Mail where + + +import Import.NoModel + +import qualified Data.Char as Char +import qualified Data.Text as Text +import qualified Data.CaseInsensitive as CI + +import qualified Text.Email.Validate as Email + +-- | domains used by LDAP accounts +fraportMailDomains :: [Text] +fraportMailDomains = ["@fraport.de"] -- <&> foldCase only! + +-- | returns the part before the @ symbol of an email address that ends with a fraport domain, preserving case +-- eg. getFraportLogin "E1234@fraport.de" == Just "E1234" +-- getFraportLogin "S.Guy@fraport.de" == Just "S.Guy" +-- getFraportLogin "S.Guy@elsewhere.com" == Nothing +-- Use CI.traverse getFraportLogin :: CI Text -> Maybe (CI Text) +-- CI.traverse getFraportLogin "S.Jost@Fraport.de" == Just "S.Jost" +getFraportLogin :: Text -> Maybe Text +getFraportLogin email = orgCase <$> lowerCaseLogin + where + orgCase = flip Text.take email . Text.length + lowerCaseLogin = firstJust (flip Text.stripSuffix $ foldCase email) fraportMailDomains + +-- | check that an email is valid and that it is not an E-account that nobody reads +-- also see `Handler.Utils.Users.getUserEmail` for Tests accepting User Type +validEmail :: Text -> Bool -- Email = Text +validEmail email = validRFC5322 && not invalidFraport + where + validRFC5322 = Email.isValid $ encodeUtf8 email + invalidFraport = case getFraportLogin email of + Just fralogin -> Text.all Char.isDigit $ Text.drop 1 fralogin -- Emails like E1234@fraport.de or 012345!fraport.de are not read + Nothing -> False + +validEmail' :: CI Text -> Bool -- UserEmail = CI Text +validEmail' = validEmail . CI.original + +-- | returns the first valid Email, if any +pickValidEmail :: [Text] -> Maybe Text +pickValidEmail = find validEmail + +-- | returns the first valid Email, if any +pickValidEmail' :: [CI Text] -> Maybe (CI Text) +pickValidEmail' = find validEmail' + +-- | returns first argument, if it is a valid email address; returns second argument untested otherwise; convenience function +pickValidUserEmail :: CI Text -> CI Text -> CI Text +pickValidUserEmail x y + | validEmail' x = x + | otherwise = y + +-- | returns first valid email address or none if none are valid +pickValidUserEmail' :: CI Text -> CI Text -> Maybe (CI Text) +pickValidUserEmail' x y + | validEmail' x = Just x + | validEmail' y = Just y + | otherwise = Nothing \ No newline at end of file diff --git a/src/Utils/Pandoc.hs b/src/Utils/Pandoc.hs new file mode 100644 index 000000000..ad7582377 --- /dev/null +++ b/src/Utils/Pandoc.hs @@ -0,0 +1,43 @@ +-- SPDX-FileCopyrightText: 2022-2024 Gregor Kleen , Steffen Jost +-- +-- SPDX-License-Identifier: AGPL-3.0-or-later + +module Utils.Pandoc where + + +import Import.NoModel + +import Data.Either (fromRight) +-- import qualified Data.Char as Char +-- import qualified Data.Text as Text +-- import qualified Data.CaseInsensitive as CI +import Text.Blaze (toMarkup) +import Text.Blaze.Html.Renderer.Text (renderHtml) +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) + +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]] + + +htmlReaderOptions, markdownReaderOptions :: P.ReaderOptions +htmlReaderOptions = markdownReaderOptions +markdownReaderOptions = def + { P.readerExtensions = P.pandocExtensions + & P.enableExtension P.Ext_hard_line_breaks + & P.enableExtension P.Ext_autolink_bare_uris + , P.readerTabStop = 2 + } + +markdownWriterOptions, htmlWriterOptions :: P.WriterOptions +markdownWriterOptions = def + { P.writerExtensions = P.readerExtensions markdownReaderOptions + , P.writerTabStop = P.readerTabStop markdownReaderOptions + } +htmlWriterOptions = markdownWriterOptions \ No newline at end of file diff --git a/src/Utils/Persist.hs b/src/Utils/Persist.hs index e414e2924..154a8346c 100644 --- a/src/Utils/Persist.hs +++ b/src/Utils/Persist.hs @@ -1,10 +1,13 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen , Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later +-- also see Utils.DB + module Utils.Persist ( fromPersistValueError , fromPersistValueErrorSql + , (~=.), (~~.) ) where import ClassyPrelude @@ -37,3 +40,15 @@ fromPersistValueErrorSql :: forall p a. -> PersistValue -> Text fromPersistValueErrorSql _ = fromPersistValueError (tshow $ typeRep @a) (tshow $ sqlType (Proxy @a)) + + +infix 4 ~=. +-- | is equal or Nothing, do not confuse with Database.Esqueleto.Utils(~=.) which does the same for proper Esqueleto queries +(~=.) :: PersistField a => EntityField v (Maybe a) -> a -> [Filter v] +(~=.) f v = [f ==. Nothing] ||. [f ==. Just v] + +infix 4 ~~. +-- | maybe is equal or Nothing, +(~~.) :: PersistField a => EntityField v (Maybe a) -> Maybe a -> [Filter v] +(~~.) f Nothing = [f ==. Nothing] +(~~.) f (Just v) = [f ==. Nothing] ||. [f ==. Just v] diff --git a/src/Utils/Postal.hs b/src/Utils/Postal.hs new file mode 100644 index 000000000..65c7b2d0a --- /dev/null +++ b/src/Utils/Postal.hs @@ -0,0 +1,32 @@ +-- SPDX-FileCopyrightText: 2024 Steffen Jost +-- +-- SPDX-License-Identifier: AGPL-3.0-or-later + +-- TODO: why is this Handler.Utils.Profile instead of Utils.Profile? +-- TODO: consider merging with Handler.Utils.Users? +module Utils.Postal + ( validPostAddress, validPostAddressText + ) where + +import Import.NoModel +import Model.Types.Markup + +import Data.Char +import qualified Data.Text.Lazy as LT + + +-- | Primitive postal address requires at least one alphabetic character, one digit and a line break +validPostAddress :: Maybe StoredMarkup -> Bool +validPostAddress (Just StoredMarkup {markupInput = addr}) = validPostAddressLazyText addr +validPostAddress _ = False + +validPostAddressText :: Text -> Bool +validPostAddressText = validPostAddressLazyText . LT.fromStrict + +validPostAddressLazyText :: LT.Text -> Bool +validPostAddressLazyText addr + | Just _ <- LT.find isLetter addr + , Just _ <- LT.find isNumber addr + -- , Just _ <- LT.find ((LineSeparator ==) . generalCategory) addr -- THIS DID NOT WORK + = 1 < length (LT.lines addr) +validPostAddressLazyText _ = False diff --git a/src/Utils/Print.hs b/src/Utils/Print.hs index d4dc3f882..9b6bea074 100644 --- a/src/Utils/Print.hs +++ b/src/Utils/Print.hs @@ -23,6 +23,7 @@ module Utils.Print -- , MDLetter , SomeLetter(..) , LetterRenewQualificationF(..) + -- , LetterRenewQualification(..) , LetterExpireQualification(..) -- , LetterCourseCertificate() , makeCourseCertificates @@ -59,7 +60,8 @@ import Jobs.Handler.SendNotification.Utils import Utils.Print.Instances () import Utils.Print.Letters import Utils.Print.SomeLetter -import Utils.Print.RenewQualification +import Utils.Print.RenewQualificationF +import Utils.Print.RenewQualification() import Utils.Print.ExpireQualification import Utils.Print.CourseCertificate @@ -145,51 +147,41 @@ pdfLaTeX lk doc = do let writerOpts = def { P.writerExtensions = P.pandocExtensions , P.writerTemplate = Just tmpl } makePDF writerOpts $ appMeta setIsDeFromLang doc - -renderLetterPDF :: (MDLetter l) => Entity User -> l -> Text -> Handler (Either Text LBS.ByteString) -renderLetterPDF rcvrEnt@Entity{entityVal=rcvr} mdl apcIdent = do + +letterTemplate :: (MDLetter l) => Entity User -> l -> Text -> Maybe [Text] -> Handler (Either Text P.Pandoc) +letterTemplate rcvrEnt@Entity{entityVal=rcvr} mdl apcIdent rcvrPostalRaw = do now <- liftIO getCurrentTime formatter@DateTimeFormatter{ format } <- getDateTimeFormatterUser' rcvr - let lang = selectDeEn $ rcvr & userLanguages -- select either German or English only, default de; see Utils.Lang - kind = getLetterKind mdl - tmpl = getTemplate mdl + rcvrPostal <- altM (return rcvrPostalRaw) $ runDB $ getPostalAddress rcvrEnt + -- (_,rcvrPostal, rcvrEmail) <- runDB $ getPostalPreferenceAndAddress + let lang = selectDeEn $ rcvr & userLanguages -- select either German or English only, default de; see Utils.Lang + tmpl = getTemplate mdl meta = addApcIdent apcIdent <> letterMeta mdl formatter lang rcvrEnt <> mkMeta [ -- toMeta "lang" lang -- receiver language is decided in MDLetter instance, since some letters have fixed languages toMeta "date" $ format SelFormatDate now , toMeta "rcvr-name" $ rcvr & userDisplayName - , toMeta "address" $ fromMaybe [rcvr & userDisplayName] $ getPostalAddress rcvr - --, toMeta "rcvr-email" $ rcvr & userDisplayEmail -- note that some templates use "email" already otherwise + , toMeta "address" $ fromMaybe [rcvr & userDisplayName] $ canonical rcvrPostal + --, toMeta "rcvr-email" $ fromMaybe [rcvr & userDisplayEmail] rcvrEmail -- note that some templates use "email" already otherwise ] - e_md <- mdTemplating tmpl meta - actRight e_md $ pdfLaTeX kind + mdTemplating tmpl meta +renderLetterPDF :: (MDLetter l) => Entity User -> l -> Text -> Maybe [Text] -> Handler (Either Text LBS.ByteString) +renderLetterPDF rcvrEnt mdl apcIdent rcvrPostal = do + e_md <- letterTemplate rcvrEnt mdl apcIdent rcvrPostal + actRight e_md $ pdfLaTeX $ getLetterKind mdl -renderLetterHtml :: (MDLetter l) => Entity User -> l -> Text -> Handler (Either Text Html) -renderLetterHtml rcvrEnt@Entity{entityVal=rcvr} mdl apcIdent = do - now <- liftIO getCurrentTime - formatter@DateTimeFormatter{ format } <- getDateTimeFormatterUser' rcvr - let lang = selectDeEn $ rcvr & userLanguages -- select either German or English only, default de; see Utils.Lang - kind = getLetterKind mdl - tmpl = getTemplate mdl - meta = addApcIdent apcIdent - <> letterMeta mdl formatter lang rcvrEnt - <> mkMeta - [ -- toMeta "lang" lang -- receiver language is decided in MDLetter instance, since some letters have fixed languages - toMeta "date" $ format SelFormatDate now - , toMeta "rcvr-name" $ rcvr & userDisplayName - , toMeta "address" $ fromMaybe [rcvr & userDisplayName] $ getPostalAddress rcvr - --, toMeta "rcvr-email" $ rcvr & userDisplayEmail -- note that some templates use "email" already otherwise - ] - e_md <- mdTemplating tmpl meta - actRight e_md $ \md -> pure . over _Left P.renderError . P.runPure $ do - html_tmpl <- compileTemplate $ templateHtml kind - -- html_tmpl <- ExceptT $ memcachedBy (Just . Right $ 6 * diffHour) ("LetterKind-Html: \n" <> tshow lk) (pure . over _Left P.renderError . P.runPure $ compileTemplate $ templateHtml lk) - let writerOpts = def { P.writerExtensions = P.pandocExtensions - , P.writerTemplate = Just html_tmpl } - P.writeHtml5 writerOpts $ appMeta setIsDeFromLang md +renderLetterHtml :: (MDLetter l) => Entity User -> l -> Text -> Maybe [Text] -> Handler (Either Text Html) +renderLetterHtml rcvrEnt mdl apcIdent rcvrPostal = do + e_md <- letterTemplate rcvrEnt mdl apcIdent rcvrPostal + actRight e_md $ \md -> pure . over _Left P.renderError . P.runPure $ do + html_tmpl <- compileTemplate $ templateHtml $ getLetterKind mdl + -- html_tmpl <- ExceptT $ memcachedBy (Just . Right $ 6 * diffHour) ("LetterKind-Html: \n" <> tshow lk) (pure . over _Left P.renderError . P.runPure $ compileTemplate $ templateHtml lk) + let writerOpts = def { P.writerExtensions = P.pandocExtensions + , P.writerTemplate = Just html_tmpl } + P.writeHtml5 writerOpts $ appMeta setIsDeFromLang md -- TODO: apcIdent does not make sense for multiple letters renderLetters :: (MDLetter l, Foldable f) => Entity User -> f l -> Text -> Handler (Either Text LBS.ByteString) @@ -197,6 +189,8 @@ renderLetters rcvrEnt@Entity{entityVal=rcvr} mdls apcIdent | Just l <- anyone mdls = do now <- liftIO getCurrentTime formatter@DateTimeFormatter{ format } <- getDateTimeFormatterUser' rcvr + rcvrPostal <- runDB $ getPostalAddress rcvrEnt + -- (_,rcvrPostal, rcvrEmail) <- runDB $ getPostalPreferenceAndAddress let lang = selectDeEn $ rcvr & userLanguages -- select either German or English only, default de; see Utils.Lang kind = getLetterKind l @@ -209,8 +203,8 @@ renderLetters rcvrEnt@Entity{entityVal=rcvr} mdls apcIdent [ -- toMeta "lang" lang -- receiver language is decided in MDLetter instance, since some letters have fixed languages toMeta "date" $ format SelFormatDate now , toMeta "rcvr-name" $ rcvr & userDisplayName - , toMeta "address" $ fromMaybe [rcvr & userDisplayName] $ getPostalAddress rcvr - --, toMeta "rcvr-email" $ rcvr & userDisplayEmail -- note that some templates use "email" already otherwise + , toMeta "address" $ fromMaybe [rcvr & userDisplayName] rcvrPostal + --, toMeta "rcvr-email" $ fromMaybe [rcvr & userDisplayEmail] rcvrEmail -- note that some templates use "email" already otherwise ] in mdTemplating tmpl meta <&> \case err@Left{} -> err @@ -234,7 +228,7 @@ printHtml _senderId (rcvr, letter) = do encRecipient :: CryptoUUIDUser <- encrypt rcvrId now <- liftIO getCurrentTime apcIdent <- letterApcIdent letter encRecipient now - renderLetterHtml rcvr letter apcIdent + renderLetterHtml rcvr letter apcIdent Nothing -- Only used in print-test-handler for PrintSendR printLetter :: (MDLetter l) => Maybe UserId -> (Entity User, l) -> Handler (Either Text (Text, FilePath)) @@ -243,7 +237,7 @@ printLetter senderId (rcvr, letter) = do encRecipient :: CryptoUUIDUser <- encrypt rcvrId now <- liftIO getCurrentTime apcIdent <- letterApcIdent letter encRecipient now - pdf <- renderLetterPDF rcvr letter apcIdent + pdf <- renderLetterPDF rcvr letter apcIdent Nothing let protoPji = getPJId letter pji = protoPji { pjiRecipient = Just rcvrId @@ -269,7 +263,7 @@ printLetter' pji pdf = do -- printJobFile <- sinkFileDB True $ yield $ LBS.toStrict pdf -- for PrintJobFile :: FileContentReference use this code printJobFile = LBS.toStrict pdf printJobAcknowledged = Nothing - qshort <- ifMaybeM printJobQualification "-" $ fmap (maybe "_" $ CI.original . qualificationShorthand ) . get + qshort <- ifNothingM printJobQualification "-" $ fmap (maybe "_" $ CI.original . qualificationShorthand ) . get let logInter = flip (logInterface "Printer" qshort) (Just 1) lprPDF printJobFilename pdf >>= \case Left err -> do @@ -287,7 +281,7 @@ reprintPDF ignoreReroute pjid = maybeM (return $ Left "Print job id is unknown." where reprint :: PrintJob -> DB (Either Text Text) reprint pj@PrintJob{..} = do - qshort <- ifMaybeM printJobQualification "-" $ fmap (maybe "_" $ CI.original . qualificationShorthand ) . get + qshort <- ifNothingM printJobQualification "-" $ fmap (maybe "_" $ CI.original . qualificationShorthand ) . get let logInter = flip (logInterface "Printer" qshort) (Just 1) result <- lprPDF' ignoreReroute printJobFilename $ LBS.fromStrict printJobFile case result of @@ -332,13 +326,14 @@ sendEmailOrLetter recipient letter = do mailSubject = mkMailSubject isSupervised encRecipient :: CryptoUUIDUser <- encrypt svr apcIdent <- letterApcIdent letter encRecipient now - case getPostalPreferenceAndAddress rcvrUsr of - (True, Nothing) -> do -- neither email nor postal is known + postalPrefs <- runDB $ getPostalPreferenceAndAddress rcvrEnt + case postalPrefs of + (_, Nothing, Nothing) -> do -- neither email nor postal is known let msg = "Notification failed for " <> tshow encRecipient <> ", who has neither a known email nor postal address. Notification: " <> tshow pjid $logErrorS "LETTER" msg return False - (True , Just _postal) -> renderLetterPDF rcvrEnt letter apcIdent >>= \case -- send printed letter + (True, postal@(Just _), _) -> renderLetterPDF rcvrEnt letter apcIdent postal >>= \case -- send printed letter Left err -> do -- pdf generation failed let msg = "Notification failed for " <> tshow encRecipient <> ". PDF generation failed: "<> cropText err <> "For Notification: " <> tshow pjid $logErrorS "LETTER" msg @@ -354,7 +349,7 @@ sendEmailOrLetter recipient letter = do $logWarnS "LETTER" $ "PDF printing to send letter with lpr returned ExitSuccess and the following message: " <> msg return True - (False, _) | Just mkMail <- mkMailBody -> renderLetterPDF rcvrEnt letter apcIdent >>= \case -- send Email, but with pdf attached + (_, postal, _email) | Just mkMail <- mkMailBody -> renderLetterPDF rcvrEnt letter apcIdent postal >>= \case -- send Email with pdf attached Left err -> do -- pdf generation failed let msg = "Notification failed for " <> tshow encRecipient <> ". PDF attachment generation failed: "<> cropText err <> "For Notification: " <> tshow pjid $logErrorS "LETTER" msg @@ -374,6 +369,7 @@ sendEmailOrLetter recipient letter = do return pdf formatter <- getDateTimeFormatterUser' rcvrUsr -- not too expensive, only calls getTimeLocale let mailBody = mkMail formatter + -- userMailTdirect computes email address once more, hence _email is currently ignored userMailTdirect svr $ do replaceMailHeader "Auto-Submitted" $ Just "auto-generated" setSubjectI mailSubject @@ -385,7 +381,7 @@ sendEmailOrLetter recipient letter = do } :: PureFile) return True - (False, _) -> renderLetterHtml rcvrEnt letter apcIdent >>= \case -- send Email, render letter directly to html + (_, postal, _email) -> renderLetterHtml rcvrEnt letter apcIdent postal >>= \case -- send Email, render letter directly to html Left err -> do -- html generation failed let msg = "Notification failed for " <> tshow encRecipient <> ". HTML generation failed: "<> cropText err <> "For Notification: " <> tshow pjid $logErrorS "LETTER" msg @@ -393,9 +389,9 @@ sendEmailOrLetter recipient letter = do Right html -> do -- html generated, send directly now userMailTdirect svr $ do replaceMailHeader "Auto-Submitted" $ Just "auto-generated" - setSubjectI mailSubject + setSubjectI mailSubject addHtmlMarkdownAlternatives html - return True + return True return $ or oks diff --git a/src/Utils/Print/Letters.hs b/src/Utils/Print/Letters.hs index 0718a294b..58715bd1b 100644 --- a/src/Utils/Print/Letters.hs +++ b/src/Utils/Print/Letters.hs @@ -129,6 +129,7 @@ defWriterOpts t = def { P.writerExtensions = P.pandocExtensions, P.writerTemplat data LetterKind = Din5008 -- scrlttr2: Standard postal letter with address field, expects peprinted FraportLogo | PinLetter -- Like Din5008, but for special paper with a protected pin field + | PinNew -- New Variant for Pin Letters for R. TODO: Remove/rename/replace PinLetter | Plain -- scrartcl: Empty, expects empty paper with no preprints | PlainLogo -- Like plain, but expects to be printed on paper with Logo -- | Logo -- Like plain, but prints Fraport Logo in the upper right corner @@ -139,15 +140,18 @@ templateLatex = let tDin5008 = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/din5008.latex") tPinLetter = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/din5008with_pin.latex") + tPinNew = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/din5008with_pin_new.latex") tPlain = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/plain_article.latex") in \case PinLetter -> tPinLetter + PinNew -> tPinNew Din5008 -> tDin5008 PlainLogo -> tPlain Plain -> tPlain paperKind :: LetterKind -> Text -- Muss genau 5 Zeichen haben! paperKind PinLetter = "a4pin" -- Pin-Brief +paperKind PinNew = "a4pin" -- Pin-Brief paperKind Plain = "a4wht" -- Ohne Logo paperKind Din5008 = "a4log" -- Mit Logo paperKind PlainLogo = "a4log" diff --git a/src/Utils/Print/RenewQualification.hs b/src/Utils/Print/RenewQualification.hs index db417b9b6..ae9692541 100644 --- a/src/Utils/Print/RenewQualification.hs +++ b/src/Utils/Print/RenewQualification.hs @@ -19,7 +19,7 @@ import Utils.Print.Letters import Handler.Utils.Widgets (nameHtml) -- , nameHtml') -data LetterRenewQualificationF = LetterRenewQualificationF +data LetterRenewQualification = LetterRenewQualification { lmsLogin :: LmsIdent , lmsPin :: Text , qualHolderID :: UserId @@ -37,30 +37,31 @@ data LetterRenewQualificationF = LetterRenewQualificationF -- this datatype is specific to this letter only, and just to avoid code duplication for derived data or constants -data LetterRenewQualificationFData = LetterRenewQualificationFData { lmsUrl, lmsUrlLogin, lmsIdent :: Text } +data LetterRenewQualificationData = LetterRenewQualificationData { lmsUrl, lmsUrlLogin, lmsIdent :: Text } deriving (Eq, Show) -letterRenewalQualificationFData :: LetterRenewQualificationF -> LetterRenewQualificationFData -letterRenewalQualificationFData LetterRenewQualificationF{lmsLogin} = LetterRenewQualificationFData{..} +letterRenewalQualificationFData :: LetterRenewQualification -> LetterRenewQualificationData +letterRenewalQualificationFData LetterRenewQualification{lmsLogin} = LetterRenewQualificationData{..} where - lmsUrl = "https://drive.fraport.de" - lmsUrlLogin = lmsUrl <> "/?login=" <> lmsIdent + lmsUrl = "drive.fraport.de" + lmsUrlLogin = "https://" <> lmsUrl <> "/?login=" <> lmsIdent lmsIdent = getLmsIdent lmsLogin -instance MDLetter LetterRenewQualificationF where +instance MDLetter LetterRenewQualification where encryptPDFfor _ = PasswordUnderling - getLetterKind _ = PinLetter + getLetterKind _ = PinNew getLetterEnvelope _ = 'f' -- maybe 'q' (Char.toLower . fst) $ Text.uncons (qualShort l) - getTemplate _ = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/fraport_renewal.md") + getTemplate _ = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/fraport_renewal_new.md") getMailSubject l = SomeMessage $ MsgMailSubjectQualificationRenewal $ qualShort l - getMailBody l@LetterRenewQualificationF{..} = Just $ \DateTimeFormatter{ format } -> - let LetterRenewQualificationFData{..} = letterRenewalQualificationFData l + getMailBody l@LetterRenewQualification{..} = Just $ \DateTimeFormatter{ format } -> + let LetterRenewQualificationData{..} = letterRenewalQualificationFData l in $(ihamletFile "templates/mail/body/qualificationRenewal.hamlet") - letterMeta l@LetterRenewQualificationF{..} DateTimeFormatter{ format } lang Entity{entityKey=rcvrId, entityVal=User{userDisplayName}} = - let LetterRenewQualificationFData{..} = letterRenewalQualificationFData l + letterMeta l@LetterRenewQualification{..} DateTimeFormatter{ format } lang Entity{entityKey=rcvrId, entityVal=User{userDisplayName}} = + let LetterRenewQualificationData{..} = letterRenewalQualificationFData l isSupervised = rcvrId /= qualHolderID + newExpire = addDays (fromIntegral $ fromMaybe 0 qualDuration) qualExpiry in mkMeta $ guardMonoid isSupervised [ toMeta "supervisor" userDisplayName @@ -79,10 +80,15 @@ instance MDLetter LetterRenewQualificationF where , mbMeta "validduration" (show <$> qualDuration) , toMeta "url-text" lmsUrl , toMeta "url" lmsUrlLogin + , toMeta "notice" [ [st|Ein Zertifikat für Ihre Unterlagen kann nur direkt nach dem erfolgreichen Test erstellt werden. Das Zertifikat wird auf die Benutzerkennung ausgestellt. Zusammen mit diesem Schreiben können Sie Ihrem Arbeitgeber zeigen, dass Sie bestanden haben. Bei erfolgreichem Abschluss der Schulung verlängert sich das Ablaufdatum automatisch auf den #{format SelFormatDate newExpire}. Wir empfehlen die Schulung zeitnah durchzuführen. Sollte bis zum Ablaufdatum das E-Learning nicht erfolgreich abgeschlossen sein oder der Test nach 5 Versuchen nicht bestanden werden, muss zur Wiedererlangung der Fahrberechtigung „#{qualShort}“ ein Grundkurs #{qualName} bei der Fahrerausbildung absolviert werden.|] + , "Benötigen Sie die Fahrberechtigung nicht mehr, informieren Sie bitte die Fahrerausbildung."::Text + , "(Please contact us if you prefer letters in English.)" + ] + , toMeta "de-subject" [st|Verlängerung Fahrberechtigung „#{qualShort}“ (#{qualName})|] + , toMeta "en-subject" [st|Renewal of driving licence „#{qualShort}“ (#{qualName})|] + ] -- TODO use [st|some simple text with interpolation|] - ] - - getPJId LetterRenewQualificationF{..} = + getPJId LetterRenewQualification{..} = PrintJobIdentification { pjiName = bool "Renewal" "Renewal Reminder" isReminder , pjiApcAcknowledge = "lms-" <> getLmsIdent lmsLogin diff --git a/src/Utils/Print/RenewQualificationF.hs b/src/Utils/Print/RenewQualificationF.hs new file mode 100644 index 000000000..b2c5338b8 --- /dev/null +++ b/src/Utils/Print/RenewQualificationF.hs @@ -0,0 +1,100 @@ +-- SPDX-FileCopyrightText: 2023 Steffen Jost +-- +-- SPDX-License-Identifier: AGPL-3.0-or-later + +{-# OPTIONS_GHC -fno-warn-unused-top-binds #-} + +module Utils.Print.RenewQualificationF where + +import Import +import Text.Hamlet + +-- import Data.Char as Char +-- import qualified Data.Text as Text +import qualified Data.CaseInsensitive as CI + +import Data.FileEmbed (embedFile) + +import Utils.Print.Letters +import Handler.Utils.Widgets (nameHtml) -- , nameHtml') + + +data LetterRenewQualificationF = LetterRenewQualificationF + { lmsLogin :: LmsIdent + , lmsPin :: Text + , qualHolderID :: UserId + , qualHolderDN :: UserDisplayName + , qualHolderSN :: UserSurname + , qualExpiry :: Day + , qualId :: QualificationId + , qualName :: Text + , qualShort :: Text + , qualSchool :: SchoolId + , qualDuration :: Maybe Int + , isReminder :: Bool + } + deriving (Eq, Show) + + +-- this datatype is specific to this letter only, and just to avoid code duplication for derived data or constants +data LetterRenewQualificationFData = LetterRenewQualificationFData { lmsUrl, lmsUrlLogin, lmsIdent :: Text } + deriving (Eq, Show) + +letterRenewalQualificationFData :: LetterRenewQualificationF -> LetterRenewQualificationFData +letterRenewalQualificationFData LetterRenewQualificationF{lmsLogin} = LetterRenewQualificationFData{..} + where + lmsUrl = "https://drive.fraport.de" + lmsUrlLogin = lmsUrl <> "/?login=" <> lmsIdent + lmsIdent = getLmsIdent lmsLogin + + +instance MDLetter LetterRenewQualificationF where + encryptPDFfor _ = PasswordUnderling + getLetterKind _ = PinLetter + getLetterEnvelope _ = 'f' -- maybe 'q' (Char.toLower . fst) $ Text.uncons (qualShort l) + getTemplate _ = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/fraport_renewal.md") + getMailSubject l = SomeMessage $ MsgMailSubjectQualificationRenewal $ qualShort l + getMailBody l@LetterRenewQualificationF{..} = Just $ \DateTimeFormatter{ format } -> + let LetterRenewQualificationFData{..} = letterRenewalQualificationFData l + in $(ihamletFile "templates/mail/body/qualificationRenewal.hamlet") + + letterMeta l@LetterRenewQualificationF{..} DateTimeFormatter{ format } lang Entity{entityKey=rcvrId, entityVal=User{userDisplayName}} = + let LetterRenewQualificationFData{..} = letterRenewalQualificationFData l + isSupervised = rcvrId /= qualHolderID + in mkMeta $ + guardMonoid isSupervised + [ toMeta "supervisor" userDisplayName + , toMeta "de-opening" ("Sehr geehrte Damen und Herren,"::Text) + , toMeta "en-opening" ("Dear Sir or Madam,"::Text) + ] <> + guardMonoid isReminder + [ toMeta "reminder" ("reminder"::Text) + ] <> + [ toMeta "lang" lang + , toMeta "login" lmsIdent + , toMeta "pin" lmsPin + , toMeta "examinee" qualHolderDN + , toMeta "subject-meta" qualHolderDN + , toMeta "expiry" (format SelFormatDate qualExpiry) + , mbMeta "validduration" (show <$> qualDuration) + , toMeta "url-text" lmsUrl + , toMeta "url" lmsUrlLogin + + ] + + getPJId LetterRenewQualificationF{..} = + PrintJobIdentification + { pjiName = bool "Renewal" "Renewal Reminder" isReminder + , pjiApcAcknowledge = "lms-" <> getLmsIdent lmsLogin + , pjiRecipient = Nothing -- to be filled later + , pjiSender = Nothing + , pjiCourse = Nothing + , pjiQualification = Just qualId + , pjiLmsUser = Just lmsLogin + , pjiFileName = "renew_" <> CI.original (unSchoolKey qualSchool) <> "-" <> qualShort <> "_" <> qualHolderSN + -- let nameRecipient = abbrvName <$> recipient + -- nameSender = abbrvName <$> sender + -- nameCourse = CI.original . courseShorthand <$> course + -- nameQuali = CI.original . qualificationShorthand <$> quali + -- in .. = T.replace " " "-" (T.intercalate "_" . catMaybes $ [Just printJobName, nameQuali, nameCourse, nameSender, nameRecipient]) + } \ No newline at end of file diff --git a/src/Utils/Set.hs b/src/Utils/Set.hs index 79e11c662..f895cd098 100644 --- a/src/Utils/Set.hs +++ b/src/Utils/Set.hs @@ -13,6 +13,7 @@ module Utils.Set , setFromFunc , mapIntersectNotOne , set2NonEmpty +, maybeInsert ) where import qualified Data.List.NonEmpty as NonEmpty @@ -81,8 +82,11 @@ setPartitionEithers = (,) <$> setMapMaybeMonotonic (preview _Left) <*> setMapMay setFromFunc :: (Finite k, Ord k) => (k -> Bool) -> Set k setFromFunc = Set.fromList . flip filter universeF - -- | convert a Set to NonEmpty, inserting a default value if necessary set2NonEmpty :: a -> Set a -> NonEmpty.NonEmpty a set2NonEmpty _ (Set.toList -> h:t) = h NonEmpty.:| t set2NonEmpty d _ = d NonEmpty.:| [] + +maybeInsert :: Ord a => Maybe a -> Set a -> Set a +maybeInsert Nothing = id +maybeInsert (Just k) = Set.insert k \ No newline at end of file diff --git a/src/Utils/TH.hs b/src/Utils/TH.hs index 40669cc2f..88982048b 100644 --- a/src/Utils/TH.hs +++ b/src/Utils/TH.hs @@ -167,6 +167,7 @@ embedRenderMessage f inner mangle = do ] ] +-- ^ Like @embedRenderMessage, but for newtype definitions embedRenderMessageVariant :: Name -- ^ Foundation Type -> Name -- ^ Name of newtype -> (Text -> Text) -- ^ Mangle constructor names diff --git a/src/Utils/Users.hs b/src/Utils/Users.hs index 2339fbed5..ac02c0b3e 100644 --- a/src/Utils/Users.hs +++ b/src/Utils/Users.hs @@ -7,7 +7,7 @@ module Utils.Users ( AuthenticationKind(..) , AddUserData(..) - , addNewUser + , addNewUser, addNewUserDB ) where import Import @@ -49,53 +49,65 @@ data AddUserData = AddUserData , audPinPassword :: Maybe Text , audEmail :: UserEmail , audIdent :: UserIdent - , audAuth :: AuthenticationKind + , audAuth :: AuthenticationKind } -- | Adds a new user to database, no background jobs are scheduled, no notifications send +-- Note: `Foundation.Yesod.Auth` contains similar code with potentially differing defaults! addNewUser :: AddUserData -> Handler (Maybe UserId) -addNewUser AddUserData{..} = do +addNewUser aud = do + udc <- getsYesod $ view _appUserDefaults + usr <- makeUser udc aud + runDB $ insertUnique usr + +-- | Variant of `addNewUser` which allows for rollback through follwing throws +addNewUserDB :: AddUserData -> DB (Maybe UserId) +addNewUserDB aud = do + udc <- liftHandler $ getsYesod $ view _appUserDefaults + usr <- makeUser udc aud + insertUnique usr + +makeUser :: MonadIO m => UserDefaultConf -> AddUserData -> m User +makeUser UserDefaultConf{..} AddUserData{..} = do now <- liftIO getCurrentTime - UserDefaultConf{..} <- getsYesod $ view _appUserDefaults - let - newUser = User - { userIdent = audIdent - , userMaxFavourites = userDefaultMaxFavourites - , userMaxFavouriteTerms = userDefaultMaxFavouriteTerms - , userTheme = userDefaultTheme - , userDateTimeFormat = userDefaultDateTimeFormat - , userDateFormat = userDefaultDateFormat - , userTimeFormat = userDefaultTimeFormat - , userDownloadFiles = userDefaultDownloadFiles - , userWarningDays = userDefaultWarningDays - , userShowSex = userDefaultShowSex - , userExamOfficeGetSynced = userDefaultExamOfficeGetSynced - , userExamOfficeGetLabels = userDefaultExamOfficeGetLabels - , userNotificationSettings = def - , userLanguages = Nothing - , userCsvOptions = def { csvFormat = review csvPreset CsvPresetXlsx } - , userTokensIssuedAfter = Nothing - , userCreated = now - , userLastLdapSynchronisation = Nothing - , userLdapPrimaryKey = audFPersonalNumber - , userLastAuthentication = Nothing - , userEmail = audEmail - , userDisplayName = audDisplayName - , userDisplayEmail = audDisplayEmail - , userFirstName = audFirstName - , userSurname = audSurname - , userTitle = audTitle - , userSex = audSex - , userBirthday = audBirthday - , userMobile = audMobile - , userTelephone = audTelephone - , userCompanyPersonalNumber = audFPersonalNumber - , userCompanyDepartment = audFDepartment - , userPostAddress = audPostAddress - , userPostLastUpdate = Nothing - , userPrefersPostal = audPrefersPostal - , userPinPassword = audPinPassword - , userMatrikelnummer = audMatriculation - , userAuthentication = mkAuthMode audAuth - } - runDB $ insertUnique newUser \ No newline at end of file + return User + { userIdent = audIdent + , userMaxFavourites = userDefaultMaxFavourites + , userMaxFavouriteTerms = userDefaultMaxFavouriteTerms + , userTheme = userDefaultTheme + , userDateTimeFormat = userDefaultDateTimeFormat + , userDateFormat = userDefaultDateFormat + , userTimeFormat = userDefaultTimeFormat + , userDownloadFiles = userDefaultDownloadFiles + , userWarningDays = userDefaultWarningDays + , userShowSex = userDefaultShowSex + , userExamOfficeGetSynced = userDefaultExamOfficeGetSynced + , userExamOfficeGetLabels = userDefaultExamOfficeGetLabels + , userNotificationSettings = def + , userLanguages = Nothing + , userCsvOptions = def { csvFormat = review csvPreset CsvPresetXlsx } + , userTokensIssuedAfter = Nothing + , userCreated = now + , userLastLdapSynchronisation = Nothing + , userLdapPrimaryKey = audFPersonalNumber + , userLastAuthentication = Nothing + , userEmail = audEmail + , userDisplayName = audDisplayName + , userDisplayEmail = audDisplayEmail + , userFirstName = audFirstName + , userSurname = audSurname + , userTitle = audTitle + , userSex = audSex + , userBirthday = audBirthday + , userMobile = audMobile + , userTelephone = audTelephone + , userCompanyPersonalNumber = audFPersonalNumber + , userCompanyDepartment = audFDepartment + , userPostAddress = audPostAddress + , userPostLastUpdate = Nothing + , userPrefersPostal = audPrefersPostal + , userPinPassword = audPinPassword + , userMatrikelnummer = audMatriculation + , userAuthentication = mkAuthMode audAuth + } + \ No newline at end of file diff --git a/templates/admin-problems.hamlet b/templates/admin-problems.hamlet index b2a48143b..3909155cf 100644 --- a/templates/admin-problems.hamlet +++ b/templates/admin-problems.hamlet @@ -63,5 +63,10 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later _{MsgInterfacesOk} ^{interfaceTable} - +
    +

    + _{MsgProblemsHeadingMisc} +
    +

    + ^{problemLogTable} diff --git a/templates/course/user/profile.hamlet b/templates/course/user/profile.hamlet index b43e61c70..c18be7f33 100644 --- a/templates/course/user/profile.hamlet +++ b/templates/course/user/profile.hamlet @@ -1,6 +1,6 @@ $newline never -$# SPDX-FileCopyrightText: 2022 Gregor Kleen ,Steffen Jost ,Winnie Ros +$# SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Steffen Jost ,Winnie Ros ,Steffen Jost $# $# SPDX-License-Identifier: AGPL-3.0-or-later @@ -24,7 +24,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later

    _{MsgTableSex}
    _{sex}
    _{MsgTableEmail} -
    #{mailtoHtml (pickValidEmail userDisplayEmail userEmail)} +
    #{mailtoHtml (pickValidUserEmail userDisplayEmail userEmail)} $maybe date <- mRegAt
    _{MsgRegisteredSince}
    #{date} diff --git a/templates/letter/din5008.latex b/templates/letter/din5008.latex index 17042126a..744b76d91 100644 --- a/templates/letter/din5008.latex +++ b/templates/letter/din5008.latex @@ -59,6 +59,8 @@ $endfor$ \def\languageshorthands#1{} $endif$ +\usepackage[sfdefault]{roboto} + \ifLuaTeX \usepackage{selnolig} % disable illegal ligatures \fi @@ -67,11 +69,11 @@ $endif$ \usepackage[$if(fontenc)$$fontenc$$else$T1$endif$]{fontenc} \usepackage[utf8]{inputenc} \usepackage{textcomp} % provide euro and other symbols - \usepackage{DejaVuSansMono} % better monofont + % \usepackage{DejaVuSansMono} % better monofont \else % if luatex or xetex \usepackage{fontspec} - \setmonofont{DejaVu Sans Mono} + % \setmonofont{DejaVu Sans Mono} \fi \renewcommand{\familydefault}{\sfdefault} diff --git a/templates/letter/din5008with_pin.latex b/templates/letter/din5008with_pin.latex index fe950b11c..3401230d7 100644 --- a/templates/letter/din5008with_pin.latex +++ b/templates/letter/din5008with_pin.latex @@ -63,15 +63,17 @@ $endif$ \usepackage{selnolig} % disable illegal ligatures \fi +\usepackage[sfdefault]{roboto} + \ifPDFTeX \usepackage[$if(fontenc)$$fontenc$$else$T1$endif$]{fontenc} \usepackage[utf8]{inputenc} \usepackage{textcomp} % provide euro and other symbols - \usepackage{DejaVuSansMono} % better monofont + % \usepackage{DejaVuSansMono} % better monofont \else % if luatex or xetex \usepackage{fontspec} - \setmonofont{DejaVu Sans Mono} + % \setmonofont{DejaVu Sans Mono} \fi \renewcommand{\familydefault}{\sfdefault} diff --git a/templates/letter/din5008with_pin_new.latex b/templates/letter/din5008with_pin_new.latex new file mode 100644 index 000000000..83eaf63fd --- /dev/null +++ b/templates/letter/din5008with_pin_new.latex @@ -0,0 +1,206 @@ +%Based upon https://github.com/benedictdudel/pandoc-letter-din5008 +\documentclass[ + paper=A4, + foldmarks=BTm, % show foldmarks top, middle, bottom + foldmarks=false, % don't print foldmarks + fromalign=left, % letter head on the right + fromphone=true, % show phone number + fromemail=true, % show email + fromlogo=false, % don't show logo in letter head + version=last, % latest version of KOMA letter + pagenumber=botright, % show pagenumbers on bottom right + firstfoot=false % first-page footer +]{scrlttr2} + +\PassOptionsToPackage{hyphens}{url} +\PassOptionsToPackage{unicode$for(hyperrefoptions)$,$hyperrefoptions$$endfor$}{hyperref} +\IfFileExists{xurl.sty}{\usepackage{xurl}}{} % add URL line breaks if available +\IfFileExists{bookmark.sty}{\usepackage{bookmark}}{\usepackage{hyperref}} +\hypersetup{ +$if(subject-meta)$ + pdfsubject={$subject-meta$}, +$endif$ +$if(author-meta)$ + pdfauthor={$author-meta$}, +$endif$ +$if(lang)$ + pdflang={$lang$}, +$endif$ +$if(is-de)$ + $if(de-subject)$ + pdftitle={$de-subject$}, + $endif$ +$else$ + $if(en-subject)$ + pdftitle={$en-subject$}, + $endif$ +$endif$ +$if(apc-ident)$ + pdfkeywords={$apc-ident$}, +$endif$ +} +\usepackage{url} + +\usepackage{iftex} + +%\usepackage[ngerman]{babel} +$if(lang)$ +\ifLuaTeX +\usepackage[bidi=basic]{babel} +\else +\usepackage[bidi=default]{babel} +\fi +\babelprovide[main,import]{$babel-lang$} +$for(babel-otherlangs)$ +\babelprovide[import]{$babel-otherlangs$} +$endfor$ +% get rid of language-specific shorthands (see #6817): +\let\LanguageShortHands\languageshorthands +\def\languageshorthands#1{} +$endif$ + +\ifLuaTeX + \usepackage{selnolig} % disable illegal ligatures +\fi + +\usepackage[sfdefault]{roboto} + +\ifPDFTeX + \usepackage[$if(fontenc)$$fontenc$$else$T1$endif$]{fontenc} + \usepackage[utf8]{inputenc} + \usepackage{textcomp} % provide euro and other symbols + % \usepackage{DejaVuSansMono} % better monofont +\else + % if luatex or xetex + \usepackage{fontspec} + % \setmonofont{DejaVu Sans Mono} +\fi +\renewcommand{\familydefault}{\sfdefault} + +$if(mathspec)$ + \ifXeTeX + \usepackage{mathspec} + \else + \usepackage{unicode-math} + \fi +$else$ + \usepackage{unicode-math} +$endif$ + +%\usepackage[a4paper, bottom=8cm, top=3cm]{geometry} %%% THIS HAD NO EFFECT AT ALL + +\usepackage{parskip}% might be useful for pandoc tightlist + +\usepackage{graphics} +\usepackage{xcolor} + +\usepackage{booktabs} +\usepackage{longtable} + +\usepackage[right]{eurosym} + +\usepackage{enumitem} + +\makeatletter + \setplength{firstheadvpos}{1.8cm} + \setplength{toaddrvpos}{5.5cm} + \setlength{\@tempskipa}{-1.2cm}% + \@addtoplength{toaddrheight}{\@tempskipa} +\makeatother + +\setlength{\oddsidemargin}{\useplength{toaddrhpos}} +\addtolength{\oddsidemargin}{-1in} +\setlength{\textwidth}{\useplength{firstheadwidth}} + +\usepackage[absolute,quiet,overlay]{textpos}%,showboxes +\setlength{\TPHorizModule}{1mm} +\setlength{\TPVertModule}{1mm} + +\providecommand{\tightlist}{% + \setlength{\itemsep}{0pt}\setlength{\parskip}{0pt}} + +\begin{document}% + \setkomavar{fromname}{$author$}% + \renewcommand*{\raggedsignature}{\raggedright}% + \setkomavar{fromaddress}{% + $for(return-address)$% + $return-address$$sep$\\ + $endfor$ + } + \setkomavar{fromphone}{$phone$} + \setkomavar{fromemail}{$email$} + %if there is a handwritten signature + %\setkomavar{signature}{$author$} + %if there is no handwritten signature + \setkomavar{signature}{} + \setplength{sigbeforevskip}{-\baselineskip} + + \setkomavar{date}{$date$} + \setkomavar{place}{$place$} + + $if(is-de)$ + \setkomavar{subject}{$de-subject$} + $else$ + \setkomavar{subject}{$en-subject$} + $endif$ + + \begin{letter}{% + $for(address)$ + $address$$sep$\\ + $endfor$ + } + + $if(apc-ident)$ + \begin{textblock}{200}(5,5)%hpos,vpos + \textcolor{white!0}{$apc-ident$}% + \end{textblock}% + $endif$ + + $if(is-de)$ + \opening{$de-opening$} + $else$ + \opening{$en-opening$} + $endif$ + + \begin{textblock}{65}(84,232)%hpos,vpos + \textcolor{black!39}{ + \begin{labeling}{Password:}%Achtung! Die Position des Logins muss sprachunabhängig immer an der gleichen Position sein, sonst kannn die Rückmeldung der Druckerei den Ident nicht mehr identifizieren! + $if(is-de)$ + \item[Benutzer:] \texttt{$login$} + \item[Passwort:] \texttt{$pin$} + $else$ + \item[User:] \texttt{$login$} + \item[Password:] \texttt{$pin$} + $endif$ + \end{labeling} + ~} + \end{textblock} + + $body$ + + $if(is-de)$ + \closing{$de-closing$} + $else$ + \closing{$en-closing$} + $endif$ + + %\ps $postskriptum$ + + $if(encludes)$ + \setkomavar*{enclseparator}{Anlage} + \encl{$encludes$} + $endif$ + + $if(notice)$ + \begin{textblock}{170}(20,258)%hpos,vpos + \scriptsize + \textbf{Hinweise für den Schulungsteilnehmer:} + \newline + $for(notice)$ + $notice$ + $sep$\newline + $endfor$ + \end{textblock} + $endif$ + \end{letter} +\end{document} diff --git a/templates/letter/fraport_renewal.md b/templates/letter/fraport_renewal.md index 930370547..cf7ea0a5d 100644 --- a/templates/letter/fraport_renewal.md +++ b/templates/letter/fraport_renewal.md @@ -86,6 +86,8 @@ $else$ $endif$ Die Durchführung des Lernprogramms und des Abschlusstests dauert etwa 2,5h. +This is the new version + Fahrberechtigungsinhaber : $examinee$ diff --git a/templates/letter/fraport_renewal_new.md b/templates/letter/fraport_renewal_new.md new file mode 100644 index 000000000..e90db735b --- /dev/null +++ b/templates/letter/fraport_renewal_new.md @@ -0,0 +1,130 @@ +--- +### Metadaten, welche hier eingestellt werden: +# Absender +de-subject: 'Verlängerung Fahrberechtigung "F" (Vorfeldführerschein)' +en-subject: Renewal of apron driving license +author: Fraport AG - Fahrerausbildung (AVN-AR) +phone: +49 69 690-30306 +email: fahrerausbildung@fraport.de +place: Frankfurt am Main +return-address: + - 60547 Frankfurt +de-opening: Liebe Fahrberechtigungsinhaber, +en-opening: Dear driver, +de-closing: | + Mit freundlichen Grüßen, + Ihre Fraport Fahrerausbildung +en-closing: | + With kind regards, + Your Fraport Driver Training +encludes: +hyperrefoptions: hidelinks + +### Metadaten, welche automatisch ersetzt werden: +url-text: 'drive.fraport.de' +url: 'https://drive.fraport.de' +date: 11.11.1111 +expiry: 00.00.0000 +lang: de-de +is-de: true +login: 123456 +pin: abcdef +paper: pin +# Emfpänger +examinee: P. Rüfling +address: + - E. M. Pfänger + - Musterfirma GmbH + - Musterstraße 11 + - 12345 Musterstadt +... +$if(titleblock)$ +$titleblock$ + +$endif$ +$for(header-includes)$ +$header-includes$ + +$endfor$ +$for(include-before)$ +$include-before$ + +$endfor$ + +$if(is-de)$ + + + +um die Rollfeldfahrberechtigung von \textbf{$examinee$} zu erhalten, benötigen wir bis zum $date$ den Nachweis, dass die theoretische und praktische flughafenspezifische Rollfeld Recurrent Schulung der Fraport AG gemäß Verordnung der Europäische Union Nr. 139/2014 absolviert wurde. + +Die Online-Schulung der Fraport AG ist erreichbar unter folgendem Link: +[$url-text$]($url$) + +Der erforderliche Benutzername und das Passwort für die Fraport Online-Schulung finden Sie untenstehend. Die Weitergabe der persönlichen Benutzerdaten an Dritte ist untersagt. Ausschließlich Sie sind berechtigt, die Benutzerdaten an den Schulungsteilnehmer auszuhändigen. + +Für die Absolvierung der Schulungsmaßnahme werden 1-2 Stunden benötigt. Der Abschluss der Schulung wird automatisch an das System der Fahrerausbildung übermittelt. + +Nach erfolgreichem Abschluss der Online-Schulung muss \textbf{$examinee$} sich von Ihrer Firma zum praktischen Teil der Schulung einplanen lassen. Im Rahmen der 3--4-stündigen praktischen Auffrischung erfolgen Funkübungen sowie die Durchführung einer Übungsfahrt mit Prüfungscharakter im Start-/Landebahnsystem. + +$else$ + + +$if(reminder)$ + this is a last **reminder**: as of $date$, +$if(supervisor)$ + $examinee$ has +$else$ + you have +$endif$ + not yet completed the below detailed e‑learning. + The qualification will expire automatically, + if the e‑learning is not concluded in time! +$else$ +$if(supervisor)$ + the apron diving license of $examinee$ +$else$ + your apron diving license +$endif$ + is about to expire soon. +$endif$ +The validity will be extended +$if(validduration)$ + by $validduration$ months +$endif$ +by successfully participating in +an e‑learning. +$if(supervisor)$ + Supervisors are kindly requested to forward the login data + below confidentially to the examinee. +$else$ + Please use the login data from the protected area below. +$endif$ +Reserve 2.5h for the entire e-learning, including the exam. + +Examinee + + : $examinee$ + +Expiry + + : $expiry$ + +E-learning website + + : [$url-text$]($url$) + + +If the apron driving license expires before completing this e-learning, +$if(supervisor)$ + the examinee has to participate in a basic training course again to regain + to regain the apron driving licence. +$else$ + you have to participate in a basic training course again to regain + your apron driving licence. +$endif$ + + +Please contact the Fraport driving school team, if you need any assistance. +(Kontaktieren Sie uns bitte, wenn Sie zukünftige Briefe in deutscher Sprache bevorzugen.) + +$endif$ diff --git a/templates/letter/plain_article.latex b/templates/letter/plain_article.latex index 7c4038158..4ba5a5540 100644 --- a/templates/letter/plain_article.latex +++ b/templates/letter/plain_article.latex @@ -56,19 +56,21 @@ $endif$ \usepackage{selnolig} % disable illegal ligatures \fi +\usepackage[sfdefault]{roboto} + \ifPDFTeX \usepackage{helvet} \usepackage[$if(fontenc)$$fontenc$$else$T1$endif$]{fontenc} \usepackage[utf8]{inputenc} \usepackage{textcomp}% provide euro and other symbols - \usepackage{DejaVuSansMono}% better monofont + % \usepackage{DejaVuSansMono}% better monofont \renewcommand{\familydefault}{\sfdefault} \else % if luatex or xetex \usepackage{fontspec} %\setmainfont{TeXGyreHeros}%could not install the package somehow tex-gyre in default.nix/shell.nix did not work - \setmainfont{DejaVu Sans} - \setmonofont{DejaVu Sans Mono} + % \setmainfont{DejaVu Sans} + %\setmonofont{DejaVu Sans Mono} \renewcommand{\familydefault}{\sfdefault} \fi diff --git a/templates/profileData.hamlet b/templates/profileData.hamlet index 9eb2817af..b33419227 100644 --- a/templates/profileData.hamlet +++ b/templates/profileData.hamlet @@ -51,30 +51,37 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
    _{MsgPrefersPostalExp}
    + $if userPrefersPostal /= actualPrefersPostal + ^{messageTooltip tooltipInvalidEmail} # #{iconLetterOrEmail userPrefersPostal} - $maybe addr <- userPostAddress + $maybe addr <- actualPostAddress
    _{MsgAdminUserPostAddress}
    + #{isAutomatic postalAutomatic} # #{addr} - $maybe postUpdate <- userPostLastUpdate -
    - _{MsgUserPostLastUpdate} -
    - ^{formatTimeW SelFormatDateTime postUpdate} + $if (not postalAutomatic) + $maybe postUpdate <- userPostLastUpdate +
    + _{MsgUserPostLastUpdate} +
    + ^{formatTimeW SelFormatDateTime postUpdate}
    _{MsgUserDisplayEmail}
    - #{mailtoHtml userDisplayEmail} - $if not (validEmail' userDisplayEmail) - \ ^{messageTooltip tooltipInvalidEmail} - $if userEmail /= userDisplayEmail + $maybe primaryEmail <- actualDisplayEmail + #{isAutomatic emailAutomatic} # + #{mailtoHtml primaryEmail} + $nothing + ^{messageTooltip tooltipInvalidEmail} # + #{mailtoHtml userDisplayEmail} + $if Just userEmail /= actualDisplayEmail
    _{MsgUserSystemEmail} -
    +
    + $if not (validEmail' userEmail) + ^{messageTooltip tooltipInvalidEmail} # #{userEmail} - $if not (validEmail' userEmail) - \ ^{messageTooltip tooltipInvalidEmail}
    _{MsgAdminUserPinPassword}
    @@ -191,7 +198,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later ^{formatTimeW SelFormatDateTime studyFeaturesLastObserved}
    - $if hasRows + $if hasRowsOwnedCourses

    _{MsgProfileCourses}
    @@ -243,4 +250,14 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later \ _{MsgProfileCorrectorRemark} _{MsgProfileCorrections} +
    +

    _{MsgProfileSupervisor} +
    + ^{supervisorsTable} + +
    +

    _{MsgProfileSupervisee} +
    + ^{superviseesTable} + ^{profileRemarks} diff --git a/templates/table/layout-wrapper.hamlet b/templates/table/layout-wrapper.hamlet index 7bfe4d358..dba882e74 100644 --- a/templates/table/layout-wrapper.hamlet +++ b/templates/table/layout-wrapper.hamlet @@ -1,8 +1,9 @@ $newline never -$# SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel +$# SPDX-FileCopyrightText: 2022-2024 Gregor Kleen ,Sarah Vaupel ,David Mosbach $# $# SPDX-License-Identifier: AGPL-3.0-or-later -
    +
    +
    ^{table} diff --git a/templates/widgets/form/form.hamlet b/templates/widgets/form/form.hamlet index 371a7c701..b89901472 100644 --- a/templates/widgets/form/form.hamlet +++ b/templates/widgets/form/form.hamlet @@ -1,6 +1,6 @@ $newline never -$# SPDX-FileCopyrightText: 2022 Sarah Vaupel ,Steffen Jost +$# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel ,Steffen Jost ,David Mosbach $# $# SPDX-License-Identifier: AGPL-3.0-or-later @@ -12,12 +12,13 @@ $# Wrapper for all kinds of forms ^{formWidget} $of FormSubmit ^{formWidget} - ^{buttonView btn} + ^{buttonViewFallback formCustomBtn btn} $of FormDualSubmit - ^{buttonView btn} + ^{buttonViewFallback formCustomBtn btn} ^{formWidget} - ^{buttonView btn} + ^{buttonViewFallback formCustomBtn btn} $of FormAutoSubmit ^{formWidget}