diff --git a/config/settings.yml b/config/settings.yml index 602c9c0e2..bbe83979c 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -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" diff --git a/messages/uniworx/categories/admin/de-de-formal.msg b/messages/uniworx/categories/admin/de-de-formal.msg index eb6cfe753..70f10b233 100644 --- a/messages/uniworx/categories/admin/de-de-formal.msg +++ b/messages/uniworx/categories/admin/de-de-formal.msg @@ -1,4 +1,4 @@ -# SPDX-FileCopyrightText: 2022 Gregor Kleen ,Winnie Ros +# SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Winnie Ros ,Steffen Jost # # SPDX-License-Identifier: AGPL-3.0-or-later @@ -101,7 +101,7 @@ ProblemsHeadingDrivers: Fahrberechtigungen ProblemsHeadingNotifications: Benachrichtigungen ProblemsHeadingMisc: Allgemein ProblemsAvsProblem: Synchronisation mit AVS/MoBaKo komplett fehlgeschlagen -ProblemsDriverSynch n@Int: #{tshow n} Diskrepanzen zwischen AVS und FRADrive +ProblemsDriverSynch n@Int: #{pluralDEeN n "Diskrepanze"} zwischen AVS und FRADrive ProblemsDriverSynch0: Alle Sperrungen von Vorfeld-Fahrberechtigungen 'F' sind im AVS eingetragen ProblemsDriverSynch1down: Alle Sperrungen von Rollfeld-Fahrberechtigungen 'R' sind im AVS eingetragen ProblemsDriverSynch1up: Alle gültigen Vorfeld-Fahrberechtigungen 'F' sind im AVS eingetragen @@ -109,7 +109,7 @@ ProblemsDriverSynch2: Alle gültigen Rollfeld-Fahrberechtigungen 'R' sind im AVS ProblemsRDriversHaveFs: Alle Inhaber einer Rollfeld-Fahrberechtigung besitzen auch eine gültige Vorfeld-Fahrberechtigung ProblemsDriversHaveAvsIds: Alle Inhaber einer Fahrberechtigung konnten einer AVS Identifikationsnummer zugeordnet werden ProblemsUsersAreReachable: Für alle Benutzer ist eine E-Mail oder postalische Adresse bekannt -ProblemsNoStalePrintJobs n@Integer: Alle Briefversandaufträge der vergangenen #{show n} Tage wurden von der Druckerei bestätigt +ProblemsNoStalePrintJobs n@Integer: Alle Briefversandaufträge #{pluralDE n "des vergangenen Tages" ("der vergangenen "<> tshow n <> " Tage")} wurden von der Druckerei bestätigt ProblemsNoBadAPCIds: Alle kürzlich empfangenen Druckauftragsbestätigungen waren gültig ProblemsUnreachableHeading: Unerreichbare Benutzer ProblemsUnreachableBody: Benutzer ohne E-Mail oder Postadresse, welche z.B. bei ablaufenden Berechtigungen nicht benachrichtigt werden können: @@ -121,6 +121,19 @@ 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: Standardansprechpartner #{boolText mempty "mit Standardumleitung" b} wechselte zu neuer Firma +AdminProblemNewlyUnsupervised: Fahrer hat keinen Firmenansprechpartner mehr nach AVS Firmenwechsel zu Firma +AdminProblemUser: Betroffener +ProblemTableMarkSolved: Als erledigt markieren +ProblemTableMarkUnsolved: Erledigt Markierung löschen + InterfacesOk: Schnittstellen sind ok. InterfacesFail n@Int: #{pluralDEeN n "Schnittstellenproblem"}! InterfaceStatus !ident-ok: Status diff --git a/messages/uniworx/categories/admin/en-eu.msg b/messages/uniworx/categories/admin/en-eu.msg index 13f35ed9f..59d2e265c 100644 --- a/messages/uniworx/categories/admin/en-eu.msg +++ b/messages/uniworx/categories/admin/en-eu.msg @@ -1,4 +1,4 @@ -# SPDX-FileCopyrightText: 2022 Sarah Vaupel ,Winnie Ros +# SPDX-FileCopyrightText: 2022-24 Sarah Vaupel ,Winnie Ros ,Steffen Jost # # SPDX-License-Identifier: AGPL-3.0-or-later @@ -18,10 +18,10 @@ NoNameCandidatesInferred: No new name-mappings inferred AllNameIncidencesDeleted: Successfully deleted all name observations AllParentIncidencesDeleted: Successfully deleted all parent-relation observations AllStandaloneIncidencesDeleted: Successfully deleted all standalone observations -IncidencesDeleted n: Successfully deleted #{show n} #{pluralEN n "observation" "observations"} -RedundantParentCandidatesRemoved n: Successfully removed #{n} rendundant #{pluralEN n "parent-candidate" "parent-candidates"} -RedundantStandaloneCandidatesRemoved n: Successfully removed #{n} rendundant #{pluralEN n "standalone-candidate" "standalone-candidates"} -ParentCandidatesInferred n: Successfully inferred #{n} field #{pluralEN n "parent-relation" "parent-reliations"} +IncidencesDeleted n: Successfully deleted #{pluralENsN n "observation"} +RedundantParentCandidatesRemoved n: Successfully removed #{n} rendundant #{pluralENs n "parent-candidate"} +RedundantStandaloneCandidatesRemoved n: Successfully removed #{n} rendundant #{pluralENs n "standalone-candidate"} +ParentCandidatesInferred n: Successfully inferred #{n} field #{pluralENs n "parent-relation"} NoParentCandidatesInferred: No new parent-relations inferred StudyDegreeChangeSuccess: Successfully updated degrees StudyTermsShort: Field shorthand @@ -101,7 +101,7 @@ ProblemsHeadingDrivers: Driving Licences ProblemsHeadingNotifications: User communication ProblemsHeadingMisc: Miscellaneous ProblemsAvsProblem: Synchronisation with AVS/MoBaKo failed entirely -ProblemsDriverSynch n: #{tshow n} mismatches between AVS and FRADrive +ProblemsDriverSynch n: #{tshow n} #{pluralEN n "mismatch" "mismatches"} between AVS and FRADrive ProblemsDriverSynch0: All revocations of apron driving licences 'F' were successfully registered with AVS ProblemsDriverSynch1down: All revocations of maneuvering area driving licences 'R' were successfully registered with AVS ProblemsDriverSynch1up: All valid apron driving licences 'F' were successfully registered with AVS @@ -109,7 +109,7 @@ ProblemsDriverSynch2: All valid maneuvering area driving licences 'R' were succe ProblemsRDriversHaveFs: All driving licence 'R' holders also have a valid 'F' licence ProblemsDriversHaveAvsIds: All driving licence holder could be matched with their AVS id ProblemsUsersAreReachable: Either Email or postal address is known for all users -ProblemsNoStalePrintJobs n: All requests for letter mailing within the last #{show n} days were acknowledged as printed by the airport printing center +ProblemsNoStalePrintJobs n: All requests for letter mailing within the last #{pluralENsN n "day"} were acknowledged as printed by the airport printing center ProblemsNoBadAPCIds: All recently received print job ids from Airport Print Center were legit ProblemsUnreachableHeading: Unreachable Users ProblemsUnreachableBody: Users without Email nor postal address, who thus cannot be notified about expiring qualifications: @@ -121,6 +121,19 @@ 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: Default company supervisor #{boolText mempty "with reroute" b} changed to new company +AdminProblemNewlyUnsupervised: Driver has no longer a company default supervisor after AVS update at new company +AdminProblemUser: Affected +ProblemTableMarkSolved: Mark done +ProblemTableMarkUnsolved: Reopen as undone + InterfacesOk: Interfaces are ok. InterfacesFail n: #{pluralENsN n "interface problem"}! InterfaceStatus: Status diff --git a/messages/uniworx/categories/avs/de-de-formal.msg b/messages/uniworx/categories/avs/de-de-formal.msg index bd5c01716..801c49e55 100644 --- a/messages/uniworx/categories/avs/de-de-formal.msg +++ b/messages/uniworx/categories/avs/de-de-formal.msg @@ -2,13 +2,16 @@ # # SPDX-License-Identifier: AGPL-3.0-or-later AvsPersonInfo: AVS Personendaten -AvsPersonId: AVS Personen Id +AvsPersonId: AVS Personen Id AvsPersonNo: AVS Personennummer +AvsPersonNoMismatch: AVS Personennummer hat sich geändert und wurde in FRADrive noch nicht aktualisiert AvsCardNo: Ausweiskartennummer AvsFirstName: Vorname AvsLastName: Nachname +AvsPrimaryCompany: Primäre Firma AvsInternalPersonalNo: Personalnummer (nur Fraport AG) AvsVersionNo: Versionsnummer +AvsQueryNeeded: Benötigt Verbindung zum AVS. AvsQueryEmpty: Bitte mindestens ein Anfragefeld ausfüllen! AvsQueryStatusInvalid t@Text: Nur numerische IDs eingeben, durch Komma getrennt! Erhalten: #{show t} AvsLicence: Fahrberechtigung @@ -27,13 +30,29 @@ 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 +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. \ No newline at end of file diff --git a/messages/uniworx/categories/avs/en-eu.msg b/messages/uniworx/categories/avs/en-eu.msg index ec7288d7d..f942bd92f 100644 --- a/messages/uniworx/categories/avs/en-eu.msg +++ b/messages/uniworx/categories/avs/en-eu.msg @@ -1,14 +1,17 @@ # SPDX-FileCopyrightText: 2022 Steffen Jost # # SPDX-License-Identifier: AGPL-3.0-or-later -AvsPersonInfo: AVS Person Info -AvsPersonId: AVS Person Id -AvsPersonNo: AVS Person Number +AvsPersonInfo: AVS person info +AvsPersonId: AVS person id +AvsPersonNo: AVS person number +AvsPersonNoMismatch: AVS person number has changed and was not yet updated in FRADrive AvsCardNo: Card number AvsFirstName: First name AvsLastName: Last name +AvsPrimaryCompany: Primary company AvsInternalPersonalNo: Personnel number (Fraport AG only) AvsVersionNo: Version number +AvsQueryNeeded: AVS connection required. AvsQueryEmpty: At least one query field must be filled! AvsQueryStatusInvalid t: Numeric IDs only, comma seperated! #{show t} AvsLicence: Driving Licence @@ -27,13 +30,29 @@ RevokeFraDriveLicences alic@AvsLicence n@Int: _{alic} revoked in FRADrive for #{ RevokeUnknownLicencesOk: AVS driving licences of unknown drivers revoked RevokeUnknownLicencesFail: Not all AVS driving licences of unknown drivers could be revoked, see log for details AvsCommunicationError: AVS interface returned an unexpected error. +AvsCommunicationTimeout: AVS interface returned no response within timeout limit. LicenceTableChangeAvs: Change in AVS LicenceTableGrantFDrive: Grant in FRADrive LicenceTableRevokeFDrive: Revoke in FRADrive TableAvsActiveCards: Valid Cards +TableAvsCardValid: Currently valid +TableAvsCardIssueDate: Issued +TableAvsCardValidTo: Valid to +AvsCardAreas: Card areas +AvsCardColor: Color AvsCardColorGreen: Green AvsCardColorBlue: Blue AvsCardColorRed: Red AvsCardColorYellow: Yellow LastAvsSynchronisation: Last AVS synchronisation -LastAvsSynchError: Last AVS Error \ No newline at end of file +LastAvsSynchError: Last AVS Error + +AvsInterfaceUnavailable: AVS interface was not configured correctly or does not respond +AvsUserUnassociated user: AVS id unknown for user #{user} +AvsUserUnknownByAvs api: AVS reports id #{tshow api} as unknown (or no longer known) +AvsUserAmbiguous api: Multiple matching users found for #{tshow api} +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 \ No newline at end of file diff --git a/messages/uniworx/categories/user/de-de-formal.msg b/messages/uniworx/categories/user/de-de-formal.msg index a3c630c46..573892220 100644 --- a/messages/uniworx/categories/user/de-de-formal.msg +++ b/messages/uniworx/categories/user/de-de-formal.msg @@ -102,3 +102,4 @@ Name !ident-ok: Name UsersChangeSupervisorsSuccess usr@Int spr@Int: #{tshow spr} Ansprechpartner für #{tshow usr} Benutzer gesetzt. UsersChangeSupervisorsWarning usr@Int spr@Int bad@Int: Nur _{MsgUsersChangeSupervisorsSuccess usr spr} #{tshow bad} Ansprechpartner #{pluralDE bad "wurde" "wurden"} nicht gefunden! UsersRemoveSupervisors usr@Int: Alle Ansprechpartner für #{tshow usr} Benutzer gelöscht. +SupervisorReason: Begründung \ No newline at end of file diff --git a/messages/uniworx/categories/user/en-eu.msg b/messages/uniworx/categories/user/en-eu.msg index 10c42830d..43bc1bf85 100644 --- a/messages/uniworx/categories/user/en-eu.msg +++ b/messages/uniworx/categories/user/en-eu.msg @@ -101,4 +101,5 @@ AuthKindNoLogin: No login Name: Name UsersChangeSupervisorsSuccess usr spr: #{pluralENsN spr "supervisor"} for #{pluralENsN usr "user"} set. UsersChangeSupervisorsWarning usr spr bad: Only _{MsgUsersChangeSupervisorsSuccess usr spr} #{pluralENsN bad "supervisors"} could not be identified! -UsersRemoveSupervisors usr: Removed all supervisors for #{pluralENsN usr "user"}. \ No newline at end of file +UsersRemoveSupervisors usr: Removed all supervisors for #{pluralENsN usr "user"}. +SupervisorReason: Reason \ No newline at end of file diff --git a/messages/uniworx/misc/de-de-formal.msg b/messages/uniworx/misc/de-de-formal.msg index 3fcd6ffe6..3ed3bd645 100644 --- a/messages/uniworx/misc/de-de-formal.msg +++ b/messages/uniworx/misc/de-de-formal.msg @@ -21,6 +21,7 @@ ClusterVolatileQuickActionsEnabled: Schnellzugriffsmenü aktiv AvsNoLicence: Keine Fahrberechtigung AvsLicenceVorfeld: Vorfeld Fahrberechtigung AvsLicenceRollfeld: Rollfeld Fahrberechtigung +AvsNoLicenceGuest: Keine Fahrberechtigung (Gast, Fahrberechtigungserwerb nicht möglich) PaginationSize: Einträge pro Seite PaginationPage: Angzeigte Seite diff --git a/messages/uniworx/misc/en-eu.msg b/messages/uniworx/misc/en-eu.msg index ed8bda4db..d652ed4ba 100644 --- a/messages/uniworx/misc/en-eu.msg +++ b/messages/uniworx/misc/en-eu.msg @@ -21,6 +21,7 @@ ClusterVolatileQuickActionsEnabled: Quick actions enabled AvsNoLicence: No driving licence AvsLicenceVorfeld: Apron driving licence AvsLicenceRollfeld: Maneuvering area driving licence +AvsNoLicenceGuest: No driving licence (Guest account, cannot acquire a diriving licence) PaginationSize: Rows per Page PaginationPage: Page to show diff --git a/messages/uniworx/utils/table_column/de-de-formal.msg b/messages/uniworx/utils/table_column/de-de-formal.msg index 0a67481af..43031fd5b 100644 --- a/messages/uniworx/utils/table_column/de-de-formal.msg +++ b/messages/uniworx/utils/table_column/de-de-formal.msg @@ -91,8 +91,10 @@ TableCompanyNrSupersDefault: Standard Ansprechpartner TableCompanyNrForeignSupers: Firmenfremde Ansprechpartner TableCompanyNrRerouteDefault: Standard Umleitungen TableCompanyNrRerouteActive: Aktive Umleitungen +TableRerouteActive: Umleitung TableCompanyPostalPreference: Benachrichtigungspräferenz neue Firmenangehörige TableSupervisor: Ansprechpartner +TableSupervisee: Ansprechpartner für TableCreationTime: Erstellungszeit TableJob !ident-ok: Job TableJobContent !ident-ok: Parameter diff --git a/messages/uniworx/utils/table_column/en-eu.msg b/messages/uniworx/utils/table_column/en-eu.msg index e7ae23a14..8546022d9 100644 --- a/messages/uniworx/utils/table_column/en-eu.msg +++ b/messages/uniworx/utils/table_column/en-eu.msg @@ -91,8 +91,10 @@ TableCompanyNrSupersDefault: Default supervisors TableCompanyNrForeignSupers: External Supervisors TableCompanyNrRerouteDefault: Default reroutes TableCompanyNrRerouteActive: Active reroutes +TableRerouteActive: Reroute TableCompanyPostalPreference: Default notification preference TableSupervisor: Supervisor +TableSupervisee: Supervisor for TableCreationTime: Creation TableJob !ident-ok: Job TableJobContent !ident-ok: Parameters diff --git a/models/audit.model b/models/audit.model index 3cd567a13..e61f11389 100644 --- a/models/audit.model +++ b/models/audit.model @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-23 Gregor Kleen ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -8,7 +8,7 @@ TransactionLog instance InstanceId initiator UserId Maybe -- User associated with performing this action remote IP Maybe -- Remote party that triggered this action via HTTP - info Value -- JSON-encoded `Transaction` + info Value -- JSON-encoded `Transaction`. Value allows full backwards compatibility deriving Eq Read Show Generic InterfaceLog @@ -29,3 +29,10 @@ InterfaceHealth hours Int UniqueInterfaceHealth interface subtype write !force -- Note that nullable fields must be either empty or unique deriving Eq Read Show Generic + +ProblemLog + time UTCTime default=now() + info Value -- generic JSON Value allows maximum backwards compatibility + solved UTCTime Maybe + solver UserId Maybe -- User who marked this problem as done + deriving Eq Read Show Generic \ No newline at end of file diff --git a/models/avs.model b/models/avs.model index 7a8a59cc0..067fb9d21 100644 --- a/models/avs.model +++ b/models/avs.model @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -16,27 +16,19 @@ UserAvs personId AvsPersonId -- unique identifier for user throughout avs; newtype for Int user UserId - noPerson Int default=0 -- only needed for manual communication with personnel from Ausweisverwaltungsstelle + noPerson Int default=0 -- only needed for manual communication with personnel from Ausweisverwaltungsstelle, redundant since needed for filtering lastSynch UTCTime default=now() lastSynchError Text Maybe + lastPersonInfo AvsPersonInfo Maybe -- just to discern field changes + lastFirmInfo AvsFirmInfo Maybe -- just to discern field changes + lastCardNo AvsFullCardNo Maybe -- just to discern changes UniqueUserAvsUser user UniqueUserAvsId personId deriving Generic Show --- Multiple UserAvsCards per UserAvs is possible and not too uncommon. --- Purpose of saving cards is to detect external changes in qualifications and postal addresses --- TODO: This table will be deleted if AVS CR3 SCF-165 is implemented -UserAvsCard - personId AvsPersonId - cardNo AvsFullCardNo - card AvsDataPersonCard - lastSynch UTCTime - -- UniqueAvsCard cardNo -- Note: cardNo is not unique; invalid cardNo may be reissued to different persons - deriving Generic - AvsSync user UserId -- Note: we need to lookup UserAvs Entity anyway, so no benefit from storing AvsPersonId here creationTime UTCTime - pause Day Maybe + pause Day Maybe -- Don't synch if last synch after this day, otherwise synch UniqueAvsSyncUser user deriving Generic \ No newline at end of file diff --git a/models/company.model b/models/company.model index c022ad5f1..7cf61bb5e 100644 --- a/models/company.model +++ b/models/company.model @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Sarah Vaupel ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Sarah Vaupel ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -6,20 +6,20 @@ Company name CompanyName -- == (CI Text) - shorthand CompanyShorthand -- == (CI Text) and CompanyKey :: CompanyShorthand -> CompanyId FUTURE TODO: a shorthand will become available through the AVS interface in the future - avsId Int default=0 -- primary key from avs + shorthand CompanyShorthand -- == (CI Text) and CompanyKey :: CompanyShorthand -> CompanyId A change to AvsId as primary key is too much work and not strictly necessary due to Uniqueness + avsId Int default=0 -- primary key from avs, use negative numbers for non-AVS companies prefersPostal Bool default=false -- new company users prefers letters by post instead of email - postAddress StoredMarkup Maybe -- default company postal address - email UserEmail Maybe -- Case-insensitive generic company eMail address + postAddress StoredMarkup Maybe -- default company postal address, including company name + email UserEmail Maybe -- Case-insensitive generic company eMail address UniqueCompanyName name - UniqueCompanyShorthand shorthand - -- UniqueCompanyAvsId avsId -- should be the case, unclear if enforcing works here, since we cannot query avs by company id - Primary shorthand -- newtype Key Company = CompanyKey { unCompanyKey :: CompanyShorthand } + -- UniqueCompanyShorthand shorthand -- unnecessary, since it is the primary key already + UniqueCompanyAvsId avsId + Primary shorthand -- newtype Key Company = CompanyKey { unCompanyKey :: CompanyShorthand } deriving Ord Eq Show Generic Binary -- TODO: a way to populate this table (manually) CompanySynonym synonym CompanyName - canonical CompanyShorthand OnDeleteCascade OnUpdateCascade + canonical CompanyShorthand OnDeleteCascade OnUpdateCascade -- DEPRECATED: should be CompanyId UniqueCompanySynonym synonym deriving Ord Eq Show Generic diff --git a/models/users.model b/models/users.model index b23fe85b2..f1e35c47e 100644 --- a/models/users.model +++ b/models/users.model @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -14,14 +14,14 @@ User json -- Each Uni2work user has a corresponding row in this table; created upon first login. surname UserSurname -- Display user names always through 'nameWidget displayName surname' displayName UserDisplayName - displayEmail UserEmail - email UserEmail -- Case-insensitive eMail address, used for sending TODO: make this nullable - ident UserIdent -- Case-insensitive user-identifier + displayEmail UserEmail -- Case-insensitive eMail address, used for sending; leave empty for using auto-update CompanyEmail via UserCompany + email UserEmail -- Case-insensitive eMail address, used for identification and fallback for sending. Defaults to "AVSNO:dddddddd" if unknown + ident UserIdent -- Case-insensitive user-identifier. Defaults to "AVSID:dddddddd" if unknown authentication AuthenticationMode -- 'AuthLDAP' or ('AuthPWHash'+password-hash) lastAuthentication UTCTime Maybe -- last login date created UTCTime default=now() lastLdapSynchronisation UTCTime Maybe - ldapPrimaryKey UserEduPersonPrincipalName Maybe + ldapPrimaryKey UserEduPersonPrincipalName Maybe -- Fraport Personnel Number or Email-Prefix for @fraport.de work here tokensIssuedAfter UTCTime Maybe -- do not accept bearer tokens issued before this time (accept all tokens if null) matrikelnummer UserMatriculation Maybe -- usually a number; AVS Personalnummer; nicht Fraport Personalnummer! firstName Text -- For export in tables, pre-split firstName from displayName @@ -44,9 +44,9 @@ User json -- Each Uni2work user has a corresponding row in this table; create mobile Text Maybe companyPersonalNumber Text Maybe -- Company will become a new table, but if company=fraport, some information is received via LDAP companyDepartment Text Maybe -- thus we store such information for ease of reference directly, if available - pinPassword Text Maybe -- used to encrypt pins within emails - postAddress StoredMarkup Maybe - postLastUpdate UTCTime Maybe -- record postal address updates + pinPassword Text Maybe -- used to encrypt pins within emails, defaults to cardno.version + postAddress StoredMarkup Maybe -- including company name, if any, but excluding username; leave empty for using auto-update CompanyPostAddress via UserCompany + postLastUpdate UTCTime Maybe -- record postal address updates prefersPostal Bool default=false -- user prefers letters by post instead of email examOfficeGetSynced Bool default=true -- whether synced status should be displayed for exam results by default examOfficeGetLabels Bool default=true -- whether labels should be displayed for exam results by default @@ -91,12 +91,16 @@ UserCompany 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 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) + 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 diff --git a/routes b/routes index 34ad73505..b3871ef8c 100644 --- a/routes +++ b/routes @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Wolfgang Witt +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Wolfgang Witt ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -70,7 +70,7 @@ /admin/avs AdminAvsR GET POST /admin/avs/#CryptoUUIDUser AdminAvsUserR GET /admin/ldap AdminLdapR GET POST -/admin/problems AdminProblemsR GET +/admin/problems AdminProblemsR GET POST /admin/problems/no-contact ProblemUnreachableR GET /admin/problems/no-avs-id ProblemWithoutAvsId GET /admin/problems/r-without-f ProblemFbutNoR GET diff --git a/src/Application.hs b/src/Application.hs index 4b60ecb39..83bda733e 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -124,7 +124,7 @@ import Handler.Utils.Memcached (manageMemcachedLocalInvalidations) import qualified System.Clock as Clock -import Utils.Avs +import Utils.Avs (mkAvsQuery) -- Import all relevant handler modules here. -- (HPack takes care to add new modules to our cabal file nowadays.) diff --git a/src/Audit.hs b/src/Audit.hs index 40c4a4206..06c5ca3d6 100644 --- a/src/Audit.hs +++ b/src/Audit.hs @@ -9,6 +9,7 @@ module Audit , AuditRemoteException(..) , getRemote , logInterface, logInterface' + , reportAdminProblem ) where @@ -152,7 +153,7 @@ logInterface' :: ( AuthId (HandlerSite m) ~ Key User -- ^ Log a transaction using information available from `HandlerT`, also calls `audit` logInterface' (Text.strip -> interfaceLogInterface) (Text.strip -> interfaceLogSubtype) interfaceLogWrite interfaceLogSuccess interfaceLogRows (Text.strip -> interfaceLogInfo) = do interfaceLogTime <- liftIO getCurrentTime - -- deleteBy $ UniqueInterfaceSubtypeWrite interfaceLogInterface interfaceLogSubtype interfaceLogWrite -- always replace: deleteBy & insert seems to be safest and fastest + -- deleteBy $ UniqueInterfaceSubtypeWrite interfaceLogInterface interfaceLogSubtype interfaceLogWrite -- deleteBy & insert would be justified here, leading to a new Row-ID, since the two rows are not truly connected. -- insert_ InterfaceLog{..} void $ upsertBy (UniqueInterfaceSubtypeWrite interfaceLogInterface interfaceLogSubtype interfaceLogWrite) ( InterfaceLog{..} ) @@ -169,3 +170,23 @@ logInterface' (Text.strip -> interfaceLogInterface) (Text.strip -> interfaceLogS , transactionInterfaceInfo = interfaceLogInfo , transactionInterfaceSuccess = Just interfaceLogSuccess } + +reportAdminProblem :: ( IsSqlBackend (YesodPersistBackend (HandlerSite m)) + , SqlBackendCanWrite (YesodPersistBackend (HandlerSite m)) + , MonadHandler m + -- , HasCallStack + ) + => AdminProblem -- ^ Problem to record + -> ReaderT (YesodPersistBackend (HandlerSite m)) m () +-- ^ Log a problem that needs interventions by admins +-- +-- - `problemLogTime` is now +-- - `problemSolver` is Nothing, we do not record the person who caused it +reportAdminProblem problem@(toJSON -> problemLogInfo) = do + problemLogTime <- liftIO getCurrentTime + let problemLogSolved = Nothing + problemLogSolver = Nothing + insert_ ProblemLog{..} + $logWarnS "Problem" $ Text.filter (/= '\n') $ tshow problem -- <> " - " <> pack (prettyCallStack callStack) + + diff --git a/src/Audit/Types.hs b/src/Audit/Types.hs index 976171ec4..1b7bf5cb8 100644 --- a/src/Audit/Types.hs +++ b/src/Audit/Types.hs @@ -1,15 +1,18 @@ --- SPDX-FileCopyrightText: 2022-23 Gregor Kleen ,Sarah Vaupel ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Sarah Vaupel ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later module Audit.Types ( Transaction(..) + , AdminProblem(..) + , decodeAdminProblem ) where import ClassyPrelude.Yesod hiding (derivePersistFieldJSON) import Model.Types.TH.JSON import Model +import Data.Aeson import Data.Aeson.TH import Utils.PathPiece @@ -251,4 +254,47 @@ deriveJSON defaultOptions , sumEncoding = TaggedObject "transaction" "data" } ''Transaction -derivePersistFieldJSON ''Transaction \ No newline at end of file +derivePersistFieldJSON ''Transaction + + + +-- Datatype for raising admin awareness to certain problems +-- Database stores generic Value in table ProblemLog, such that changes do not disturb old entries +-- Note that is no RenderMessage instance, instead see @Handler.Admin.adminProblemCell +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? + } + | AdminProblemNewlyUnsupervised + { adminProblemUser :: UserId -- user who had supervsior but no longer has + , adminProblemCompanyOld :: Maybe CompanyId -- old company + , adminProblemCompanyNew :: CompanyId -- new company of the user + } + | AdminProblemUnknown -- miscellanous problem, just displaying text + { adminProblemText :: Text + } + deriving (Eq, Ord, Read, Show, Generic) + +-- Columns shown in problem table: adminProblemCompany, adminProblemUser +-- For display: add clause to Handler.Admin.adminProblemCell + +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece' 2 + , fieldLabelModifier = camelToPathPiece' 2 + , tagSingleConstructors = True + , sumEncoding = TaggedObject "problem" "data" + , rejectUnknownFields = False + } ''AdminProblem + +derivePersistFieldJSON ''AdminProblem + +decodeAdminProblem :: Value -> AdminProblem +decodeAdminProblem v = case fromJSON v of + Error msg -> AdminProblemUnknown $ pack msg + Success p -> p diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 127e0ed88..499cded08 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -32,6 +32,7 @@ module Database.Esqueleto.Utils , orderByOrd, orderByEnum , strip, lower, ciEq , selectExists, selectNotExists + , filterExists , SqlHashable , sha256 , isTrue, isFalse @@ -41,16 +42,17 @@ module Database.Esqueleto.Utils , greatest, least , abs , SqlProject(..) - , (->.), (->>.), (#>>.) + , (->.), (->>.), (->>>.), (#>>.) , fromSqlKey , unKey , subSelectCountDistinct , selectCountRows, selectCountDistinct , selectMaybe - , num2text + , num2text --, text2num , day, day', dayMaybe, interval, diffDays, diffTimes , exprLift , explicitUnsafeCoerceSqlExprValue + , truncateTable , module Database.Esqueleto.Utils.TH ) where @@ -67,6 +69,8 @@ import qualified Database.Esqueleto.PostgreSQL as E import qualified Database.Esqueleto.Internal.Internal as E import Database.Esqueleto.Utils.TH +import qualified Database.Persist.Postgresql as P + import qualified Data.Text as Text import qualified Data.Text.Lazy as Lazy (Text) import qualified Data.ByteString.Lazy as Lazy (ByteString) @@ -351,7 +355,7 @@ mkExactFilterMaybeLast' lensexists lenslike row criterias -- | generic filter creation for dbTable -- Given a lens-like function, make filter searching for needles in String-like elements -- (Keep Set here to ensure that there are no duplicates) -mkContainsFilter :: E.SqlString a +mkContainsFilter :: (E.SqlString a, Ord a) => (t -> E.SqlExpr (E.Value a)) -- ^ getter from query to searched element -> t -- ^ query row -> Set.Set a -- ^ needle collection @@ -359,7 +363,7 @@ mkContainsFilter :: E.SqlString a mkContainsFilter = mkContainsFilterWith id -- | like `mkContainsFilter` but allows for conversion; convenient in conjunction with `anyFilter` and `allFilter` -mkContainsFilterWith :: E.SqlString b +mkContainsFilterWith :: (E.SqlString b, Ord a) => (a -> b) -> (t -> E.SqlExpr (E.Value b)) -- ^ getter from query to searched element -> t -- ^ query row @@ -367,7 +371,7 @@ mkContainsFilterWith :: E.SqlString b -> E.SqlExpr (E.Value Bool) mkContainsFilterWith cast lenslike row criterias | Set.null criterias = true - | otherwise = any (hasInfix $ lenslike row) (E.val . cast <$> Set.toList criterias) + | otherwise = any (hasInfix (lenslike row) . E.val . cast) criterias -- | like `mkContainsFilterWith` but allows conversion to produce multiple needles mkContainsFilterWithSet :: (E.SqlString b, Ord b, Ord a) @@ -378,7 +382,7 @@ mkContainsFilterWithSet :: (E.SqlString b, Ord b, Ord a) -> E.SqlExpr (E.Value Bool) mkContainsFilterWithSet cast lenslike row criterias | Set.null criterias = true - | otherwise = any (hasInfix $ lenslike row) (E.val <$> Set.toList (foldMap cast criterias)) + | otherwise = any (hasInfix (lenslike row) . E.val) (foldMap cast criterias) -- | like `mkContainsFilterWithSet` but fixed to comma separated Texts mkContainsFilterWithComma :: (E.SqlString b, Ord b) @@ -389,7 +393,7 @@ mkContainsFilterWithComma :: (E.SqlString b, Ord b) -> E.SqlExpr (E.Value Bool) mkContainsFilterWithComma cast lenslike row (foldMap commaSeparatedText -> criterias) | Set.null criterias = true - | otherwise = any (hasInfix $ lenslike row) (E.val . cast <$> Set.toList criterias) + | otherwise = any (hasInfix (lenslike row) . E.val . cast) criterias -- | like `mkContainsFilterWithComma` but enforced the existence of all Texts prefixed with + mkContainsFilterWithCommaPlus :: (E.SqlString b, Ord b) @@ -405,8 +409,8 @@ mkContainsFilterWithCommaPlus cast lenslike row (foldMap commaSeparatedText -> c | otherwise = cond_compulsory E.&&. cond_optional where (Set.mapMonotonic (Text.stripStart . Text.drop 1) -> compulsories, alternatives) = Set.partition (Text.isPrefixOf "+") criterias - cond_compulsory = all (hasInfix $ lenslike row) (E.val . cast <$> Set.toList compulsories) - cond_optional = any (hasInfix $ lenslike row) (E.val . cast <$> Set.toList alternatives) + cond_compulsory = all (hasInfix (lenslike row) . E.val . cast) compulsories + cond_optional = any (hasInfix (lenslike row) . E.val . cast) alternatives mkDayFilter :: (t -> E.SqlExpr (E.Value UTCTime)) -- ^ getter from query to searched element -> t -- ^ query row @@ -451,7 +455,7 @@ mkExistsFilterWithComma :: PathPiece a -> E.SqlExpr (E.Value Bool) mkExistsFilterWithComma cast query row (foldMap commaSeparatedText -> criterias) | Set.null criterias = true - | otherwise = any (E.exists . query row) (cast <$> Set.toList criterias) + | otherwise = any (E.exists . query row . cast) criterias -- | Combine several filters, using logical or @@ -510,6 +514,13 @@ selectExists query = do _other -> error "SELECT EXISTS ... returned zero or more than one rows" selectNotExists = fmap not . selectExists +filterExists :: (MonadIO m, PersistEntity val, MonoFoldable mono, PersistField (Element mono)) + => EntityField val (Element mono) -> mono -> E.SqlReadT m [Element mono] +filterExists prj vs = fmap (fmap Ex.unValue) <$> Ex.select $ do + ent <- Ex.from Ex.table + Ex.where_ $ ent Ex.^. prj `Ex.in_` vals vs + return $ ent Ex.^. prj + class SqlHashable a instance SqlHashable Text @@ -603,7 +614,7 @@ max, min :: PersistField a max a b = bool a b $ b E.>. a min a b = bool a b $ b E.<. a --- these alternatives for max/min ought to be more efficient; note that NULL is avoided by PostgreSQL greatest/least +-- these alternatives for max/min ought to be more efficient; note that NULL is avoided by PostgreSQL greatest/least; for Bool: t > f greatest :: PersistField a => E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value a) greatest a b = E.unsafeSqlFunction "GREATEST" $ E.toArgList (a,b) @@ -642,9 +653,15 @@ infixl 8 ->. infixl 8 ->>. -(->>.) :: E.SqlExpr (E.Value a) -> Text -> E.SqlExpr (E.Value Text) +(->>.) :: E.SqlExpr (E.Value a) -> Text -> E.SqlExpr (E.Value Text) (->>.) expr t = E.unsafeSqlBinOp "->>" expr $ E.val t +infixl 8 ->>>. + +-- Unsafe variant to obtain a DB key from a JSON field. Use with caution! +(->>>.) :: (PersistField (Key entity)) => E.SqlExpr (E.Value a) -> Text -> E.SqlExpr (E.Value (Maybe (Key entity))) +(->>>.) expr t = E.unsafeSqlCastAs "int" $ E.unsafeSqlBinOp "->>" expr $ E.val t + infixl 8 #>>. (#>>.) :: E.SqlExpr (E.Value a) -> Text -> E.SqlExpr (E.Value (Maybe Text)) @@ -692,6 +709,10 @@ selectMaybe = fmap listToMaybe . E.select . (<* E.limit 1) num2text :: Num n => E.SqlExpr (E.Value n) -> E.SqlExpr (E.Value Text) num2text = E.unsafeSqlCastAs "text" +-- unsafe, use with care! +-- text2num :: E.SqlExpr (E.Value Text) -> E.SqlExpr (E.Value n) +-- text2num = E.unsafeSqlCastAs "int" + day :: E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value Day) day = E.unsafeSqlCastAs "date" @@ -750,3 +771,7 @@ instance (PersistField a1, PersistField a2, PersistField b, Finite a1, Finite a2 ] (E.else_ $ E.else_ $ E.veryUnsafeCoerceSqlExprValue (E.nothing :: E.SqlExpr (E.Value (Maybe ())))) + +truncateTable :: (MonadIO m, BackendCompatible SqlBackend backend, PersistEntity record) + => record -> ReaderT backend m () +truncateTable tbl = E.rawExecute ("TRUNCATE TABLE " <> P.tableName tbl <> " RESTART IDENTITY") [] \ No newline at end of file diff --git a/src/Foundation/I18n.hs b/src/Foundation/I18n.hs index fd2bb9479..8fc50b5e4 100644 --- a/src/Foundation/I18n.hs +++ b/src/Foundation/I18n.hs @@ -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) @@ -602,7 +605,7 @@ unRenderMessage = unRenderMessage' (==) unRenderMessageLenient :: forall a master. (Ord a, Finite a, RenderMessage master a) => master -> Text -> [a] unRenderMessageLenient = unRenderMessage' cmp - where cmp = (==) `on` mk . under packed (filter Char.isAlphaNum . concatMap unidecode) + where cmp = (==) `on` mk . under packed (concatMap $ filter Char.isAlphaNum . unidecode) instance Default DateTimeFormatter where diff --git a/src/Foundation/Type.hs b/src/Foundation/Type.hs index 5c77e9863..162eb0887 100644 --- a/src/Foundation/Type.hs +++ b/src/Foundation/Type.hs @@ -43,7 +43,7 @@ import Data.Time.Clock.POSIX (POSIXTime) import GHC.Fingerprint (Fingerprint) import Handler.Sheet.PersonalisedFiles.Types (PersonalisedSheetFilesSeedKey) -import Utils.Avs (AvsQuery) +import Utils.Avs (AvsQuery()) type SMTPPool = Pool SMTPConnection diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs index efabadc80..9e9aa85c6 100644 --- a/src/Foundation/Yesod/Auth.hs +++ b/src/Foundation/Yesod/Auth.hs @@ -182,7 +182,7 @@ upsertCampusUser upsertMode ldapData = do userDefaultConf <- getsYesod $ view _appUserDefaults (newUser,userUpdate) <- decodeUser now userDefaultConf upsertMode ldapData - --TODO: newUser should be associated with a company and company supervisor through Handler.Utils.Company.upsertUserCompany, but this is called by upsertAvsUser already - conflict? + --TODO: newUser should be associated with a company and company supervisor through Handler.Utils.Company.oldUpsertUserCompany, but this is called by upsertAvsUser already - conflict? oldUsers <- for (userLdapPrimaryKey newUser) $ \pKey -> selectKeysList [ UserLdapPrimaryKey ==. Just pKey ] [] diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index fd001c768..f07476330 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -8,17 +8,19 @@ 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 @@ -33,12 +35,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 +79,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 +111,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 +214,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 +284,103 @@ 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 AdminProblemNewlyUnsupervised{adminProblemCompanyNew} + = i18nCell MsgAdminProblemNewlyUnsupervised <> companyIdCell adminProblemCompanyNew +adminProblemCell AdminProblemUnknown{adminProblemText} + = textCell $ "Problem: " <> adminProblemText diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index 9521912c9..cfcbd973c 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -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 @@ -28,8 +28,6 @@ import Handler.Utils import Handler.Utils.Avs -- import Handler.Utils.Qualification -import Utils.Avs - import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Legacy as E @@ -43,6 +41,13 @@ import qualified Database.Esqueleto.Utils as E single :: (k,a) -> Map k a single = uncurry Map.singleton +exceptionWgt :: SomeException -> Widget +exceptionWgt (SomeException e) = [whamlet|

Error:

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

+ AVS Konfiguration +