fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge branch 'fradrive/cr3'

Browse Source
This commit is contained in:
Steffen Jost 2024-04-26 18:14:17 +02:00
commit b8d41d10c9
80 changed files with 4895 additions and 1195 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
config/settings.yml
View File

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

19
messages/uniworx/categories/admin/de-de-formal.msg
View File

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

27
messages/uniworx/categories/admin/en-eu.msg
View File

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

21
messages/uniworx/categories/avs/de-de-formal.msg
View File

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

27
messages/uniworx/categories/avs/en-eu.msg
View File

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

1
messages/uniworx/categories/user/de-de-formal.msg
View File

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

3
messages/uniworx/categories/user/en-eu.msg
View File

@ -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"}.
UsersRemoveSupervisors usr: Removed all supervisors for #{pluralENsN usr "user"}.
SupervisorReason: Reason

1
messages/uniworx/misc/de-de-formal.msg
View File

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

1
messages/uniworx/misc/en-eu.msg
View File

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

2
messages/uniworx/utils/table_column/de-de-formal.msg
View File

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

2
messages/uniworx/utils/table_column/en-eu.msg
View File

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

11
models/audit.model
View File

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

20
models/avs.model
View File

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

18
models/company.model
View File

@ -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
canonical CompanyShorthand OnDeleteCascade OnUpdateCascade -- DEPRECATED: should be CompanyId
UniqueCompanySynonym synonym
deriving Ord Eq Show Generic

26
models/users.model
View File

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

4
routes
View File

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

2
src/Application.hs
View File

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

23
src/Audit.hs
View File

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

50
src/Audit/Types.hs
View File

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

49
src/Database/Esqueleto/Utils.hs
View File

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

5
src/Foundation/I18n.hs
View File

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

2
src/Foundation/Type.hs
View File

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

2
src/Foundation/Yesod/Auth.hs
View File

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

164
src/Handler/Admin.hs
View File

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

510
src/Handler/Admin/Avs.hs
View File

@ -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|<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 +145,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 +382,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 +413,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
@ -680,49 +679,150 @@ 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|
<p>
Vorläufige Admin Ansicht AVS Daten.
Ansicht zeigt aktuelle Daten.
Es erfolgte damit aber noch kein Update der FRADrive Daten.
<p>
<dl .deflist>
<dt .deflist__dt>InfoPersonContact <br>
<i>(bevorzugt)
<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)
<dd .deflist__dd>
$maybe dataPerson <- mbDataPerson
#{decodeUtf8 (Pretty.encodePretty (toJSON dataPerson))}
$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}
|]
let heading = [whamlet|_{MsgAvsPersonNo} #{userAvsNoPerson}|]
Entity{entityVal=UserAvs{..}} <- runDB $ getBy404 $ UniqueUserAvsUser uid
mbContact <- try $ avsQuery $ AvsQueryContact $ Set.singleton $ AvsObjPersonId userAvsPersonId
mbStatus <- try $ avsQuery $ AvsQueryStatus $ Set.singleton userAvsPersonId
-- mbDataPerson <- lookupAvsUser userAvsPersonId -- TODO: delete Handler.Utils.Avs.lookupAvsUser if no longer needed
msgWarningTooltip <- messageI Warning MsgMessageWarning
let warnBolt = messageTooltip msgWarningTooltip
heading = [whamlet|_{MsgAvsPersonNo} #{userAvsNoPerson}|]
siteLayout heading $ do
setTitle $ toHtml $ show userAvsNoPerson
resWgt
let contactWgt = case mbContact of
Left err -> exceptionWgt err
Right (AvsResponseContact adcs) -> do
let cs = mkContactWgt warnBolt userAvsNoPerson <$> toList adcs
mconcat cs
cardsWgt = case mbStatus of
Left err -> exceptionWgt err
Right (AvsResponseStatus asts) -> do
let cs = mkCardsWgt . avsStatusPersonCardStatus <$> toList asts
mconcat cs
-- cardsWgt = case mbDataPerson of
-- Nothing -> mempty
-- Just AvsDataPerson{avsPersonPersonCards=crds} -> mkCardsWgt crds
[whamlet|
<p>
Die Ansicht zeigt ausschließlich kürzlich vom AVS abgerufene Daten:
<p>
^{contactWgt}
<p>
^{cardsWgt}
|]
-- <p>
-- Vorläufige Admin Ansicht AVS Daten.
-- Ansicht zeigt aktuelle Daten.
-- Es erfolgte damit aber noch kein Update der FRADrive Daten.
-- <p>
-- <dl .deflist>
-- <dt .deflist__dt>InfoPersonContact <br>
-- <i>(bevorzugt)
-- <dd .deflist__dd>
-- $case mbContact
-- $of Left err
-- ^{exceptionWgt err}
-- $of Right contactInfo
-- #{decodeUtf8 (Pretty.encodePretty (toJSON contactInfo))}
-- <dt .deflist__dt>PersonStatus und mehrere PersonSearch <br>
-- <i>(benötigt mehrere AVS Abfragen)
-- <dd .deflist__dd>
-- $maybe dataPerson <- mbDataPerson
-- #{decodeUtf8 (Pretty.encodePretty (toJSON dataPerson))}
-- $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}
-- |]
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>
#{avsInfoLastName}
<dt .deflist__dt>
_{MsgAvsFirstName}
<dd .deflist__dd>
#{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
_{MsgAvsNoLicenceGuest}
|]
mkCardsWgt :: Set AvsDataPersonCard -> Widget
mkCardsWgt crds =
[whamlet|
<table>
<thead>
<th>_{MsgAvsCardNo}
<th>_{MsgTableAvsCardValid}
<th>_{MsgAvsCardColor}
<th>_{MsgAvsCardAreas}
<th>_{MsgTableCompany}
<th>_{MsgTableAvsCardIssueDate}
<th>_{MsgTableAvsCardValidTo}
<tbody>
$forall c <- crds
$with AvsDataPersonCard{avsDataValid,avsDataCardColor,avsDataCardAreas,avsDataFirm,avsDataIssueDate,avsDataValidTo} <- c
<tr>
<td>
#{tshowAvsFullCardNo (getFullCardNo c)}
<td>
#{boolSymbol avsDataValid}
<td>
_{avsDataCardColor}
<td>
$forall a <- avsDataCardAreas
#{a} #
<td>
$maybe f <- avsDataFirm
#{f}
<td>
$maybe d <- avsDataIssueDate
^{formatTimeW SelFormatDate d}
<td>
$maybe d <- avsDataValidTo
^{formatTimeW SelFormatDate d}
|]
instance HasEntity (DBRow (Entity UserAvs, Entity User)) User where
hasEntity = _dbrOutput . _2
@ -740,7 +840,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 +848,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

2
src/Handler/Admin/Test.hs
View File

@ -354,7 +354,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

6
src/Handler/Course/Edit.hs
View File

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

2
src/Handler/Course/User.hs
View File

