Merge branch 'fradrive/cr3'

config/settings.yml

@@ -91,8 +91,8 @@ study-features-recache-relevance-within: 172800
 study-features-recache-relevance-interval: 293
 
 # Enqueue at specified hour, a few minutes later
-# job-lms-qualifications-enqueue-hour: 15
+job-lms-qualifications-enqueue-hour: 16
-# job-lms-qualifications-dequeue-hour: 3
+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"
+  host:         "_env:AVSHOST:skytest.fra.fraport.de"
-  port:    "_env:AVSPORT:443"
+  port:         "_env:AVSPORT:443"
-  user:    "_env:AVSUSER:fradrive"
+  user:         "_env:AVSUSER:fradrive"
-  pass:    "_env:AVSPASS:"
+  pass:         "_env:AVSPASS:\"0000\""
+  timeout:      "_env:AVSTIMEOUT:42"
+  cache-expiry: "_env:AVSCACHEEXPIRY:420"
 
 lpr:
   host:    "_env:LPRHOST:fravm017173.fra.fraport.de"

messages/uniworx/categories/admin/de-de-formal.msg

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

messages/uniworx/categories/admin/en-eu.msg

@@ -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"}
+IncidencesDeleted n: Successfully deleted #{pluralENsN n "observation"}
-RedundantParentCandidatesRemoved n: Successfully removed #{n} rendundant #{pluralEN n "parent-candidate" "parent-candidates"}
+RedundantParentCandidatesRemoved n: Successfully removed #{n} rendundant #{pluralENs n "parent-candidate"}
-RedundantStandaloneCandidatesRemoved n: Successfully removed #{n} rendundant #{pluralEN n "standalone-candidate" "standalone-candidates"}
+RedundantStandaloneCandidatesRemoved n: Successfully removed #{n} rendundant #{pluralENs n "standalone-candidate"}
-ParentCandidatesInferred n: Successfully inferred #{n} field #{pluralEN n "parent-relation" "parent-reliations"}
+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

messages/uniworx/categories/avs/de-de-formal.msg

@@ -2,13 +2,16 @@
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later
 AvsPersonInfo: AVS Personendaten
-AvsPersonId: AVS Personen Id 
+AvsPersonId: AVS Personen Id
 AvsPersonNo: AVS Personennummer
+AvsPersonNoMismatch: AVS Personennummer hat sich geändert und wurde in FRADrive noch nicht aktualisiert
 AvsCardNo: Ausweiskartennummer 
 AvsFirstName: Vorname
 AvsLastName: Nachname
+AvsPrimaryCompany: Primäre Firma
 AvsInternalPersonalNo: Personalnummer (nur Fraport AG)
 AvsVersionNo: Versionsnummer
+AvsQueryNeeded: Benötigt Verbindung zum AVS.
 AvsQueryEmpty: Bitte mindestens ein Anfragefeld ausfüllen!
 AvsQueryStatusInvalid t@Text: Nur numerische IDs eingeben, durch Komma getrennt! Erhalten: #{show t}
 AvsLicence: Fahrberechtigung
@@ -27,13 +30,29 @@ RevokeFraDriveLicences alic@AvsLicence n@Int: _{alic} in FRADrive entzogen für
 RevokeUnknownLicencesOk: AVS Fahrberechtigungen unbekannter Fahrer wurden gesperrt
 RevokeUnknownLicencesFail: Nicht alle AVS Fahrberechtigungen unbekannter Fahrer konnten entzogen werden, siehe Log für Details
 AvsCommunicationError: AVS Schnittstelle lieferte einen unerwarteten Fehler.
+AvsCommunicationTimeout: AVS Schnittstelle antwortete nicht.
 LicenceTableChangeAvs: Im AVS ändern
 LicenceTableGrantFDrive: In FRADrive erteilen
 LicenceTableRevokeFDrive: In FRADrive entziehen
 TableAvsActiveCards: Gültige Ausweise
+TableAvsCardValid: Aktuell gültig
+TableAvsCardIssueDate: Ausgestellt am
+TableAvsCardValidTo: Gültig bis
+AvsCardAreas: Ausweiszusätze
+AvsCardColor: Ausweisfarbe
 AvsCardColorGreen: Grün
 AvsCardColorBlue: Blau
 AvsCardColorRed: Rot
 AvsCardColorYellow: Gelb
 LastAvsSynchronisation: Letzte AVS-Synchronisation
 LastAvsSynchError: Letzte AVS-Fehlermeldung
+
+AvsInterfaceUnavailable: AVS Schnittstelle nicht richtig konfiguriert oder antwortet nicht
+AvsUserUnassociated user@UserDisplayName: AVS Id unbekannt für Nutzer #{user}
+AvsUserUnknownByAvs api@AvsPersonId: AVS kennt Id #{tshow api} nicht (mehr)
+AvsUserAmbiguous api@AvsPersonId: AVS Id #{tshow api} ist nicht eindeutig
+AvsPersonSearchEmpty: AVS Suche lieferte leeres Ergebnis
+AvsPersonSearchAmbiguous: AVS Suche lieferte mehrere uneindeutige Ergebnisse
+AvsSetLicencesFailed reason@Text: Setzen der Fahrlizenz im AVS fehlgeschlagen. Grund: #{reason}
+AvsIdMismatch api1@AvsPersonId api2@AvsPersonId: AVS Suche für Id #{tshow api1} lieferte stattdessen Id #{tshow api2}
+AvsUserCreationFailed api@AvsPersonId: Für AVS Id #{tshow api} konnte kein neuer Benutzer angelegt werden, da es eine gemeinsame Id (z.B. Personalnummer) mit einem existierenden, aber verschiedenen Nutzer gibt.

messages/uniworx/categories/avs/en-eu.msg

@@ -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
+AvsPersonInfo: AVS person info
-AvsPersonId: AVS Person Id
+AvsPersonId: AVS person id
-AvsPersonNo: AVS Person Number
+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

messages/uniworx/categories/user/de-de-formal.msg

@@ -102,3 +102,4 @@ Name !ident-ok: Name
 UsersChangeSupervisorsSuccess usr@Int spr@Int: #{tshow spr} Ansprechpartner für #{tshow usr} Benutzer gesetzt.
 UsersChangeSupervisorsWarning usr@Int spr@Int bad@Int: Nur _{MsgUsersChangeSupervisorsSuccess usr spr} #{tshow bad} Ansprechpartner #{pluralDE bad "wurde" "wurden"} nicht gefunden!
 UsersRemoveSupervisors usr@Int: Alle Ansprechpartner für #{tshow usr} Benutzer gelöscht.
+SupervisorReason: Begründung

messages/uniworx/categories/user/en-eu.msg

@@ -101,4 +101,5 @@ AuthKindNoLogin: No login
 Name: Name
 UsersChangeSupervisorsSuccess usr spr: #{pluralENsN spr "supervisor"} for #{pluralENsN usr "user"} set.
 UsersChangeSupervisorsWarning usr spr bad: Only _{MsgUsersChangeSupervisorsSuccess usr spr} #{pluralENsN bad "supervisors"} could not be identified!
-UsersRemoveSupervisors usr: Removed all supervisors for #{pluralENsN usr "user"}.
+UsersRemoveSupervisors usr: Removed all supervisors for #{pluralENsN usr "user"}.
+SupervisorReason: Reason

messages/uniworx/misc/de-de-formal.msg

@@ -21,6 +21,7 @@ ClusterVolatileQuickActionsEnabled: Schnellzugriffsmenü aktiv
 AvsNoLicence: Keine Fahrberechtigung
 AvsLicenceVorfeld: Vorfeld Fahrberechtigung
 AvsLicenceRollfeld: Rollfeld Fahrberechtigung
+AvsNoLicenceGuest: Keine Fahrberechtigung (Gast, Fahrberechtigungserwerb nicht möglich)
 
 PaginationSize: Einträge pro Seite
 PaginationPage: Angzeigte Seite

messages/uniworx/misc/en-eu.msg

@@ -21,6 +21,7 @@ ClusterVolatileQuickActionsEnabled: Quick actions enabled
 AvsNoLicence: No driving licence
 AvsLicenceVorfeld: Apron driving licence
 AvsLicenceRollfeld: Maneuvering area driving licence
+AvsNoLicenceGuest: No driving licence (Guest account, cannot acquire a diriving licence)
 
 PaginationSize: Rows per Page
 PaginationPage: Page to show

messages/uniworx/utils/table_column/de-de-formal.msg

@@ -91,8 +91,10 @@ TableCompanyNrSupersDefault: Standard Ansprechpartner
 TableCompanyNrForeignSupers: Firmenfremde Ansprechpartner
 TableCompanyNrRerouteDefault: Standard Umleitungen
 TableCompanyNrRerouteActive: Aktive Umleitungen
+TableRerouteActive: Umleitung
 TableCompanyPostalPreference: Benachrichtigungspräferenz neue Firmenangehörige
 TableSupervisor: Ansprechpartner
+TableSupervisee: Ansprechpartner für
 TableCreationTime: Erstellungszeit
 TableJob !ident-ok: Job
 TableJobContent !ident-ok: Parameter

messages/uniworx/utils/table_column/en-eu.msg

@@ -91,8 +91,10 @@ TableCompanyNrSupersDefault: Default supervisors
 TableCompanyNrForeignSupers: External Supervisors
 TableCompanyNrRerouteDefault: Default reroutes
 TableCompanyNrRerouteActive: Active reroutes
+TableRerouteActive: Reroute
 TableCompanyPostalPreference: Default notification preference
 TableSupervisor: Supervisor
+TableSupervisee: Supervisor for
 TableCreationTime: Creation
 TableJob !ident-ok: Job
 TableJobContent !ident-ok: Parameters

models/audit.model

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

models/avs.model

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

models/company.model

@@ -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
+  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
+  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 
+  postAddress     StoredMarkup Maybe      -- default company postal address, including company name 
-  email           UserEmail Maybe         -- Case-insensitive generic company eMail address
+  email           UserEmail Maybe         -- Case-insensitive generic company eMail address  
   UniqueCompanyName name 
-  UniqueCompanyShorthand shorthand
+  -- UniqueCompanyShorthand shorthand     -- unnecessary, since it is the primary key already
-  -- UniqueCompanyAvsId avsId             -- should be the case, unclear if enforcing works here, since we cannot query avs by company id
+  UniqueCompanyAvsId avsId  
-  Primary shorthand             -- newtype Key Company = CompanyKey { unCompanyKey :: CompanyShorthand }
+  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

models/users.model

@@ -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
+    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 sending  TODO: make this nullable
+    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
+    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
+    pinPassword           Text Maybe -- used to encrypt pins within emails, defaults to cardno.version
-    postAddress           StoredMarkup Maybe 
+    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
+    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
+    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)
+    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
     

routes

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Wolfgang Witt <Wolfgang.Witt@campus.lmu.de>
+-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Wolfgang Witt <Wolfgang.Witt@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -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

src/Application.hs

@@ -124,7 +124,7 @@ import Handler.Utils.Memcached (manageMemcachedLocalInvalidations)
 
 import qualified System.Clock as Clock
 
-import Utils.Avs
+import Utils.Avs (mkAvsQuery)
 
 -- Import all relevant handler modules here.
 -- (HPack takes care to add new modules to our cabal file nowadays.)

src/Audit.hs

@@ -9,6 +9,7 @@ module Audit
   , AuditRemoteException(..)
   , getRemote
   , logInterface, logInterface'
+  , reportAdminProblem
   ) where
 
 
@@ -152,7 +153,7 @@ logInterface' :: ( AuthId (HandlerSite m) ~ Key User
 -- ^ Log a transaction using information available from `HandlerT`, also calls `audit`
 logInterface' (Text.strip -> interfaceLogInterface) (Text.strip -> interfaceLogSubtype) interfaceLogWrite interfaceLogSuccess interfaceLogRows (Text.strip -> interfaceLogInfo) = do
   interfaceLogTime  <- liftIO getCurrentTime
-  -- deleteBy $ UniqueInterfaceSubtypeWrite interfaceLogInterface interfaceLogSubtype interfaceLogWrite -- always replace: deleteBy & insert seems to be safest and fastest
+  -- deleteBy $ UniqueInterfaceSubtypeWrite interfaceLogInterface interfaceLogSubtype interfaceLogWrite -- deleteBy & insert would be justified here, leading to a new Row-ID, since the two rows are not truly connected.
   -- insert_ InterfaceLog{..}
   void $ upsertBy (UniqueInterfaceSubtypeWrite interfaceLogInterface interfaceLogSubtype interfaceLogWrite)
     ( InterfaceLog{..} )
