Resolve "DBTable: Kein automatisches Filtern bei Input-Change, sondern manuelle Übernahme via Button" #216
5
.babelrc
5
.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 }],
|
||||
|
||||
@ -1,3 +1,3 @@
|
||||
SPDX-FileCopyrightText: 2022 Felix Hamann <felix.hamann@campus.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>
|
||||
SPDX-FileCopyrightText: 2022-2024 Felix Hamann <felix.hamann@campus.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,David Mosbach <david.mosbach@uniworx.de>
|
||||
|
||||
SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
49
CHANGELOG.md
49
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)
|
||||
|
||||
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Wolfgang Witt <Wolfgang.Witt@campus.lmu.de>
|
||||
# SPDX-FileCopyrightText: 2022-2024 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Wolfgang Witt <Wolfgang.Witt@campus.lmu.de>,David Mosbach <david.mosbach@uniworx.de>
|
||||
#
|
||||
# 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
|
||||
|
||||
6
fixtest.sh
Executable file
6
fixtest.sh
Executable file
@ -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
|
||||
@ -1,10 +1,16 @@
|
||||
// SPDX-FileCopyrightText: 2022 Sarah Vaupel <vaupel.sarah@campus.lmu.de>
|
||||
// SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <vaupel.sarah@campus.lmu.de>,David Mosbach <david.mosbach@uniworx.de>
|
||||
//
|
||||
// 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);
|
||||
|
||||
@ -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 <table> or a <div .div__course-teaser> in its element!');
|
||||
throw new Error('Table utility needs a <table> or a <div .div__course-teaser> 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 = (<HTMLElement>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(<string[][]>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');
|
||||
}
|
||||
@ -1,4 +1,4 @@
|
||||
// SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>
|
||||
// SPDX-FileCopyrightText: 2022-2024 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,David Mosbach <david.mosbach@uniworx.de>
|
||||
//
|
||||
// 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);
|
||||
|
||||
|
||||
@ -1,11 +1,11 @@
|
||||
// SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>
|
||||
// SPDX-FileCopyrightText: 2022-2024 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,David Mosbach <david.mosbach@uniworx.de>
|
||||
//
|
||||
// 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,
|
||||
@ -1,4 +1,4 @@
|
||||
# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
|
||||
# SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>
|
||||
#
|
||||
# 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
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
# SPDX-FileCopyrightText: 2022 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
|
||||
# SPDX-FileCopyrightText: 2022-24 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>
|
||||
#
|
||||
# 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
|
||||
|
||||
@ -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.
|
||||
@ -1,14 +1,17 @@
|
||||
# SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
|
||||
#
|
||||
# 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
|
||||
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.
|
||||
@ -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?
|
||||
|
||||
@ -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?
|
||||
|
||||
@ -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
|
||||
@ -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"}.
|
||||
UsersRemoveSupervisors usr: Removed all supervisors for #{pluralENsN usr "user"}.
|
||||
SupervisorReason: Reason
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -1,8 +1,9 @@
|
||||
# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>
|
||||
# SPDX-FileCopyrightText: 2022-2024 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,David Mosbach <david.mosbach@uniworx.de>
|
||||
#
|
||||
# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
BtnSubmit: Senden
|
||||
BtnApplyFilter: Filter Anwenden
|
||||
BtnAbort: Abbrechen
|
||||
BtnDelete: Löschen
|
||||
BtnRegister: Anmelden
|
||||
|
||||
@ -1,8 +1,9 @@
|
||||
# SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>
|
||||
# SPDX-FileCopyrightText: 2022-2024 Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,David Mosbach <david.mosbach@uniworx.de>
|
||||
#
|
||||
# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
BtnSubmit: Submit
|
||||
BtnApplyFilter: Apply Filter
|
||||
BtnAbort: Abort
|
||||
BtnDelete: Delete
|
||||
BtnRegister: Register
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
|
||||
-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
|
||||
--
|
||||
-- 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
|
||||
@ -1,4 +1,4 @@
|
||||
-- SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
|
||||
-- SPDX-FileCopyrightText: 2022-24 Steffen Jost <jost@tcs.ifi.lmu.de>
|
||||
--
|
||||
-- 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
|
||||
deriving Generic Show
|
||||
@ -1,4 +1,4 @@
|
||||
-- SPDX-FileCopyrightText: 2022 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
|
||||
-- SPDX-FileCopyrightText: 2022-24 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
|
||||
--
|
||||
-- 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
|
||||
|
||||
@ -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
|
||||
deriving Generic Show
|
||||
@ -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
|
||||
deriving Generic Show
|
||||
@ -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
|
||||
deriving Generic Show
|
||||
@ -1,4 +1,4 @@
|
||||
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
|
||||
-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
|
||||
--
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
;
|
||||
|
||||
@ -1,3 +1,3 @@
|
||||
{
|
||||
"version": "27.4.59"
|
||||
"version": "27.4.64"
|
||||
}
|
||||
|
||||
862
package-lock.json
generated
862
package-lock.json
generated
@ -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": {
|
||||
|
||||
@ -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"
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: uniworx
|
||||
version: 27.4.59
|
||||
version: 27.4.64
|
||||
dependencies:
|
||||
- base
|
||||
- yesod
|
||||
|
||||
6
routes
6
routes
@ -1,4 +1,4 @@
|
||||
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Wolfgang Witt <Wolfgang.Witt@campus.lmu.de>
|
||||
-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Wolfgang Witt <Wolfgang.Witt@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>
|
||||
--
|
||||
-- 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
|
||||
|
||||
@ -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
|
||||
;
|
||||
})
|
||||
|
||||
@ -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
|
||||
|
||||
23
src/Audit.hs
23
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)
|
||||
|
||||
|
||||
|
||||
@ -1,15 +1,18 @@
|
||||
-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>
|
||||
-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>
|
||||
--
|
||||
-- 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
|
||||
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
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
-- SPDX-FileCopyrightText: 2022 Felix Hamann <felix.hamann@campus.lmu.de>,Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>
|
||||
-- SPDX-FileCopyrightText: 2022-2024 Felix Hamann <felix.hamann@campus.lmu.de>,Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,David Mosbach <david.mosbach@uniworx.de>
|
||||
--
|
||||
-- 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")
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
-- SPDX-FileCopyrightText: 2022 Felix Hamann <felix.hamann@campus.lmu.de>,Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
|
||||
-- SPDX-FileCopyrightText: 2022-2024 Felix Hamann <felix.hamann@campus.lmu.de>,Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,David Mosbach <david.mosbach@uniworx.de>
|
||||
--
|
||||
-- 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")
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
-- SPDX-FileCopyrightText: 2022 Felix Hamann <felix.hamann@campus.lmu.de>,Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>
|
||||
-- SPDX-FileCopyrightText: 2022-2024 Felix Hamann <felix.hamann@campus.lmu.de>,Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,David Mosbach <david.mosbach@uniworx.de>
|
||||
--
|
||||
-- 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")
|
||||
|
||||
@ -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") []
|
||||
@ -1,4 +1,4 @@
|
||||
-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
|
||||
-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>,David Mosbach <david.mosbach@uniworx.de>
|
||||
--
|
||||
-- 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
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
-- SPDX-FileCopyrightText: 2022 Wolfgang Witt <Wolfgang.Witt@campus.lmu.de>
|
||||
-- SPDX-FileCopyrightText: 2022-2024 Wolfgang Witt <Wolfgang.Witt@campus.lmu.de>,David Mosbach <david.mosbach@uniworx.de>
|
||||
--
|
||||
-- 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]
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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 ] []
|
||||
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
|
||||
-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
|
||||
--
|
||||
-- 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]
|
||||
@ -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|<h2>Error:</h2> #{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}
|
||||
<h2>
|
||||
AVS Konfiguration
|
||||
<ul>
|
||||
<li>
|
||||
Host: #{decodeUtf8 (avsUser avsConf)}@#{avsHost avsConf}:#{avsPort avsConf}
|
||||
<li>
|
||||
Timeout sekundäre AVS Abfragen: #{avsTimeout avsConf}s
|
||||
<li>
|
||||
Cache Gültigkeit sekundäre AVS Abfragen: #{tshow (avsCacheExpiry avsConf)}
|
||||
$nothing
|
||||
AVS nicht konfiguriert!
|
||||
|]
|
||||
mAvsQuery <- getsYesod $ view _appAvsQuery
|
||||
case mAvsQuery of
|
||||
Nothing -> siteLayoutMsg MsgMenuAvs [whamlet|Error: AVS interface configuration is incomplete.|] -- should never occur after initilisation
|
||||
Just AvsQuery{..} -> do
|
||||
((presult, pwidget), penctype) <- runFormPost $ makeAvsPersonForm Nothing
|
||||
|
||||
((presult, pwidget), penctype) <- runFormPost $ makeAvsPersonForm Nothing
|
||||
|
||||
let procFormPerson fr = do
|
||||
addMessage Info $ text2Html $ "Query: " <> tshow (toJSON fr)
|
||||
res <- avsQueryPerson fr
|
||||
case res of
|
||||
Left err -> let msg = tshow err in return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
|
||||
Right (AvsResponsePerson pns) -> return $ Just [whamlet|
|
||||
<ul>
|
||||
$forall p <- pns
|
||||
<li>#{decodeUtf8 (Pretty.encodePretty (toJSON p))}
|
||||
|]
|
||||
mbPerson <- formResultMaybe presult procFormPerson
|
||||
let procFormPerson fr = do
|
||||
addMessage Info $ text2Html $ "Query: " <> tshow (toJSON fr)
|
||||
tryShow $ do
|
||||
AvsResponsePerson pns <- avsQuery fr
|
||||
return [whamlet|
|
||||
<ul>
|
||||
$forall p <- pns
|
||||
<li>^{jsonWidget p}
|
||||
|] -- <li>#{decodeUtf8 (Pretty.encodePretty (toJSON p))}
|
||||
mbPerson <- formResultMaybe presult (Just <<$>> procFormPerson)
|
||||
|
||||
((sresult, swidget), senctype) <- runFormPost $ makeAvsStatusForm Nothing
|
||||
let procFormStatus fr = do
|
||||
addMessage Info $ text2Html $ "Status Query: " <> tshow (toJSON fr)
|
||||
res <- avsQueryStatus fr
|
||||
case res of
|
||||
Left err -> let msg = tshow err in return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
|
||||
Right (AvsResponseStatus pns) -> return $ Just [whamlet|
|
||||
<ul>
|
||||
$forall p <- pns
|
||||
<li>#{decodeUtf8 (Pretty.encodePretty (toJSON p))}
|
||||
|]
|
||||
mbStatus <- formResultMaybe sresult procFormStatus
|
||||
((sresult, swidget), senctype) <- runFormPost $ makeAvsStatusForm Nothing
|
||||
let procFormStatus fr = do
|
||||
addMessage Info $ text2Html $ "Status Query: " <> tshow (toJSON fr)
|
||||
tryShow $ do
|
||||
AvsResponseStatus pns <- avsQuery fr
|
||||
return [whamlet|
|
||||
<ul>
|
||||
$forall p <- pns
|
||||
<li>^{jsonWidget p}
|
||||
|]
|
||||
mbStatus <- formResultMaybe sresult (Just <<$>> procFormStatus)
|
||||
|
||||
((cresult, cwidget), cenctype) <- runFormPost $ makeAvsContactForm Nothing
|
||||
let procFormContact fr = do
|
||||
addMessage Info $ text2Html $ "Contact Query: " <> tshow (toJSON fr)
|
||||
res <- avsQueryContact fr
|
||||
case res of
|
||||
Left err -> let msg = tshow err in return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
|
||||
Right (AvsResponseContact pns) -> return $ Just [whamlet|
|
||||
<ul>
|
||||
$forall AvsDataContact{..} <- pns
|
||||
<li>
|
||||
<ul>
|
||||
<li>AvsId: #{tshow avsContactPersonID}
|
||||
<li>#{decodeUtf8 (Pretty.encodePretty (toJSON avsContactPersonInfo))}
|
||||
<li>#{decodeUtf8 (Pretty.encodePretty (toJSON avsContactFirmInfo))}
|
||||
|]
|
||||
mbContact <- formResultMaybe cresult procFormContact
|
||||
|
||||
|
||||
((crUsrRes, crUsrWgt), crUsrEnctype) <- runFormPost $ identifyForm FIDAvsCreateUser $ \html ->
|
||||
flip (renderAForm FormStandard) html $ areq textField (fslI MsgAvsCardNo) Nothing
|
||||
let procFormCrUsr fr = do
|
||||
-- addMessage Info $ text2Html $ "Query: " <> tshow (toJSON fr)
|
||||
res <- try $ guessAvsUser fr
|
||||
case res of
|
||||
(Right (Just uid)) -> do
|
||||
uuid :: CryptoUUIDUser <- encrypt uid
|
||||
return $ Just [whamlet|<h2>Success:</h2> <a href=@{ForProfileR uuid}>User created or updated.|]
|
||||
(Right Nothing) ->
|
||||
return $ Just [whamlet|<h2>Warning:</h2> No user found.|]
|
||||
(Left e) -> do
|
||||
let msg = tshow (e :: SomeException)
|
||||
return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
|
||||
mbCrUser <- formResultMaybe crUsrRes procFormCrUsr
|
||||
|
||||
((getLicRes, getLicWgt), getLicEnctype) <- runFormPost $ identifyForm FIDAvsQueryLicence $ \html ->
|
||||
flip (renderAForm FormStandard) html $ (,,) <$> aopt intField (fslI $ text2message "Min AvsPersonId") Nothing
|
||||
<*> aopt intField (fslI $ text2message "Max AvsPersonId") Nothing
|
||||
<*> aopt (selectField $ return avsLicenceOptions) (fslI MsgAvsLicence) Nothing
|
||||
let procFormGetLic fr = do
|
||||
res <- avsQueryGetAllLicences
|
||||
case res of
|
||||
(Right (AvsResponseGetLicences lics)) -> do
|
||||
let flics = Set.toList $ Set.filter lfltr lics
|
||||
lfltr = case fr of -- not pretty, but it'll do
|
||||
(Just idmin, Just idmax, Just lic) -> \AvsPersonLicence{..} -> (avsLicenceRampLicence == lic) && (avsLicencePersonID `inBetween` (AvsPersonId idmin, AvsPersonId idmax))
|
||||
(Just idmin, Nothing, Just lic) -> \AvsPersonLicence{..} -> (avsLicenceRampLicence == lic) && (avsLicencePersonID == AvsPersonId idmin)
|
||||
(Nothing , Just idmax, Just lic) -> \AvsPersonLicence{..} -> (avsLicenceRampLicence == lic) && (avsLicencePersonID == AvsPersonId idmax)
|
||||
(Nothing , Nothing, Just lic) -> \AvsPersonLicence{..} -> avsLicenceRampLicence == lic
|
||||
(Just idmin, Just idmax, Nothing ) -> (`inBetween` (AvsPersonId idmin, AvsPersonId idmax)) . avsLicencePersonID
|
||||
(Just idmin, Nothing, Nothing ) -> (== AvsPersonId idmin) . avsLicencePersonID
|
||||
(Nothing , Just idmax, Nothing ) -> (== AvsPersonId idmax) . avsLicencePersonID
|
||||
(Nothing , Nothing, Nothing ) -> const True
|
||||
addMessage Info $ text2Html $ "Query returned " <> tshow (length flics) <> " licences."
|
||||
return $ Just [whamlet|
|
||||
<h2>Success:</h2>
|
||||
((cresult, cwidget), cenctype) <- runFormPost $ makeAvsContactForm Nothing
|
||||
let procFormContact fr = do
|
||||
addMessage Info $ text2Html $ "Contact Query: " <> tshow (toJSON fr)
|
||||
tryShow $ do
|
||||
AvsResponseContact pns <- avsQuery fr
|
||||
return [whamlet|
|
||||
<ul>
|
||||
$forall AvsDataContact{..} <- pns
|
||||
<li>
|
||||
<ul>
|
||||
$forall AvsPersonLicence{..} <- flics
|
||||
<li> #{tshow avsLicencePersonID}: #{licence2char avsLicenceRampLicence}
|
||||
|]
|
||||
|
||||
(Left err) -> do
|
||||
let msg = tshow err
|
||||
return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
|
||||
mbGetLic <- formResultMaybe getLicRes procFormGetLic
|
||||
|
||||
((setLicRes, setLicWgt), setLicEnctype) <- runFormPost $ identifyForm FIDAvsSetLicence $ \html ->
|
||||
flip (renderAForm FormStandard) html $ (,) <$> areq intField (fslI MsgAvsPersonId) Nothing
|
||||
<*> areq (selectField $ return avsLicenceOptions) (fslI MsgAvsLicence) (Just AvsLicenceVorfeld)
|
||||
let procFormSetLic (aid, lic) = do
|
||||
res <- try $ setLicenceAvs (AvsPersonId aid) lic
|
||||
case res of
|
||||
(Right True) ->
|
||||
return $ Just [whamlet|<h2>Success:</h2> Licence #{tshow (licence2char lic)} set for #{tshow aid}.|]
|
||||
(Right False) ->
|
||||
return $ Just [whamlet|<h2>Error:</h2> Licence could not be set for #{tshow aid}.|]
|
||||
(Left e) -> do
|
||||
let msg = tshow (e :: SomeException)
|
||||
return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
|
||||
mbSetLic <- formResultMaybe setLicRes procFormSetLic
|
||||
<li>AvsId: #{tshow avsContactPersonID}
|
||||
<li>^{jsonWidget avsContactPersonInfo}
|
||||
<li>^{jsonWidget avsContactFirmInfo}
|
||||
|] -- <li>#{decodeUtf8 (Pretty.encodePretty (toJSON avsContactPersonInfo))}
|
||||
mbContact <- formResultMaybe cresult (Just <<$>> procFormContact)
|
||||
|
||||
|
||||
(qryLicForm, qryLicRes) <- runButtonForm FIDAvsQueryLicenceDiffs
|
||||
mbQryLic <- case qryLicRes of
|
||||
Nothing -> return Nothing
|
||||
(Just BtnCheckLicences) -> do
|
||||
res <- try $ do
|
||||
allLicences <- throwLeftM avsQueryGetAllLicences
|
||||
computeDifferingLicences allLicences
|
||||
case res of
|
||||
(Right diffs) -> do
|
||||
let showLics l = Text.intercalate ", " $ fmap (tshow . avsLicencePersonID) $ Set.toList $ Set.filter ((l ==) . avsLicenceRampLicence) diffs
|
||||
r_grant = showLics AvsLicenceRollfeld
|
||||
f_set = showLics AvsLicenceVorfeld
|
||||
revoke = showLics AvsNoLicence
|
||||
return $ Just [whamlet|
|
||||
<h2>Licence check differences:
|
||||
<h3>Grant R:
|
||||
<p>
|
||||
#{r_grant}
|
||||
<h3>Set to F:
|
||||
<p>
|
||||
#{f_set}
|
||||
<h3>Revoke licence:
|
||||
<p>
|
||||
#{revoke}
|
||||
|]
|
||||
(Left e) -> do
|
||||
let msg = tshow (e :: SomeException)
|
||||
return $ Just [whamlet|<h2>Licence check error:</h2> #{msg}|]
|
||||
-- (Just BtnSynchLicences) -> do
|
||||
-- res <- try synchAvsLicences
|
||||
-- case res of
|
||||
-- (Right True) ->
|
||||
-- return $ Just [whamlet|<h2>Success:</h2> Licences sychronized.|]
|
||||
-- (Right False) ->
|
||||
-- return $ Just [whamlet|<h2>Error:</h2> Licences could not be synchronized, see error log.|]
|
||||
-- (Left e) -> do
|
||||
-- let msg = tshow (e :: SomeException)
|
||||
-- return $ Just [whamlet|<h2>Licence synchronisation error:</h2> #{msg}|]
|
||||
((crUsrRes, crUsrWgt), crUsrEnctype) <- runFormPost $ identifyForm FIDAvsCreateUser $ \html ->
|
||||
flip (renderAForm FormStandard) html $ areq textField (fslI MsgAvsCardNo) Nothing
|
||||
let procFormCrUsr fr = do
|
||||
-- addMessage Info $ text2Html $ "Query: " <> tshow (toJSON fr)
|
||||
res <- try $ guessAvsUser fr
|
||||
case res of
|
||||
(Right (Just uid)) -> do
|
||||
uuid :: CryptoUUIDUser <- encrypt uid
|
||||
return $ Just [whamlet|<h2>Success:</h2> <a href=@{ForProfileR uuid}>User created or updated.|]
|
||||
(Right Nothing) ->
|
||||
return $ Just [whamlet|<h2>Warning:</h2> No user found.|]
|
||||
(Left e) -> return $ Just $ exceptionWgt e
|
||||
mbCrUser <- formResultMaybe crUsrRes procFormCrUsr
|
||||
|
||||
actionUrl <- fromMaybe AdminAvsR <$> getCurrentRoute
|
||||
siteLayoutMsg MsgMenuAvs $ do
|
||||
setTitleI MsgMenuAvs
|
||||
let wrapFormHere fw fe = wrapForm fw def { formAction = Just $ SomeRoute actionUrl, formEncoding = fe }
|
||||
personForm = wrapFormHere pwidget penctype
|
||||
statusForm = wrapFormHere swidget senctype
|
||||
contactForm = wrapFormHere cwidget cenctype
|
||||
crUsrForm = wrapFormHere crUsrWgt crUsrEnctype
|
||||
getLicForm = wrapFormHere getLicWgt getLicEnctype
|
||||
setLicForm = wrapFormHere setLicWgt setLicEnctype
|
||||
-- TODO: use i18nWidgetFile instead if this is to become permanent
|
||||
$(widgetFile "avs")
|
||||
((getLicRes, getLicWgt), getLicEnctype) <- runFormPost $ identifyForm FIDAvsQueryLicence $ \html ->
|
||||
flip (renderAForm FormStandard) html $ (,,) <$> aopt intField (fslI $ text2message "Min AvsPersonId") Nothing
|
||||
<*> aopt intField (fslI $ text2message "Max AvsPersonId") Nothing
|
||||
<*> aopt (selectField $ return avsLicenceOptions) (fslI MsgAvsLicence) Nothing
|
||||
let procFormGetLic fr = tryShow $ do
|
||||
AvsResponseGetLicences lics <- avsQuery AvsQueryGetAllLicences
|
||||
let flics = Set.toList $ Set.filter lfltr lics
|
||||
lfltr = case fr of -- not pretty, but it'll do
|
||||
(Just idmin, Just idmax, Just lic) -> \AvsPersonLicence{..} -> (avsLicenceRampLicence == lic) && (avsLicencePersonID `inBetween` (AvsPersonId idmin, AvsPersonId idmax))
|
||||
(Just idmin, Nothing, Just lic) -> \AvsPersonLicence{..} -> (avsLicenceRampLicence == lic) && (avsLicencePersonID == AvsPersonId idmin)
|
||||
(Nothing , Just idmax, Just lic) -> \AvsPersonLicence{..} -> (avsLicenceRampLicence == lic) && (avsLicencePersonID == AvsPersonId idmax)
|
||||
(Nothing , Nothing, Just lic) -> \AvsPersonLicence{..} -> avsLicenceRampLicence == lic
|
||||
(Just idmin, Just idmax, Nothing ) -> (`inBetween` (AvsPersonId idmin, AvsPersonId idmax)) . avsLicencePersonID
|
||||
(Just idmin, Nothing, Nothing ) -> (== AvsPersonId idmin) . avsLicencePersonID
|
||||
(Nothing , Just idmax, Nothing ) -> (== AvsPersonId idmax) . avsLicencePersonID
|
||||
(Nothing , Nothing, Nothing ) -> const True
|
||||
addMessage Info $ text2Html $ "Query returned " <> tshow (length flics) <> " licences."
|
||||
return [whamlet|
|
||||
<h2>Success:</h2>
|
||||
<ul>
|
||||
$forall AvsPersonLicence{..} <- flics
|
||||
<li> #{tshow avsLicencePersonID}: #{licence2char avsLicenceRampLicence}
|
||||
|]
|
||||
mbGetLic <- formResultMaybe getLicRes (Just <<$>> procFormGetLic)
|
||||
|
||||
((setLicRes, setLicWgt), setLicEnctype) <- runFormPost $ identifyForm FIDAvsSetLicence $ \html ->
|
||||
flip (renderAForm FormStandard) html $ (,) <$> areq intField (fslI MsgAvsPersonId) Nothing
|
||||
<*> areq (selectField $ return avsLicenceOptions) (fslI MsgAvsLicence) (Just AvsLicenceVorfeld)
|
||||
let procFormSetLic (aid, lic) = do
|
||||
res <- try $ setLicenceAvs (AvsPersonId aid) lic
|
||||
case res of
|
||||
(Right True) ->
|
||||
return $ Just [whamlet|<h2>Success:</h2> Licence #{tshow (licence2char lic)} set for #{tshow aid}.|]
|
||||
(Right False) ->
|
||||
return $ Just [whamlet|<h2>Error:</h2> Licence could not be set for #{tshow aid}.|]
|
||||
(Left e) -> do
|
||||
let msg = tshow (e :: SomeException)
|
||||
return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
|
||||
mbSetLic <- formResultMaybe setLicRes procFormSetLic
|
||||
|
||||
|
||||
(qryLicForm, qryLicRes) <- runButtonForm FIDAvsQueryLicenceDiffs
|
||||
mbQryLic <- case qryLicRes of
|
||||
Nothing -> return Nothing
|
||||
(Just BtnCheckLicences) -> do
|
||||
res <- try $ do
|
||||
allLicences <- avsQuery AvsQueryGetAllLicences
|
||||
computeDifferingLicences allLicences
|
||||
case res of
|
||||
(Right diffs) -> do
|
||||
let showLics l = Text.intercalate ", " $ fmap (tshow . avsLicencePersonID) $ Set.toList $ Set.filter ((l ==) . avsLicenceRampLicence) diffs
|
||||
r_grant = showLics AvsLicenceRollfeld
|
||||
f_set = showLics AvsLicenceVorfeld
|
||||
revoke = showLics AvsNoLicence
|
||||
return $ Just [whamlet|
|
||||
<h2>Licence check differences:
|
||||
<h3>Grant R:
|
||||
<p>
|
||||
#{r_grant}
|
||||
<h3>Set to F:
|
||||
<p>
|
||||
#{f_set}
|
||||
<h3>Revoke licence:
|
||||
<p>
|
||||
#{revoke}
|
||||
|]
|
||||
(Left e) -> do
|
||||
let msg = tshow (e :: SomeException)
|
||||
return $ Just [whamlet|<h2>Licence check error:</h2> #{msg}|]
|
||||
-- (Just BtnSynchLicences) -> do
|
||||
-- res <- try synchAvsLicences
|
||||
-- case res of
|
||||
-- (Right True) ->
|
||||
-- return $ Just [whamlet|<h2>Success:</h2> Licences sychronized.|]
|
||||
-- (Right False) ->
|
||||
-- return $ Just [whamlet|<h2>Error:</h2> Licences could not be synchronized, see error log.|]
|
||||
-- (Left e) -> do
|
||||
-- let msg = tshow (e :: SomeException)
|
||||
-- return $ Just [whamlet|<h2>Licence synchronisation error:</h2> #{msg}|]
|
||||
|
||||
actionUrl <- fromMaybe AdminAvsR <$> getCurrentRoute
|
||||
siteLayoutMsg MsgMenuAvs $ do
|
||||
setTitleI MsgMenuAvs
|
||||
let wrapFormHere fw fe = wrapForm fw def { formAction = Just $ SomeRoute actionUrl, formEncoding = fe }
|
||||
personForm = wrapFormHere pwidget penctype
|
||||
statusForm = wrapFormHere swidget senctype
|
||||
contactForm = wrapFormHere cwidget cenctype
|
||||
crUsrForm = wrapFormHere crUsrWgt crUsrEnctype
|
||||
getLicForm = wrapFormHere getLicWgt getLicEnctype
|
||||
setLicForm = wrapFormHere setLicWgt setLicEnctype
|
||||
-- TODO: use i18nWidgetFile instead if this is to become permanent
|
||||
$(widgetFile "avs")
|
||||
|
||||
{-
|
||||
|
||||
@ -383,7 +383,7 @@ getProblemAvsSynchR = do
|
||||
numUnknownLicenceOwners = length unknownLicenceOwners
|
||||
|
||||
(btnImportUnknownWgt, btnImportUnknownRes) <- runButtonFormHash unknownLicenceOwners FIDBtnAvsImportUnknown
|
||||
ifMaybeM btnImportUnknownRes () $ \BtnAvsImportUnknown -> do
|
||||
ifNothingM btnImportUnknownRes () $ \BtnAvsImportUnknown -> do
|
||||
res <- catchAllAvs $ forM (take 500 unknownLicenceOwners) $ try . upsertAvsUserById -- TODO: turn this into a background job
|
||||
let procRes (Right _) = (Sum 1, mempty :: Set.Set AvsPersonId, mempty :: Set.Set AvsPersonId, mempty)
|
||||
--TODO: continue here!
|
||||
@ -414,7 +414,7 @@ getProblemAvsSynchR = do
|
||||
^{revokeUnknownExecWgt}
|
||||
|]
|
||||
|
||||
ifMaybeM btnRevokeUnknownRes () $ \BtnAvsRevokeUnknown -> do
|
||||
ifNothingM btnRevokeUnknownRes () $ \BtnAvsRevokeUnknown -> do
|
||||
let revokes = Set.map (AvsPersonLicence AvsNoLicence) $ Set.fromList unknownLicenceOwners
|
||||
no_revokes = Set.size revokes
|
||||
oks <- catchAllAvs $ setLicencesAvs revokes
|
||||
@ -677,52 +677,204 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do
|
||||
|
||||
|
||||
|
||||
getAdminAvsUserR :: CryptoUUIDUser -> Handler Html
|
||||
getAdminAvsUserR uuid = do
|
||||
uid <- decrypt uuid
|
||||
Entity{entityVal=UserAvs{..}} <- runDB $ getBy404 $ UniqueUserAvsUser uid
|
||||
mAvsQuery <- getsYesod $ view _appAvsQuery
|
||||
resWgt <- case mAvsQuery of
|
||||
Nothing -> return [whamlet|Error: AVS interface configuration is incomplete.|] -- should never occur after initilisation
|
||||
Just AvsQuery{..} -> do
|
||||
mbContact <- avsQueryContact $ AvsQueryContact $ Set.singleton $ AvsObjPersonId userAvsPersonId
|
||||
mbDataPerson <- lookupAvsUser userAvsPersonId
|
||||
return [whamlet|
|
||||
data UserAvsAction = UserAvsSwitchCompany
|
||||
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
||||
deriving anyclass (Universe, Finite)
|
||||
|
||||
nullaryPathPiece ''UserAvsAction $ camelToPathPiece' 1
|
||||
embedRenderMessage ''UniWorX ''UserAvsAction id
|
||||
instance Button UniWorX UserAvsAction where
|
||||
btnClasses UserAvsSwitchCompany = [BCIsButton, BCDefault]
|
||||
|
||||
|
||||
getAdminAvsUserR, postAdminAvsUserR :: CryptoUUIDUser -> Handler Html
|
||||
getAdminAvsUserR = postAdminAvsUserR
|
||||
postAdminAvsUserR uuid = do
|
||||
isModal <- hasCustomHeader HeaderIsModal
|
||||
|
||||
uid <- decrypt uuid
|
||||
Entity{entityVal=UserAvs{..}} <- runDB $ getBy404 $ UniqueUserAvsUser uid
|
||||
-- let fltrById prj = over _Wrapped (Set.filter ((== userAvsPersonId) . prj)) -- not sufficiently polymorphic
|
||||
let fltrIdContact = over _Wrapped (Set.filter ((== userAvsPersonId) . avsContactPersonID))
|
||||
-- fltrIdStatus = over _Wrapped (Set.filter ((== userAvsPersonId) . avsStatusPersonID))
|
||||
mbContact <- try $ fmap fltrIdContact $ avsQuery $ AvsQueryContact $ Set.singleton $ AvsObjPersonId userAvsPersonId
|
||||
-- mbStatus <- try $ fmap fltrIdStatus $ avsQuery $ AvsQueryStatus $ Set.singleton userAvsPersonId
|
||||
mbStatus <- try $ queryAvsFullStatus userAvsPersonId -- TODO: delete Handler.Utils.Avs.lookupAvsUser if no longer needed -- NOTE: currently needed to provide card firms that are missing in AVS status query responses
|
||||
let compsUsed :: [CompanyName] = stripCI <$> mbStatus ^.. _Right . _Wrapped . folded . _avsStatusPersonCardStatus . folded . _avsDataFirm . _Just
|
||||
compDict <- if 1 >= length compsUsed
|
||||
then return mempty -- switch company only sensible if there is more than one company to choose
|
||||
else do
|
||||
let switchCompFormHandler :: [(CompanyName,CompanyId)] -> Maybe CompanyId -> Handler Widget
|
||||
switchCompFormHandler availComps _ | 1 >= length availComps = return mempty -- don't offer a form if there is only one company
|
||||
switchCompFormHandler availComps mbPrime = do
|
||||
let switchCompForm :: AForm (HandlerFor UniWorX) (CryptoUUIDUser,CompanyId)
|
||||
switchCompForm = (,)
|
||||
<$> apopt hiddenField "" (Just uuid)
|
||||
<*> areq (selectFieldList [(ciOriginal cn, cid) | (cn, cid) <- availComps]) "new primary company" mbPrime
|
||||
<* aopt (buttonField UserAvsSwitchCompany) "" Nothing
|
||||
switchCompValidate :: FormValidator (CryptoUUIDUser,CompanyId) Handler ()
|
||||
switchCompValidate = do
|
||||
(uuid_rcvd,_) <- State.get
|
||||
guardValidation MsgWrongButtonValue $ uuid_rcvd == uuid
|
||||
((spRes, spWgt), spEnc) <- runFormPost . validateForm switchCompValidate . identifyForm ("switch-primary-company"::Text) $ renderAForm FormStandard switchCompForm
|
||||
formResultModal spRes (AdminAvsUserR uuid) (\(_,cid) -> do
|
||||
lift $ $logInfoS "AVS" ("Switch company option result " <> tshow spRes)
|
||||
problems <- liftHandler . runDB $ do
|
||||
(usrUp, problems) <- switchAvsUserCompany True False uid cid
|
||||
update uid usrUp
|
||||
forM problems $ \p -> reportAdminProblem p >> msgAdminProblem p
|
||||
forM_ problems (\p -> do
|
||||
-- lift $ $logErrorS "AVS" $ "Switch company problem: " <> tshow p -- no instance Show for SomeMessages
|
||||
tell . pure =<< messageI Warning p
|
||||
)
|
||||
let ok = if null problems then Success else Error
|
||||
tell . pure =<< messageI ok (MsgUserAvsCompanySwitched $ unCompanyKey cid)
|
||||
)
|
||||
return $ wrapForm spWgt
|
||||
def { formAction = Just $ SomeRoute (AdminAvsUserR uuid), formEncoding = spEnc, formSubmit = FormNoSubmit, formAttrs = [ asyncSubmitAttr | isModal ]}
|
||||
(availComps, primName, primId) <- runDB $ do
|
||||
mbPrimeUsrComp :: Maybe UserCompany <- getUserPrimaryCompany uid
|
||||
mbPrimeComp :: Maybe Company <- traverseJoin (get . userCompanyCompany) mbPrimeUsrComp
|
||||
-- let fltrCmps = (CompanyName <-. compsUsed) : maybeEmpty mbPrimeComp (\Company{companyShorthand=pShort} -> [CompanyShorthand !=. pShort])
|
||||
comps :: [Entity Company] <- selectList [CompanyName <-. compsUsed] [Asc CompanyName, Asc CompanyAvsId] -- company name is already unique, but AVS sometimes contains uses whitespace
|
||||
return ([(companyName v, k) | (Entity k v) <- comps], companyName <$> mbPrimeComp, CompanyKey . companyShorthand <$> mbPrimeComp)
|
||||
-- formDict <- Map.traverseWithKey runSwitchFrom compDict
|
||||
swForm <- switchCompFormHandler availComps primId
|
||||
return (primName, swForm)
|
||||
|
||||
msgWarningTooltip <- messageI Warning MsgMessageWarning
|
||||
let warnBolt = messageTooltip msgWarningTooltip
|
||||
heading = [whamlet|_{MsgAvsPersonNo} #{userAvsNoPerson}|]
|
||||
siteLayout heading $ do
|
||||
setTitle $ toHtml $ show userAvsNoPerson
|
||||
let contactWgt = case mbContact of
|
||||
Left err -> exceptionWgt err
|
||||
Right (AvsResponseContact adcs) ->
|
||||
if null adcs
|
||||
then [whamlet|_{MsgAvsPersonSearchEmpty}|]
|
||||
else
|
||||
let cs = mkContactWgt warnBolt userAvsNoPerson <$> toList adcs
|
||||
in mconcat cs
|
||||
cardsWgt = case mbStatus of
|
||||
Left err -> exceptionWgt err
|
||||
Right (AvsResponseStatus asts) ->
|
||||
if null asts
|
||||
then [whamlet|_{MsgAvsStatusSearchEmpty}|]
|
||||
else
|
||||
let cs = mkCardsWgt compDict . avsStatusPersonCardStatus <$> toList asts
|
||||
in mconcat cs
|
||||
[whamlet|
|
||||
<p>
|
||||
Vorläufige Admin Ansicht AVS Daten.
|
||||
Ansicht zeigt aktuelle Daten.
|
||||
Es erfolgte damit aber noch kein Update der FRADrive Daten.
|
||||
^{contactWgt}
|
||||
<p>
|
||||
<dl .deflist>
|
||||
<dt .deflist__dt>InfoPersonContact <br>
|
||||
<i>(bevorzugt)
|
||||
^{cardsWgt}
|
||||
<p>
|
||||
_{MsgAvsCurrentData}
|
||||
|]
|
||||
where
|
||||
mkContactWgt :: Widget -> Int -> AvsDataContact -> Widget
|
||||
mkContactWgt warnBolt reqAvsNo AvsDataContact
|
||||
{ -- avsContactPersonID = _api
|
||||
avsContactPersonInfo = AvsPersonInfo{..}
|
||||
, avsContactFirmInfo = AvsFirmInfo{ avsFirmFirm = firmName }
|
||||
} =
|
||||
let avsNoOk = readMay avsInfoPersonNo /= Just reqAvsNo in
|
||||
[whamlet|
|
||||
<section .profile>
|
||||
<dl .deflist.profile-dl>
|
||||
$if avsNoOk
|
||||
<dt .deflist__dt>
|
||||
_{MsgAvsPersonNo}
|
||||
<dd .deflist__dd>
|
||||
#{avsInfoPersonNo}
|
||||
^{warnBolt}
|
||||
_{MsgAvsPersonNoMismatch}
|
||||
<dt .deflist__dt>
|
||||
_{MsgAvsLastName}
|
||||
<dd .deflist__dd>
|
||||
$case mbContact
|
||||
$of Left err
|
||||
Fehler: #{tshow err}
|
||||
$of Right contactInfo
|
||||
#{decodeUtf8 (Pretty.encodePretty (toJSON contactInfo))}
|
||||
<dt .deflist__dt>PersonStatus und mehrere PersonSearch <br>
|
||||
<i>(benötigt mehrere AVS Abfragen)
|
||||
#{avsInfoLastName}
|
||||
<dt .deflist__dt>
|
||||
_{MsgAvsFirstName}
|
||||
<dd .deflist__dd>
|
||||
$maybe dataPerson <- mbDataPerson
|
||||
#{decodeUtf8 (Pretty.encodePretty (toJSON dataPerson))}
|
||||
#{avsInfoFirstName}
|
||||
<dt .deflist__dt>
|
||||
_{MsgAvsPrimaryCompany}
|
||||
<dd .deflist__dd>
|
||||
#{firmName}
|
||||
$maybe bday <- avsInfoDateOfBirth
|
||||
<dt .deflist__dt>
|
||||
_{MsgAdminUserBirthday}
|
||||
<dd .deflist__dd>
|
||||
^{formatTimeW SelFormatDate bday}
|
||||
<dt .deflist__dt>
|
||||
_{MsgAvsLicence}
|
||||
<dd .deflist__dd>
|
||||
$maybe licence <- parseAvsLicence avsInfoRampLicence
|
||||
_{licence}
|
||||
$nothing
|
||||
Keine Daten erhalten.
|
||||
<h3>
|
||||
Provisorische formatierte Ansicht
|
||||
<p>
|
||||
Generisch formatierte Ansicht, die zeigt, in welche Richtung die Endansicht gehen könnte.
|
||||
In der Endansicht wären nur ausgewählte Felder mit besserer Bennenung in einer manuell gewählten Reihenfolge sichtbar.
|
||||
<p>
|
||||
^{foldMap jsonWidget mbContact}
|
||||
<p>
|
||||
^{foldMap jsonWidget mbDataPerson}
|
||||
_{MsgAvsNoLicenceGuest}
|
||||
|]
|
||||
|
||||
-- mkCardsWgt :: (Maybe CompanyName, Map CompanyName Widget, Widget) -> Set AvsDataPersonCard -> Widget
|
||||
mkCardsWgt :: (Maybe CompanyName, Widget) -> Set AvsDataPersonCard -> Widget
|
||||
mkCardsWgt (mbPrimName, swForm) crds
|
||||
| null crds = [whamlet|_{MsgAvsCardsEmpty}|]
|
||||
| otherwise = do
|
||||
let hasCompany = isJust $ Set.foldr ((<|>) . avsDataFirm) Nothing crds -- some if, since a true AVS status query never delivers values for these fields, but queryAvsFullStatus-workaround does
|
||||
hasIssueDate = isJust $ Set.foldr ((<|>) . avsDataIssueDate) Nothing crds
|
||||
hasValidToDate = isJust $ Set.foldr ((<|>) . avsDataValidTo) Nothing crds
|
||||
[whamlet|
|
||||
<div .scrolltable .scrolltable-bordered>
|
||||
<table .table .table--striped>
|
||||
<thead>
|
||||
<tr .table__row .table__row--head>
|
||||
<th .table__th>_{MsgAvsCardNo}
|
||||
<th .table__th>_{MsgTableAvsCardValid}
|
||||
<th .table__th>_{MsgAvsCardColor}
|
||||
<th .table__th>_{MsgAvsCardAreas}
|
||||
$if hasIssueDate
|
||||
<th .table__th>_{MsgTableAvsCardIssueDate}
|
||||
$if hasValidToDate
|
||||
<th .table__th>_{MsgTableAvsCardValidTo}
|
||||
$if hasCompany
|
||||
<th .table__th>_{MsgTableCompany}
|
||||
<th .table__th>_{MsgAvsPrimaryCompany}
|
||||
<tbody>
|
||||
$forall c <- Set.toDescList crds
|
||||
$with AvsDataPersonCard{avsDataValid,avsDataCardColor,avsDataCardAreas,avsDataFirm,avsDataIssueDate,avsDataValidTo} <- c
|
||||
<tr .table__row>
|
||||
<td .table__td>
|
||||
#{tshowAvsFullCardNo (getFullCardNo c)}
|
||||
<td .table__td>
|
||||
#{boolSymbol avsDataValid}
|
||||
<td .table__td>
|
||||
_{avsDataCardColor}
|
||||
<td .table__td>
|
||||
$forall a <- avsDataCardAreas
|
||||
#{a} #
|
||||
$if hasIssueDate
|
||||
<td .table__td>
|
||||
$maybe d <- avsDataIssueDate
|
||||
^{formatTimeW SelFormatDate d}
|
||||
$if hasValidToDate
|
||||
<td .table__td>
|
||||
$maybe d <- avsDataValidTo
|
||||
^{formatTimeW SelFormatDate d}
|
||||
$if hasCompany
|
||||
<td .table__td>
|
||||
$maybe f <- avsDataFirm
|
||||
#{f}
|
||||
<td .table__td>
|
||||
$maybe f <- avsDataFirm
|
||||
$with fci <- stripCI f
|
||||
$maybe primName <- mbPrimName
|
||||
$if (primName == fci)
|
||||
_{MsgAvsPrimaryCompany}
|
||||
<p>
|
||||
^{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
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
|
||||
-- SPDX-FileCopyrightText: 2022-2024 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,David Mosbach <david.mosbach@uniworx.de>
|
||||
--
|
||||
-- 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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
-- SPDX-FileCopyrightText: 2022-23 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>, Steffen Jost <s.jost@fraport.de>
|
||||
-- SPDX-FileCopyrightText: 2022-24 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>, Steffen Jost <s.jost@fraport.de>,David Mosbach <david.mosbach@uniworx.de>
|
||||
--
|
||||
-- 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")
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
|
||||
-- SPDX-FileCopyrightText: 2022-2024 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>,David Mosbach <david.mosbach@uniworx.de>
|
||||
--
|
||||
-- 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
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
-- SPDX-FileCopyrightText: 2023 Steffen Jost <S.Jost@fraport.de>
|
||||
-- SPDX-FileCopyrightText: 2023-2024 Steffen Jost <S.Jost@fraport.de>,David Mosbach <david.mosbach@uniworx.de>
|
||||
--
|
||||
-- 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
|
||||
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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)]
|
||||
|
||||
@ -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
|
||||
|
||||
@ -1,7 +1,9 @@
|
||||
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
|
||||
-- SPDX-FileCopyrightText: 2022-2024 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>,David Mosbach <david.mosbach@uniworx.de>
|
||||
--
|
||||
-- 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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
|
||||
-- SPDX-FileCopyrightText: 2022-2024 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>,David Mosbach <david.mosbach@uniworx.de>
|
||||
--
|
||||
-- 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
|
||||
}
|
||||
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
|
||||
-- SPDX-FileCopyrightText: 2022-2024 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>,David Mosbach <david.mosbach@uniworx.de>
|
||||
--
|
||||
-- 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
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
|
||||
-- SPDX-FileCopyrightText: 2022-2024 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,David Mosbach <david.mosbach@uniworx.de>
|
||||
--
|
||||
-- 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|
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
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]
|
||||
File diff suppressed because it is too large
Load Diff
@ -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 ->
|
||||
|
||||
@ -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
|
||||
@ -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
|
||||
|
||||
@ -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|
|
||||
<h2>_{MsgMailSupervisedNote}
|
||||
<p>
|
||||
@ -84,7 +87,7 @@ userMailT uid mAct = do
|
||||
<li>
|
||||
#{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)
|
||||
|
||||
@ -1,17 +1,18 @@
|
||||
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
|
||||
-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>, Steffen Jost <s.jost@fraport.de>
|
||||
--
|
||||
-- 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
|
||||
|
||||
@ -1,31 +1,24 @@
|
||||
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
|
||||
-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
|
||||
--
|
||||
-- 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)
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
-- SPDX-FileCopyrightText: 2022 Felix Hamann <felix.hamann@campus.lmu.de>,Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
|
||||
-- SPDX-FileCopyrightText: 2022-24 Felix Hamann <felix.hamann@campus.lmu.de>,Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>
|
||||
--
|
||||
-- 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
|
||||
|
||||
@ -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 --
|
||||
----------------------------
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
-- SPDX-FileCopyrightText: 2022-23 Felix Hamann <felix.hamann@campus.lmu.de>,Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>
|
||||
-- SPDX-FileCopyrightText: 2022-24 Felix Hamann <felix.hamann@campus.lmu.de>,Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>,David Mosbach <david.mosbach@uniworx.de>
|
||||
--
|
||||
-- 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
|
||||
|
||||
@ -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)
|
||||
|
||||
47
src/Handler/Utils/avs_callgraph.md
Normal file
47
src/Handler/Utils/avs_callgraph.md
Normal file
@ -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
|
||||
```
|
||||
@ -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))
|
||||
|
||||
@ -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))
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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"
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
-- SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
|
||||
-- SPDX-FileCopyrightText: 2022-24 Steffen Jost <jost@tcs.ifi.lmu.de>
|
||||
--
|
||||
-- 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.
|
||||
@ -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
|
||||
}
|
||||
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
|
||||
-- SPDX-FileCopyrightText: 2022-2024 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,David Mosbach <david.mosbach@uniworx.de>
|
||||
--
|
||||
-- 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
|
||||
|
||||
|
||||
116
src/Utils.hs
116
src/Utils.hs
@ -1,4 +1,4 @@
|
||||
-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>
|
||||
-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>
|
||||
--
|
||||
-- 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)
|
||||
|
||||
|
||||
176
src/Utils/Avs.hs
176
src/Utils/Avs.hs
@ -1,7 +1,8 @@
|
||||
-- SPDX-FileCopyrightText: 2022 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
|
||||
-- SPDX-FileCopyrightText: 2022-24 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <s.jost@frapor.de>
|
||||
--
|
||||
-- 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
|
||||
|
||||
143
src/Utils/DB.hs
143
src/Utils/DB.hs
@ -1,16 +1,17 @@
|
||||
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
|
||||
-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
|
||||
--
|
||||
-- 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
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
-- SPDX-FileCopyrightText: 2023 Felix Hamann <felix.hamann@campus.lmu.de>,Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Wolfgang Witt <Wolfgang.Witt@campus.lmu.de>
|
||||
-- SPDX-FileCopyrightText: 2023-2024 Felix Hamann <felix.hamann@campus.lmu.de>,Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Wolfgang Witt <Wolfgang.Witt@campus.lmu.de>,David Mosbach <david.mosbach@uniworx.de>
|
||||
--
|
||||
-- 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 --
|
||||
|
||||
@ -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
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
|
||||
-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
|
||||
--
|
||||
-- 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` --
|
||||
|
||||
64
src/Utils/Mail.hs
Normal file
64
src/Utils/Mail.hs
Normal file
@ -0,0 +1,64 @@
|
||||
-- SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
|
||||
--
|
||||
-- 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
|
||||
Some files were not shown because too many files have changed in this diff Show More
Reference in New Issue
Block a user