@ -11,7 +11,7 @@ import Import
import Utils.Form
import Handler.Utils
import Handler.Utils.SheetType
import Handler.Utils.Profile (pickValidEmail)
import Handler.Utils.Profile (pickValidUserEmail)
import Handler.Utils.StudyFeatures
import Handler.Submission.List

61
src/Handler/Firm.hs
View File

@ -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
@ -229,14 +232,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 +257,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 +287,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 +312,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 +622,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 +635,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 +1029,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 +1050,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

10
src/Handler/LMS.hs
View File

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

8
src/Handler/LMS/Fake.hs
View File

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

113
src/Handler/Profile.hs
View File

@ -2,6 +2,8 @@
--
-- 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)
@ -581,10 +584,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 +627,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 +1013,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

13
src/Handler/Qualification.hs
View File

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

12
src/Handler/Users.hs
View File

@ -64,8 +64,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)
@ -192,9 +192,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,8 +370,8 @@ 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, _)) ->
hijackUser uid >>= sendResponse
@ -385,7 +387,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

1010
src/Handler/Utils/Avs.hs
View File

File diff suppressed because it is too large Load Diff

4
src/Handler/Utils/Communication.hs
View File

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

78
src/Handler/Utils/Company.hs
View File

@ -8,53 +8,39 @@ 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
import Database.Persist.Postgresql
-- 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
-- | 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?
-- | 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
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)
-- 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 ]
]
)
-- | 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

6
src/Handler/Utils/Concurrent.hs
View File

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

55
src/Handler/Utils/Mail.hs
View File

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

28
src/Handler/Utils/Pandoc.hs
View File

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

55
src/Handler/Utils/Profile.hs
View File

@ -1,13 +1,13 @@
-- 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
, validDisplayName, checkDisplayName, fixDisplayName
, validPostAddress, validPostAddressText
, validFraportPersonalNumber
) where
@ -16,16 +16,12 @@ 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.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
-- | 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
@ -70,38 +66,19 @@ validDisplayName (fmap stripFold -> mTitle) (stripFold -> fName) (stripFold -> s
-- | 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 (Just StoredMarkup {markupInput = addr}) = validPostAddressLazyText addr
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
validPostAddressText :: Text -> Bool
validPostAddressText = validPostAddressLazyText . LT.fromStrict
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
validPostAddressLazyText :: LT.Text -> Bool
validPostAddressLazyText addr
| Just _ <- LT.find isLetter addr
, Just _ <- LT.find isNumber addr
-- , Just _ <- LT.find ((LineSeparator ==) . generalCategory) addr -- THIS DID NOT WORK
= 1 < length (LT.lines addr)
validPostAddressLazyText _ = False
validFraportPersonalNumber :: Maybe Text -> Bool
validFraportPersonalNumber Nothing = False

13
src/Handler/Utils/Table/Cells.hs
View File

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

39
src/Handler/Utils/Table/Columns.hs
View File

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

30
src/Handler/Utils/Table/Pagination.hs
View File

@ -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>
--
-- 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)
@ -1198,13 +1210,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 +1237,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
@ -1671,7 +1689,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

169
src/Handler/Utils/Users.hs
View File