@@ -169,3 +170,23 @@ logInterface' (Text.strip -> interfaceLogInterface) (Text.strip -> interfaceLogS
     , transactionInterfaceInfo    = interfaceLogInfo
     , transactionInterfaceSuccess = Just interfaceLogSuccess
     }
+
+reportAdminProblem ::  ( IsSqlBackend (YesodPersistBackend (HandlerSite m))
+                  , SqlBackendCanWrite (YesodPersistBackend (HandlerSite m))
+                  , MonadHandler m                 
+                  -- , HasCallStack
+                  )
+      => AdminProblem -- ^ Problem to record 
+      -> ReaderT (YesodPersistBackend (HandlerSite m)) m ()
+-- ^ Log a problem that needs interventions by admins 
+--
+--   - `problemLogTime` is now
+--   - `problemSolver` is Nothing, we do not record the person who caused it
+reportAdminProblem problem@(toJSON -> problemLogInfo) = do
+  problemLogTime <- liftIO getCurrentTime
+  let problemLogSolved = Nothing
+      problemLogSolver = Nothing
+  insert_ ProblemLog{..}
+  $logWarnS "Problem" $ Text.filter (/= '\n') $ tshow problem -- <> " - " <> pack (prettyCallStack callStack)
+
+

src/Audit/Types.hs

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

src/Database/Esqueleto/Utils.hs

@@ -32,6 +32,7 @@ module Database.Esqueleto.Utils
   , orderByOrd, orderByEnum
   , strip, lower, ciEq
   , selectExists, selectNotExists
+  , filterExists
   , SqlHashable
   , sha256
   , isTrue, isFalse
@@ -41,16 +42,17 @@ module Database.Esqueleto.Utils
   , greatest, least
   , abs
   , SqlProject(..)
-  , (->.), (->>.), (#>>.)
+  , (->.), (->>.), (->>>.), (#>>.)
   , fromSqlKey
   , unKey
   , subSelectCountDistinct
   , selectCountRows, selectCountDistinct
   , selectMaybe
-  , num2text
+  , num2text --, text2num
   , day, day', dayMaybe, interval, diffDays, diffTimes
   , exprLift
   , explicitUnsafeCoerceSqlExprValue
+  , truncateTable
   , module Database.Esqueleto.Utils.TH
   ) where
 
@@ -67,6 +69,8 @@ import qualified Database.Esqueleto.PostgreSQL as E
 import qualified Database.Esqueleto.Internal.Internal as E
 import Database.Esqueleto.Utils.TH
 
+import qualified Database.Persist.Postgresql as P
+
 import qualified Data.Text as Text
 import qualified Data.Text.Lazy as Lazy (Text)
 import qualified Data.ByteString.Lazy as Lazy (ByteString)
@@ -351,7 +355,7 @@ mkExactFilterMaybeLast' lensexists lenslike row criterias
 -- | generic filter creation for dbTable
 --   Given a lens-like function, make filter searching for needles in String-like elements
 --   (Keep Set here to ensure that there are no duplicates)
-mkContainsFilter :: E.SqlString a
+mkContainsFilter :: (E.SqlString a, Ord a)
                  => (t -> E.SqlExpr (E.Value a))  -- ^ getter from query to searched element
                  -> t                             -- ^ query row
                  -> Set.Set a                     -- ^ needle collection
@@ -359,7 +363,7 @@ mkContainsFilter :: E.SqlString a
 mkContainsFilter = mkContainsFilterWith id
 
 -- | like `mkContainsFilter` but allows for conversion; convenient in conjunction with `anyFilter` and `allFilter`
-mkContainsFilterWith :: E.SqlString b
+mkContainsFilterWith :: (E.SqlString b, Ord a)
                      => (a -> b)
                      -> (t -> E.SqlExpr (E.Value b))  -- ^ getter from query to searched element
                      -> t                             -- ^ query row
@@ -367,7 +371,7 @@ mkContainsFilterWith :: E.SqlString b
                      -> E.SqlExpr (E.Value Bool)
 mkContainsFilterWith cast lenslike row criterias
   | Set.null criterias = true
-  | otherwise = any (hasInfix $ lenslike row) (E.val . cast <$> Set.toList criterias)
+  | otherwise = any (hasInfix (lenslike row) . E.val . cast) criterias
 
 -- | like `mkContainsFilterWith` but allows conversion to produce multiple needles
 mkContainsFilterWithSet :: (E.SqlString b, Ord b, Ord a)
@@ -378,7 +382,7 @@ mkContainsFilterWithSet :: (E.SqlString b, Ord b, Ord a)
                      -> E.SqlExpr (E.Value Bool)
 mkContainsFilterWithSet cast lenslike row criterias
   | Set.null criterias = true
-  | otherwise = any (hasInfix $ lenslike row) (E.val <$> Set.toList (foldMap cast criterias))
+  | otherwise = any (hasInfix (lenslike row) . E.val)  (foldMap cast criterias)
 
 -- | like `mkContainsFilterWithSet` but fixed to comma separated Texts
 mkContainsFilterWithComma :: (E.SqlString b, Ord b)
@@ -389,7 +393,7 @@ mkContainsFilterWithComma :: (E.SqlString b, Ord b)
                      -> E.SqlExpr (E.Value Bool)
 mkContainsFilterWithComma cast lenslike row (foldMap commaSeparatedText -> criterias)
   | Set.null criterias = true
-  | otherwise = any (hasInfix $ lenslike row) (E.val . cast <$> Set.toList criterias)
+  | otherwise = any (hasInfix (lenslike row) . E.val . cast) criterias
 
 -- | like `mkContainsFilterWithComma` but enforced the existence of all Texts prefixed with +
 mkContainsFilterWithCommaPlus :: (E.SqlString b, Ord b)
@@ -405,8 +409,8 @@ mkContainsFilterWithCommaPlus cast lenslike row (foldMap commaSeparatedText -> c
   | otherwise             = cond_compulsory E.&&. cond_optional
   where    
     (Set.mapMonotonic (Text.stripStart . Text.drop 1) -> compulsories, alternatives) = Set.partition (Text.isPrefixOf "+") criterias
-    cond_compulsory = all (hasInfix $ lenslike row) (E.val . cast <$> Set.toList compulsories)
+    cond_compulsory = all (hasInfix (lenslike row) . E.val . cast) compulsories
-    cond_optional   = any (hasInfix $ lenslike row) (E.val . cast <$> Set.toList alternatives)
+    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") []

src/Foundation/I18n.hs

@@ -210,6 +210,9 @@ maybeBoolMessage Nothing      n _ _ = n
 maybeBoolMessage (Just True)  _ t _ = t
 maybeBoolMessage (Just False) _ _ f = f
 
+-- | Convenience function avoiding type signatures
+boolText :: Text -> Text -> Bool -> Text
+boolText = bool
 
 newtype ShortTermIdentifier = ShortTermIdentifier TermIdentifier
   deriving stock (Eq, Ord, Read, Show)
@@ -602,7 +605,7 @@ unRenderMessage = unRenderMessage' (==)
 
 unRenderMessageLenient :: forall a master. (Ord a, Finite a, RenderMessage master a) => master -> Text -> [a]
 unRenderMessageLenient = unRenderMessage' cmp
-  where cmp = (==) `on` mk . under packed (filter Char.isAlphaNum . concatMap unidecode)
+  where cmp = (==) `on` mk . under packed (concatMap $ filter Char.isAlphaNum . unidecode)
 
 
 instance Default DateTimeFormatter where

src/Foundation/Type.hs

@@ -43,7 +43,7 @@ import Data.Time.Clock.POSIX (POSIXTime)
 import GHC.Fingerprint (Fingerprint)
 import Handler.Sheet.PersonalisedFiles.Types (PersonalisedSheetFilesSeedKey)
 
-import Utils.Avs (AvsQuery)
+import Utils.Avs (AvsQuery())
 
 
 type SMTPPool = Pool SMTPConnection

src/Foundation/Yesod/Auth.hs

@@ -182,7 +182,7 @@ upsertCampusUser upsertMode ldapData = do
   userDefaultConf <- getsYesod $ view _appUserDefaults
 
   (newUser,userUpdate) <- decodeUser now userDefaultConf upsertMode ldapData
-  --TODO: newUser should be associated with a company and company supervisor through Handler.Utils.Company.upsertUserCompany, but this is called by upsertAvsUser already - conflict?
+  --TODO: newUser should be associated with a company and company supervisor through Handler.Utils.Company.oldUpsertUserCompany, but this is called by upsertAvsUser already - conflict?
 
   oldUsers <- for (userLdapPrimaryKey newUser) $ \pKey -> selectKeysList [ UserLdapPrimaryKey ==. Just pKey ] []
 

src/Handler/Admin.hs

@@ -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, postAdminProblemsR :: Handler Html
-getAdminProblemsR = do 
+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

src/Handler/Admin/Avs.hs

@@ -17,7 +17,7 @@ module Handler.Admin.Avs
 import Import
 import qualified Control.Monad.State.Class as State
 -- import Data.Aeson (encode)
-import qualified Data.Aeson.Encode.Pretty as Pretty
+-- import qualified Data.Aeson.Encode.Pretty as Pretty
 import qualified Data.Text as Text
 import qualified Data.CaseInsensitive as CI
 import qualified Data.Set  as Set
@@ -28,8 +28,6 @@ import Handler.Utils
 import Handler.Utils.Avs
 -- import Handler.Utils.Qualification
 
-import Utils.Avs
-
 
 import           Database.Esqueleto.Experimental ((:&)(..))
 import qualified Database.Esqueleto.Legacy as E
@@ -43,6 +41,13 @@ import qualified Database.Esqueleto.Utils        as E
 single :: (k,a) -> Map k a
 single = uncurry Map.singleton
 
+exceptionWgt :: SomeException -> Widget
+exceptionWgt (SomeException e) = [whamlet|<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
+  ((presult, pwidget), penctype) <- runFormPost $ makeAvsPersonForm Nothing
-    Nothing -> siteLayoutMsg MsgMenuAvs [whamlet|Error: AVS interface configuration is incomplete.|] -- should never occur after initilisation
-    Just AvsQuery{..} -> do
-      ((presult, pwidget), penctype) <- runFormPost $ makeAvsPersonForm Nothing
 
-      let procFormPerson fr = do
+  let procFormPerson fr = do
-            addMessage Info $ text2Html $ "Query: " <> tshow (toJSON fr)
+        addMessage Info $ text2Html $ "Query: " <> tshow (toJSON fr)
-            res <- avsQueryPerson fr
+        tryShow $ do
-            case res of
+          AvsResponsePerson pns <- avsQuery fr
-              Left  err -> let msg = tshow err in return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
+          return [whamlet|
-              Right (AvsResponsePerson pns) -> return $ Just [whamlet|
+              <ul>
-                  <ul>
+                $forall p <- pns
-                    $forall p <- pns
+                  <li>^{jsonWidget p}
-                      <li>#{decodeUtf8 (Pretty.encodePretty (toJSON p))}
+            |] -- <li>#{decodeUtf8 (Pretty.encodePretty (toJSON p))}
-                |]
+  mbPerson <- formResultMaybe presult (Just <<$>> procFormPerson)
-      mbPerson <- formResultMaybe presult procFormPerson
 
-      ((sresult, swidget), senctype) <- runFormPost $ makeAvsStatusForm Nothing
+  ((sresult, swidget), senctype) <- runFormPost $ makeAvsStatusForm Nothing
-      let procFormStatus fr = do
+  let procFormStatus fr = do
-            addMessage Info $ text2Html $ "Status Query: " <> tshow (toJSON fr)
+        addMessage Info $ text2Html $ "Status Query: " <> tshow (toJSON fr)
-            res <- avsQueryStatus fr
+        tryShow $ do 
-            case res of
+          AvsResponseStatus pns <- avsQuery fr
-              Left err -> let msg = tshow err in return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
+          return [whamlet|
-              Right (AvsResponseStatus pns) -> return $ Just [whamlet|
+              <ul>
-                  <ul>
+                $forall p <- pns
-                    $forall p <- pns
+                  <li>^{jsonWidget p}
-                      <li>#{decodeUtf8 (Pretty.encodePretty (toJSON p))}
+            |]
-                |]
+  mbStatus <- formResultMaybe sresult (Just <<$>> procFormStatus)
-      mbStatus <- formResultMaybe sresult procFormStatus
 
-      ((cresult, cwidget), cenctype) <- runFormPost $ makeAvsContactForm Nothing
+  ((cresult, cwidget), cenctype) <- runFormPost $ makeAvsContactForm Nothing
-      let procFormContact fr = do
+  let procFormContact fr = do
-            addMessage Info $ text2Html $ "Contact Query: " <> tshow (toJSON fr)
+        addMessage Info $ text2Html $ "Contact Query: " <> tshow (toJSON fr)
-            res <- avsQueryContact fr
+        tryShow $ do
-            case res of
+          AvsResponseContact pns <- avsQuery fr
-              Left err -> let msg = tshow err in return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
+          return [whamlet|
-              Right (AvsResponseContact pns) -> return $ Just [whamlet|
+              <ul>
-                  <ul>
+                $forall AvsDataContact{..} <- pns
-                    $forall AvsDataContact{..} <- pns
+                  <li>
-                      <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>
                     <ul>
-                      $forall AvsPersonLicence{..} <- flics
+                      <li>AvsId: #{tshow avsContactPersonID}                      
-                        <li> #{tshow avsLicencePersonID}: #{licence2char avsLicenceRampLicence}
+                      <li>^{jsonWidget avsContactPersonInfo}
-                  |]
+                      <li>^{jsonWidget avsContactFirmInfo}              
-
+            |] -- <li>#{decodeUtf8 (Pretty.encodePretty (toJSON avsContactPersonInfo))}
-              (Left err) -> do
+  mbContact <- formResultMaybe cresult (Just <<$>> procFormContact)
-                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
 
 
-      (qryLicForm, qryLicRes) <- runButtonForm FIDAvsQueryLicenceDiffs
+  ((crUsrRes, crUsrWgt), crUsrEnctype) <- runFormPost $ identifyForm FIDAvsCreateUser $ \html ->
-      mbQryLic <- case qryLicRes of
+    flip (renderAForm FormStandard) html $ areq textField (fslI MsgAvsCardNo) Nothing
-        Nothing -> return Nothing
+  let procFormCrUsr fr = do
-        (Just BtnCheckLicences) -> do
+        -- addMessage Info $ text2Html $ "Query: " <> tshow (toJSON fr)
-          res <- try $ do
+        res <- try $ guessAvsUser fr
-            allLicences <- throwLeftM avsQueryGetAllLicences
+        case res of
-            computeDifferingLicences allLicences
+          (Right (Just uid)) -> do
-          case res of
+            uuid :: CryptoUUIDUser <- encrypt uid
-            (Right diffs) -> do
+            return $ Just [whamlet|<h2>Success:</h2> <a href=@{ForProfileR uuid}>User created or updated.|]
-              let showLics l = Text.intercalate ", " $ fmap (tshow . avsLicencePersonID) $ Set.toList $ Set.filter ((l ==) . avsLicenceRampLicence) diffs
+          (Right Nothing) ->
-                  r_grant = showLics AvsLicenceRollfeld
+            return $ Just [whamlet|<h2>Warning:</h2> No user found.|]
-                  f_set   = showLics AvsLicenceVorfeld
+          (Left e) -> return $ Just $ exceptionWgt e
-                  revoke  = showLics AvsNoLicence
+  mbCrUser <- formResultMaybe crUsrRes procFormCrUsr
-              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
+  ((getLicRes, getLicWgt), getLicEnctype) <- runFormPost $ identifyForm FIDAvsQueryLicence $ \html ->
-      siteLayoutMsg MsgMenuAvs $ do
+    flip (renderAForm FormStandard) html $ (,,) <$> aopt intField (fslI $ text2message "Min AvsPersonId") Nothing
-        setTitleI MsgMenuAvs
+                                                <*> aopt intField (fslI $ text2message "Max AvsPersonId") Nothing
-        let wrapFormHere fw fe = wrapForm fw def { formAction = Just $ SomeRoute actionUrl, formEncoding = fe }
+                                                <*> aopt (selectField $ return avsLicenceOptions) (fslI MsgAvsLicence) Nothing
-            personForm  = wrapFormHere pwidget  penctype
+  let procFormGetLic fr = tryShow $ do
-            statusForm  = wrapFormHere swidget  senctype
+        AvsResponseGetLicences lics <- avsQuery AvsQueryGetAllLicences
-            contactForm = wrapFormHere cwidget  cenctype
+        let flics = Set.toList $ Set.filter lfltr lics
-            crUsrForm   = wrapFormHere crUsrWgt crUsrEnctype
+            lfltr = case fr of -- not pretty, but it'll do
-            getLicForm  = wrapFormHere getLicWgt getLicEnctype
+                (Just idmin, Just idmax, Just lic) -> \AvsPersonLicence{..} -> (avsLicenceRampLicence == lic) && (avsLicencePersonID `inBetween` (AvsPersonId idmin, AvsPersonId idmax))
-            setLicForm  = wrapFormHere setLicWgt setLicEnctype
+                (Just idmin, Nothing,    Just lic) -> \AvsPersonLicence{..} -> (avsLicenceRampLicence == lic) && (avsLicencePersonID == AvsPersonId idmin)
-        -- TODO: use i18nWidgetFile instead if this is to become permanent
+                (Nothing   , Just idmax, Just lic) -> \AvsPersonLicence{..} -> (avsLicenceRampLicence == lic) && (avsLicencePersonID == AvsPersonId idmax)
-        $(widgetFile "avs")
+                (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
+  Entity{entityVal=UserAvs{..}} <- runDB $ getBy404 $ UniqueUserAvsUser uid  
-  mAvsQuery <- getsYesod $ view _appAvsQuery
+  mbContact <- try $ avsQuery $ AvsQueryContact $ Set.singleton $ AvsObjPersonId userAvsPersonId
-  resWgt <- case mAvsQuery of
+  mbStatus  <- try $ avsQuery $ AvsQueryStatus  $ Set.singleton                  userAvsPersonId
-    Nothing -> return [whamlet|Error: AVS interface configuration is incomplete.|] -- should never occur after initilisation
+  -- mbDataPerson <- lookupAvsUser userAvsPersonId -- TODO: delete Handler.Utils.Avs.lookupAvsUser if no longer needed
-    Just AvsQuery{..} -> do
+  
-      mbContact <- avsQueryContact $ AvsQueryContact $ Set.singleton $ AvsObjPersonId userAvsPersonId
+  msgWarningTooltip <- messageI Warning MsgMessageWarning
-      mbDataPerson <- lookupAvsUser userAvsPersonId
+  let warnBolt = messageTooltip msgWarningTooltip
-      return [whamlet|
+      heading = [whamlet|_{MsgAvsPersonNo} #{userAvsNoPerson}|]
-        <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}|]
   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

src/Handler/Admin/Test.hs

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

src/Handler/Course/Edit.hs

@@ -291,9 +291,9 @@ getCourseNewR = do
                 }
         [] -> do
             (tidOk,sshOk,cshOk) <- runDB $ (,,)
-                <$> ifMaybeM mbTid True existsKey
+                <$> ifNothingM mbTid True existsKey
-                <*> ifMaybeM mbSsh True existsKey
+                <*> ifNothingM mbSsh True existsKey
-                <*> ifMaybeM mbCsh True (\csh -> not . null <$> selectKeysList [CourseShorthand ==. csh] [LimitTo 1])
+                <*> 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

src/Handler/Course/User.hs

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

src/Handler/Firm.hs

@@ -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:
+-- | remove supervisors for given users; maybe restricted to those linked to a given companies
-deleteSupervisors :: NonEmpty UserId -> DB Int64
+deleteSupervisors :: NonEmpty UserId -> [CompanyId] -> DB Int64
-deleteSupervisors usrs = deleteWhereCount [UserSupervisorUser <-. toList usrs]
+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.||.  (usr E.^. UserSurname      `E.hasInfix` E.val        crit )
-                    E.orderBy [E.asc $ cmp E.^. CompanyId]
+                    -- 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
+         $ bool (deleteSupervisors uids [cid]) (return 0) firmUserActSetSuperKeep
-        <* putMany [UserSupervisor s u firmUserActSetSuperReroute | u <- toList uids, s <- newSupers]
+        <* 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
 

src/Handler/LMS.hs

@@ -499,13 +499,7 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
                 E.on $     usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
                 E.where_ $ usrComp E.^. UserCompanyUser    E.==. queryUser row E.^. UserId E.&&. testcrit
         )        
-      , single ("avs-card"  , FilterColumn $ \(queryUser -> user) (criterion :: Set.Set Text) -> case readAvsFullCardNo =<< Set.lookupMin criterion of
+      , fltrAVSCardNos queryUser
-            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)
-          )
       , 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)

src/Handler/LMS/Fake.hs

@@ -71,11 +71,11 @@ fakeQualificationUsers (Entity qid Qualification{qualificationRefreshWithin}) (u
     theSupervisor <- selectKeysList [UserSurname ==. "Jost", UserFirstName ==. "Steffen"] [Asc UserCreated, LimitTo 1]
     let addSupervisor = case theSupervisor of 
           [s] -> \suid k -> case k of 
-                    1 -> void $ insertBy $ UserSupervisor s suid True
+                    1 -> void $ insertBy $ UserSupervisor s suid True Nothing Nothing
                     2 -> do
-                          void $ insertBy $ UserSupervisor s    suid True
+                          void $ insertBy $ UserSupervisor s    suid True Nothing (Just "Test")
-                          void $ insertBy $ UserSupervisor suid suid True
+                          void $ insertBy $ UserSupervisor suid suid True Nothing Nothing
-                    3 -> void $ insertBy $ UserSupervisor s suid True
+                    3 -> void $ insertBy $ UserSupervisor s suid True Nothing Nothing
                     _ -> return ()
           _   -> \_ _ -> return ()
         expiryOffsets = concatMap (replicate usersPerDay) [0..(diffDays dto dfrom)]

src/Handler/Profile.hs

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

src/Handler/Qualification.hs

@@ -19,7 +19,6 @@ import Handler.Utils
 import Handler.Utils.Users
 import Handler.Utils.LMS
 
-
 import qualified Data.Set as Set
 import qualified Data.Map as Map
 import qualified Data.Csv as Csv
@@ -404,19 +403,13 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
       -- , single ("validity", SortColumn $ queryQualUser >>> validQualification now)
       ]
     dbtFilter = mconcat