@ -12,12 +12,15 @@ module Handler.Utils.Users
, NameMatchQuality(..)
, matchesName
, GuessUserInfo(..)
, guessUser
, guessUser, guessUserByEmail
, UserAssimilateException(..), UserAssimilateExceptionReason(..)
, assimilateUser
, userPrefersEmail, userPrefersLetter
, getEmailAddress
, getPostalAddress, getPostalPreferenceAndAddress
, getUserPrimaryCompany
, 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,93 @@ abbrvName User{userDisplayName, userFirstName, userSurname} =
assemble = Text.intercalate "."
-- deprecated, used getPostalPreferenceAndAddress
userPrefersLetter :: User -> Bool
userPrefersLetter = fst . getPostalPreferenceAndAddress
getUserPrimaryCompany :: UserId -> (Company -> Maybe a) -> DB (Maybe a)
getUserPrimaryCompany uid prj = runMaybeT $ do
Entity{entityVal=UserCompany{userCompanyCompany=cid}} <- MaybeT $
selectFirst [UserCompanyUser ==. uid, UserCompanyUseCompanyAddress ==. True]
[Desc UserCompanyPriority, Desc UserCompanySupervisorReroute, Desc UserCompanySupervisor, Asc UserCompanyCompany]
company <- MaybeT $ get cid
-- hoistMaybe $ prj company
MaybeT $ pure $ prj company
-- deprecated, used getPostalPreferenceAndAddress
userPrefersEmail :: User -> Bool
userPrefersEmail = not . userPrefersLetter
-- | 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) 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
-- 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 <- getUserPrimaryCompany 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
getUserPrimaryCompany 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
getUserPrimaryCompany 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 +200,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 +352,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 +936,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 +955,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 +975,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 +992,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
View 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
```

8
src/Jobs/Handler/ChangeUserDisplayEmail.hs
View File

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

10
src/Jobs/Handler/Invitation.hs
View File

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

5
src/Jobs/Handler/LMS.hs
View File

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

7
src/Jobs/Handler/QueueNotification.hs
View File

@ -16,7 +16,8 @@ import Jobs.Queue
import qualified Data.Set as Set
import Handler.Utils.Profile (pickValidEmail')
-- import Handler.Utils.Profile (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

20
src/Jobs/Handler/SendCourseCommunication.hs
View File

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

19
src/Jobs/Handler/SendNotification/SubmissionEdited.hs
View File

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

14
src/Jobs/Handler/SendNotification/SubmissionRated.hs
View File

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

153
src/Jobs/Handler/SynchroniseAvs.hs
View File

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

2
src/Jobs/Handler/SynchroniseLdap.hs
View File

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

22
src/Jobs/Types.hs
View File

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

22
src/Model/Migration/Definitions.hs
View File

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

151
src/Model/Types/Avs.hs
View File

@ -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
@ -25,7 +25,7 @@ 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
{-
@ -77,13 +77,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 +110,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 +159,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 +202,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 +246,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 +308,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 +348,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 +417,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 }
@ -411,7 +449,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 +523,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 +565,7 @@ instance ToJSON AvsPersonInfo where
, "LastName" .= avsInfoLastName
, "RampLicence" .= avsInfoRampLicence
]
-- derivePersistFieldJSON ''AvsPersonInfo
derivePersistFieldJSON ''AvsPersonInfo
data AvsFirmCommunication = AvsFirmCommunication
@ -527,7 +574,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 +587,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 +608,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,15 +621,28 @@ 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 declared in Handler.Utils.Avs due to required dependencies:
-- _avsFirmPostAddress :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe StoredMarkup)
-- _avsFirmPrefersPostal :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo Bool
-- _avsFirmPrimaryEmail :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe Text)
-- 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 .: "Firm" <&> Text.strip) -- AVS may contain leading/trailing whitespace
<*> o .: "FirmNo"
<*> o .: "Abbreviation"
<*> (o .: "Abbreviation" <&> Text.strip) -- AVS may contain leading/trailing whitespace
<*> o .:?! "ZIPCode"
<*> o .:?! "City"
<*> o .:?! "Country"
@ -600,14 +665,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 +695,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 +708,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 +719,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 +756,7 @@ deriveJSON defaultOptions
-------------
-- Queries --
-------------
data AvsQueryPerson = AvsQueryPerson
{ avsPersonQueryCardNo :: Maybe AvsCardNo
, avsPersonQueryVersionNo :: Maybe AvsVersionNo
@ -695,7 +764,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 +777,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.

5
src/Model/Types/Markup.hs
View File

@ -32,6 +32,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
@ -67,7 +68,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 +80,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
}

13
src/Model/Types/Misc.hs
View File

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

14
src/Settings.hs
View File

@ -330,6 +330,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 +531,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"

110
src/Utils.hs
View File

@ -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)]
@ -907,13 +929,16 @@ 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 +950,9 @@ positiveSum = maybePositive . getSum
maybeM :: Monad m => m b -> (a -> m b) -> m (Maybe a) -> m b
maybeM dft act mb = mb >>= maybe dft act
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,7 +1212,6 @@ shortCircuitM sc binOp mx my = do
| sc x -> return x
| otherwise -> binOp x <$> my
guardM :: MonadPlus m => m Bool -> m ()
guardM f = guard =<< f
@ -1193,6 +1254,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 +1284,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 +1758,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)

55
src/Utils/Avs.hs
View File

@ -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,7 +76,20 @@ avsQueryAllLicences = AvsQueryGetLicences $ AvsObjPersonId avsPersonIdZero
mkAvsQuery :: BaseUrl -> BasicAuthData -> ClientEnv -> AvsQuery
#ifdef DEVELOPMENT
mkAvsQuery _ _ _ = AvsQuery
{ avsQueryPerson = \_ -> return . Right $ AvsResponsePerson mempty
{ avsQueryPerson =
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
in \case
AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "00001234"), avsPersonQueryVersionNo=Just "4"} -> return . Right $ AvsResponsePerson steffen
AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "00001234")} -> return . Right $ AvsResponsePerson steffen
AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "00009944"), avsPersonQueryVersionNo=Just "4"} -> return . Right $ AvsResponsePerson stephan
AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "00003344"), avsPersonQueryVersionNo=Just "1"} -> return . Right $ AvsResponsePerson sarah
AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "34")} -> return . Right $ AvsResponsePerson $ steffen <> sarah
AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "4") , avsPersonQueryVersionNo=Just "4"} -> return . Right $ AvsResponsePerson $ steffen <> stephan
_ -> 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)
, avsQuerySetLicences = \_ -> return . Right $ AvsResponseSetLicences mempty
@ -78,10 +97,11 @@ mkAvsQuery _ _ _ = AvsQuery
}
#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 +124,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
@ -114,18 +135,18 @@ splitQuery rawQuery q
-- Utility Functions --
-----------------------
-- | 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

80
src/Utils/DB.hs
View File

@ -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,6 +107,22 @@ 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
@ -142,6 +177,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 +254,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))

9
src/Utils/Icon.hs
View File

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

13
src/Utils/Lens.hs
View File

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

43
src/Utils/Pandoc.hs Normal file
View File

@ -0,0 +1,43 @@
-- SPDX-FileCopyrightText: 2022-2024 Gregor Kleen <gregor.kleen@ifi.lmu.de>, Steffen Jost <s.jost@fraport.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
module Utils.Pandoc where
import Import.NoModel
import Data.Either (fromRight)
-- import qualified Data.Char as Char
-- import qualified Data.Text as Text
-- import qualified Data.CaseInsensitive as CI
import Text.Blaze (toMarkup)
import Text.Blaze.Html.Renderer.Text (renderHtml)
import qualified Text.Pandoc as P
markdownToHtml :: Html -> Either P.PandocError Html
markdownToHtml html = P.runPure $ P.writeHtml5 htmlWriterOptions =<< P.readMarkdown markdownReaderOptions (toStrict $ renderHtml html)
plaintextToHtml :: Text -> Html
plaintextToHtml text = fromRight (toMarkup text) $ P.runPure $
P.writeHtml5 htmlWriterOptions =<< P.readMarkdown markdownReaderOptions text
-- Line below does not work as intended, also see Handler.Utils.Pandoc.plaintextToMarkdownWith which uses this code
-- where pandoc = P.Pandoc mempty [P.Plain [P.Str text]]
htmlReaderOptions, markdownReaderOptions :: P.ReaderOptions
htmlReaderOptions = markdownReaderOptions
markdownReaderOptions = def
{ P.readerExtensions = P.pandocExtensions
& P.enableExtension P.Ext_hard_line_breaks
& P.enableExtension P.Ext_autolink_bare_uris
, P.readerTabStop = 2
}
markdownWriterOptions, htmlWriterOptions :: P.WriterOptions
markdownWriterOptions = def
{ P.writerExtensions = P.readerExtensions markdownReaderOptions
, P.writerTabStop = P.readerTabStop markdownReaderOptions
}
htmlWriterOptions = markdownWriterOptions

17
src/Utils/Persist.hs
View File

@ -1,10 +1,13 @@
-- 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
-- also see Utils.DB
module Utils.Persist
( fromPersistValueError
, fromPersistValueErrorSql
, (~=.), (~~.)
) where
import ClassyPrelude
@ -37,3 +40,15 @@ fromPersistValueErrorSql :: forall p a.
-> PersistValue
-> Text
fromPersistValueErrorSql _ = fromPersistValueError (tshow $ typeRep @a) (tshow $ sqlType (Proxy @a))
infix 4 ~=.
-- | is equal or Nothing, do not confuse with Database.Esqueleto.Utils(~=.) which does the same for proper Esqueleto queries
(~=.) :: PersistField a => EntityField v (Maybe a) -> a -> [Filter v]
(~=.) f v = [f ==. Nothing] ||. [f ==. Just v]
infix 4 ~~.
-- | maybe is equal or Nothing,
(~~.) :: PersistField a => EntityField v (Maybe a) -> Maybe a -> [Filter v]
(~~.) f Nothing = [f ==. Nothing]
(~~.) f (Just v) = [f ==. Nothing] ||. [f ==. Just v]

86
src/Utils/Print.hs
View File

@ -145,51 +145,41 @@ pdfLaTeX lk doc = do
let writerOpts = def { P.writerExtensions = P.pandocExtensions
, P.writerTemplate = Just tmpl }
makePDF writerOpts $ appMeta setIsDeFromLang doc
renderLetterPDF :: (MDLetter l) => Entity User -> l -> Text -> Handler (Either Text LBS.ByteString)
renderLetterPDF rcvrEnt@Entity{entityVal=rcvr} mdl apcIdent = do
letterTemplate :: (MDLetter l) => Entity User -> l -> Text -> Maybe [Text] -> Handler (Either Text P.Pandoc)
letterTemplate rcvrEnt@Entity{entityVal=rcvr} mdl apcIdent rcvrPostalRaw = do
now <- liftIO getCurrentTime
formatter@DateTimeFormatter{ format } <- getDateTimeFormatterUser' rcvr
let lang = selectDeEn $ rcvr & userLanguages -- select either German or English only, default de; see Utils.Lang
kind = getLetterKind mdl
tmpl = getTemplate mdl
rcvrPostal <- altM (return rcvrPostalRaw) $ runDB $ getPostalAddress rcvrEnt
-- (_,rcvrPostal, rcvrEmail) <- runDB $ getPostalPreferenceAndAddress
let lang = selectDeEn $ rcvr & userLanguages -- select either German or English only, default de; see Utils.Lang
tmpl = getTemplate mdl
meta = addApcIdent apcIdent
<> letterMeta mdl formatter lang rcvrEnt
<> mkMeta
[ -- toMeta "lang" lang -- receiver language is decided in MDLetter instance, since some letters have fixed languages
toMeta "date" $ format SelFormatDate now
, toMeta "rcvr-name" $ rcvr & userDisplayName
, toMeta "address" $ fromMaybe [rcvr & userDisplayName] $ getPostalAddress rcvr
--, toMeta "rcvr-email" $ rcvr & userDisplayEmail -- note that some templates use "email" already otherwise
, toMeta "address" $ fromMaybe [rcvr & userDisplayName] $ canonical rcvrPostal
--, toMeta "rcvr-email" $ fromMaybe [rcvr & userDisplayEmail] rcvrEmail -- note that some templates use "email" already otherwise
]
e_md <- mdTemplating tmpl meta
actRight e_md $ pdfLaTeX kind
mdTemplating tmpl meta
renderLetterPDF :: (MDLetter l) => Entity User -> l -> Text -> Maybe [Text] -> Handler (Either Text LBS.ByteString)
renderLetterPDF rcvrEnt mdl apcIdent rcvrPostal = do
e_md <- letterTemplate rcvrEnt mdl apcIdent rcvrPostal
actRight e_md $ pdfLaTeX $ getLetterKind mdl
renderLetterHtml :: (MDLetter l) => Entity User -> l -> Text -> Handler (Either Text Html)
renderLetterHtml rcvrEnt@Entity{entityVal=rcvr} mdl apcIdent = do
now <- liftIO getCurrentTime
formatter@DateTimeFormatter{ format } <- getDateTimeFormatterUser' rcvr
let lang = selectDeEn $ rcvr & userLanguages -- select either German or English only, default de; see Utils.Lang
kind = getLetterKind mdl
tmpl = getTemplate mdl
meta = addApcIdent apcIdent
<> letterMeta mdl formatter lang rcvrEnt
<> mkMeta
[ -- toMeta "lang" lang -- receiver language is decided in MDLetter instance, since some letters have fixed languages
toMeta "date" $ format SelFormatDate now
, toMeta "rcvr-name" $ rcvr & userDisplayName
, toMeta "address" $ fromMaybe [rcvr & userDisplayName] $ getPostalAddress rcvr
--, toMeta "rcvr-email" $ rcvr & userDisplayEmail -- note that some templates use "email" already otherwise
]
e_md <- mdTemplating tmpl meta
actRight e_md $ \md -> pure . over _Left P.renderError . P.runPure $ do
html_tmpl <- compileTemplate $ templateHtml kind
-- html_tmpl <- ExceptT $ memcachedBy (Just . Right $ 6 * diffHour) ("LetterKind-Html: \n" <> tshow lk) (pure . over _Left P.renderError . P.runPure $ compileTemplate $ templateHtml lk)
let writerOpts = def { P.writerExtensions = P.pandocExtensions
, P.writerTemplate = Just html_tmpl }
P.writeHtml5 writerOpts $ appMeta setIsDeFromLang md
renderLetterHtml :: (MDLetter l) => Entity User -> l -> Text -> Maybe [Text] -> Handler (Either Text Html)
renderLetterHtml rcvrEnt mdl apcIdent rcvrPostal = do
e_md <- letterTemplate rcvrEnt mdl apcIdent rcvrPostal
actRight e_md $ \md -> pure . over _Left P.renderError . P.runPure $ do
html_tmpl <- compileTemplate $ templateHtml $ getLetterKind mdl
-- html_tmpl <- ExceptT $ memcachedBy (Just . Right $ 6 * diffHour) ("LetterKind-Html: \n" <> tshow lk) (pure . over _Left P.renderError . P.runPure $ compileTemplate $ templateHtml lk)
let writerOpts = def { P.writerExtensions = P.pandocExtensions
, P.writerTemplate = Just html_tmpl }
P.writeHtml5 writerOpts $ appMeta setIsDeFromLang md
-- TODO: apcIdent does not make sense for multiple letters
renderLetters :: (MDLetter l, Foldable f) => Entity User -> f l -> Text -> Handler (Either Text LBS.ByteString)
@ -197,6 +187,8 @@ renderLetters rcvrEnt@Entity{entityVal=rcvr} mdls apcIdent
| Just l <- anyone mdls = do
now <- liftIO getCurrentTime
formatter@DateTimeFormatter{ format } <- getDateTimeFormatterUser' rcvr
rcvrPostal <- runDB $ getPostalAddress rcvrEnt
-- (_,rcvrPostal, rcvrEmail) <- runDB $ getPostalPreferenceAndAddress
let lang = selectDeEn $ rcvr & userLanguages -- select either German or English only, default de; see Utils.Lang
kind = getLetterKind l
@ -209,8 +201,8 @@ renderLetters rcvrEnt@Entity{entityVal=rcvr} mdls apcIdent
[ -- toMeta "lang" lang -- receiver language is decided in MDLetter instance, since some letters have fixed languages
toMeta "date" $ format SelFormatDate now
, toMeta "rcvr-name" $ rcvr & userDisplayName
, toMeta "address" $ fromMaybe [rcvr & userDisplayName] $ getPostalAddress rcvr
--, toMeta "rcvr-email" $ rcvr & userDisplayEmail -- note that some templates use "email" already otherwise
, toMeta "address" $ fromMaybe [rcvr & userDisplayName] rcvrPostal
--, toMeta "rcvr-email" $ fromMaybe [rcvr & userDisplayEmail] rcvrEmail -- note that some templates use "email" already otherwise
]
in mdTemplating tmpl meta <&> \case
err@Left{} -> err
@ -234,7 +226,7 @@ printHtml _senderId (rcvr, letter) = do
encRecipient :: CryptoUUIDUser <- encrypt rcvrId
now <- liftIO getCurrentTime
apcIdent <- letterApcIdent letter encRecipient now
renderLetterHtml rcvr letter apcIdent
renderLetterHtml rcvr letter apcIdent Nothing
-- Only used in print-test-handler for PrintSendR
printLetter :: (MDLetter l) => Maybe UserId -> (Entity User, l) -> Handler (Either Text (Text, FilePath))
@ -243,7 +235,7 @@ printLetter senderId (rcvr, letter) = do
encRecipient :: CryptoUUIDUser <- encrypt rcvrId
now <- liftIO getCurrentTime
apcIdent <- letterApcIdent letter encRecipient now
pdf <- renderLetterPDF rcvr letter apcIdent
pdf <- renderLetterPDF rcvr letter apcIdent Nothing
let protoPji = getPJId letter
pji = protoPji
{ pjiRecipient = Just rcvrId
@ -269,7 +261,7 @@ printLetter' pji pdf = do
-- printJobFile <- sinkFileDB True $ yield $ LBS.toStrict pdf -- for PrintJobFile :: FileContentReference use this code
printJobFile = LBS.toStrict pdf
printJobAcknowledged = Nothing
qshort <- ifMaybeM printJobQualification "-" $ fmap (maybe "_" $ CI.original . qualificationShorthand ) . get
qshort <- ifNothingM printJobQualification "-" $ fmap (maybe "_" $ CI.original . qualificationShorthand ) . get
let logInter = flip (logInterface "Printer" qshort) (Just 1)
lprPDF printJobFilename pdf >>= \case
Left err -> do
@ -287,7 +279,7 @@ reprintPDF ignoreReroute pjid = maybeM (return $ Left "Print job id is unknown."
where
reprint :: PrintJob -> DB (Either Text Text)
reprint pj@PrintJob{..} = do
qshort <- ifMaybeM printJobQualification "-" $ fmap (maybe "_" $ CI.original . qualificationShorthand ) . get
qshort <- ifNothingM printJobQualification "-" $ fmap (maybe "_" $ CI.original . qualificationShorthand ) . get
let logInter = flip (logInterface "Printer" qshort) (Just 1)
result <- lprPDF' ignoreReroute printJobFilename $ LBS.fromStrict printJobFile
case result of
@ -332,13 +324,14 @@ sendEmailOrLetter recipient letter = do
mailSubject = mkMailSubject isSupervised
encRecipient :: CryptoUUIDUser <- encrypt svr
apcIdent <- letterApcIdent letter encRecipient now
case getPostalPreferenceAndAddress rcvrUsr of
(True, Nothing) -> do -- neither email nor postal is known
postalPrefs <- runDB $ getPostalPreferenceAndAddress rcvrEnt
case postalPrefs of
(_, Nothing, Nothing) -> do -- neither email nor postal is known
let msg = "Notification failed for " <> tshow encRecipient <> ", who has neither a known email nor postal address. Notification: " <> tshow pjid
$logErrorS "LETTER" msg
return False
(True , Just _postal) -> renderLetterPDF rcvrEnt letter apcIdent >>= \case -- send printed letter
(True, postal@(Just _), _) -> renderLetterPDF rcvrEnt letter apcIdent postal >>= \case -- send printed letter
Left err -> do -- pdf generation failed
let msg = "Notification failed for " <> tshow encRecipient <> ". PDF generation failed: "<> cropText err <> "For Notification: " <> tshow pjid
$logErrorS "LETTER" msg
@ -354,7 +347,7 @@ sendEmailOrLetter recipient letter = do
$logWarnS "LETTER" $ "PDF printing to send letter with lpr returned ExitSuccess and the following message: " <> msg
return True
(False, _) | Just mkMail <- mkMailBody -> renderLetterPDF rcvrEnt letter apcIdent >>= \case -- send Email, but with pdf attached
(_, postal, _email) | Just mkMail <- mkMailBody -> renderLetterPDF rcvrEnt letter apcIdent postal >>= \case -- send Email with pdf attached
Left err -> do -- pdf generation failed
let msg = "Notification failed for " <> tshow encRecipient <> ". PDF attachment generation failed: "<> cropText err <> "For Notification: " <> tshow pjid
$logErrorS "LETTER" msg
@ -374,6 +367,7 @@ sendEmailOrLetter recipient letter = do
return pdf
formatter <- getDateTimeFormatterUser' rcvrUsr -- not too expensive, only calls getTimeLocale
let mailBody = mkMail formatter
-- userMailTdirect computes email address once more, hence _email is currently ignored
userMailTdirect svr $ do
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
setSubjectI mailSubject
@ -385,7 +379,7 @@ sendEmailOrLetter recipient letter = do
} :: PureFile)
return True
(False, _) -> renderLetterHtml rcvrEnt letter apcIdent >>= \case -- send Email, render letter directly to html
(_, postal, _email) -> renderLetterHtml rcvrEnt letter apcIdent postal >>= \case -- send Email, render letter directly to html
Left err -> do -- html generation failed
let msg = "Notification failed for " <> tshow encRecipient <> ". HTML generation failed: "<> cropText err <> "For Notification: " <> tshow pjid
$logErrorS "LETTER" msg
@ -393,9 +387,9 @@ sendEmailOrLetter recipient letter = do
Right html -> do -- html generated, send directly now
userMailTdirect svr $ do
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
setSubjectI mailSubject
setSubjectI mailSubject
addHtmlMarkdownAlternatives html
return True
return True
return $ or oks

6
src/Utils/Set.hs
View File

@ -13,6 +13,7 @@ module Utils.Set
, setFromFunc
, mapIntersectNotOne
, set2NonEmpty
, maybeInsert
) where
import qualified Data.List.NonEmpty as NonEmpty
@ -81,8 +82,11 @@ setPartitionEithers = (,) <$> setMapMaybeMonotonic (preview _Left) <*> setMapMay
setFromFunc :: (Finite k, Ord k) => (k -> Bool) -> Set k
setFromFunc = Set.fromList . flip filter universeF
-- | convert a Set to NonEmpty, inserting a default value if necessary
set2NonEmpty :: a -> Set a -> NonEmpty.NonEmpty a
set2NonEmpty _ (Set.toList -> h:t) = h NonEmpty.:| t
set2NonEmpty d _ = d NonEmpty.:| []
maybeInsert :: Ord a => Maybe a -> Set a -> Set a
maybeInsert Nothing = id
maybeInsert (Just k) = Set.insert k

1
src/Utils/TH.hs
View File

@ -167,6 +167,7 @@ embedRenderMessage f inner mangle = do
]
]
-- ^ Like @embedRenderMessage, but for newtype definitions
embedRenderMessageVariant :: Name -- ^ Foundation Type
-> Name -- ^ Name of newtype
-> (Text -> Text) -- ^ Mangle constructor names

104
src/Utils/Users.hs
View File

@ -7,7 +7,7 @@
module Utils.Users
( AuthenticationKind(..)
, AddUserData(..)
, addNewUser
, addNewUser, addNewUserDB
) where
import Import
@ -49,53 +49,65 @@ data AddUserData = AddUserData
, audPinPassword :: Maybe Text
, audEmail :: UserEmail
, audIdent :: UserIdent
, audAuth :: AuthenticationKind
, audAuth :: AuthenticationKind
}
-- | Adds a new user to database, no background jobs are scheduled, no notifications send
-- Note: `Foundation.Yesod.Auth` contains similar code with potentially differing defaults!
addNewUser :: AddUserData -> Handler (Maybe UserId)
addNewUser AddUserData{..} = do
addNewUser aud = do
udc <- getsYesod $ view _appUserDefaults
usr <- makeUser udc aud
runDB $ insertUnique usr
-- | Variant of `addNewUser` which allows for rollback through follwing throws
addNewUserDB :: AddUserData -> DB (Maybe UserId)
addNewUserDB aud = do
udc <- liftHandler $ getsYesod $ view _appUserDefaults
usr <- makeUser udc aud
insertUnique usr
makeUser :: MonadIO m => UserDefaultConf -> AddUserData -> m User
makeUser UserDefaultConf{..} AddUserData{..} = do
now <- liftIO getCurrentTime
UserDefaultConf{..} <- getsYesod $ view _appUserDefaults
let
newUser = User
{ userIdent = audIdent
, userMaxFavourites = userDefaultMaxFavourites
, userMaxFavouriteTerms = userDefaultMaxFavouriteTerms
, userTheme = userDefaultTheme
, userDateTimeFormat = userDefaultDateTimeFormat
, userDateFormat = userDefaultDateFormat
, userTimeFormat = userDefaultTimeFormat
, userDownloadFiles = userDefaultDownloadFiles
, userWarningDays = userDefaultWarningDays
, userShowSex = userDefaultShowSex
, userExamOfficeGetSynced = userDefaultExamOfficeGetSynced
, userExamOfficeGetLabels = userDefaultExamOfficeGetLabels
, userNotificationSettings = def
, userLanguages = Nothing
, userCsvOptions = def { csvFormat = review csvPreset CsvPresetXlsx }
, userTokensIssuedAfter = Nothing
, userCreated = now
, userLastLdapSynchronisation = Nothing
, userLdapPrimaryKey = audFPersonalNumber
, userLastAuthentication = Nothing
, userEmail = audEmail
, userDisplayName = audDisplayName
, userDisplayEmail = audDisplayEmail
, userFirstName = audFirstName
, userSurname = audSurname
, userTitle = audTitle
, userSex = audSex
, userBirthday = audBirthday
, userMobile = audMobile
, userTelephone = audTelephone
, userCompanyPersonalNumber = audFPersonalNumber
, userCompanyDepartment = audFDepartment
, userPostAddress = audPostAddress
, userPostLastUpdate = Nothing
, userPrefersPostal = audPrefersPostal
, userPinPassword = audPinPassword
, userMatrikelnummer = audMatriculation
, userAuthentication = mkAuthMode audAuth
}
runDB $ insertUnique newUser
return User
{ userIdent = audIdent
, userMaxFavourites = userDefaultMaxFavourites
, userMaxFavouriteTerms = userDefaultMaxFavouriteTerms
, userTheme = userDefaultTheme
, userDateTimeFormat = userDefaultDateTimeFormat
, userDateFormat = userDefaultDateFormat
, userTimeFormat = userDefaultTimeFormat
, userDownloadFiles = userDefaultDownloadFiles
, userWarningDays = userDefaultWarningDays
, userShowSex = userDefaultShowSex
, userExamOfficeGetSynced = userDefaultExamOfficeGetSynced
, userExamOfficeGetLabels = userDefaultExamOfficeGetLabels
, userNotificationSettings = def
, userLanguages = Nothing
, userCsvOptions = def { csvFormat = review csvPreset CsvPresetXlsx }
, userTokensIssuedAfter = Nothing
, userCreated = now
, userLastLdapSynchronisation = Nothing
, userLdapPrimaryKey = audFPersonalNumber
, userLastAuthentication = Nothing
, userEmail = audEmail
, userDisplayName = audDisplayName
, userDisplayEmail = audDisplayEmail
, userFirstName = audFirstName
, userSurname = audSurname
, userTitle = audTitle
, userSex = audSex
, userBirthday = audBirthday
, userMobile = audMobile
, userTelephone = audTelephone
, userCompanyPersonalNumber = audFPersonalNumber
, userCompanyDepartment = audFDepartment
, userPostAddress = audPostAddress
, userPostLastUpdate = Nothing
, userPrefersPostal = audPrefersPostal
, userPinPassword = audPinPassword
, userMatrikelnummer = audMatriculation
, userAuthentication = mkAuthMode audAuth
}

7
templates/admin-problems.hamlet
View File

@ -63,5 +63,10 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
_{MsgInterfacesOk}
^{interfaceTable}
<!-- section h2 {MsgProblemsHeadingMisc} -->
<section>
<h2>
_{MsgProblemsHeadingMisc}
<div>
<p>
^{problemLogTable}

4
templates/course/user/profile.hamlet
View File

@ -1,6 +1,6 @@
$newline never
$# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
$# SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,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
@ -24,7 +24,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
<dt .deflist__dt>_{MsgTableSex}
<dd .deflist__dd>_{sex}
<dt .deflist__dt>_{MsgTableEmail}
<dd .deflist__dd>#{mailtoHtml (pickValidEmail userDisplayEmail userEmail)}
<dd .deflist__dd>#{mailtoHtml (pickValidUserEmail userDisplayEmail userEmail)}
$maybe date <- mRegAt
<dt .deflist__dt>_{MsgRegisteredSince}
<dd .deflist__dd>#{date}

45
templates/profileData.hamlet
View File

@ -51,30 +51,37 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
<dt .deflist__dt>
_{MsgPrefersPostalExp}
<dd .deflist__dd>
$if userPrefersPostal /= actualPrefersPostal
^{messageTooltip tooltipInvalidEmail} #
#{iconLetterOrEmail userPrefersPostal}
$maybe addr <- userPostAddress
$maybe addr <- actualPostAddress
<dt .deflist__dt>
_{MsgAdminUserPostAddress}
<dd .deflist__dd>
#{isAutomatic postalAutomatic} #
#{addr}
$maybe postUpdate <- userPostLastUpdate
<dt .deflist__dt>
_{MsgUserPostLastUpdate}
<dd .deflist__dd>
^{formatTimeW SelFormatDateTime postUpdate}
$if (not postalAutomatic)
$maybe postUpdate <- userPostLastUpdate
<dt .deflist__dt>
_{MsgUserPostLastUpdate}
<dd .deflist__dd>
^{formatTimeW SelFormatDateTime postUpdate}
<dt .deflist__dt>
_{MsgUserDisplayEmail}
<dd .deflist__dd .email>
#{mailtoHtml userDisplayEmail}
$if not (validEmail' userDisplayEmail)
\ ^{messageTooltip tooltipInvalidEmail}
$if userEmail /= userDisplayEmail
$maybe primaryEmail <- actualDisplayEmail
#{isAutomatic emailAutomatic} #
#{mailtoHtml primaryEmail}
$nothing
^{messageTooltip tooltipInvalidEmail} #
#{mailtoHtml userDisplayEmail}
$if Just userEmail /= actualDisplayEmail
<dt .deflist__dt>
_{MsgUserSystemEmail}
<dd .deflist__dd>
<dd .deflist__dd>
$if not (validEmail' userEmail)
^{messageTooltip tooltipInvalidEmail} #
#{userEmail}
$if not (validEmail' userEmail)
\ ^{messageTooltip tooltipInvalidEmail}
<dt .deflist__dt>
_{MsgAdminUserPinPassword}
<dd .deflist__dd>
@ -191,7 +198,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
^{formatTimeW SelFormatDateTime studyFeaturesLastObserved}
<section>
<div .container>
$if hasRows
$if hasRowsOwnedCourses
<div .container>
<h2>_{MsgProfileCourses}
<div .container>
@ -243,4 +250,14 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
\ _{MsgProfileCorrectorRemark}
<a href=@{CorrectionsR}>_{MsgProfileCorrections}
<div .container>
<h2> _{MsgProfileSupervisor}
<div .container>
^{supervisorsTable}
<div .container>
<h2> _{MsgProfileSupervisee}
<div .container>
^{superviseesTable}
^{profileRemarks}

2
test/Database.hs
View File

@ -56,7 +56,7 @@ main = do
Custom.purgePool $ appConnPool foundation
truncateDb
DBMigrate -> db' $ return ()
DBFill -> db' $ fillDb
DBFill -> db' fillDb
(_, _, _, errs) -> do
forM_ errs $ hPutStrLn stderr
hPutStrLn stderr $ usageInfo "uniworxdb" argsDescr

73
test/Database/Fill.hs
View File

@ -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@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
@ -595,7 +595,7 @@ fillDb = do
let matrikel = tshow <$> [baseMatrikel..] List.\\ [6969, 669966, 996699]
manyUsers <- insertMany . getZipList $ manyUser <$> ZipList ((,,) <$> firstNames <*> middlenames <*> surnames) <*> ZipList matrikel
matUsers <- selectList [UserMatrikelnummer !=. Nothing] []
insertMany_ [UserAvs (AvsPersonId n) uid n now Nothing | Entity uid User{userMatrikelnummer = fmap readMay -> Just (Just n)} <- matUsers]
insertMany_ [UserAvs (AvsPersonId n) uid n now Nothing Nothing Nothing Nothing | Entity uid User{userMatrikelnummer = fmap readMay -> Just (Just n)} <- matUsers]
let tmin = -1
tmax = 2
@ -655,19 +655,19 @@ fillDb = do
, let rcName = CI.mk $ "Random Corp " <> tshow n <> bool "" " GmbH" (even n)
, let rcShort = CI.mk $ "RC" <> tshow n
]
void . insert' $ UserCompany jost fraportAg True True
void . insert' $ UserCompany svaupel nice True False
void . insert' $ UserCompany gkleen nice False False
void . insert' $ UserCompany gkleen fraGround False True
void . insert' $ UserCompany fhamann bpol False False
void . insert' $ UserCompany fhamann ffacil True True
void . insert' $ UserCompany fhamann nice False False
void . insert' $ UserCompany jost fraportAg True True 0 False
void . insert' $ UserCompany svaupel nice True False 0 False
void . insert' $ UserCompany gkleen nice False False 1 True
void . insert' $ UserCompany gkleen fraGround False True 2 False
void . insert' $ UserCompany fhamann bpol False False 1 True
void . insert' $ UserCompany fhamann ffacil True True 2 True
void . insert' $ UserCompany fhamann nice False False 3 False
-- need more tests
insertMany_ [UserCompany uid fraGround False False| Entity uid User{userFirstName = "John"} <- matUsers]
insertMany_ [UserCompany uid bpol False False| Entity uid User{userFirstName = "Elizabeth"} <- matUsers]
insertMany_ [UserCompany uid bpol True True| Entity uid User{userFirstName = "Clark", userSurname = dn} <- matUsers, dn == "Walker" || dn == "Robinson"]
insertMany_ [UserCompany uid ffacil False False| Entity uid User{userSurname = "Walker"} <- matUsers]
insertMany_ [UserCompany uid rckey issuper False
insertMany_ [UserCompany uid fraGround False False 0 True | Entity uid User{userFirstName = "John"} <- matUsers]
insertMany_ [UserCompany uid bpol False False 0 False | Entity uid User{userFirstName = "Elizabeth"} <- matUsers]
insertMany_ [UserCompany uid bpol True True 0 True | Entity uid User{userFirstName = "Clark", userSurname = dn} <- matUsers, dn == "Walker" || dn == "Robinson"]
insertMany_ [UserCompany uid ffacil False False 0 False | Entity uid User{userSurname = "Walker"} <- matUsers]
insertMany_ [UserCompany uid rckey issuper False 0 True
| rckey <- randComps
, Just n <- [readMay $ drop 2 $ unpack $ CI.original $ unCompanyKey rckey]
, Entity uid User{userSurname = uSurname} <- take (n `div` 20) $ drop (2*n) matUsers
@ -681,17 +681,17 @@ fillDb = do
-- void . insert' $ UserSupervisor svaupel gkleen False
-- void . insert' $ UserSupervisor svaupel fhamann True
-- void . insert' $ UserSupervisor sbarth tinaTester True
let supvs = [ UserSupervisor jost gkleen True
, UserSupervisor jost svaupel False
, UserSupervisor jost sbarth False
, UserSupervisor jost tinaTester True
, UserSupervisor jost jost True
, UserSupervisor svaupel gkleen False
, UserSupervisor svaupel fhamann True
, UserSupervisor sbarth tinaTester True
, UserSupervisor gkleen fhamann False
, UserSupervisor gkleen gkleen True
, UserSupervisor tinaTester tinaTester False
let supvs = [ UserSupervisor jost gkleen True (Just fraportAg) (Just "Staff")
, UserSupervisor jost svaupel False (Just fraportAg) (Just "Staff")
, UserSupervisor jost sbarth False (Just fraportAg) (Just "Staff")
, UserSupervisor jost tinaTester True (Just fraportAg) (Just "Staff")
, UserSupervisor jost jost True (Just fraportAg) (Just "Staff")
, UserSupervisor svaupel gkleen False (Just nice) (Just "Staff")
, UserSupervisor svaupel fhamann True (Just nice) (Just "Staff")
, UserSupervisor sbarth tinaTester True (Just nice) (Just "Staff")
, UserSupervisor gkleen fhamann False (Just fraGround) (Just "Staff")
, UserSupervisor gkleen gkleen True (Just fraGround) (Just "Staff")
, UserSupervisor tinaTester tinaTester False Nothing (Just "Staff")
]
++ take 444 [ UserSupervisor fhamann uid True | Entity uid _ <- matUsers, uid /= jost]
++ take 123 [ UserSupervisor gkleen uid True | Entity uid _ <- drop 369 matUsers ]
@ -736,16 +736,12 @@ fillDb = do
void . insert' $ UserSchool uid mi False
for_ [jost] $ \uid ->
void . insert' $ UserSchool uid avn False
void . insert' $ UserAvs (AvsPersonId 12345678) jost 87654321 (n_day' $ -12) (Just "Some Message here")
void . insert' $ UserAvs (AvsPersonId 2) svaupel 2 (n_day' $ -22) Nothing
void . insert' $ UserAvs (AvsPersonId 3) gkleen 3 (n_day' $ -32) Nothing
void . insert' $ UserAvs (AvsPersonId 4) sbarth 4 now Nothing
void . insert' $ UserAvs (AvsPersonId 5) fhamann 5 now (Just "another message from avs synch")
void . insert' $ UserAvs (AvsPersonId 77) tinaTester 77 now Nothing
insert_ $ UserAvsCard (AvsPersonId 12345678) (AvsFullCardNo (AvsCardNo "1234") "4") (AvsDataPersonCard True Nothing Nothing AvsCardColorGelb (Set.fromList ['F']) Nothing Nothing Nothing Nothing (AvsCardNo "1234") "4") now
insert_ $ UserAvsCard (AvsPersonId 2) (AvsFullCardNo (AvsCardNo "3344") "1") (AvsDataPersonCard True Nothing Nothing AvsCardColorRot (Set.fromList ['F','R']) Nothing Nothing Nothing Nothing (AvsCardNo "3344") "1") now
insert_ $ UserAvsCard (AvsPersonId 3) (AvsFullCardNo (AvsCardNo "7788") "1") (AvsDataPersonCard False Nothing Nothing AvsCardColorRot (Set.fromList ['F','R']) Nothing Nothing Nothing Nothing (AvsCardNo "7788") "1") now
insert_ $ UserAvsCard (AvsPersonId 4) (AvsFullCardNo (AvsCardNo "9999") "4") (AvsDataPersonCard True Nothing Nothing AvsCardColorGelb (Set.fromList ['F']) Nothing Nothing Nothing Nothing (AvsCardNo "9999") "4") now
void . insert' $ UserAvs (AvsPersonId 12345678) jost 87654321 (n_day' $ -12) (Just "Some Message here") Nothing Nothing Nothing
void . insert' $ UserAvs (AvsPersonId 2) svaupel 2 (n_day' $ -22) Nothing Nothing Nothing Nothing
void . insert' $ UserAvs (AvsPersonId 3) gkleen 3 (n_day' $ -32) Nothing Nothing Nothing Nothing
void . insert' $ UserAvs (AvsPersonId 4) sbarth 4 now Nothing Nothing Nothing Nothing
void . insert' $ UserAvs (AvsPersonId 5) fhamann 5 now (Just "another message from avs synch") Nothing Nothing Nothing
void . insert' $ UserAvs (AvsPersonId 77) tinaTester 77 now Nothing Nothing Nothing Nothing
let f_descr = Just $ htmlToStoredMarkup [shamlet|<p>Berechtigung zum Führen eines Fahrzeuges auf den Fahrstrassen des Vorfeldes.|]
let r_descr = Just $ htmlToStoredMarkup [shamlet|<p>Berechtigung zum Führen eines Fahrzeuges auf dem gesamten Rollfeld.|]
@ -786,7 +782,7 @@ fillDb = do
, let selsome = odd $ length udn, let astatus = bool Nothing (Just LmsBlocked) selsome, let astatusDay = bool Nothing (Just now) selsome]
void . insert' $ LmsUser qid_f jost (LmsIdent "ijk" ) "123" False now Nothing Nothing now Nothing (Just $ n_day' (-7)) (Just $ n_day' (-5)) False False
void . insert' $ LmsUser qid_f svaupel (LmsIdent "bcdefg") "abc" False now (Just LmsSuccess) (Just $ n_day' 1) (n_day' (-1)) (Just now) (Just $ n_day' 0) Nothing True False
void . insert' $ LmsUser qid_f gkleen (LmsIdent "hiklmn") "@#!" True now (Just LmsBlocked) (Just $ now) (n_day' (-2)) (Just now) (Just $ n_day' (-4)) Nothing False True
void . insert' $ LmsUser qid_f gkleen (LmsIdent "hiklmn") "@#!" True now (Just LmsBlocked) (Just now) (n_day' (-2)) (Just now) (Just $ n_day' (-4)) Nothing False True
void . insert' $ LmsUser qid_f tinaTester (LmsIdent "qwvu") "45678" True now (Just LmsSuccess) (Just $ n_day' (-22)) (n_day' (-3)) (Just $ n_day' (-1)) (Just $ n_day' (-1)) Nothing True True
void . insert' $ LmsUser qid_f maxMuster (LmsIdent "xyz") "a1b2c3" False now (Just LmsBlocked) (Just $ n_day' (-11)) (n_day' (-4)) (Just $ n_day' (-2)) (Just $ n_day' (-2)) Nothing True True
void . insert' $ LmsUser qid_f fhamann (LmsIdent "123") "456" False now Nothing Nothing now Nothing Nothing Nothing False False
@ -802,6 +798,11 @@ fillDb = do
void . insert $ PrintJob "TestJob9" "AckTestJob9" "job9" "No Text herein." (n_day' (-1)) Nothing (Just svaupel) Nothing Nothing Nothing (Just $ LmsIdent "abcdefg")
void . insert $ PrintJob "TestJob0" "AckTestJob0" "job0" "No Text herein." (n_day' (-3)) Nothing Nothing Nothing Nothing Nothing (Just $ LmsIdent "hijklmn")
insert_ $ ProblemLog now (toJSON $ AdminProblemNewCompany fraportAg) Nothing Nothing
insert_ $ ProblemLog now (toJSON $ AdminProblemNewCompany ffacil ) Nothing Nothing
insert_ $ ProblemLog now (toJSON $ AdminProblemSupervisorNewCompany fhamann fraportAg ffacil True ) Nothing Nothing
insert_ $ ProblemLog now (toJSON $ AdminProblemSupervisorNewCompany gkleen ffacil fraGround False) Nothing Nothing
insert_ $ ProblemLog now (toJSON $ AdminProblemUnknown "This is a test problem only.") Nothing Nothing
let
examLabels = Map.fromList

4
test/ModelSpec.hs
View File

@ -43,8 +43,8 @@ import Data.Universe
instance Arbitrary EmailAddress where
arbitrary = do
local <- suchThat (CBS.pack . getPrintableString <$> arbitrary) (\l -> isEmail l (CBS.pack "example.com"))
domain <- suchThat (CBS.pack . getPrintableString <$> arbitrary) (\d -> isEmail (CBS.pack "example") d)
local <- suchThat (CBS.pack . getPrintableString <$> arbitrary) (\l -> isEmail l (CBS.pack "example.com"))
domain <- suchThat (CBS.pack . getPrintableString <$> arbitrary) (isEmail (CBS.pack "example"))
let (Just result) = emailAddress (makeEmailLike local domain)
pure result

2137
uniworx.cabal.bak Normal file
View File

File diff suppressed because it is too large Load Diff