-      [ single $ fltrUserNameEmail   queryUser
+      [ single $ fltrUserNameEmail queryUser
       , single ("avs-number"  , FilterColumn . E.mkExistsFilter $ \row criterion ->
               E.from $ \usrAvs -> -- do 
                 E.where_ $ usrAvs E.^. UserAvsUser      E.==. queryUser row E.^. UserId
                     E.&&.  ((E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.==.
                           (E.explicitUnsafeCoerceSqlExprValue "citext" (usrAvs E.^. UserAvsNoPerson) :: E.SqlExpr (E.Value (CI Text))) ))
-      , single ("avs-card"  , FilterColumn $ \(queryUser -> user) (criterion :: Set.Set Text) -> case readAvsFullCardNo =<< Set.lookupMin criterion of
+      , fltrAVSCardNos queryUser
-            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)
-          )
       , 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

src/Handler/Users.hs

@@ -64,8 +64,8 @@ embedRenderMessage ''UniWorX ''UserAction id
 
 data UserActionData = UserLdapSyncData 
                     | UserHijack
-                    | UserAddSupervisorData { getActionSupervisors :: Set Text, getActionRerouteNotifications :: Bool } 
+                    | UserAddSupervisorData { getActionSupervisors :: Set Text, getActionRerouteNotifications :: Bool, getActionSupervisorReason :: Maybe Text } 
-                    | UserSetSupervisorData { getActionSupervisors :: Set Text, getActionRerouteNotifications :: Bool }
+                    | 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
+      queueAvsUpdateByUID userSet Nothing
-      addMessageI Success . MsgSynchroniseAvsUserQueued $ Set.size userSet      
+      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

src/Handler/Utils/Communication.hs

@@ -102,7 +102,7 @@ crJobsCourseCommunication jCourse Communication{..} = do
       adrReceiverMails = Set.map (Address Nothing . CI.original) rawReceiverMails
   netReceiverAddresses <- lift $ do
     netReceiverIds <- getReceiversFor $ jSender : Set.toList rawReceiverIds -- ensure supervisors get only one email
-    (userAddress . entityVal) <<$>> selectList [UserId <-. netReceiverIds] []
+    maybeMapM getEmailAddressFor netReceiverIds
   -- let jAllRecipientAddresses = Set.fromList netReceiverAddresses <> adrReceiverMails
   let jAllRecipientAddresses = Set.map getAddress (Set.fromList (AddressEqIgnoreName <$> netReceiverAddresses) <> Set.map AddressEqIgnoreName adrReceiverMails)
   forM_ jAllRecipientAddresses $ \raddr ->
@@ -124,7 +124,7 @@ crJobsFirmCommunication jCompanies Communication{..} = do
       adrReceiverMails = Set.map (Address Nothing . CI.original) rawReceiverMails
   netReceiverAddresses <- lift $ do
     netReceiverIds <- getReceiversFor $ jSender : Set.toList rawReceiverIds -- ensure supervisors get only one email
-    (userAddress . entityVal) <<$>> selectList [UserId <-. netReceiverIds] []
+    maybeMapM getEmailAddressFor netReceiverIds    
   -- let jAllRecipientAddresses = Set.fromList netReceiverAddresses <> adrReceiverMails
   let jAllRecipientAddresses = Set.map getAddress (Set.fromList (AddressEqIgnoreName <$> netReceiverAddresses) <> Set.map AddressEqIgnoreName adrReceiverMails)
   forM_ jAllRecipientAddresses $ \raddr ->

src/Handler/Utils/Company.hs

@@ -8,53 +8,39 @@ import Import
 -- import Utils.PathPiece
 
 -- import Data.CaseInsensitive (CI)
-import qualified Data.CaseInsensitive as CI
+-- import qualified Data.CaseInsensitive as CI
-import qualified Data.Char as Char
+-- import qualified Data.Char as Char
-import qualified Data.Text as Text
+-- 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: use this function in company view Handler.Firm #157
--- TODO: update company address, maybe?!
+
-upsertCompany :: Text -> Maybe StoredMarkup -> DB CompanyId
+-- | add all company supervisors for a given users
-upsertCompany cName cAddr = 
+addCompanySupervisors :: (MonadIO m, BackendCompatible SqlBackend backend, PersistQueryWrite backend, PersistUniqueWrite backend) 
-  let cName' = CI.mk cName in
+                      => Key Company -> Key User -> ReaderT backend m ()
-  getBy (UniqueCompanyName cName') >>= \case 
+addCompanySupervisors cid uid = 
-    Just ent -> return $ entityKey ent
+  E.insertSelectWithConflict
-    Nothing  -> getBy (UniqueCompanySynonym cName') >>= \case
+    UniqueUserSupervisor
-      Just ent -> return . CompanyKey . companySynonymCanonical $ entityVal ent
+    ( do 
-      Nothing  -> do
+        userCompany <- E.from $ E.table @UserCompany
-        let cShort  = companyShorthandFromName cName            
+        E.where_ $ userCompany E.^. UserCompanyCompany E.==. E.val cid
-        cShort' <- findShort cName' $ CI.mk cShort
+            E.&&.  userCompany E.^. UserCompanySupervisor
-        let compy  = Company cName' cShort' 0 False cAddr Nothing -- TODO: Fix this once AVS CR3 SCF-165 is implemented
+        return $ UserSupervisor
-        either entityKey id <$> insertBy compy
+          E.<#  (userCompany E.^. UserCompanyUser)
-  where 
+          E.<&>  E.val uid
-    findShort :: CompanyName -> CompanyShorthand -> DB CompanyShorthand    
+          E.<&> (userCompany E.^. UserCompanySupervisorReroute)
-    findShort fna fsh = aux 0
+          E.<&>  E.justVal cid
-      where 
+          E.<&>  E.justVal (tshow SupervisorReasonCompanyDefault)
-        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
+    (\current excluded -> -- Supervision between chosen individuals exists already; keep old reason and company, if exists
-                  Nothing -> return fsh'
+        [ UserSupervisorCompany E.=. E.coalesce [current  E.^. UserSupervisorCompany, excluded E.^. UserSupervisorCompany] -- do we want this? Ok, since we delete unconditionally first?!
-                  _other  -> aux (n+1)
+        , 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

src/Handler/Utils/Concurrent.hs

@@ -13,6 +13,12 @@ import UnliftIO.Concurrent as Handler.Utils.Concurrent hiding (yield)
 
 
 
+maybeTimeoutHandler :: Maybe Int -> HandlerFor site a -> HandlerFor site (Maybe a)
+maybeTimeoutHandler Nothing     = fmap Just
+maybeTimeoutHandler (Just secs) = timeoutHandler $ bool maxBound micro (micro > 0)
+  where 
+    micro = 1000000 * secs
+
 -- | Run a handler action until it finishes or if it exceeds a given number of microseconds via `registerDelay`
 timeoutHandler :: Int -> HandlerFor site a -> HandlerFor site (Maybe a)
 timeoutHandler maxWait act = do

src/Handler/Utils/Mail.hs

@@ -3,9 +3,7 @@
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
 module Handler.Utils.Mail
-  ( addRecipientsDB
+  ( addRecipientsDB    
-  , userAddress, userAddress'
-  , userAddressFrom
   , 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
+-- userAddress :: User -> Address
--- ^ Format an e-mail address suitable for usage as a recipient
+-- -- ^ 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.
+-- -- Like userAddressFrom, but prefers `userDisplayEmail` (if valid) and otherwise uses `userEmail`. Unlike Uni2work, userEmail from LDAP is untrustworthy.
-userAddress User{userEmail, userDisplayEmail, userDisplayName}
+-- userAddress User{userEmail, userDisplayEmail, userDisplayName}
-  = Address (Just userDisplayName) $ CI.original $ pickValidEmail userDisplayEmail userEmail
+--   = Address (Just userDisplayName) $ CI.original $ pickValidUserEmail userDisplayEmail userEmail
 
-userAddress' :: UserEmail -> UserEmail -> UserDisplayName -> Address
+-- userAddress' :: UserEmail -> UserEmail -> UserDisplayName -> Address
--- Like userAddress', but does not require a complete entity
+-- -- Like userAddress', but does not require a complete entity
-userAddress' userEmail  userDisplayEmail userDisplayName
+-- userAddress' userEmail  userDisplayEmail userDisplayName
-  = Address (Just userDisplayName) $ CI.original $ pickValidEmail userDisplayEmail userEmail
+--   = Address (Just userDisplayName) $ CI.original $ pickValidUserEmail userDisplayEmail userEmail
 
-userAddressError :: (MonadHandler m, HandlerSite m ~ UniWorX) => User -> m (Bool, Address)
+
-userAddressError User{userEmail, userDisplayEmail, userDisplayName} 
+userAddressError :: (MonadHandler m, HandlerSite m ~ UniWorX, m ~ HandlerFor UniWorX) => Entity User -> m (Bool, Address)
-  | Just okEmail <- pickValidEmail' userDisplayEmail userEmail = pure (True, Address (Just userDisplayName) $ CI.original okEmail)
+userAddressError usr@Entity{entityVal=User{userEmail, userDisplayEmail, userDisplayName}} = 
-  | otherwise = do
+  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)

src/Handler/Utils/Pandoc.hs

@@ -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
+  ( module Utils.Pandoc
-  , renderMarkdownWith, parseMarkdownWith
+  , htmlField, htmlFieldSmall
-  , htmlReaderOptions, markdownReaderOptions
+  , renderMarkdownWith, parseMarkdownWith  
-  , markdownWriterOptions, htmlWriterOptions
   ) 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

src/Handler/Utils/Profile.hs

@@ -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
+  ( module Utils.Mail
-  , validPostAddress  
+  , validDisplayName, checkDisplayName, fixDisplayName
-  , validEmail, validEmail', pickValidEmail, pickValidEmail'
+  , 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
+import Utils.Mail 
-
--- | Instead of CI.mk, this still allows use of Text.isInfixOf, etc.
-stripFold :: Text -> Text 
-stripFold = Text.toCaseFold . Text.strip
 
 -- | 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})
+validPostAddress (Just StoredMarkup {markupInput = addr}) = 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) 
-    = True
 validPostAddress _ = False
 
--- also see `Handler.Utils.Users.getEmailAddress` for Tests accepting User Type
+validPostAddressText :: Text -> Bool
-validEmail :: Email -> Bool      -- Email = Text
+validPostAddressText = validPostAddressLazyText . LT.fromStrict
-validEmail email = validRFC5322 && not invalidFraport
-  where 
-    validRFC5322 = Email.isValid $ encodeUtf8 email
-    invalidFraport = case Text.stripSuffix "@fraport.de" (foldCase email) of  
-      Just fralogin -> all isDigit $ drop 1 fralogin
-      Nothing       -> False
 
-validEmail' :: UserEmail -> Bool -- UserEmail = CI Text
+validPostAddressLazyText :: LT.Text -> Bool
-validEmail' = validEmail . CI.original
+validPostAddressLazyText addr
-
+  | Just _ <- LT.find isLetter addr
--- | returns first argument, if it is a valid email address; returns second argument untested otherwise; convenience function
+  , Just _ <- LT.find isNumber addr
-pickValidEmail :: UserEmail -> UserEmail -> UserEmail
+  -- , Just _ <- LT.find ((LineSeparator ==) . generalCategory) addr -- THIS DID NOT WORK
-pickValidEmail x y
+    = 1 < length (LT.lines addr)    
-  | validEmail' x = x
+validPostAddressLazyText _ = False
-  | otherwise     = y
-
--- | returns first valid email address or none if none are valid
-pickValidEmail' :: UserEmail -> UserEmail -> Maybe UserEmail
-pickValidEmail' x y 
-  | validEmail' x = Just x
-  | validEmail' y = Just y
-  | otherwise     = Nothing
 
 validFraportPersonalNumber :: Maybe Text -> Bool
 validFraportPersonalNumber Nothing = False

src/Handler/Utils/Table/Cells.hs

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

src/Handler/Utils/Table/Columns.hs

@@ -8,6 +8,8 @@ module Handler.Utils.Table.Columns where
 
 import Import hiding (link)
 
+import qualified Data.Map as Map
+
 import qualified Database.Esqueleto.Legacy as E
 import qualified Database.Esqueleto.Utils as E hiding ((->.))
 import Database.Esqueleto.Utils (mkExactFilter, mkExactFilterWith, mkContainsFilter, mkContainsFilterWith, mkContainsFilterWithComma, mkContainsFilterWithCommaPlus, anyFilter)
@@ -21,6 +23,8 @@ import Handler.Utils.Form
 import Handler.Utils.Widgets
 import Handler.Utils.DateTime
 import Handler.Utils.StudyFeatures
+import Handler.Utils.Avs (queryAvsCardNos)
+import Handler.Utils.Concurrent
 
 import qualified Data.CaseInsensitive as CI
 
@@ -801,6 +805,41 @@ fltrCompanyNameNrHdrUI msg mPrev =
   prismAForm (singletonFilter "company-name-number") mPrev $ aopt textField (fslI msg & setTooltip MsgTableFilterCommaNameNr)
 
 
+---------
+-- AVS --
+---------
+
+
+fltrAVSCardNos :: (IsFilterColumnHandler t ([Text] -> Handler (a -> E.SqlExpr (E.Value Bool))), IsString k) 
+              => (a -> E.SqlExpr (Entity User)) -> Map k (FilterColumn t fs)
+fltrAVSCardNos queryUser = Map.singleton "avs-card" fch
+  where 
+    fch = FilterColumnHandler $ \case
+      [] -> return (const E.true)
+      cs -> do
+        let crds = mapMaybe parseAvsCardNo $ foldMap anySeparatedText cs
+        toutsecs <- getsYesod $ preview $ _appAvsConf . _Just . _avsTimeout
+        maybeTimeoutHandler toutsecs (try $ queryAvsCardNos crds) >>= \case 
+          Nothing               -> addMessageI Error MsgAvsCommunicationTimeout 
+                                >> return (const E.false)
+          (Just (Left err))     -> addMessage  Error (someExc2Html err)
+                                >> return (const E.false)
+          (Just (Right (null -> True))) -> return (const E.false)
+          (Just (Right apids)) -> return $ 
+            \(queryUser -> user) ->
+              E.exists $ E.from $ \usrAvs ->
+                E.where_ $ usrAvs E.^. UserAvsUser E.==. user E.^. UserId
+                    E.&&.  usrAvs E.^. UserAvsPersonId `E.in_` E.vals apids
+    someExc2Html :: SomeException -> Html
+    someExc2Html (SomeException e) = text2Html $ tshow e
+
+fltrAVSCardNosUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
+fltrAVSCardNosUI mPrev = 
+  prismAForm (singletonFilter "avs-card" ) mPrev $ 
+    aopt textField (fslI MsgAvsCardNo & setTooltip (SomeMessages [SomeMessage MsgTableFilterComma, SomeMessage MsgAvsQueryNeeded]))
+
+
+
 ----------------------------
 -- Colonnade manipulation --
 ----------------------------

src/Handler/Utils/Table/Pagination.hs

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

src/Handler/Utils/Users.hs

@@ -12,12 +12,15 @@ module Handler.Utils.Users
   , NameMatchQuality(..)
   , matchesName
   , GuessUserInfo(..)
-  , guessUser
+  , guessUser, guessUserByEmail
   , UserAssimilateException(..), UserAssimilateExceptionReason(..)
   , assimilateUser
-  , userPrefersEmail, userPrefersLetter
+  , getUserPrimaryCompany
-  , getEmailAddress
+  , getUserEmail
-  , getPostalAddress, getPostalPreferenceAndAddress
+  , 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
+getUserPrimaryCompany :: UserId -> (Company -> Maybe a) -> DB (Maybe a)
-userPrefersLetter :: User -> Bool
+getUserPrimaryCompany uid prj = runMaybeT $ do
-userPrefersLetter = fst . getPostalPreferenceAndAddress
+  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
+-- | result (True, Nothing, Nothing) indicates that neither userEmail nor userPostAddress is known
-userPrefersEmail :: User -> Bool
+getPostalPreferenceAndAddress :: Entity User -> DB (Bool, Maybe [Text], Maybe UserEmail)
-userPrefersEmail = not . userPrefersLetter
+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
+-- | result (True, Nothing, Nothing) indicates that neither userEmail nor userPostAddress is known
-getPostalPreferenceAndAddress :: User -> (Bool, Maybe [Text])
+--   primed variant returns storedMarkup without prefixed userDisplayName
-getPostalPreferenceAndAddress usr@User{userPrefersPostal} =
+getPostalPreferenceAndAddress' :: Entity User -> DB (Bool, Maybe StoredMarkup, Maybe UserEmail)
-    ((userPrefersPostal && postPossible) || not emailPossible, pa)
+getPostalPreferenceAndAddress' usr = do
-    -- (((userPrefersPostal || isNothing userPinPassword) && postPossible) || not emailPossible, pa) -- ignore email/post preference if no pinPassword is set
+  pa <- getPostalAddress' usr
-  where        
+  em <- getUserEmail   usr
-    pa = getPostalAddress usr
+  let usrPrefPost = usr ^. _entityVal . _userPrefersPostal
-    postPossible  = isJust pa
+      finalPref   = (usrPrefPost && isJust pa) || isNothing em
-    emailPossible = isJust $ getEmailAddress usr
+      -- 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
+getJustEmailAddress :: Entity User -> DB Address
-getEmailAddress User{userDisplayEmail, userEmail} = pickValidEmail' userDisplayEmail userEmail
+getJustEmailAddress = maybeThrowM ExceptionUserHasNoEmail . getEmailAddress
 
-getPostalAddress :: User -> Maybe [Text]
+getEmailAddress :: Entity User -> DB (Maybe Address)
-getPostalAddress User{..}
+getEmailAddress usr@Entity{entityVal=User{userDisplayName}} = toAddress <<$>> getUserEmail usr  
-  | Just pa <- userPostAddress
+  where toAddress = Address (Just userDisplayName) . CI.original
-    = Just $ userDisplayName : html2textlines pa
+
-  | Just abt <- userCompanyDepartment
+getUserEmail :: Entity User -> DB (Maybe UserEmail)
-    = Just $ if | "BVD" `isPrefixOf` abt -> [userDisplayName, abt, "Bodenverkehrsdienste"]
+getUserEmail Entity{entityKey=uid, entityVal=User{userDisplayEmail, userEmail}}
-                | otherwise              -> [userDisplayName, abt, "Hausbriefkasten"     ]
+  | 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 $ upsertBySafe (UniqueUserAvsId (oldUserAvs ^. _userAvsPersonId)) oldUserAvs{userAvsUser=newUserId} (_userAvsUser .~ newUserId)
-         void $ upsertBy (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)

src/Handler/Utils/avs_callgraph.md

@@ -0,0 +1,47 @@
+# Demo
+## Mermaid Flowcharts
+
+```mermaid
+flowchart LR;
+  gau([guessAvsUser])
+  %% uau([XupsertAvsUser])
+  uaubi[upsertAvsUserById]
+  uaubis[upsertAvsUserByIds]
+  uaubc[upsertAvsUserByCard]
+  ldap[[ldapLookupAndUpsert]]
+  lau[lookupAvsUser]
+  laus[lookupAvsUsers - DEPRECATED?]
+  gla[guessLicenceAddress - DEPRECATED]
+  ur([?updateReceivers])
+  caubi[createAvsUserById]
+  ucomp[upsertAvsCompany]
+
+  aqc{{AvsQueryContact}}
+  aqp{{AvsQueryPerson}}
+  aqs{{AvsQueryStatus}}
+
+  
+  uaubc-->uaubi
+  uaubc-->aqp
+  
+  gau-->uaubi
+  gau-->uaubc
+  gau-->ldap
+  
+  %% uau-..->uaubi
+  %% uau-..->uaubc
+  
+  uaubi-->uaubis
+  uaubi-->caubi-->uaubis
+  uaubis-->aqc
+  caubi-->aqs
+  caubi-->aqc
+
+  caubi-->ucomp
+  uaubis-->ucomp
+
+  lau-->laus
+  laus-->aqs
+
+  ur-->uaubi
+```

src/Jobs/Handler/ChangeUserDisplayEmail.hs

@@ -9,6 +9,7 @@ module Jobs.Handler.ChangeUserDisplayEmail
 import Import
 
 import Handler.Utils.Mail
+import Handler.Utils.Users
 import qualified Data.HashSet as HashSet
 import qualified Data.HashMap.Strict as HashMap
 import qualified Data.CaseInsensitive as CI
@@ -24,10 +25,13 @@ dispatchJobChangeUserDisplayEmail jUser jDisplayEmail = JobHandlerException $ do
     setDisplayEmailUrl = SomeRoute (SetDisplayEmailR, [(toPathPiece GetBearer, toPathPiece jwt)])
   setDisplayEmailUrl' <- toTextUrl setDisplayEmailUrl
 
-  user@User{..} <- runDB $ getJust jUser
+  (Entity{entityVal=User{..}}, userAddress) <- runDB $ do
+    usrEnt <- getJustEntity jUser -- error aborts job
+    usrAdr <- getJustEmailAddress usrEnt
+    return (usrEnt, usrAdr)
 
   userMailT jUser $ do
-    _mailTo .= pure (userAddress user & _addressEmail .~ CI.original jDisplayEmail)
+    _mailTo .= pure (userAddress & _addressEmail .~ CI.original jDisplayEmail)
     replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
     setSubjectI MsgMailSubjectChangeUserDisplayEmail
     addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/changeUserDisplayEmail.hamlet") :: HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX))

src/Jobs/Handler/Invitation.hs

@@ -8,6 +8,7 @@ module Jobs.Handler.Invitation
 
 import Import
 import Handler.Utils.Mail
+import Handler.Utils.Users
 
 import qualified Data.CaseInsensitive as CI
 import Text.Hamlet
@@ -20,12 +21,15 @@ dispatchJobInvitation :: Maybe UserId
                       -> Html
                       -> JobHandler UniWorX
 dispatchJobInvitation jInviter jInvitee jInvitationUrl jInvitationSubject jInvitationExplanation = JobHandlerException $ do
-  mInviter <- join <$> traverse (runDB . get) jInviter
+  (mInviter, mInviterAddress) <- ifNothingM jInviter (Nothing,Nothing) $ \uid -> runDB $ do 
+    usrEnt <- getEntity uid
+    usrAdr <- join <$> traverse getEmailAddress usrEnt
+    return (usrEnt ^? _Just . _entityVal, usrAdr)
 
   mailT def $ do
     _mailTo .= [Address Nothing $ CI.original jInvitee]
-    whenIsJust mInviter $ \jInviter' ->
+    whenIsJust mInviterAddress $ \jInviterAddress ->
-      replaceMailHeader "Reply-To" . Just . renderAddress $ userAddressFrom jInviter'
+      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))

src/Jobs/Handler/LMS.hs

@@ -60,7 +60,7 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act
     act = do
       quali <- getJust qid -- may throw an error, aborting the job
       let qshort = CI.original $ qualificationShorthand quali
-      $logInfoS "LMS" $ "Notifying about exipiring qualification " <> qshort
+      $logInfoS "LMS" $ "Notifying about expiring qualification " <> qshort
       now <- liftIO getCurrentTime
       case qualificationRefreshWithin quali of
         Nothing -> return () -- TODO: no renewal period, no reminders currently
@@ -92,7 +92,7 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act
                           }
                   _ -> return ()
           -- send second reminders first, before enqueing even more
-          ifMaybeM (qualificationRefreshReminder quali) () sendReminders
+          ifNothingM (qualificationRefreshReminder quali) () sendReminders
 
           renewalUsers <- E.select $ do
             quser <- E.from $ E.table @QualificationUser
@@ -129,7 +129,6 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act
           qprefix = fst <$> Text.uncons (Text.toLower qshort)
       identsInUseVs <- E.select $ do
         lui <- E.from $
-
           ( (E.^. LmsUserIdent)     <$> E.from (E.table @LmsUser    ) ) -- no filter by Qid, since LmsIdents must be unique across all
           `E.union_`
           ( (E.^. LmsReportIdent)   <$> E.from (E.table @LmsReport  ) ) -- V2

src/Jobs/Handler/QueueNotification.hs

@@ -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}) -> 
+            .| C.filterM (\(notification', override, usr@(Entity _ User{userNotificationSettings})) -> 
-                and2M (return $ isJust $ pickValidEmail' userDisplayEmail userEmail) $
+                and2M (isJust <$> hoist lift (getUserEmail usr)) $
                   or2M (return override) $ notificationAllowed userNotificationSettings <$> hoist lift (classifyNotification notification'))
             .| C.map (\(notification', _, Entity uid _) -> JobSendNotification uid notification')
             .| sinkDBJobs

src/Jobs/Handler/SendCourseCommunication.hs

@@ -12,6 +12,7 @@ import Import
 import Text.Hamlet
 
 import Handler.Utils
+import Handler.Utils.Users
 
 import qualified Data.CaseInsensitive as CI
 import Handler.Utils.Csv (partIsAttachmentCsv)
@@ -28,14 +29,17 @@ dispatchJobSendCourseCommunication :: Either UserEmail UserId
                                    -> CommunicationContent
                                    -> JobHandler UniWorX
 dispatchJobSendCourseCommunication jRecipientEmail jAllRecipientAddresses jCourse jSender jMailObjectUUID CommunicationContent{..} = JobHandlerException $ do
-  (sender, Course{..}) <- runDB $ (,)
+  (Course{..}, senderAddress) <- runDB $ do
-    <$> getJust jSender
+    crs <- getJust jCourse
-    <*> 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 $ (,)
+  senderAddress <- runDB $ getJustEmailAddressFor jSender
-  --   <$> getJust jSender
+    
-  --   <*> ifMaybeM jCompany Nothing get
-  sender <- runDB $ getJust 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

src/Jobs/Handler/SendNotification/SubmissionEdited.hs

@@ -13,6 +13,7 @@ module Jobs.Handler.SendNotification.SubmissionEdited
 import Import
 
 import Handler.Utils
+import Handler.Utils.Users
 import Jobs.Handler.SendNotification.Utils
 
 import Text.Hamlet
@@ -36,10 +37,11 @@ dispatchNotificationSubmissionEdited nInitiator nSubmission jRecipient = userMai
       E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val nSubmission
            E.&&. user E.^. UserId E.!=. E.val jRecipient
       return user
+    coSubmittorsAddrs <- maybeMapM getEmailAddress coSubmittors
 
-    return (course, sheet, submission, initiator, coSubmittors)
+    return (course, sheet, submission, initiator, coSubmittorsAddrs)
 
-  let allCoSubmittors = Text.intercalate ", " $ map (renderAddress . userAddressFrom . entityVal) coSubmittors
+  let allCoSubmittors = Text.intercalate ", " $ map renderAddress coSubmittors
   addMailHeader "Reply-To" allCoSubmittors
 
   replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
@@ -69,14 +71,15 @@ dispatchNotificationSubmissionUserCreated nUser nSubmission jRecipient = userMai
       E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val nSubmission
            E.&&. user E.^. UserId E.!=. E.val jRecipient
       return user
+    coSubmittorsAddrs <- maybeMapM getEmailAddress coSubmittors
 
     user <- getJust nUser
 
-    return (user, course, sheet, submission, coSubmittors)
+    return (user, course, sheet, submission, coSubmittorsAddrs)
 
   let isSelf = nUser == jRecipient
 
-  let allCoSubmittors = Text.intercalate ", " $ map (renderAddress . userAddressFrom . entityVal) coSubmittors
+  let allCoSubmittors = Text.intercalate ", " $ map renderAddress coSubmittors
   addMailHeader "Reply-To" allCoSubmittors
 
   replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
@@ -99,7 +102,7 @@ dispatchNotificationSubmissionUserCreated nUser nSubmission jRecipient = userMai
 
 dispatchNotificationSubmissionUserDeleted :: UserId -> SheetId -> SubmissionId -> UserId -> Handler ()
 dispatchNotificationSubmissionUserDeleted nUser nSheet nSubmission jRecipient = userMailT jRecipient $ do
-  (User{..}, Course{..}, Sheet{..}, mSubmission, coSubmittors) <- liftHandler . runDB $ do
+  (User{..}, Course{..}, Sheet{..}, mSubmission, coSubmittors, coSubmittorsAddrs) <- liftHandler . runDB $ do
     submission <- get nSubmission
 
     sheet <- maybe (getJust nSheet) (belongsToJust submissionSheet) submission
@@ -110,15 +113,15 @@ dispatchNotificationSubmissionUserDeleted nUser nSheet nSubmission jRecipient =
       E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val nSubmission
            E.&&. user E.^. UserId E.!=. E.val jRecipient
       return user
-
+    coSubmittorsAddrs <- maybeMapM getEmailAddress coSubmittors
     user <- getJust nUser
 
-    return (user, course, sheet, submission, coSubmittors)
+    return (user, course, sheet, submission, coSubmittors, coSubmittorsAddrs)
 
   let isSelf = nUser == jRecipient
 
   unless (null coSubmittors) $ do
-    let allCoSubmittors = Text.intercalate ", " $ map (renderAddress . userAddressFrom . entityVal) coSubmittors
+    let allCoSubmittors = Text.intercalate ", " $ map renderAddress coSubmittorsAddrs
     addMailHeader "Reply-To" allCoSubmittors
 
   replaceMailHeader "Auto-Submitted" $ Just "auto-generated"

src/Jobs/Handler/SendNotification/SubmissionRated.hs

@@ -11,6 +11,7 @@ module Jobs.Handler.SendNotification.SubmissionRated
 import Import
 
 import Handler.Utils
+import Handler.Utils.Users
 import Jobs.Handler.SendNotification.Utils
 
 import Text.Hamlet
@@ -19,22 +20,25 @@ import qualified Data.CaseInsensitive as CI
 
 dispatchNotificationSubmissionRated :: SubmissionId -> UserId -> Handler ()
 dispatchNotificationSubmissionRated nSubmission jRecipient = maybeT_ $ do
-  (Course{..}, Sheet{..}, Submission{..}, corrector, sheetTypeDesc, hasAccess, csid) <- lift . runDB $ do
+  (Course{..}, Sheet{..}, Submission{..}, corrector, correctorAddr, sheetTypeDesc, hasAccess, csid) <- lift . runDB $ do
     submission@Submission{submissionRatingBy} <- getJust nSubmission
     sheet@Sheet{sheetName} <- belongsToJust submissionSheet submission
     course@Course{..} <- belongsToJust sheetCourse sheet
-    corrector <- traverse getJust submissionRatingBy
+    correctorEnt  <- traverse getJustEntity submissionRatingBy
+    correctorAddr <- join <$> traverse getEmailAddress correctorEnt
+    let corrector = correctorEnt ^? _Just . _entityVal
+
     sheetTypeDesc <- sheetTypeDescription (sheetCourse sheet) (sheetType sheet)
     csid <- encrypt nSubmission
 
     hasAccess <- is _Authorized <$> evalAccessForDB (Just jRecipient) (CSubmissionR courseTerm courseSchool courseShorthand sheetName csid CorrectionR) False
-    return (course, sheet, submission, corrector, sheetTypeDesc, hasAccess, csid)
+    return (course, sheet, submission, corrector, correctorAddr, sheetTypeDesc, hasAccess, csid)
 
   guard hasAccess
 
   lift . userMailT jRecipient $ do
-    whenIsJust corrector $ \corrector' ->
+    whenIsJust correctorAddr $ \correctorAddr' ->
-      addMailHeader "Reply-To" . renderAddress $ userAddressFrom corrector'
+      addMailHeader "Reply-To" $ renderAddress correctorAddr'
     replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
     setSubjectI $ MsgMailSubjectSubmissionRated courseShorthand
 

src/Jobs/Handler/SynchroniseAvs.hs

@@ -4,29 +4,34 @@
 
 module Jobs.Handler.SynchroniseAvs
   ( dispatchJobSynchroniseAvs  
-  , dispatchJobSynchroniseAvsId
+  -- , dispatchJobSynchroniseAvsId
-  , dispatchJobSynchroniseAvsUser
+  -- , dispatchJobSynchroniseAvsUser  
-  , dispatchJobSynchroniseAvsNext
   , 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
+-- dispatchJobSynchroniseAvsId :: AvsPersonId -> Maybe Day -> JobHandler UniWorX
--- dispatchJobSynchroniseAvs' numIterations epoch iteration pause = JobHandlerAtomic $ do 
+-- 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
+-- dispatchJobSynchroniseAvsQueue :: JobHandler UniWorX
-dispatchJobSynchroniseAvsId apid pause = JobHandlerException $ do 
+-- dispatchJobSynchroniseAvsQueue = JobHandlerException $ do
-  ok <- runDB $ getBy (UniqueUserAvsId apid) >>= 
+--     (unlinked,linked) <- runDB $ do
-    \case
+--       jobs <- E.select (do
-      (Just Entity{entityVal=UserAvs{userAvsUser=uid}}) -> do -- known user 
+--           (avsSync :& usrAvs) <- E.from $  E.table @AvsSync 
-        workJobSychronizeAvs uid pause
+--                               `E.leftJoin` E.table @UserAvs
-        return True
+--             `E.on` (\(avsSync :& usrAvs) -> avsSync E.^. AvsSyncUser E.=?. usrAvs E.?. UserAvsUser)
-      _ -> -- unknown avsPersonId, attempt to create user
+--           let pause    = avsSync E.^. AvsSyncPause  
-        return False
+--               lastSync = usrAvs  E.?. UserAvsLastSynch
-  unless ok $ void $ maybeCatchAll $ upsertAvsUserById apid
+--           E.where_ $  E.isNothing pause
-
+--                 E.||. E.isNothing lastSync
-
+--                 E.||. pause E.>. E.dayMaybe lastSync
-dispatchJobSynchroniseAvsUser :: UserId -> Maybe Day -> JobHandler UniWorX
+--           return (avsSync E.^. AvsSyncId, avsSync E.^. AvsSyncUser, usrAvs E.?. UserAvsPersonId)
-dispatchJobSynchroniseAvsUser uid pause = JobHandlerException $ runDB $ workJobSychronizeAvs uid pause
+--         )
-
+--       let (syncIds, unlinked, linked) = foldl' discernJob mempty jobs
-workJobSychronizeAvs :: UserId -> Maybe Day -> DB ()
+--       E.deleteWhere [AvsSyncId <-. syncIds]
-workJobSychronizeAvs uid pause = do
+--       return (unlinked, linked)
-    now <- liftIO getCurrentTime
+    
-    -- void $ E.upsert
+--     void $ updateAvsUserByIds  linked
-    --   AvsSync { avsSyncUser         = uid
+--     void $ linktoAvsUserByUIDs unlinked
-    --           , avsSyncCreationTime = now
+--     -- we do not reschedule failed synchs here in order to avoid a loop
-    --           , avsSyncPause        = pause
+--   where 
-    --           }
+--     discernJob (accSync, accUid, accApi) (E.Value k,           _, E.Value (Just api)) = (k:accSync, accUid, Set.insert api accApi)
-    --   [ \oldSync -> (AvsSyncPause E.=. E.greatest (E.val pause) (oldSync E.^. AvsSyncPause)) oldSync ] -- causes Esqueleto to call undefined at Database.Esqueleto.Internal.Internal.renderUpdates:1308
+--     discernJob (accSync, accUid, accApi) (E.Value k, E.Value uid, E.Value  Nothing  ) = (k:accSync, Set.insert uid accUid, accApi)
-    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
+dispatchJobSynchroniseAvsQueue = JobHandlerException $ do    
-  syncJob <- runDB $ 
+    jobs <- runDB $ do
-    selectFirst [] [Asc AvsSyncCreationTime] >>= \case
+      jobs <- E.select (do
-      Nothing -> return Nothing -- nothing more to do
+          (avsSync :& usrAvs) <- E.from $  E.table @AvsSync 
-      Just Entity{entityKey=asid, entityVal=AvsSync{..}} -> do
+                              `E.leftJoin` E.table @UserAvs
-        delete asid        
+            `E.on` (\(avsSync :& usrAvs) -> avsSync E.^. AvsSyncUser E.=?. usrAvs E.?. UserAvsUser)
-        getBy (UniqueUserAvsUser avsSyncUser) >>= \case
+          let pause    = avsSync E.^. AvsSyncPause  
-          Just uae@Entity{entityVal=UserAvs{userAvsLastSynch} }
+              lastSync = usrAvs  E.?. UserAvsLastSynch
-            | maybe True (utctDay userAvsLastSynch <) avsSyncPause -> return $ Just uae
+          E.where_ $  E.isNothing pause
-          _other -> return Nothing -- we just updated this one within the given limit or the entity does not exist
+                E.||. E.isNothing lastSync
-        
+                E.||. pause E.>. E.dayMaybe lastSync
-  ifMaybeM syncJob () $ \Entity{entityKey=avsKey, entityVal=UserAvs{userAvsPersonId=apid}} -> do
+          return (avsSync E.^. AvsSyncUser, usrAvs E.?. UserAvsPersonId)
-    void $ queueJob JobSynchroniseAvsNext
+        )
-    catch (void $ upsertAvsUserById apid) -- already updates UserAvsLastSynch
+      now <- liftIO getCurrentTime
-            (\exc -> do 
+      E.truncateTable $ AvsSync (error "truncateTable: AvsSyncUser not needed") now Nothing
-              now <- liftIO getCurrentTime
+      return jobs
-              let excMsg = tshow exc <> " at " <> tshow now
+    let (unlinked, linked) = foldl' discernJob mempty jobs
-              runDB (update avsKey [UserAvsLastSynchError =. Just excMsg, UserAvsLastSynch =. now])
+    $logInfoS "SynchronisAvs" [st|AVS synch performing for #{length linked} AVS linked users and #{length unlinked} unlinked users|]
-              case exc of
+    void $ updateAvsUserByIds  linked
-                AvsInterfaceUnavailable -> return ()  -- ignore and retry later
+    void $ linktoAvsUserByUIDs unlinked
-                AvsUserUnknownByAvs _   -> return ()  -- ignore for users no longer listed in AVS
+    $logInfoS "SynchronisAvs" [st|AVS synch performed for #{length linked} AVS linked users and #{length unlinked} unlinked users|]
-                otherExc                -> throwM otherExc
+    -- 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)
--- needed, since JobSynchroniseAvsQueue cannot requeue itself due to JobNoQueueSame (and having no parameters)
+    discernJob (accUid, accApi) (E.Value uid, E.Value  Nothing  ) = (Set.insert uid accUid,                accApi)
-dispatchJobSynchroniseAvsNext :: JobHandler UniWorX
+    
-dispatchJobSynchroniseAvsNext = JobHandlerException $ void $ queueJob JobSynchroniseAvsQueue

src/Jobs/Handler/SynchroniseLdap.hs

@@ -37,7 +37,7 @@ dispatchJobSynchroniseLdap numIterations epoch iteration
         userIteration, currentIteration :: Integer
         userIteration = toInteger (hash epoch `hashWithSalt` userId) `mod` toInteger numIterations
         currentIteration = toInteger iteration `mod` toInteger numIterations
-      $logDebugS "SynchroniseLdap" [st|User ##{tshow (fromSqlKey userId)}: sync on #{tshow userIteration}/#{tshow numIterations}, now #{tshow currentIteration}|]
+      $logDebugS "SynchroniseLdap" [st|User ##{tshow (fromSqlKey userId)}: LDAP sync on #{tshow userIteration}/#{tshow numIterations}, now #{tshow currentIteration}|]
       guard $ userIteration == currentIteration
 
       return $ JobSynchroniseLdapUser userId

src/Jobs/Types.hs

@@ -102,14 +102,13 @@ data Job
                               , jIteration :: Natural
                               , jSynchAfter :: Maybe Day
                               }
-  | JobSynchroniseAvsUser     { jUser :: UserId
+  -- | JobSynchroniseAvsUser     { jUser :: UserId
-                              , jSynchAfter :: Maybe Day
+  --                             , jSynchAfter :: Maybe Day
-                              }
+  --                             }
-  | JobSynchroniseAvsId       { jAvsId      :: AvsPersonId
+  -- | JobSynchroniseAvsId       { jAvsId      :: AvsPersonId
-                              , jSynchAfter :: Maybe Day
+  --                             , jSynchAfter :: Maybe Day
-                              }                              
+  --                             }                              
-  | JobSynchroniseAvsQueue
+  | JobSynchroniseAvsQueue  
-  | JobSynchroniseAvsNext
   | JobChangeUserDisplayEmail { jUser :: UserId
                               , jDisplayEmail :: UserEmail
                               }
@@ -351,10 +350,9 @@ jobNoQueueSame = \case
   JobSynchroniseLdap{}                -> Just JobNoQueueSame
   JobSynchroniseLdapUser{}            -> Just JobNoQueueSame
   JobSynchroniseAvs{}                 -> Just JobNoQueueSame
-  JobSynchroniseAvsUser{}             -> Just JobNoQueueSame
+  -- JobSynchroniseAvsUser{}             -> Just JobNoQueueSame
-  JobSynchroniseAvsId{}               -> Just JobNoQueueSame
+  -- JobSynchroniseAvsId{}               -> Just JobNoQueueSame
-  JobSynchroniseAvsQueue{}            -> Just JobNoQueueSame
+  JobSynchroniseAvsQueue{}            -> Just JobNoQueueSame  
-  JobSynchroniseAvsNext{}             -> Just JobNoQueueSame  
   JobChangeUserDisplayEmail{}         -> Just JobNoQueueSame
   JobPruneSessionFiles{}              -> Just JobNoQueueSameTag
   JobPruneUnreferencedFiles{}         -> Just JobNoQueueSameTag

src/Model/Migration/Definitions.hs

@@ -48,8 +48,9 @@ import qualified Data.Time.Zones as TZ
 
 data ManualMigration
   = Migration20230524QualificationUserBlock
-  | Migration20230703LmsUserStatus
+  | Migration20230703LmsUserStatus    
   | Migration20240212InitInterfaceHealth        -- create table interface_health and fill with default values
+  | Migration20240224UniquenessCompanyAvsNr  
   deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)
   deriving anyclass (Universe, Finite)
 
@@ -94,11 +95,10 @@ migrateManual = do
     , ("idx_qualification_user_block_quser"  ,"CREATE INDEX idx_qualification_user_block_quser ON \"qualification_user_block\" (\"qualification_user\")")
     , ("idx_qualification_user_block_unblock","CREATE INDEX idx_qualification_user_block_unblock ON \"qualification_user_block\" (\"unblock\")")
     , ("idx_qualification_user_block_from"   ,"CREATE INDEX idx_qualification_user_block_from ON \"qualification_user_block\" (\"from\")")    
-    , ("idx_print_job_apc_ident"             ,"CREATE INDEX idx_print_job_apc_ident ON \"print_job\" (\"apc_ident\")")
+    , ("idx_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_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

src/Model/Types/Avs.hs

@@ -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
+parseAvsCardNo :: Text -> Maybe (Either AvsCardNo AvsFullCardNo)
-discernAvsCardPersonalNo (Text.span Char.isDigit -> (c, pv))
+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
+    = Just $ Left $ fl c
-  | not $ Text.null c
+  | Just ('.', v) <- Text.uncons pv
-  , Just ('.', v) <- Text.uncons pv
   , Just (Char.isDigit -> True, "") <- Text.uncons v
-    = Just $ Left $ AvsFullCardNo (AvsCardNo c) v
+    = Just $ Right $ fr c v 
-discernAvsCardPersonalNo _ = Nothing
+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
+  { avsFirmFirm             :: Text -- enthält manchmal Leerzeichen an Anfang oder Ende!
-  , avsFirmFirmNo           :: Int
+  , avsFirmFirmNo           :: Int  -- bei Verwendung ohne AVS: negative Zahl einsetzen
-  , avsFirmAbbreviation     :: Text -- enthält manchmal Leerzeichen!
+  , 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.

src/Model/Types/Markup.hs

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

src/Model/Types/Misc.hs

@@ -58,6 +58,19 @@ $(deriveSimpleWith ''ToMessage 'toMessage (over Text.packed $ Text.intercalate "
 derivePersistField "Theme"
 
 
+data SupervisorReason
+  = SupervisorReasonCompanyDefault
+  | SupervisorReasonAvsSuperior
+  | SupervisorReasonUnknown
+  deriving (Eq, Ord, Enum, Bounded, Generic)
+  deriving anyclass (Universe, Finite, NFData)
+
+instance Show SupervisorReason where
+  show SupervisorReasonCompanyDefault = "Firmenstandard"
+  show SupervisorReasonAvsSuperior    = "Vorgesetzer"
+  show SupervisorReasonUnknown        = "Unbekannt"
+
+
 data FavouriteReason
   = FavouriteVisited
   | FavouriteParticipant

src/Settings.hs

@@ -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"
+    avsHost         <- o .: "host"
-    avsPort <- o .: "port"
+    avsPort         <- o .: "port"
-    avsUser <- o .: "user"
+    avsUser         <- o .: "user"
-    avsPass <- o .:? "pass" .!= ""
+    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"

src/Utils.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022-23 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>
+-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -11,7 +11,7 @@ import ClassyPrelude.Yesod hiding (foldlM, Proxy, handle, catch, bracket)
 
 -- import Data.Double.Conversion.Text -- faster implementation for textPercent?
 import qualified Data.Foldable as Fold
-import qualified Data.Traversable as Trav
+import qualified Data.Traversable as Trav 
 import Data.Foldable as Utils (foldlM, foldrM)
 import Data.Monoid (First, Sum(..), Endo)
 import Data.Proxy
@@ -23,7 +23,7 @@ import qualified Data.CaseInsensitive as CI
 
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Char8 as CBS
--- import qualified Data.Char as Char
+import qualified Data.Char as Char
 import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text
 
@@ -305,10 +305,18 @@ tshowCrop = cropText . tshow
 stripCI :: Text -> CI Text 
 stripCI = CI.mk . Text.strip
 
+-- | Instead of CI.mk, this still allows use of Text.isInfixOf, etc.
+stripFold :: Text -> Text 
+stripFold = Text.toCaseFold . Text.strip
+
+
 -- | just to avoid adding an import for this
 ciOriginal :: CI Text -> Text 
 ciOriginal = CI.original
 
+ciShow :: Show a => a -> CI Text
+ciShow = CI.mk . tshow
+
 citext2lower :: CI Text -> Text 
 citext2lower = Text.toLower . CI.original
 
@@ -520,10 +528,20 @@ snakecase2camelcase t = Text.concat $ map textToCapital words
     words = Text.splitOn '_' t 
 -}
 
+-- | Unlike @Data.Text.unlines, there is no trailing LF at the end
+textUnlines :: [Text] -> Text
+textUnlines = Text.intercalate $ Text.singleton '\n'
+
 -- also see Utils.Form.cfCommaSeparatedSet
 commaSeparatedText :: Text -> Set Text
 commaSeparatedText = Set.fromList . mapMaybe (assertM' (not . Text.null) . Text.strip) . Text.split (==',')
 
+-- also see Utils.Form.cfAnySeparatedSet
+anySeparatedText :: Text -> [Text]
+anySeparatedText = mapMaybe (assertM' (not . Text.null) . Text.strip) . Text.split anySeparator
+  where anySeparator :: Char -> Bool
+        anySeparator c = Char.isSeparator c || c == ',' || c == ';'
+
 
 -----------
 -- Fixed --
@@ -688,6 +706,10 @@ zipMaybes (Just x:xs) (Just y:ys) = (x,y) : zipMaybes xs ys
 zipMaybes      (_:xs)      (_:ys) =         zipMaybes xs ys
 zipMaybes        _              _ = []
 
+bcons :: Bool -> a -> [a] -> [a]
+bcons False _ = id
+bcons True  x = (x:)
+
 -- | Merge/Add any attribute-value pair to an existing list of such pairs.
 --   If the attribute exists, the new valu will be prepended, separated by a single empty space
 insertAttr :: Text -> Text -> [(Text,Text)] -> [(Text,Text)]
@@ -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
+-- ifNothingM m d a = maybe (return d) a m
-ifMaybeM Nothing dft _  = return dft
+ifNothingM :: Monad m => Maybe a -> b -> (a -> m b) -> m b -- more convenient argument order as compared to maybeM
-ifMaybeM (Just x) _ act = act x
+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
 
-{-
+-- | Only execute second action if the first does not produce a result
---   Takes computations returnings @Maybes@; tries each one in order.
+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)
+--   HOWEVER, this function counterintuitively forces the entire foldable!
-firstJustsM = foldlM go Nothing 
+-- 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 :: Monad m => m (Maybe a) -> m (Maybe a) -> m (Maybe a)
-    go Nothing          action = action
+    go n p = n >>= \case {Nothing -> p; res -> return res}  
-    go result@(Just _) _action = return result
+
--}
+-- 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)
 

src/Utils/Avs.hs

@@ -1,7 +1,8 @@
--- SPDX-FileCopyrightText: 2022 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
+-- SPDX-FileCopyrightText: 2022-24 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <s.jost@frapor.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
+
 module Utils.Avs where
 
 import Import.NoModel
@@ -13,9 +14,10 @@ import qualified Data.Text          as Text
 
 import Servant
 import Servant.Client
-#ifdef DEVELOPMENT
+
-#else
+#ifndef DEVELOPMENT
 import Servant.Client.Core (requestPath)
+import UnliftIO.Concurrent (threadDelay)
 #endif
 
 import Model.Types.Avs
@@ -35,7 +37,10 @@ avsMaxSetLicenceAtOnce :: Int
 avsMaxSetLicenceAtOnce = 80   -- maximum input set size for avsQuerySetLicences as enforced by AVS
 
 avsMaxQueryAtOnce :: Int
-avsMaxQueryAtOnce = 500       -- maximum input set size for avsQueryStatus as enforced by AVS
+avsMaxQueryAtOnce = 500       -- maximum input set size for avsQueryStatus and avsQueryContact as enforced by AVS
+
+avsMaxQueryDelay :: Int
+avsMaxQueryDelay = 300000    -- microsecond to wait before sending another AVS query
 
 
 avsApi :: Proxy AVS
@@ -62,7 +67,8 @@ data AvsQuery = AvsQuery
 
 makeLenses_ ''AvsQuery
 
--- | To query all active licences, a special constant argument must be prepared
+
+-- | AVS/VSM-interface currently only allows GetLicences with query argument ID 0, which means all licences; all other queries yield an empty response
 avsQueryAllLicences :: AvsQueryGetLicences
 avsQueryAllLicences = AvsQueryGetLicences $ AvsObjPersonId avsPersonIdZero
 
@@ -70,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 :: Maybe Day -> AvsLicence -> Set AvsDataPersonCard -> Maybe AvsDataPersonCard
-getValidLicence cutoff licence' cards = Set.lookupMax validLicenceCards
+-- getValidLicence cutoff licence' cards = Set.lookupMax validLicenceCards
-  where
+--   where
-    licence = licence2char licence'
+--     licence = licence2char licence'
-    validLicenceCards = Set.filter cardMatch cards
+--     validLicenceCards = Set.filter cardMatch cards
-    cardMatch AvsDataPersonCard{..} =
+--     cardMatch AvsDataPersonCard{..} =
-      avsDataValid && (avsDataValidTo >= cutoff) && (licence `Set.member` avsDataCardAreas)
+--       avsDataValid && (avsDataValidTo >= cutoff) && (licence `Set.member` avsDataCardAreas)
-
 
+-- | DEPRECTATED
 getCompanyAddress :: AvsDataPersonCard -> (Maybe Text, Maybe Text, Maybe AvsDataPersonCard)
 getCompanyAddress card@AvsDataPersonCard{..} 
   | Just street <- avsDataStreet

src/Utils/DB.hs

@@ -1,16 +1,17 @@
--- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
+-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
+-- also see Utils.Persist
+
 module Utils.DB where
 
-import ClassyPrelude.Yesod
+import ClassyPrelude.Yesod hiding (addMessageI)
 
 import qualified Data.List as List
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 import qualified Database.Esqueleto.Legacy as E
--- import Database.Persist -- currently not needed here
 
 import Utils
 import Control.Lens
@@ -20,7 +21,7 @@ import Control.Monad.Catch hiding (bracket)
 
 import qualified Utils.Pool as Custom
 
-import Database.Persist.Sql (runSqlConn)
+import Database.Persist.Sql (runSqlConn) -- , updateWhereCount)
 
 import GHC.Stack (HasCallStack, CallStack, callStack)
 
@@ -29,6 +30,24 @@ import GHC.Stack (HasCallStack, CallStack, callStack)
 
 -- import Control.Monad.Trans.Reader (withReaderT)
 
+-- | Obtain a record projection from an EntityField
+getFieldEnt  :: PersistEntity record => EntityField record typ -> Entity record -> typ
+getFieldEnt = view . fieldLens
+
+getField     :: PersistEntity record => EntityField record typ -> record -> typ
+getField = view . fieldLensVal
+
+-- | Obtain a lens from an EntityField
+fieldLensVal :: PersistEntity record => EntityField record typ -> Lens' record typ
+fieldLensVal f = entityLens . fieldLens f
+  where 
+    entityLens :: Lens' record (Entity record)
+    entityLens = lens getVal setVal
+    getVal :: record -> Entity record
+    getVal   = Entity (error "fieldLensVal unexpectectly required an entity key") -- this is safe, since the lens is only used locally
+    setVal :: record -> Entity record -> record
+    setVal _ = entityVal
+    
 
 emptyOrIn :: PersistField typ
           => E.SqlExpr (E.Value typ) -> Set typ -> E.SqlExpr (E.Value Bool)
@@ -88,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))

src/Utils/Icon.hs

@@ -118,6 +118,7 @@ data Icon
   | IconCompany
   | IconEdit
   | IconUserEdit
+  | IconMagic      -- indicates automatic updates
   
   deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic)
   deriving anyclass (Universe, Finite, NFData)
@@ -214,6 +215,7 @@ iconText = \case
     IconCompany                 -> "building"
     IconEdit                    -> "edit"
     IconUserEdit                -> "user-edit"
+    IconMagic                   -> "wand-magic"
 
 nullaryPathPiece ''Icon $ camelToPathPiece' 1
 deriveLift ''Icon
@@ -291,11 +293,16 @@ isBad :: Bool -> Markup
 isBad True  = icon IconProblem
 isBad False = mempty
 
--- ^ Maybe display an icon that denotes that something™ is bad
+-- ^ Maybe display an icon that denotes that something™ is new
 isNew :: Bool -> Markup
 isNew True  = icon IconNew
 isNew False = mempty
 
+-- ^ Maybe display an icon that denotes that something™ is automagically updated or derived
+isAutomatic :: Bool -> Markup
+isAutomatic True  = icon IconMagic
+isAutomatic False = mempty
+
 boolSymbol :: Bool -> Markup
 boolSymbol True  = icon IconOK
 boolSymbol False = icon IconNotOK

src/Utils/Lens.hs

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

src/Utils/Mail.hs

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

src/Utils/Pandoc.hs

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

src/Utils/Persist.hs

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

src/Utils/Print.hs

@@ -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
+  rcvrPostal <- altM (return rcvrPostalRaw) $ runDB $ getPostalAddress rcvrEnt
-      kind = getLetterKind        mdl
+  -- (_,rcvrPostal, rcvrEmail) <- runDB $ getPostalPreferenceAndAddress
-      tmpl = getTemplate          mdl
+  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 "address"    $ fromMaybe [rcvr & userDisplayName] $ canonical rcvrPostal            
-            --, toMeta "rcvr-email"    $ rcvr & userDisplayEmail -- note that some templates use "email" already otherwise
+            --, toMeta "rcvr-email"    $ fromMaybe [rcvr & userDisplayEmail] rcvrEmail -- note that some templates use "email" already otherwise
             ]
-  e_md <- mdTemplating tmpl meta
+  mdTemplating tmpl meta
-  actRight e_md $ pdfLaTeX kind
 
+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 :: (MDLetter l) => Entity User -> l -> Text -> Maybe [Text] -> Handler (Either Text Html)
-renderLetterHtml rcvrEnt@Entity{entityVal=rcvr} mdl apcIdent = do
+renderLetterHtml rcvrEnt mdl apcIdent rcvrPostal = do
-    now <- liftIO getCurrentTime  
+  e_md <- letterTemplate rcvrEnt mdl apcIdent rcvrPostal
-    formatter@DateTimeFormatter{ format } <- getDateTimeFormatterUser' rcvr
+  actRight e_md $ \md -> pure . over _Left P.renderError . P.runPure $ do   
-    let lang = selectDeEn $ rcvr & userLanguages   -- select either German or English only, default de; see Utils.Lang
+    html_tmpl <- compileTemplate $ templateHtml $ getLetterKind mdl
-        kind = 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)
-        tmpl = getTemplate          mdl
+    let writerOpts  = def { P.writerExtensions = P.pandocExtensions
-        meta = addApcIdent apcIdent
+                          , P.writerTemplate   = Just html_tmpl }
-            <> letterMeta mdl formatter lang rcvrEnt
+    P.writeHtml5 writerOpts $ appMeta setIsDeFromLang md
-            <> 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
 
 -- 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 "address"    $ fromMaybe [rcvr & userDisplayName] rcvrPostal
-                          --, toMeta "rcvr-email"    $ rcvr & userDisplayEmail -- note that some templates use "email" already otherwise
+                          --, 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 
+    postalPrefs <- runDB $ getPostalPreferenceAndAddress rcvrEnt
-      (True, Nothing) -> do -- neither email nor postal is known
+    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
 
 

src/Utils/Set.hs

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

src/Utils/TH.hs

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

src/Utils/Users.hs

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

templates/admin-problems.hamlet

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

templates/course/user/profile.hamlet

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

templates/profileData.hamlet

@@ -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
+        $if (not postalAutomatic)
-          <dt .deflist__dt>
+          $maybe postUpdate <- userPostLastUpdate
-            _{MsgUserPostLastUpdate}
+            <dt .deflist__dt>
-          <dd .deflist__dd>
+              _{MsgUserPostLastUpdate}
-            ^{formatTimeW SelFormatDateTime postUpdate}      
+            <dd .deflist__dd>
+              ^{formatTimeW SelFormatDateTime postUpdate}
       <dt .deflist__dt>
         _{MsgUserDisplayEmail}
       <dd .deflist__dd .email>
-        #{mailtoHtml userDisplayEmail}
+        $maybe primaryEmail <- actualDisplayEmail
-          $if not (validEmail' userDisplayEmail)
+          #{isAutomatic emailAutomatic} #
-            \ ^{messageTooltip tooltipInvalidEmail}
+          #{mailtoHtml primaryEmail}
-      $if userEmail /= userDisplayEmail
+        $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}

test/Database.hs

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

test/Database/Fill.hs

@@ -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 jost    fraportAg    True   True  0 False
-  void . insert' $ UserCompany svaupel nice         True   False 
+  void . insert' $ UserCompany svaupel nice         True   False 0 False
-  void . insert' $ UserCompany gkleen  nice         False  False 
+  void . insert' $ UserCompany gkleen  nice         False  False 1 True
-  void . insert' $ UserCompany gkleen  fraGround    False  True 
+  void . insert' $ UserCompany gkleen  fraGround    False  True  2 False
-  void . insert' $ UserCompany fhamann bpol         False  False 
+  void . insert' $ UserCompany fhamann bpol         False  False 1 True
-  void . insert' $ UserCompany fhamann ffacil       True   True 
+  void . insert' $ UserCompany fhamann ffacil       True   True  2 True
-  void . insert' $ UserCompany fhamann nice         False  False
+  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 fraGround False False 0 True | Entity uid User{userFirstName = "John"} <- matUsers]
-  insertMany_ [UserCompany uid bpol False False| Entity uid User{userFirstName = "Elizabeth"} <- matUsers]
+  insertMany_ [UserCompany uid bpol False False 0 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 bpol True True 0 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 ffacil False False 0 False   | Entity uid User{userSurname = "Walker"} <- matUsers]
-  insertMany_ [UserCompany uid rckey issuper False
+  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
+  let supvs = [ UserSupervisor jost gkleen            True  (Just fraportAg)  (Just "Staff")
-              , UserSupervisor jost svaupel      False
+              , UserSupervisor jost svaupel           False (Just fraportAg)  (Just "Staff")
-              , UserSupervisor jost sbarth       False
+              , UserSupervisor jost sbarth            False (Just fraportAg)  (Just "Staff")
-              , UserSupervisor jost tinaTester   True
+              , UserSupervisor jost tinaTester        True  (Just fraportAg)  (Just "Staff")
-              , UserSupervisor jost jost         True
+              , UserSupervisor jost jost              True  (Just fraportAg)  (Just "Staff")
-              , UserSupervisor svaupel gkleen    False
+              , UserSupervisor svaupel gkleen         False (Just nice)       (Just "Staff")
-              , UserSupervisor svaupel fhamann   True
+              , UserSupervisor svaupel fhamann        True  (Just nice)       (Just "Staff")
-              , UserSupervisor sbarth tinaTester True
+              , UserSupervisor sbarth tinaTester      True  (Just nice)       (Just "Staff")
-              , UserSupervisor gkleen fhamann    False
+              , UserSupervisor gkleen fhamann         False (Just fraGround)  (Just "Staff")
-              , UserSupervisor gkleen gkleen     True
+              , UserSupervisor gkleen gkleen          True  (Just fraGround)  (Just "Staff")
-              , UserSupervisor tinaTester tinaTester False
+              , 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 12345678) jost        87654321  (n_day' $ -12) (Just "Some Message here") Nothing Nothing Nothing
-  void . insert' $ UserAvs (AvsPersonId 2)        svaupel     2         (n_day' $ -22) 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 
+  void . insert' $ UserAvs (AvsPersonId 3)        gkleen      3         (n_day' $ -32) Nothing Nothing Nothing Nothing
-  void . insert' $ UserAvs (AvsPersonId 4)        sbarth      4         now            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")
+  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
+  void . insert' $ UserAvs (AvsPersonId 77)       tinaTester  77        now            Nothing Nothing Nothing 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
 
   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

test/ModelSpec.hs

@@ -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"))
+      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)
+      domain <- suchThat (CBS.pack . getPrintableString <$> arbitrary) (isEmail (CBS.pack "example"))
       let (Just result) = emailAddress (makeEmailLike local domain)
       pure result