Merge branch 'fradrive/api-avs'

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

@@ -19,6 +19,7 @@ UnauthorizedTokenInvalidAuthorityGroup: Ihr Authorisierungs-Token basiert auf de
 UnauthorizedTokenInvalidAuthorityValue: Ihr Authorisierungs-Token basiert auf Rechten, deren Spezifikation nicht interpretiert werden konnte.
 UnauthorizedTokenInvalidImpersonation: Ihr Authorisierungs-Token enthält die Anweisung sich als ein Nutzer:in auszugeben, dies ist jedoch nicht allen Benutzer:innen, auf deren Rechten ihr Authorisierungs-Token basiert, erlaubt.
 UnauthorizedToken404: Authorisierungs-Tokens können nicht auf Fehlerseiten ausgewertet werden.
+UnauthorizedSupervisor: Sie sind kein Ansprechpartner:in für diesen Benutzer:in.
 UnauthorizedSiteAdmin: Sie sind nicht System-weiter Administrator:in.
 UnauthorizedSchoolAdmin: Sie sind nicht als Administrator:in für dieses Institut eingetragen.
 UnauthorizedAdminEscalation: Sie sind nicht Administrator:in für alle Institute, für die dieser Nutzer/diese Nutzerin Administrator:in oder Veranstalter:in ist.
@@ -27,7 +28,6 @@ UnauthorizedExamExamOffice: Es existieren keine Prüfungsergebnisse für Nutzer:
 UnauthorizedSchoolExamOffice: Sie sind nicht mit Prüfungsverwaltung für dieses Institut beauftragt.
 UnauthorizedSystemExamOffice: Sie sind nicht mit systemweiter Prüfungsverwaltung beauftragt.
 UnauthorizedSystemPrinter: Sie sind nicht mit systemweitem Druck und Briefversand beauftragt.
-UnauthorizedSystemSap: Sie sind nicht mit der systemweitem SAP Schnittstellenverwaltung beauftragt.
 UnauthorizedExternalExamExamOffice: Es existieren keine Prüfungsergebnisse für Nutzer:innen, für die Sie mit der Prüfungsverwaltung beauftragt sind.
 UnauthorizedEvaluation: Sie sind nicht mit der Kursumfragenverwaltung beauftragt.
 UnauthorizedAllocationAdmin: Sie sind nicht mit der Administration von Zentralanmeldungen beauftragt.

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

@@ -19,6 +19,7 @@ UnauthorizedTokenInvalidAuthorityGroup: Your authorisation-token is based in an
 UnauthorizedTokenInvalidAuthorityValue: The specification of the rights in which your authorisation-token is based, could not be interpreted.
 UnauthorizedTokenInvalidImpersonation: Your authorisation-token contains an instruction to impersonate an user. Not all users on whose rights your token is based however are permitted to do so.
 UnauthorizedToken404: Authorisation-tokens cannot be processed on error pages.
+UnauthorizedSupervisor: You are not a supervisor for the requested user.
 UnauthorizedSiteAdmin: You are no system-wide administrator.
 UnauthorizedSchoolAdmin: You are no administrator for this department.
 UnauthorizedAdminEscalation: You aren't an administrator for all departments for which this user is an administrator.
@@ -29,7 +30,6 @@ UnauthorizedExamExamOffice: You are not part of the appropriate exam office for
 UnauthorizedSchoolExamOffice: You are not part of an exam office for this school.
 UnauthorizedSystemExamOffice: You are not charged with system wide exam administration.
 UnauthorizedSystemPrinter: You are not charged with system wide letter printing.
-UnauthorizedSystemSap: You are not charged with system wide SAP administration.
 UnauthorizedExternalExamExamOffice: You are not part of the appropriate exam office for any of the participants of this exam.
 UnauthorizedSchoolLecturer: You are no lecturer for this department.
 UnauthorizedLecturer: You are no administrator for this course.

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

@@ -10,4 +10,5 @@ AvsLastName: Nachname
 AvsInternalPersonalNo: Personalnummer (nur Fraport AG)
 AvsVersionNo: Versionsnummer
 AvsQueryEmpty: Bitte mindestens ein Anfragefeld ausfüllen!
-AvsQueryStatusInvalid t@Text: Nur numerische IDs eingeben, durch Komma getrennt! Erhalten: #{show t}
+AvsQueryStatusInvalid t@Text: Nur numerische IDs eingeben, durch Komma getrennt! Erhalten: #{show t}
+AvsLicence: Fahrberechtigung

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

@@ -10,4 +10,5 @@ AvsLastName: Last name
 AvsInternalPersonalNo: Personnel number (Fraport AG only)
 AvsVersionNo: Version number
 AvsQueryEmpty: At least one query field must be filled!
-AvsQueryStatusInvalid t: Numeric IDs only, comma seperated! #{show t}
+AvsQueryStatusInvalid t: Numeric IDs only, comma seperated! #{show t}
+AvsLicence: Driving Licence

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

@@ -18,5 +18,4 @@ BothSubmissions: Abgabe direkt in Uni2work oder extern mit Pseudonym
 SystemExamOffice: Prüfungsverwaltung
 SystemFaculty: Fakultätsmitglied
 SystemStudent: Student:in
-SystemPrinter: Drucker:in
+SystemPrinter: Drucker:in
-SystemSap: SAP Verwalter:in

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

@@ -18,5 +18,4 @@ BothSubmissions: Submission either directly in Uni2work or externally via pseudo
 SystemExamOffice: Exam office
 SystemFaculty: Faculty member
 SystemStudent: Student
-SystemPrinter: Printing staff
+SystemPrinter: Printing staff
-SystemSap: SAP Administrator

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

@@ -19,4 +19,5 @@ PrintCourse: Kurse
 PrintQualification: Qualifikation
 PrintPDF !ident-ok: PDF
 PrintManualRenewal: Vorfeldführerschein Renewal-Brief testweise versenden
-PrintLmsUser: E-Learning Benachrichtigung?
+PrintLmsUser: E-Learning Id
+PrintJobs: Druckaufräge

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

@@ -19,4 +19,5 @@ PrintCourse: Course
 PrintQualification: Qualification
 PrintPDF: PDF
 PrintManualRenewal: Manual sending of an apron driver's licence renewal letter
-PrintLmsUser: E-learning notification?
+PrintLmsUser: E-learning id
+PrintJobs: Print jobs

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

@@ -13,7 +13,10 @@ QualificationElearningStart: E-Learning automatisch starten
 TableQualificationCountActive: Aktive
 TableQualificationCountActiveTooltip: Anzahl Personen mit momentan gültiger Qualifikation
 TableQualificationCountTotal: Gesamt
-TableQualificationSapExport: Übermittlung SAP
+TableQualificationIsAvsLicence: AVS
+TableQualificationIsAvsLicenceTooltip: Wird die Qualifikation mit dem AVS synchronisiert? Wenn ja, als welche Qualifikation? Betrifft nur Benutzer mit AVS PersonenID.
+TableQualificationSapExport: SAP
+TableQualificationSapExportTooltip: Wird die Qualifikation an SAP übermittelt? Betrifft nur Benutzer mit Fraport Personalnummer.
 LmsQualificationValidUntil: Gültig bis
 TableQualificationLastRefresh: Zuletzt erneuert
 TableQualificationFirstHeld: Erstmalig
@@ -56,7 +59,7 @@ LmsErrorNoRefreshElearning: Fehler: E-Learning wird nicht automatisch gestartet,
 MailSubjectQualificationRenewal qname@Text: Qualifikation #{qname} muss demnächst erneuert werden
 MailSubjectQualificationExpiry qname@Text: Qualifikation #{qname} läuft demnächst ab
 MailSubjectQualificationExpired qname@Text: Qualifikation #{qname} ist ab sofort ungültig
-MailBodyQualificationRenewal: Sie müssen diese Qualifikaton demnächst durch einen E-Learning Kurs erneuern.
+MailBodyQualificationRenewal qname@Text: Sie müssen Qualifikaton #{qname} demnächst durch einen E-Learning Kurs erneuern, siehe Anhang.
 MailBodyQualificationExpiry: Diese Qualifikaton läuft bald ab. Tätigkeiten, welche diese Qualifikation voraussetzen dürfen dann nicht länger ausgeübt werden!
 MailBodyQualificationExpired: Diese Qualifikaton is nun abgelaufen. Tätigkeiten, welche diese Qualifikation voraussetzen dürfen ab sofort nicht länger ausgeübt werden! Es ist möglich, dass die Qualifikation vorzeit ungültig wurde, z.B. wegen erfolgloser Teilnahme an einem verpflichtendem E-Learning.
 LmsRenewalInstructions: Anweisungen zur Verlängerung finden Sie im angehängten PDF. Um Missbrauch zu verhindern wurde das PDF dem von Ihnen in FRADrive hinterlegten PDF-Passwort verschlüsselt. Falls kein PDF-Passwort hinterlegt wurde, ist das PDF-Passwort Ihre Fraport Ausweisnummer, inklusive Punkt und der Ziffer danach.
@@ -69,6 +72,7 @@ LmsPinRenewal n@Int: E-Learning Pin ausgetauscht für #{n} #{pluralDE n "Prüfli
 LmsActionFailed n@Int: Aktion nicht durchgeführt für #{n} #{pluralDE n "Person" "Personen"}, da diese derzeit nicht an einer Prüfung teilnehmen.
 MppOpening: Anrede
 MppClosing: Grußformel
+MppSupervisor: Ansprechpartner
 MppDate: Datum
 MppURL: Link E-Learning
 MppLogin !ident-ok: Login

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

@@ -13,7 +13,10 @@ QualificationElearningStart: Start e-learning automatically
 TableQualificationCountActive: Active
 TableQualificationCountActiveTooltip: Number of currently valid qualification holders
 TableQualificationCountTotal: Total
+TableQualificationIsAvsLicence: AVS Driving License
+TableQualificationIsAvsLicenceTooltip: Under which name is this qualification synchronized with AVS, if any? Only applies to qualification holders having an AVS PersonID.
 TableQualificationSapExport: Sent to SAP
+TableQualificationSapExportTooltip: Is this qualification transmitted to SAP? Only applies to qualification holder having a Fraport AG personnel number.
 LmsQualificationValidUntil: Valid until
 TableQualificationLastRefresh: Last renewed
 TableQualificationFirstHeld: First held
@@ -53,10 +56,10 @@ LmsResultCsvExceptionDuplicatedKey: CSV import with ambiguous key
 LmsUserlistCsvExceptionDuplicatedKey: CSV import with ambiguous key
 LmsDirectUpload: Direct upload for automated Systems
 LmsErrorNoRefreshElearning: Error: E-learning will not be started automatically due to refresh-within time period not being set.
-MailSubjectQualificationRenewal qname@Text: Qualification #{qname} must be renewed shortly
+MailSubjectQualificationRenewal qname: Qualification #{qname} must be renewed shortly
-MailSubjectQualificationExpiry qname@Text: Qualification #{qname} expires soon
+MailSubjectQualificationExpiry qname: Qualification #{qname} expires soon
-MailSubjectQualificationExpired qname@Text: Qualification #{qname} is no longer valid
+MailSubjectQualificationExpired qname: Qualification #{qname} is no longer valid
-MailBodyQualificationRenewal: You will soon need to renew this qualficiation by completing an e-learning course.
+MailBodyQualificationRenewal qname: You will soon need to renew qualficiation #{qname} by completing an e-learning course. For details see attachment.
 MailBodyQualificationExpiry: This qualificaton expires soon. You may then no longer execute any duties that require this qualification as a precondition!
 MailBodyQualificationExpired: This qualificaton is now expired. You may no longer execute any duties that require this qualification as a precondition! It is possible that the qualification expired prematurely, e.g. due to a failed compulsory e-learning.
 LmsRenewalInstructions: Instruction on how to accomplish the renewal are enclosed in the attached PDF. In order to avoid misuse, the PDF is encrypted with your chosen FRADrive PDF-Password. If you have not yet chosen a PDF-Password yet, then the password is your Fraport id card number, inkluding the punctuation mark and the Digit thereafter.
@@ -69,6 +72,7 @@ LmsPinRenewal n@Int: E-learning pin replaced randomly for #{n} #{pluralENs n "ex
 LmsActionFailed n@Int: No action for #{n} #{pluralENs n "person"}, since there was no ongoing examination.
 MppOpening: Opening
 MppClosing: Closing
+MppSupervisor: Supervisor
 MppDate: Date
 MppURL: Link e-learning
 MppLogin: Login

messages/uniworx/categories/send/send_notifications/de-de-formal.msg

@@ -148,3 +148,11 @@ MailUserSystemFunctionsNoFunctions: Keine
 
 #utils.hs + templates
 MailEditNotifications: Benachrichtigungen ein-/ausschalten
+
+#supervisor
+MailSupervisorNote: Hinweis für Ansprechpartner
+MailSupervisorBody undername@Text supername@Text: Sie erhalten diese Nachricht, da #{supername} als Ansprechpartner für #{undername} eingetragen ist in
+MailSupervisorCopy undermail@Text: Diese Nachricht ist eine Kopie einer Nachricht, welche an #{undermail} gesendet wurde.
+MailSupervisorNoCopy: Warnung: Diese Nachricht wurde nicht an den eingentlichen Empfänger versandt! Für die Weiterleitung sind alle für diesen Empfänger in FRADrive eingetragenen Ansprechpartner verantwortlich!
+MailSupervisedNote: Hinweis
+MailSupervisedBody: Eine Kopie dieser Nachricht wurde auch an folgende in FRADrive eingetragene Ansprechpartner gesendet:

messages/uniworx/categories/send/send_notifications/en-eu.msg

@@ -148,3 +148,11 @@ MailUserSystemFunctionsNoFunctions: None
 
 #utils.hs + templates
 MailEditNotifications: Enable/Disable notifications
+
+#supervisor
+MailSupervisorNote: Note to supervisor
+MailSupervisorBody undername supername: You receive this message, since #{supername} is registered as supervisor for #{undername} in
+MailSupervisorCopy undermail: This is a copy of a message originally sent to #{undermail}.
+MailSupervisorNoCopy: Warning: This message was not sent to the original recipient! The FRADrive registered supervisor, i.e. you, is responsible for forwarding this message to the recipient!
+MailSupervisedNote: Please Note
+MailSupervisedBody: A copy of this message has been sent to all supervisors registered for you in FRADrive, namely:

messages/uniworx/categories/settings/auth_settings/de-de-formal.msg

@@ -14,7 +14,6 @@ AuthTagAdmin: Nutzer:in ist Administrator:in
 AuthTagExamOffice: Nutzer:in ist mit Prüfungsverwaltung beauftragt
 AuthTagSystemExamOffice: Nutzer:in ist mit systemweiter Prüfungsverwaltung beauftragt
 AuthTagSystemPrinter: Nutzer:in ist mit systemweiten Druck von Briefen beauftragt
-AuthTagSystemSap: Nutzer:in ist mit systemweiter SAP Schnittstellen-Administration beauftragt
 AuthTagEvaluation: Nutzer:in ist mit Kursumfragenverwaltung beauftragt
 AuthTagAllocationAdmin: Nutzer:in ist mit der Administration von Zentralanmeldungen beauftragt
 AuthTagToken: Nutzer:in präsentiert Authorisierungs-Token
@@ -59,3 +58,4 @@ AuthTagSubmissionGroup: Nutzer:in ist Mitglied in registrierter Abgabegruppe
 AuthTagWorkflow: Nutzer:in hat passende Workflow-Rolle
 AuthTagStudent: Nutzer:in ist Student:in
 AuthTagExamTime: Zeitliche Einschränkungen durch relevante Prüfung sind erfüllt
+AuthTagSupervisor: Nutzer:in ist Ansprechpartner für jemand anderes

messages/uniworx/categories/settings/auth_settings/en-eu.msg

@@ -14,7 +14,6 @@ AuthTagAdmin: User is administrator
 AuthTagExamOffice: User is part of an exam office
 AuthTagSystemExamOffice: User is charged with system wide exam administration
 AuthTagSystemPrinter: User is responsible for system wide letter printing
-AuthTagSystemSap: User is responsible for system wide SAP interface administration
 AuthTagEvaluation: User is charged with course evaluation
 AuthTagAllocationAdmin: User is charged with administration of central allocations
 AuthTagToken: User is presenting an authorisation-token
@@ -59,3 +58,4 @@ AuthTagSubmissionGroup: User is part of a submission group
 AuthTagWorkflow: User has matching workflow role
 AuthTagStudent: User is a student
 AuthTagExamTime: Exam time restrictions are satisfied
+AuthTagSupervisor: User is supervisor for someone else

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

@@ -119,6 +119,7 @@ SettingsUpdate: Einstellungen erfolgreich gespeichert
 TokensResetSuccess: Authorisierungs-Tokens invalidiert
 ProfileTitle: Benutzereinstellungen
 HeadingProfileData: Persönliche Daten
+HeadingForProfileData udn@UserDisplayName: Persönliche Daten von #{udn}
 ProfileRegistered: Angemeldet
 LastEditByUser: Ihre letzte Bearbeitung
 SubmissionGroupName: Gruppenname

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

@@ -119,6 +119,7 @@ SettingsUpdate: Successfully updated settings
 TokensResetSuccess: Successfully invalidated all authorisation tokens
 ProfileTitle: Settings
 HeadingProfileData: Personal information
+HeadingForProfileData udn: Personal information of #{udn}
 ProfileRegistered: Registered
 LastEditByUser: Your last edit
 SubmissionGroupName: Group name

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

@@ -13,7 +13,7 @@ AdminUserAuth: Authentifizierung
 AdminUserMatriculation: Matrikelnummer
 AdminUserSex: Geschlecht
 AdminUserTelephone: Telefonnummer
-AdminUserMobile: Mobiltelefonmummer
+AdminUserMobile: Mobiltelefonnummer
 AdminUserFPersonalNumber: Personalnummer (nur Fraport AG)
 AdminUserFDepartment: Abteilung
 AdminUserPostAddress: Postalische Anschrift

models/avs.model

@@ -3,16 +3,27 @@
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
 -- Tables to save data received AVS
--- Purpose is to detect external changes in qualifications and postal addresses
+
+-- When creating an AvsUser the following cases are possible:
+-- 1. User does not exist, hence a new UserId ought to be created.
+-- 2. User does exists and can be matched by UserCompanyPersonalNumber
+-- 3. User does exists but cannot be matched now :(
+--      How can the matching be performed later?
+--      Do we need to merge users?
+-- > Handler.Utils.UsersassimilateUser 
+
+
 UserAvs
-  personId        AvsPersonId -- unique identifier for user throughout avs
+  personId        AvsPersonId -- unique identifier for user throughout avs; newtype for Int
-  user            UserId  
+  user            UserId
   UniqueUserAvsUser user
-  UniqueUserAvsId personId
+  UniqueUserAvsId   personId
   deriving Generic
 
+-- Multiple UserAvsCards per UserAvs is possible and not too uncommon.
+-- Purpose of saving cards is to detect external changes in qualifications and postal addresses
 UserAvsCard 
-  personId        AvsPersonId  
+  personId        AvsPersonId    
   cardNo          AvsCardNo
   card            AvsDataPersonCard
   lastSynch       UTCTime

models/company.model

@@ -0,0 +1,22 @@
+-- SPDX-FileCopyrightText: 2022 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
+--
+-- SPDX-License-Identifier: AGPL-3.0-or-later
+
+-- Description of companies associated with users
+
+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
+  -- postAddress StoredMarkup Maybe   --
+  -- avsId     Int                    -- FUTURE TODO: once this number becomes available through AVS interface; this could be the primary key   
+  UniqueCompanyName name 
+  UniqueCompanyShorthand shorthand
+  Primary shorthand             -- newtype Key Company = CompanyKey { unSchoolKey :: CompanyShorthand }
+  deriving Ord Eq Show Generic
+
+-- TODO: a way to populate this table (manually)
+CompanySynonym
+  synonym     CompanyName
+  canonical   CompanyShorthand
+  UniqueCompanySynonym synonym
+  deriving Ord Eq Show Generic

models/lms.model

@@ -15,9 +15,13 @@ Qualification
   -- elearningOnly       Bool                   -- successful E-learing automatically increases validity. NO!
   -- refreshInvitation   StoredMarkup           -- hard-coded I18N-MSGs used instead, but displayed on qualification page NO!
   -- expiryNotification  StoredMarkup Maybe     -- configurable user-profile-notifcations are used instead NO!
+  avsLicence          AvsLicence Maybe          -- if set, is synchronized to Avs as a driving licence
   sapId               Text Maybe                -- if set, all QualificationUsers with userCompanyPersonalNumber are transmitted via SAP interface under this id
   SchoolQualificationShort school shorthand            -- must be unique per school and shorthand
   SchoolQualificationName  school name                 -- must be unique per school and name
+  -- across all schools, only one qualification may be a driving licence:
+  UniqueQualificationAvsLicence avsLicence      !force
+    -- NOTE: two NULL values are not equal for the purpose of Uniqueness constraints!
   deriving Generic
 
 -- TODOs:

models/schools.model

@@ -6,7 +6,7 @@
 -- Each school must have a unique human-readable shorthand which is used as database row key
 School json
     name          (CI Text)
-    shorthand     (CI Text)  -- SchoolKey :: SchoolShorthand -> SchoolId
+    shorthand     SchoolShorthand -- type SchoolShorthand = (CI Text)  -- SchoolKey :: SchoolShorthand -> SchoolId
     examMinimumRegisterBeforeStart NominalDiffTime Maybe
     examMinimumRegisterDuration    NominalDiffTime Maybe
     examRequireModeForRegistration Bool default=false

models/users.model

@@ -15,7 +15,7 @@ User json    -- Each Uni2work user has a corresponding row in this table; create
     surname        UserSurname              -- Display user names always through 'nameWidget displayName surname'
     displayName    UserDisplayName
     displayEmail   UserEmail
-    email          UserEmail                -- Case-insensitive eMail address -- TODO: make this nullable
+    email          UserEmail                -- Case-insensitive eMail address, used for sending  TODO: make this nullable
     ident          UserIdent                -- Case-insensitive user-identifier
     authentication AuthenticationMode       -- 'AuthLDAP' or ('AuthPWHash'+password-hash)
     lastAuthentication UTCTime Maybe        -- last login date
@@ -40,7 +40,7 @@ User json    -- Each Uni2work user has a corresponding row in this table; create
     sex            Sex Maybe
     showSex        Bool default=false
     telephone      Text Maybe            
-    mobile         Text Maybe                   
+    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
@@ -80,9 +80,19 @@ UserGroupMember
     group         UserGroupName
     user          UserId
     primary       Checkmark nullable
-
     UniquePrimaryUserGroupMember group primary !force
     UniqueUserGroupMember group user
-
     deriving Generic
-    
+UserCompany 
+    user                  UserId  
+    company               CompanyId     
+    supervisor            Bool       -- is this user a company supervisor?    
+    UniqueUserCompany user -- only one company per user is currently allowed
+    deriving Generic
+UserSupervisor
+    supervisor            UserId -- multiple supervisor per trainee possible
+    user                  UserId
+    rerouteNotifications  Bool   -- User can be his own supervisor to receive notifications as well
+    UniqueUserSupervisor supervisor user
+    deriving Generic
+    

routes

@@ -38,6 +38,7 @@
 --    !read           -- only if it is read-only access (i.e. GET but not POST)
 --    !write          -- only if it is write access     (i.e. POST only, included for completeness)
 --
+--    !token          -- requires bearer token
 --    !no-escalation  --
 --    !deprecated     -- like free, but logs and gives a warning; entirely disabled in production
 --    !development    -- like free, but only for development builds
@@ -54,10 +55,10 @@
 /users/#CryptoUUIDUser        AdminUserR       GET POST
 /users/#CryptoUUIDUser/delete AdminUserDeleteR     POST
 /users/#CryptoUUIDUser/hijack AdminHijackUserR     POST       !adminANDno-escalation
-/users/#CryptoUUIDUser/notifications UserNotificationR GET POST   !self
+/users/#CryptoUUIDUser/notifications  UserNotificationR           GET POST   !self
-/users/#CryptoUUIDUser/password      UserPasswordR     GET POST   !selfANDis-pw-hash
+/users/#CryptoUUIDUser/password       UserPasswordR               GET POST   !selfANDis-pw-hash
-!/users/functionary-invite/new AdminNewFunctionaryInviteR  GET POST
+!/users/functionary-invite/new        AdminNewFunctionaryInviteR  GET POST
-!/users/functionary-invite     AdminFunctionaryInviteR     GET POST
+!/users/functionary-invite            AdminFunctionaryInviteR     GET POST
 !/users/add                   AdminUserAddR    GET POST
 /admin                        AdminR           GET
 /admin/test                   AdminTestR       GET POST
@@ -94,13 +95,17 @@
 
 /external-apis ExternalApisR ServantApiExternalApis getServantApi
 
-/user                      ProfileR            GET POST        !free
+/user                      ProfileR            GET POST         !free
-/user/profile              ProfileDataR        GET             !free
+/user/profile              ProfileDataR        GET              !free
-/user/authpreds            AuthPredsR          GET POST        !free
+/user/authpreds            AuthPredsR          GET POST         !free
-/user/set-display-email    SetDisplayEmailR    GET POST        !free
+/user/set-display-email    SetDisplayEmailR    GET POST         !free
-/user/csv-options          CsvOptionsR         GET POST        !free
+/user/csv-options          CsvOptionsR         GET POST         !free
-/user/lang                 LangR                   POST        !free
+/user/lang                 LangR                   POST         !free
-/user/storage-key          StorageKeyR             POST        !free
+/user/storage-key          StorageKeyR             POST         !free
+
+/for/#CryptoUUIDUser/user         ForProfileR       GET POST    !supervisor !self
+/for/#CryptoUUIDUser/user/profile ForProfileDataR   GET         !supervisor !self
+
 
 /exam-office               ExamOfficeR                         !exam-office:
   /                        EOExamsR            GET POST        !system-exam-office
@@ -275,26 +280,26 @@
 -- !/*{CI FilePath} CryptoFileNameDispatchR GET                  !free -- Disabled until preliminary check for valid cID exists
 
 -- for users
-/qualification                                          QualificationAllR             GET   !free -- TODO repurpose
+/qualification                                          QualificationAllR             GET         -- TODO repurpose
-/qualification/#SchoolId                                QualificationSchoolR          GET   !free -- TODO repurpose
+/qualification/#SchoolId                                QualificationSchoolR          GET         -- TODO repurpose
 /qualification/#SchoolId/#QualificationShorthand        QualificationR                GET         -- TODO repurpose
 
 -- SAP export
-/qualifications/sap/direct                              QualificationSAPDirectR   GET   !system-sap 
+/qualifications/sap/direct                              QualificationSAPDirectR   GET   !token
 -- OSIS CSV Export Demo
 /lms                                                    LmsAllR               GET POST  !free -- TODO verify that this is ok
 /lms/#SchoolId                                          LmsSchoolR            GET       !free -- TODO verify that this is ok
 /lms/#SchoolId/#QualificationShorthand                  LmsR  				        GET POST  !free -- TODO Filtering does not work!
 /lms/#SchoolId/#QualificationShorthand/edit             LmsEditR			        GET POST
 /lms/#SchoolId/#QualificationShorthand/users            LmsUsersR	            GET
-/lms/#SchoolId/#QualificationShorthand/users/direct     LmsUsersDirectR	      GET
+/lms/#SchoolId/#QualificationShorthand/users/direct     LmsUsersDirectR	      GET       --   development
 /lms/#SchoolId/#QualificationShorthand/userlist         LmsUserlistR	        GET POST
-/lms/#SchoolId/#QualificationShorthand/userlist/upload  LmsUserlistUploadR	  GET POST
+/lms/#SchoolId/#QualificationShorthand/userlist/upload  LmsUserlistUploadR	  GET POST  --   development
-/lms/#SchoolId/#QualificationShorthand/userlist/direct  LmsUserlistDirectR	      POST
+/lms/#SchoolId/#QualificationShorthand/userlist/direct  LmsUserlistDirectR	      POST  !token
+/lms/#SchoolId/#QualificationShorthand/fake             LmsFakeR              GET POST  !development -- TODO: delete this testing URL
 /lms/#SchoolId/#QualificationShorthand/result           LmsResultR            GET POST
-/lms/#SchoolId/#QualificationShorthand/result/upload    LmsResultUploadR      GET POST
+/lms/#SchoolId/#QualificationShorthand/result/upload    LmsResultUploadR      GET POST  --   development
-/lms/#SchoolId/#QualificationShorthand/result/direct    LmsResultDirectR          POST
+/lms/#SchoolId/#QualificationShorthand/result/direct    LmsResultDirectR          POST  !token
-/lms/#SchoolId/#QualificationShorthand/fake             LmsFakeR              GET POST -- TODO: delete this testing URL
 
 /api           ApiDocsR              GET      !free
 /swagger       SwaggerR              GET      !free

src/Auth/LDAP.hs

@@ -64,9 +64,9 @@ findUser conf@LdapConf{..} ldap ident retAttrs = fromMaybe [] <$> findM (assertM
       | ident' <- [ident, [st|#{ident}@lmu.de|], [st|#{ident}@fraport.de|]]
       , ldapUserEmail' <- toList ldapUserEmail
       -- ] ++
-      -- [ ldapUserDisplayName   Ldap.:= Text.encodeUtf8 ident
+      -- [ ldapUserDisplayName   Ldap.:= Text.encodeUtf8 ident  -- for Fraport, userDisplayName has the pattern "Surname, Firstnames"
       ] ++
-      [ ldapUserFraportPersonalnummer Ldap.:= Text.encodeUtf8 ident  -- for Fraport, userDisplayname has pattern "Surname, Firstnames"
+      [ ldapUserFraportPersonalnummer Ldap.:= Text.encodeUtf8 ident
       ]
 
 findUserMatr :: LdapConf -> Ldap -> Text -> [Ldap.Attr] -> IO [Ldap.SearchEntry]

src/Data/Time/Clock/Instances.hs

@@ -99,7 +99,7 @@ instance PersistField CalendarDiffDays where
       coerceICcd :: Integer -> CDDdb
       coerceICcd = fromIntegral
 
-      -- placement in Utils impossivle due to cyclic dependencies
+      -- placement in Utils impossible due to cyclic dependencies
       -- Data.Tuple.Extra is not yet a dependency
       -- both = join (***)  is still too cryptic for me
       both :: (a -> b) -> (a, a) -> (b, b)

src/Database/Esqueleto/Utils.hs

@@ -7,7 +7,7 @@
 
 module Database.Esqueleto.Utils
   ( true, false
-  , justVal, justValList
+  , justVal, justValList, toValues
   , isJust, alt
   , isInfixOf, hasInfix
   , strConcat, substring
@@ -50,7 +50,9 @@ import Data.Universe
 import qualified Data.Set as Set
 import qualified Data.List as List
 import qualified Data.Foldable as F
+import Data.List.NonEmpty (NonEmpty(..))
 import qualified Database.Esqueleto.Legacy as E
+import qualified Database.Esqueleto.Experimental as Ex
 import qualified Database.Esqueleto.PostgreSQL as E
 import qualified Database.Esqueleto.Internal.Internal as E
 import Database.Esqueleto.Utils.TH
@@ -97,10 +99,15 @@ false = E.val False
 -- infinity = unsafeSqlValue "'infinity'"
 
 justVal :: PersistField typ => typ -> E.SqlExpr (E.Value (Maybe typ))
-justVal = E.val . Just
+-- justVal = E.val . Just
+justVal = E.just . E.val
 
 justValList :: PersistField typ => [typ] -> E.SqlExpr (E.ValueList (Maybe typ))
-justValList = E.valList . map Just
+-- justValList = E.valList . map Just
+justValList = E.justList . E.valList
+
+toValues :: PersistField typ => NonEmpty typ -> Ex.From (Ex.SqlExpr (Ex.Value typ)) -- E.From invalid here, requires Esqueleto.Experimental
+toValues = E.values . fmap Ex.val
 
 infixl 4 =?.
 (=?.) ::  PersistField typ => E.SqlExpr (E.Value typ) ->  E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value Bool)
@@ -430,6 +437,7 @@ bool onFalse onTrue val = E.case_
   (E.else_ onFalse)
 
 -- called see greatest and least within postgresql
+-- TODO: this is buggy! Both return always the first argument if any argument is NULL!
 max, min :: PersistField a
          => E.SqlExpr (E.Value a)
          -> E.SqlExpr (E.Value a)
@@ -437,7 +445,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
+-- these alternatives for max/min ought to be more efficient; note that NULL is avoided by greatest/least
 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)
 

src/Foundation/Authorization.hs

@@ -550,6 +550,19 @@ tagAccessPredicate AuthAdmin = cacheAPSchoolFunction SchoolAdmin (Just $ Right d
         adrights <- lift $ selectFirst [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolAdmin] []
         guardMExceptT (isJust adrights) (unauthorizedI MsgUnauthorizedSiteAdmin)
         return Authorized
+
+tagAccessPredicate AuthSupervisor = APDB $ \_ _ mAuthId route _ -> case route of 
+    ForProfileR     cID -> checkSupervisor (mAuthId, cID)
+    ForProfileDataR cID -> checkSupervisor (mAuthId, cID)
+    r -> $unsupportedAuthPredicate AuthSupervisor r    
+  where 
+    checkSupervisor sup@(mAuthId, cID) = $cachedHereBinary sup . exceptT return return $ do
+      authId <- maybeExceptT AuthenticationRequired $ return mAuthId
+      uid <- decrypt cID
+      isSupervisor <- lift . existsBy $ UniqueUserSupervisor authId uid
+      guardMExceptT isSupervisor (unauthorizedI MsgUnauthorizedSupervisor)
+      return Authorized
+
 tagAccessPredicate AuthSystemExamOffice = cacheAPSystemFunction SystemExamOffice (Just $ Right diffHour) $ \mAuthId' _ _ examOfficeList -> if
   | maybe True (`Set.notMember` examOfficeList) mAuthId' -> Right $ if
       | is _Nothing mAuthId' -> return AuthenticationRequired
@@ -568,15 +581,6 @@ tagAccessPredicate AuthSystemPrinter = cacheAPSystemFunction SystemPrinter (Just
       isPrinter <- lift $ exists [UserSystemFunctionUser ==. authId, UserSystemFunctionFunction ==. SystemPrinter, UserSystemFunctionIsOptOut ==. False]
       guardMExceptT isPrinter $ unauthorizedI MsgUnauthorizedSystemPrinter
       return Authorized
-tagAccessPredicate AuthSystemSap = cacheAPSystemFunction SystemSap (Just $ Right diffHour) $ \mAuthId' _ _ sapList -> if
-  | maybe True (`Set.notMember` sapList) mAuthId' -> Right $ if
-      | is _Nothing mAuthId' -> return AuthenticationRequired
-      | otherwise -> unauthorizedI MsgUnauthorizedSystemSap
-  | otherwise -> Left $ APDB $ \_ _ mAuthId _ _ -> $cachedHereBinary mAuthId . exceptT return return $ do
-      authId <- maybeExceptT AuthenticationRequired $ return mAuthId
-      isPrinter <- lift $ exists [UserSystemFunctionUser ==. authId, UserSystemFunctionFunction ==. SystemSap, UserSystemFunctionIsOptOut ==. False]
-      guardMExceptT isPrinter $ unauthorizedI MsgUnauthorizedSystemSap
-      return Authorized      
 tagAccessPredicate AuthStudent = cacheAPSystemFunction SystemStudent (Just $ Right diffHour) $ \mAuthId' _ _ studentList -> if
   | maybe True (`Set.notMember` studentList) mAuthId' -> Right $ if
       | is _Nothing mAuthId' -> return AuthenticationRequired
@@ -1661,6 +1665,8 @@ tagAccessPredicate AuthSelf = APDB $ \_ _ mAuthId route _ -> exceptT return retu
     UserNotificationR cID -> return $ Left cID
     UserPasswordR cID -> return $ Left cID
     CourseR _ _ _ (CUserR cID) -> return $ Left cID
+    ForProfileR     cID -> return $ Left cID
+    ForProfileDataR cID -> return $ Left cID
     CApplicationR _ _ _ cID _ -> do
       appId <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSelf) (const True :: CryptoIDError -> Bool) $ decrypt cID
       CourseApplication{..} <- maybeMExceptT (unauthorizedI MsgUnauthorizedSelf) . $cachedHereBinary appId $ get appId

src/Foundation/Navigation.hs

@@ -182,14 +182,16 @@ breadcrumb (LmsResultUploadR    ssh  qsh) = i18nCrumb MsgMenuLmsUpload     $ Jus
 breadcrumb (LmsResultDirectR    ssh  qsh) = i18nCrumb MsgMenuLmsUpload     $ Just $ LmsResultR    ssh qsh -- never displayed
 breadcrumb (LmsFakeR            ssh  qsh) = i18nCrumb MsgMenuLmsFake       $ Just $ LmsR          ssh qsh -- TODO: remove in production
 
-breadcrumb ProfileR         = i18nCrumb MsgBreadcrumbProfile   Nothing
+breadcrumb ProfileR               = i18nCrumb MsgBreadcrumbProfile   Nothing
-breadcrumb SetDisplayEmailR = i18nCrumb MsgUserDisplayEmail  $ Just ProfileR
+breadcrumb ForProfileR{}          = i18nCrumb MsgBreadcrumbProfile   Nothing
-breadcrumb ProfileDataR     = i18nCrumb MsgMenuProfileData   $ Just ProfileR
+breadcrumb SetDisplayEmailR       = i18nCrumb MsgUserDisplayEmail  $ Just ProfileR
-breadcrumb AuthPredsR       = i18nCrumb MsgMenuAuthPreds     $ Just ProfileR
+breadcrumb ProfileDataR           = i18nCrumb MsgMenuProfileData   $ Just ProfileR
-breadcrumb CsvOptionsR      = i18nCrumb MsgCsvOptions        $ Just ProfileR
+breadcrumb (ForProfileDataR cID)  = i18nCrumb MsgMenuProfileData   $ Just (ForProfileR cID)
-breadcrumb LangR            = i18nCrumb MsgMenuLanguage      $ Just ProfileR
+breadcrumb AuthPredsR             = i18nCrumb MsgMenuAuthPreds     $ Just ProfileR
+breadcrumb CsvOptionsR            = i18nCrumb MsgCsvOptions        $ Just ProfileR
+breadcrumb LangR                  = i18nCrumb MsgMenuLanguage      $ Just ProfileR
 
-breadcrumb StorageKeyR      = i18nCrumb MsgBreadcrumbStorageKey Nothing
+breadcrumb StorageKeyR            = i18nCrumb MsgBreadcrumbStorageKey Nothing
 
 breadcrumb TermShowR              = i18nCrumb MsgMenuTermShow    $ Just NewsR
 breadcrumb TermCurrentR           = i18nCrumb MsgMenuTermCurrent $ Just TermShowR
@@ -641,7 +643,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the
       , navForceActive = False
       }
   , return $ NavFooter NavLink
-      { navLabel       = MsgMenuTermsUse      
+      { navLabel       = MsgMenuTermsUse
       , navRoute       = LegalR :#: ("terms-of-use" :: Text)
       , navAccess'     = NavAccessTrue
       , navType        = NavTypeLink { navModal = False }
@@ -1411,6 +1413,19 @@ pageActions ProfileR = return
     , navChildren = []
     }
   ]
+pageActions (ForProfileR cID) = return
+  [ NavPageActionPrimary
+    { navLink = NavLink
+      { navLabel       = MsgMenuProfileData
+      , navRoute       = ForProfileDataR cID
+      , navAccess'     = NavAccessTrue
+      , navType        = NavTypeLink { navModal = False }
+      , navQuick'      = mempty
+      , navForceActive = False
+      }
+    , navChildren = []
+    }
+  ]
 pageActions TermShowR = do
   participantsSecondary <- pageQuickActions NavQuickViewPageActionSecondary ParticipantsListR
   return

src/Foundation/Types.hs

@@ -14,7 +14,7 @@ import Import.NoFoundation
 data UpsertCampusUserMode
   = UpsertCampusUserLoginLdap
   | UpsertCampusUserLoginDummy { upsertCampusUserIdent :: UserIdent }
-  | UpsertCampusUserLoginOther { upsertCampusUserIdent :: UserIdent }
+  | UpsertCampusUserLoginOther { upsertCampusUserIdent :: UserIdent } -- erlaubt keinen späteren Login
   | UpsertCampusUserLdapSync   { upsertCampusUserIdent :: UserIdent }
   | UpsertCampusUserGuessUser
   deriving (Eq, Ord, Read, Show, Generic, Typeable)

src/Foundation/Yesod/Auth.hs

@@ -4,7 +4,7 @@
 
 module Foundation.Yesod.Auth
   ( authenticate
-  , upsertCampusUser
+  , upsertCampusUser, upsertCampusUserByCn 
   , decodeUserTest
   , CampusUserConversionException(..)
   , campusUserFailoverMode, updateUserLanguage
@@ -152,6 +152,14 @@ _upsertCampusUserMode mMode cs@Creds{..}
 
     defaultOther = apHash
 
+upsertCampusUserByCn :: forall m.
+                        ( MonadHandler m, HandlerSite m ~ UniWorX
+                        , MonadThrow m
+                        )
+                      => Text -> SqlPersistT m (Entity User)
+upsertCampusUserByCn persNo = upsertCampusUser UpsertCampusUserGuessUser [(ldapPrimaryKey,[Text.encodeUtf8 persNo])]
+
+
 upsertCampusUser :: forall m.
                     ( MonadHandler m, HandlerSite m ~ UniWorX
                     , MonadThrow m

src/Handler/Admin/Avs.hs

@@ -14,9 +14,24 @@ import qualified Data.Text as Text
 import qualified Data.Set  as Set
 
 import Handler.Utils
+import Handler.Utils.Avs
 
 import Utils.Avs
 
+-- Button needed only here
+data ButtonAvsTest = BtnCheckLicences
+  deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
+instance Universe ButtonAvsTest
+instance Finite ButtonAvsTest
+
+nullaryPathPiece ''ButtonAvsTest camelToPathPiece
+
+instance Button UniWorX ButtonAvsTest where
+  btnLabel    BtnCheckLicences = "Check all licences" -- could be msg
+  btnClasses  BtnCheckLicences = [BCIsButton, BCPrimary]  
+-- END Button
+
+
 avsCardNoField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m AvsCardNo
 avsCardNoField = convertField AvsCardNo avsCardNo textField
 
@@ -57,6 +72,17 @@ validateAvsQueryStatus = do
   AvsQueryStatus ids <- State.get
   guardValidation (MsgAvsQueryStatusInvalid $ tshow ids) $ not (null ids)
 
+
+avsLicenceOptions :: OptionList AvsLicence
+avsLicenceOptions = mkOptionList 
+  [ Option 
+    { optionDisplay       = Text.singleton $ licence2char l
+    , optionInternalValue = l
+    , optionExternalValue = toJsonText l
+    }  
+  | l <- universeF
+  ]
+
 getAdminAvsR,  postAdminAvsR :: Handler Html
 getAdminAvsR = postAdminAvsR
 postAdminAvsR = do
@@ -81,16 +107,73 @@ postAdminAvsR = do
               Right jsn -> return . Just $ tshow jsn         
       mbStatus <- formResultMaybe sresult procFormStatus
 
+      ((crUsrRes, crUsrWgt), crUsrEnctype) <- runFormPost $ identifyForm FIDAvsCreateUser $ \html -> 
+        flip (renderAForm FormStandard) html $ areq textField (fslI MsgAvsCardNo) Nothing
+      let procFormCrUsr fr = do 
+            res <- try $ upsertAvsUser 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 $ areq intField (fslI MsgAvsPersonId) Nothing
+      let procFormGetLic fr = do 
+            res <- try $ getLicenceByAvsId $ AvsPersonId fr
+            case res of 
+              (Right (Just lic)) -> 
+                return $ Just [whamlet|<h2>Success:</h2> Licence #{tshow lic}|]
+              (Right Nothing) ->
+                return $ Just [whamlet|<h2>Warning:</h2> User not found.|]
+              (Left e) -> do
+                let msg = tshow (e :: SomeException)
+                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
+
+
+      ((qryLicRes, qryLicWgt), qryLicEnctype) <- runFormPost $ identifyForm FIDAvsQueryLicenceDiffs (buttonForm :: Form ButtonAvsTest)
+      let procFormQryLic BtnCheckLicences = do 
+            res <- try checkLicences
+            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>Error:</h2> #{msg}|]
+      mbQryLic <- formResultMaybe qryLicRes procFormQryLic
+
       actionUrl <- fromMaybe AdminAvsR <$> getCurrentRoute
       siteLayoutMsg MsgMenuAvs $ do
         setTitleI MsgMenuAvs
-        let personForm = wrapForm pwidget def 
+        let wrapFormHere fw fe = wrapForm fw def { formAction = Just $ SomeRoute actionUrl, formEncoding = fe }
-                          { formAction = Just $ SomeRoute actionUrl
+            personForm = wrapFormHere pwidget  penctype
-                          , formEncoding = penctype
+            statusForm = wrapFormHere swidget  senctype
-                          }
+            crUsrForm  = wrapFormHere crUsrWgt crUsrEnctype
-            statusForm = wrapForm swidget def 
+            getLicForm = wrapFormHere getLicWgt getLicEnctype
-                          { formAction = Just $ SomeRoute actionUrl
+            setLicForm = wrapFormHere setLicWgt setLicEnctype
-                          , formEncoding = senctype
+            qryLicForm = wrapForm     qryLicWgt def { formAction = Just $ SomeRoute actionUrl, formEncoding = qryLicEnctype, formSubmit = FormNoSubmit }
-                          }
         -- TODO: use i18nWidgetFile instead if this is to become permanent
         $(widgetFile "avs")  

src/Handler/Admin/Test.hs

@@ -22,10 +22,14 @@ import qualified Data.ByteString.Lazy as LBS
 import qualified Data.Set as Set
 import qualified Data.Map as Map
 
-import qualified Text.Pandoc        as P
+import qualified Text.Pandoc          as P
-import qualified Text.Pandoc.PDF    as P
+import qualified Text.Pandoc.PDF      as P
 import qualified Text.Pandoc.Builder  as P
 
+-- just to test i18nHamlet
+import Text.Hamlet
+-- import Handler.Utils.I18n
+
 import Handler.Admin.Test.Download (testDownload)
 
 
@@ -207,6 +211,10 @@ postAdminTestR = do
 
   testDownloadWidget <- testDownload
 
+  testHamlet1 <- withUrlRenderer $(hamletFile "templates/i18n/test/en-eu.hamlet")
+  --let testHamlet2 = $(i18nHamletFile "test")
+  let testHamlet2 = testHamlet1
+
   let locallyDefinedPageHeading = [whamlet|Admin TestPage for Uni2work|]
   siteLayout locallyDefinedPageHeading $ do
   -- defaultLayout $ do
@@ -276,6 +284,14 @@ postAdminTestR = do
          ^{testDownloadWidget}
     |]
 
+    [whamlet|
+      <section>
+        <h2>Test i18nHamlet 1
+        #{testHamlet1}
+      <section>
+        <h2>Test i18nHamlet 2
+        #{testHamlet2}
+    |]
     i18n $ MsgPrintDebugForStupid "DebugForStupid"
 
 

src/Handler/LMS.hs

@@ -83,8 +83,9 @@ postLmsAllR = do
     FormMissing -> return ()
     _other -> addMessage Warning "Kein korrekter LMS Knopf erkannt"
 
+  isAdmin <- hasReadAccessTo AdminR
   lmsTable <- runDB $ do
-    view _2 <$> mkLmsAllTable
+    view _2 <$> mkLmsAllTable isAdmin
   siteLayoutMsg MsgMenuQualifications $ do
     setTitleI MsgMenuQualifications
     $(widgetFile "lms-all")
@@ -100,9 +101,10 @@ resultAllQualificationTotal  :: Lens' AllQualificationTableData Word64
 resultAllQualificationTotal  = _dbrOutput . _3 . _unValue
 
 
-mkLmsAllTable :: DB (Any, Widget)
+mkLmsAllTable :: Bool -> DB (Any, Widget)
-mkLmsAllTable = do
+mkLmsAllTable isAdmin = do
   now <- liftIO getCurrentTime
+  
   let
     resultDBTable = DBTable{..}
       where
@@ -136,11 +138,19 @@ mkLmsAllTable = do
           -- , sortable Nothing (i18nCell MsgQualificationRefreshWithin)   $ foldMap textCell . view (resultAllQualification . _qualificationRefreshWithin . to formatCalendarDiffDays) -- does not work, since there is a maybe in between
           , sortable (Just "qelearning") (i18nCell MsgTableLmsElearning & cellTooltip MsgQualificationElearningStart)
                                                                         $ tickmarkCell . view (resultAllQualification . _qualificationElearningStart)
-          , sortable Nothing (i18nCell MsgTableQualificationSapExport)  $ \(view (resultAllQualification . _qualificationSapId) -> sapid) -> tickmarkCell $ isJust sapid
+          , sortable Nothing (i18nCell MsgTableQualificationIsAvsLicence & cellTooltip MsgTableQualificationIsAvsLicenceTooltip) 
+                  $ \(view (resultAllQualification . _qualificationAvsLicence) -> licence) -> maybeCell licence $ textCell . T.singleton . licence2char
+          , sortable Nothing (i18nCell MsgTableQualificationSapExport & cellTooltip MsgTableQualificationSapExportTooltip)  
+                  $ \(view (resultAllQualification . _qualificationSapId) -> mbSapId) ->
+                      let icn = IconOK -- change icon here, if desired
+                      in case mbSapId of 
+                        Nothing               -> mempty
+                        Just sapId | isAdmin  -> cellTooltipIcon (Just icn) (text2message sapId) mempty
+                        Just _                -> iconCell icn 
           , sortable Nothing (i18nCell MsgTableQualificationCountActive & cellTooltip MsgTableQualificationCountActiveTooltip)
-                                                                        $ \(view resultAllQualificationActive -> n) -> wgtCell $ word2widget n
+                  $ \(view resultAllQualificationActive -> n) -> wgtCell $ word2widget n
           , sortable Nothing (i18nCell MsgTableQualificationCountTotal) $ wgtCell . word2widget . view resultAllQualificationTotal
-                                                                       -- \(view resultAllQualificationTotal  -> n) -> wgtCell $ word2widget n
+                                                                        -- \(view resultAllQualificationTotal  -> n) -> wgtCell $ word2widget n
           ]
         dbtSorting = mconcat
           [
@@ -322,9 +332,11 @@ lmsTableQuery qid (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser) = do
     --   - using noExsists on printJob join condition works, but only deliver single value;
     --  experiments with separate sub-query showed that we would need two subsqueries to learn whether the request was indeed the latest
     E.on $ user E.^. UserId E.=?. lmsUser  E.?. LmsUserUser
-            E.&&. E.val qid E.=?. lmsUser  E.?. LmsUserQualification            -- NOTE: condition was once erroneously placed in where-clause
+            E.&&. E.val qid E.=?. lmsUser  E.?. LmsUserQualification            -- NOTE: condition was once erroneously placed in where-clause, which does not work
     E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser
     E.where_ $    E.val qid E.==. qualUser E.^. QualificationUserQualification
+    -- TODO: decide whether to use subSelect or LeftOuterJoin and delete the other!
+    -- Letztes Datum anzeigen, wenn mehrere, dann diese in klickbaren Tooltip verstecken!
     let printAcknowledged = E.subSelectMaybe . E.from $ \pj -> do
                     E.where_ $ E.isJust (pj E.^. PrintJobLmsUser)
                         E.&&. ((lmsUser E.?. LmsUserIdent) E.==. (pj E.^. PrintJobLmsUser))
@@ -334,6 +346,14 @@ lmsTableQuery qid (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser) = do
     return (qualUser, user, lmsUser, printAcknowledged)
 
 
+newtype LmsTableFilterProj = LmsTableFilterProj { ltProjFilterMayAccess  :: Maybe Bool }
+
+instance Default LmsTableFilterProj where
+  def = LmsTableFilterProj
+    { ltProjFilterMayAccess  = Nothing }
+
+makeLenses_ ''LmsTableFilterProj
+
 mkLmsTable :: forall h p cols act act'.
               ( Functor h, ToSortable h
               , Ord act, PathPiece act, RenderMessage UniWorX act
@@ -357,7 +377,17 @@ mkLmsTable (Entity qid quali) acts restrict cols psValidator = do
     dbtIdent = "qualification"
     dbtSQLQuery q = lmsTableQuery qid q <* E.where_ (restrict q)
     dbtRowKey = queryUser >>> (E.^. UserId)
-    dbtProj = dbtProjFilteredPostId
+    --dbtProj = dbtProjFilteredPostId
+    dbtProj = (views _dbtProjRow . set _dbrOutput) =<< do
+      qusr <-    view $ _dbtProjRow . resultQualUser
+      user <-    view $ _dbtProjRow . resultUser
+      lusr <- preview $ _dbtProjRow . resultLmsUser      
+      pjac <- preview $ _dbtProjRow . resultPrintAck
+      forMM_ (view $ _dbtProjFilter . _ltProjFilterMayAccess) $ \b -> do 
+        euid <- encrypt $ user ^. _entityKey
+        guardM . lift . lift . fmap (== b) . hasReadAccessTo . urlRoute $ ForProfileDataR euid -- TODO create a page with proper rights; this is only for admins!        
+      return (qusr,user,lusr,E.Value pjac)
+
     dbtColonnade = cols
     dbtSorting = mconcat
       [ single $ sortUserNameLink queryUser
@@ -375,7 +405,8 @@ mkLmsTable (Entity qid quali) acts restrict cols psValidator = do
       , single ("lms-ended"   , SortColumn $ queryLmsUser  >>> (E.?. LmsUserEnded))
       ]
     dbtFilter = mconcat
-      [ single $ fltrUserNameEmail   queryUser
+      [ single ("may-access"  , FilterProjected $ (_ltProjFilterMayAccess  ?~) . getAny)
+      , single $ fltrUserNameEmail   queryUser
       , single ("lms-ident"   , FilterColumn . E.mkContainsFilterWith (Just . LmsIdent) $ views (to queryLmsUser) (E.?. LmsUserIdent))
       -- , single ("lms-status"  , FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) ((E.>=. E.val nowaday) . (E.^. LmsUserStatus))) -- LmsStatus cannot be filtered easily within the DB
       , single ("validity"    , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) ((E.>=. E.val nowaday) . (E.^. QualificationUserValidUntil)))
@@ -420,7 +451,7 @@ mkLmsTable (Entity qid quali) acts restrict cols psValidator = do
           <*>  preview (resultLmsUser  . _entityVal . _lmsUserStarted)
           <*>  preview (resultLmsUser  . _entityVal . _lmsUserDatePin)
           <*> (join . preview (resultLmsUser  . _entityVal . _lmsUserReceived))
-          <*> (join . preview (resultLmsUser  . _entityVal . _lmsUserNotified))
+          <*> (join . preview (resultLmsUser  . _entityVal . _lmsUserNotified)) -- TODO: only exports last email date / print job sending date, not print acknowledge
           <*> (join . preview (resultLmsUser  . _entityVal . _lmsUserEnded))
     dbtCsvDecode = Nothing
     dbtExtraReps = []
@@ -499,6 +530,7 @@ postLmsR sid qsh = do
                   cDate           = if | not letterSent  ->  foldMap dateTimeCell notifyDate
                                        | Just d <- lastLetterDate -> dateTimeCell d
                                        | otherwise -> i18nCell MsgPrintJobUnacknowledged
+                  lprLink :: Maybe (Route UniWorX)  = lmsident <&> (\lid -> urlRoute (PrintCenterR, [("print-job-lmsid", toPathPiece lid)]))
                   cAckDates = case letterDates of
                     Just ackDates@(_:_:_) -> spacerCell <> modalCell [whamlet|
                           <h1>
@@ -511,10 +543,10 @@ postLmsR sid qsh = do
                                     ^{formatTimeW SelFormatDateTime ackdate}
                                   $nothing
                                     _{MsgPrintJobUnacknowledged}
-                          $maybe _lu <- lmsident
+                          $maybe lu <- lprLink
                             <p>
-                              <a href=@{PrintCenterR}>
+                              <a href=@{lu}>
-                                Link to PrintJob
+                                _{MsgPrintJobs}
                         |]
                         -- (PrintCenterR, [("pj-lmsid", toPathPiece lu)])
                     _ -> mempty
@@ -528,7 +560,7 @@ postLmsR sid qsh = do
           where
             -- i18nLms :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a
             i18nLms msg = cell [whamlet|LMS #|] <> i18nCell msg
-        psValidator = def -- TODO: hier einen Filter für Schützlinge einbauen
+        psValidator = def & forceFilter "may-access" (Any True)
     tbl <- mkLmsTable qent acts (const E.true) colChoices psValidator
     return (tbl, qent)
 

src/Handler/LMS/Fake.hs

@@ -68,10 +68,20 @@ fakeQualificationUsers (Entity qid Qualification{qualificationRefreshWithin}) (u
         PWHashConf{..} <- getsYesod $ view _appAuthPWHash
         pwHash <- liftIO $ PWStore.makePasswordWith pwHashAlgorithm pw pwHashStrength
         return $ AuthPWHash $ TEnc.decodeUtf8 pwHash
-    let expiryOffsets = concatMap (replicate usersPerDay) [0..(diffDays dto dfrom)]
+    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
+                    2 -> do
+                          void $ insertBy $ UserSupervisor s    suid True
+                          void $ insertBy $ UserSupervisor suid suid True
+                    3 -> void $ insertBy $ UserSupervisor s suid True
+                    _ -> return ()
+          _   -> \_ _ -> return ()
+        expiryOffsets = concatMap (replicate usersPerDay) [0..(diffDays dto dfrom)]
         expiryNotifyDay = addGregorianDurationClip (fromMaybe calendarDay qualificationRefreshWithin) dfrom
-        fakeUser :: ([Text], UserSurname, (Maybe Languages, DateTimeFormat, DateTimeFormat, DateTimeFormat), Bool) -> User
+        fakeUser :: ([Text], UserSurname, (Maybe Languages, DateTimeFormat, DateTimeFormat, DateTimeFormat), Bool, Int) -> User
-        fakeUser (firstNames, userSurname, (userLanguages, userDateTimeFormat, userDateFormat, userTimeFormat), userPrefersPostal) =
+        fakeUser (firstNames, userSurname, (userLanguages, userDateTimeFormat, userDateFormat, userTimeFormat), userPrefersPostal, _isSupervised) =
           let userIdent = CI.mk $ Text.intercalate "." (take 1 firstNames ++ (Text.take 1 <$> drop 1 firstNames) ++ [userSurname]) <> "@example.com"
               userEmail = userIdent
               userDisplayEmail = userIdent
@@ -122,6 +132,7 @@ fakeQualificationUsers (Entity qid Qualification{qualificationRefreshWithin}) (u
                           [ QualificationUserValidUntil  =. qualificationUserValidUntil
                           , QualificationUserLastRefresh =. qualificationUserLastRefresh
                           ]
+              addSupervisor uid (user ^. _5)
               return $ either (const 0) (const 1) euid
               -- ok <- insertUnique QualificationUser{..} -- We do not overwrite any existing qualifications, just to be on the save side:
               -- return $ maybe 0 (const 1) ok
@@ -154,11 +165,13 @@ fakeQualificationUsers (Entity qid Qualification{qualificationRefreshWithin}) (u
                  , (Just $ Languages ["fr"]        , DateTimeFormat "%d-%m-%Y %R"   , DateTimeFormat "%d-%m-%Y"   , DateTimeFormat "%R")
                  , (Just $ Languages ["fr","en"]   , DateTimeFormat "%B %d %Y %R"   , DateTimeFormat "%B %d %y"   , DateTimeFormat "%I:%M:%S %p")
                  ]
-    postal    = [False, True, False]
+    postal     = [False, True, False]
+    supervised = [0,1,2,3]
 
-    names = getZipList $ (\f m s l p -> (f : concat m, s, l, p))
+    names = getZipList $ (\f m s l p v -> (f : concat m, s, l, p, v))
               <$> ZipList (cycle givenNames)
               <*> ZipList (cycle middlenames)
               <*> ZipList (cycle surnames)
               <*> ZipList (cycle someLangs)
               <*> ZipList (cycle postal)
+              <*> ZipList (cycle supervised)

src/Handler/LMS/Users.hs

@@ -153,6 +153,7 @@ getLmsUsersR sid qsh = do
 
 getLmsUsersDirectR :: SchoolId -> QualificationShorthand -> Handler TypedContent
 getLmsUsersDirectR sid qsh = do
+  $logInfoS "LMS" $ "Direct Download Users for " <> tshow qsh <> " at " <> tshow sid
   lms_users <- runDB $ do
     qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
     selectList [LmsUserQualification ==. qid, LmsUserEnded ==. Nothing] [Asc LmsUserStarted, Asc LmsUserIdent]

src/Handler/PrintCenter.hs

@@ -45,7 +45,7 @@ single :: (k,a) -> Map k a
 single = uncurry Map.singleton
 
 data MetaPinRenewal = MetaPinRenewal
-      { mppRecipient :: Text
+      { mppExaminee :: Text
       , mppAddress   :: StoredMarkup
       , mppLogin     :: Text
       , mppPin       :: Text
@@ -54,13 +54,14 @@ data MetaPinRenewal = MetaPinRenewal
       , mppLang      :: Lang
       , mppOpening   :: Maybe Text
       , mppClosing   :: Maybe Text
+      , mppSupervisor:: Maybe Text
       }
   deriving (Eq, Ord, Show, Generic, Typeable)
 
 -- TODO: just for testing, remove in production
 instance Default MetaPinRenewal where
   def = MetaPinRenewal
-          { mppRecipient = "Papa Schlumpf"
+          { mppExaminee = "Papa Schlumpf"
           , mppAddress   = plaintextToStoredMarkup ("Erdbeerweg 42\n98726 Schlumpfhausen"::Text)
           , mppLogin     = "keiner123"
           , mppPin       = "89998a"
@@ -69,13 +70,14 @@ instance Default MetaPinRenewal where
           , mppLang      = "de-de"
           , mppOpening   = Just "Lieber Schlumpfi,"
           , mppClosing   = Nothing
+          , mppSupervisor= Nothing
           }
 
 makeRenewalForm :: Maybe MetaPinRenewal -> Form MetaPinRenewal
 makeRenewalForm tmpl = identifyForm FIDLmsLetter . validateForm validateMetaPinRenewal $ \html -> do
   now_day <- utctDay <$> liftIO getCurrentTime
   flip (renderAForm FormStandard) html $ MetaPinRenewal
-    <$> areq textField        (fslI MsgMppRecipient)         (mppRecipient <$> tmpl)
+    <$> areq textField        (fslI MsgMppRecipient)         (mppExaminee <$> tmpl)
     <*> areq htmlField        (fslI MsgMppAddress)           (mppAddress   <$> tmpl)
     <*> areq textField        (fslI MsgMppLogin)             (mppLogin     <$> tmpl)
     <*> areq textField        (fslI MsgMppPin)               (mppPin       <$> tmpl)
@@ -84,6 +86,7 @@ makeRenewalForm tmpl = identifyForm FIDLmsLetter . validateForm validateMetaPinR
     <*> areq (langField True) (fslI MsgMppLang)             ((mppLang      <$> tmpl) <|> Just "de-de")
     <*> aopt textField        (fslI MsgMppOpening)           (mppOpening   <$> tmpl)
     <*> aopt textField        (fslI MsgMppClosing)           (mppClosing   <$> tmpl)
+    <*> aopt textField        (fslI MsgMppSupervisor)        (mppSupervisor<$> tmpl)
 
 validateMetaPinRenewal :: FormValidator MetaPinRenewal Handler ()
 validateMetaPinRenewal = do
@@ -93,9 +96,9 @@ validateMetaPinRenewal = do
 
 mprToMeta :: MetaPinRenewal -> P.Meta
 mprToMeta MetaPinRenewal{..} = mkMeta
-  --  formatTimeUser SelFormatDate mppDate mppRecipient
+  --  formatTimeUser SelFormatDate mppDate mppExaminee
-  [ toMeta "recipient"  mppRecipient
+  [ toMeta "examinee"  mppExaminee
-  , toMeta "address"   (mppRecipient : (mppAddress & html2textlines))
+  , toMeta "address"   (mppExaminee : (mppAddress & html2textlines))
   , toMeta "login"      mppLogin
   , toMeta "pin"        mppPin
   , mbMeta "url"       (mppURL  <&> tshow)
@@ -103,6 +106,7 @@ mprToMeta MetaPinRenewal{..} = mkMeta
   , toMeta "lang"       mppLang
   , mbMeta keyOpening   mppOpening
   , mbMeta keyClosing   mppClosing
+  , mbMeta "supervisor" mppSupervisor
   ]
   where
     deOrEn     = if isDe mppLang then "de" else "en"
@@ -112,7 +116,7 @@ mprToMeta MetaPinRenewal{..} = mkMeta
 mprToMetaUser :: (MonadHandler m, HandlerSite m ~ UniWorX) => Entity User -> MetaPinRenewal -> m P.Meta
 mprToMetaUser entUser@Entity{entityVal = u} mpr = do
   let userLang = userLanguages u >>= (listToMaybe . view _Wrapped) -- auch möglich `op Languages` statt `view _Wrapped`
-      meta = mprToMeta mpr{ mppRecipient = userDisplayName u
+      meta = mprToMeta mpr{ mppExaminee = userDisplayName u
                            -- , mppAddress = userDisplayName u : html2textlines userAddress --TODO once we have User addresses within the DB
                           , mppLang = fromMaybe (mppLang mpr) userLang -- check if this is the desired behaviour!
                           }
@@ -197,53 +201,53 @@ mkPJTable = do
     dbtProj = dbtProjFilteredPostId
     dbtColonnade = mconcat
       [ dbSelectIf (applying _2) id (return . view (resultPrintJob . _entityKey)) (\r -> isNothing $ r ^. resultPrintJob . _entityVal . _printJobAcknowledged)
-      , sortable (Just "pj-created")      (i18nCell MsgPrintJobCreated)       $ \(   view $ resultPrintJob . _entityVal . _printJobCreated      -> t) ->      dateTimeCell t
+      , sortable (Just "created")      (i18nCell MsgPrintJobCreated)       $ \(   view $ resultPrintJob . _entityVal . _printJobCreated      -> t) ->      dateTimeCell t
-      , sortable (Just "pj-acknowledged") (i18nCell MsgPrintJobAcknowledged)  $ \(   view $ resultPrintJob . _entityVal . _printJobAcknowledged -> t) -> maybeDateTimeCell t
+      , sortable (Just "acknowledged") (i18nCell MsgPrintJobAcknowledged)  $ \(   view $ resultPrintJob . _entityVal . _printJobAcknowledged -> t) -> maybeDateTimeCell t
-      , sortable (Just "pj-filename")     (i18nCell MsgPrintPDF)  $ \r -> let k = r ^. resultPrintJob . _entityKey
+      , sortable (Just "filename")     (i18nCell MsgPrintPDF)  $ \r -> let k = r ^. resultPrintJob . _entityKey
-                                                                              t = r ^. resultPrintJob . _entityVal . _printJobFilename
+                                                                           t = r ^. resultPrintJob . _entityVal . _printJobFilename
-                                                                          in anchorCellM (PrintDownloadR <$> encrypt k) (toWgt t)
+                                                                       in anchorCellM (PrintDownloadR <$> encrypt k) (toWgt t)
-      , sortable (Just "pj-name")         (i18nCell MsgPrintJobName)          $ \(   view $ resultPrintJob . _entityVal . _printJobName         -> n) -> textCell n
+      , sortable (Just "name")         (i18nCell MsgPrintJobName)          $ \(   view $ resultPrintJob . _entityVal . _printJobName         -> n) -> textCell n
-      , sortable (Just "pj-recipient")    (i18nCell MsgPrintRecipient)        $ \(preview resultRecipient -> u) -> maybeCell u $ cellHasUserLink AdminUserR
+      , sortable (Just "recipient")    (i18nCell MsgPrintRecipient)        $ \(preview resultRecipient -> u) -> maybeCell u $ cellHasUserLink AdminUserR
-      , sortable (Just "pj-sender")       (i18nCell MsgPrintSender)           $ \(preview resultSender    -> u) -> maybeCell u $ cellHasUserLink AdminUserR
+      , sortable (Just "sender")       (i18nCell MsgPrintSender)           $ \(preview resultSender    -> u) -> maybeCell u $ cellHasUserLink AdminUserR
-      , sortable (Just "pj-course")       (i18nCell MsgPrintCourse)           $ \(preview $ resultCourse        . _entityVal -> c) -> maybeCell c courseCell
+      , sortable (Just "course")       (i18nCell MsgPrintCourse)           $ \(preview $ resultCourse        . _entityVal -> c) -> maybeCell c courseCell
-      , sortable (Just "pj-qualification")(i18nCell MsgPrintQualification)    $ \(preview $ resultQualification . _entityVal -> q) -> maybeCell q qualificationCell
+      , sortable (Just "qualification")(i18nCell MsgPrintQualification)    $ \(preview $ resultQualification . _entityVal -> q) -> maybeCell q qualificationCell
-      , sortable (Just "pj-lmsid")        (i18nCell MsgPrintLmsUser)          $ \(   view $ resultPrintJob . _entityVal . _printJobLmsUser -> l) -> foldMap textCell (getLmsIdent <$> l)
+      , sortable (Just "lmsid")        (i18nCell MsgPrintLmsUser)          $ \(   view $ resultPrintJob . _entityVal . _printJobLmsUser -> l) -> foldMap textCell (getLmsIdent <$> l)
       ]
     dbtSorting = mconcat
-      [ single ("pj-name"         , SortColumn $ queryPrintJob      >>> (E.^. PrintJobName))
+      [ single ("name"         , SortColumn $ queryPrintJob      >>> (E.^. PrintJobName))
-      , single ("pj-filename"     , SortColumn $ queryPrintJob      >>> (E.^. PrintJobFilename))
+      , single ("filename"     , SortColumn $ queryPrintJob      >>> (E.^. PrintJobFilename))
-      , single ("pj-created"      , SortColumn $ queryPrintJob      >>> (E.^. PrintJobCreated))
+      , single ("created"      , SortColumn $ queryPrintJob      >>> (E.^. PrintJobCreated))
-      , single ("pj-acknowledged" , SortColumn $ queryPrintJob      >>> (E.^. PrintJobAcknowledged))
+      , single ("acknowledged" , SortColumn $ queryPrintJob      >>> (E.^. PrintJobAcknowledged))
-      , single ("pj-recipient"    , sortUserNameBareM queryRecipient)
+      , single ("recipient"    , sortUserNameBareM queryRecipient)
-      , single ("pj-sender"       , sortUserNameBareM querySender   )
+      , single ("sender"       , sortUserNameBareM querySender   )
-      , single ("pj-course"       , SortColumn $ queryCourse        >>> (E.?. CourseName))
+      , single ("course"       , SortColumn $ queryCourse        >>> (E.?. CourseName))
-      , single ("pj-qualification", SortColumn $ queryQualification >>> (E.?. QualificationName))
+      , single ("qualification", SortColumn $ queryQualification >>> (E.?. QualificationName))
-      , single ("pj-lmsid"        , SortColumn $ queryPrintJob      >>> (E.^. PrintJobLmsUser))
+      , single ("lmsid"        , SortColumn $ queryPrintJob      >>> (E.^. PrintJobLmsUser))
       ]
     dbtFilter = mconcat
-      [ single ("pj-name"         , FilterColumn . E.mkContainsFilter          $ views (to queryPrintJob)      (E.^. PrintJobName))
+      [ single ("name"         , FilterColumn . E.mkContainsFilter          $ views (to queryPrintJob)      (E.^. PrintJobName))
-      , single ("pj-filename"     , FilterColumn . E.mkContainsFilter          $ views (to queryPrintJob)      (E.^. PrintJobFilename))
+      , single ("filename"     , FilterColumn . E.mkContainsFilter          $ views (to queryPrintJob)      (E.^. PrintJobFilename))
-      , single ("pj-created"      , FilterColumn . E.mkDayFilter               $ views (to queryPrintJob)      (E.^. PrintJobCreated))
+      , single ("created"      , FilterColumn . E.mkDayFilter               $ views (to queryPrintJob)      (E.^. PrintJobCreated))
-      --, single ("pj-created"      , FilterColumn . E.mkDayBetweenFilter               $ views (to queryPrintJob)      (E.^. PrintJobCreated))
+      --, single ("created"      , FilterColumn . E.mkDayBetweenFilter               $ views (to queryPrintJob)      (E.^. PrintJobCreated))
-      , single ("pj-recipient"    , FilterColumn . E.mkContainsFilterWith Just $ views (to queryRecipient)     (E.?. UserDisplayName))
+      , single ("recipient"    , FilterColumn . E.mkContainsFilterWith Just $ views (to queryRecipient)     (E.?. UserDisplayName))
-      , single ("pj-sender"       , FilterColumn . E.mkContainsFilterWith Just $ views (to querySender)        (E.?. UserDisplayName))
+      , single ("sender"       , FilterColumn . E.mkContainsFilterWith Just $ views (to querySender)        (E.?. UserDisplayName))
-      , single ("pj-course"       , FilterColumn . E.mkContainsFilterWith Just $ views (to queryCourse)        (E.?. CourseName))
+      , single ("course"       , FilterColumn . E.mkContainsFilterWith Just $ views (to queryCourse)        (E.?. CourseName))
-      , single ("pj-qualification", FilterColumn . E.mkContainsFilterWith Just $ views (to queryQualification) (E.?. QualificationName))
+      , single ("qualification", FilterColumn . E.mkContainsFilterWith Just $ views (to queryQualification) (E.?. QualificationName))
-      , single ("pj-lmsid"        , FilterColumn . E.mkContainsFilterWith Just $ views (to queryPrintJob)      (E.^. PrintJobLmsUser))
+      , single ("lmsid"        , FilterColumn . E.mkContainsFilterWith Just $ views (to queryPrintJob)      (E.^. PrintJobLmsUser))
       , single ("acknowledged"    , FilterColumn . E.mkExactFilterLast $ views (to queryPrintJob) (E.isJust . (E.^. PrintJobAcknowledged)))
       ]
     dbtFilterUI mPrev = mconcat
-      [ prismAForm (singletonFilter "pj-name"         . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)                        (fslI MsgPrintJobName)
+      [ prismAForm (singletonFilter "name"         . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)                        (fslI MsgPrintJobName)
-      , prismAForm (singletonFilter "pj-filename"     . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)                        (fslI MsgPrintJobFilename)
+      , prismAForm (singletonFilter "filename"     . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)                        (fslI MsgPrintJobFilename)
-      , prismAForm (singletonFilter "pj-created"      . maybePrism _PathPiece) mPrev $ aopt (hoistField lift  dayField)                        (fslI MsgPrintJobCreated)
+      , prismAForm (singletonFilter "created"      . maybePrism _PathPiece) mPrev $ aopt (hoistField lift  dayField)                        (fslI MsgPrintJobCreated)
-      --, prismAForm (singletonFilter "pj-created"      . maybePrism _PathPiece) mPrev ((,) <$> aopt (hoistField lift  dayField)                        (fslI MsgPrintJobCreated)
+      --, prismAForm (singletonFilter "created"      . maybePrism _PathPiece) mPrev ((,) <$> aopt (hoistField lift  dayField)                        (fslI MsgPrintJobCreated)
       --                                                                                  <*> aopt (hoistField lift  dayField)                        (fslI MsgPrintJobCreated)
       --                                                                          )
-      , prismAForm (singletonFilter "pj-recipient"    . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)                        (fslI MsgPrintRecipient)
+      , prismAForm (singletonFilter "recipient"    . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)                        (fslI MsgPrintRecipient)
-      , prismAForm (singletonFilter "pj-sender"       . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)                        (fslI MsgPrintSender)
+      , prismAForm (singletonFilter "sender"       . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)                        (fslI MsgPrintSender)
-      , prismAForm (singletonFilter "pj-course"       . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)                        (fslI MsgPrintCourse)
+      , prismAForm (singletonFilter "course"       . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)                        (fslI MsgPrintCourse)
-      , prismAForm (singletonFilter "pj-qualification". maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)                        (fslI MsgPrintQualification)
+      , prismAForm (singletonFilter "qualification". maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)                        (fslI MsgPrintQualification)
-      , prismAForm (singletonFilter "pj-lmsid"        . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)                        (fslI MsgPrintLmsUser)
+      , prismAForm (singletonFilter "lmsid"        . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)                        (fslI MsgPrintLmsUser)
       , prismAForm (singletonFilter "acknowledged"    . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgPrintJobAcknowledged)
       ]
     dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout}
@@ -275,7 +279,7 @@ mkPJTable = do
         (First (Just act), jobMap) <- inp
         let jobSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) jobMap
         return (act, jobSet)
-    psValidator = def & defaultSorting [SortAscBy "pj-created"]
+    psValidator = def & defaultSorting [SortAscBy "created"]
                       & defaultFilter (singletonMap "acknowledged" [toPathPiece False])
   over _1 postprocess <$> dbTable psValidator DBTable{..}
 
@@ -304,7 +308,7 @@ postPrintSendR = do
   let procFormSend mpr = do
         receivers <- runDB $ Ex.select $ do
           user <- Ex.from $ Ex.table @User
-          Ex.where_ $ E.val (mppRecipient mpr) `E.isInfixOf` (user E.^. UserIdent)
+          Ex.where_ $ E.val (mppExaminee mpr) `E.isInfixOf` (user E.^. UserIdent)
           pure user
         letters <- case receivers of
           [] -> pure . (Nothing ,) <$> pdfRenewal (mprToMeta mpr)
@@ -317,7 +321,7 @@ postPrintSendR = do
             -- liftIO $ LBS.writeFile "/tmp/generated.pdf" bs -- DEBUGGING ONLY
             -- addMessage Warning "PDF momentan nur gespeicher unter /tmp/generated.pdf"
             uID <- maybeAuthId
-            runDB (sendLetter "Test-Brief" bs (mbRecipient, uID) Nothing Nothing Nothing) >>= \case -- calls lpr
+            runDB (sendLetter' "Test-Brief" bs (mbRecipient, uID) Nothing Nothing Nothing) >>= \case -- calls lpr
               Left err -> do
                 let msg = "PDF printing failed with error: " <> err
                 $logErrorS "LPR" msg
@@ -420,7 +424,7 @@ postPrintAckDirectR = do
         case enr of
           Left (e :: SomeException) -> do -- catch all to avoid ok220 in case of any error
             $logWarnS "APC" $ "Result upload failed parsing: " <> tshow e
-            return (badRequest400, "Exception: " <> tshow e)
+            return (badRequest400, "Error: " <> tshow e)
           Right lids -> do
             now <- liftIO getCurrentTime
             nr <- updateWhereCount
@@ -440,11 +444,11 @@ postPrintAckDirectR = do
                   $logWarnS "APC" msg
                   return (ok200, msg)
     []     -> do
-      let msg = "Warning: No file received. A file of lms identifiers must be supplied for print job acknowledging."
+      let msg = "Error: No file received. A file of lms identifiers must be supplied for print job acknowledging."
       $logWarnS "APC" msg
       return (badRequest400, msg)
     _other -> do
       let msg = "Error: Only a single file may be uploaded for print job acknowlegement; all ignored."
       $logErrorS "APC" msg
       return (badRequest400, msg)
-  sendResponseStatus status msg -- must be outside of runDB; otherweise transaction is rolled back
+  sendResponseStatus status msg -- must be outside of runDB; otherwise transaction is rolled back

src/Handler/Profile.hs

@@ -4,7 +4,9 @@
 
 module Handler.Profile
   ( getProfileR, postProfileR
-  , getProfileDataR, makeProfileData
+  , getForProfileR, postForProfileR
+  , getProfileDataR, makeProfileData  
+  , getForProfileDataR
   , getAuthPredsR, postAuthPredsR
   , getUserNotificationR, postUserNotificationR
   , getSetDisplayEmailR, postSetDisplayEmailR
@@ -482,10 +484,19 @@ instance Finite ProfileAnchor
 nullaryPathPiece ''ProfileAnchor $ camelToPathPiece' 1
 
 
-getProfileR, postProfileR :: Handler Html
+getForProfileR , postForProfileR :: CryptoUUIDUser -> Handler Html
-getProfileR = postProfileR
+getForProfileR = postForProfileR
-postProfileR = do
+postForProfileR cID = do 
-  (uid, user@User{..}) <- requireAuthPair
+  uid <- decrypt cID
+  user <- runDB $ get404 uid
+  serveProfileR (uid, user)
+
+getProfileR,   postProfileR :: Handler Html
+getProfileR  = postProfileR
+postProfileR = requireAuthPair >>= serveProfileR
+
+serveProfileR :: (UserId, User) -> Handler Html
+serveProfileR (uid, user@User{..}) = do
   (userSchools, userExamOfficeLabels) <- runDB $ do
     userSchools <- fmap (setOf $ folded . _Value) . E.select . E.from $ \school -> do
       E.where_ . E.exists . E.from $ \userSchool ->
@@ -632,6 +643,14 @@ getProfileDataR = do
     setTitleI MsgHeadingProfileData
     dataWidget
 
+getForProfileDataR :: CryptoUUIDUser -> Handler Html
+getForProfileDataR cID = do
+  uid <- decrypt cID
+  (user,dataWidget) <- runDB $ bind2 (get404 uid) $ makeProfileData . Entity uid    
+  defaultLayout $ do
+    setTitleI $ MsgHeadingForProfileData $ userDisplayName user
+    dataWidget
+
 makeProfileData :: Entity User -> DB Widget
 makeProfileData (Entity uid User{..}) = do
   functions <- Map.fromListWith Set.union . map (\(Entity _ UserFunction{..}) -> (userFunctionFunction, Set.singleton userFunctionSchool)) <$> selectList [UserFunctionUser ==. uid] []
@@ -1004,7 +1023,7 @@ mkQualificationsTable =
       , dbtProj      = dbtProjId 
       , dbtColonnade = mconcat
           [ colSchool (_dbrOutput . _1 . _entityVal . _qualificationSchool)
-          , sortable (Just "quali")         (i18nCell MsgQualificationName)             $ qualificationCell         <$> view (_dbrOutput . _1 . _entityVal)
+          , sortable (Just "quali")         (i18nCell MsgQualificationName)             $ qualificationDescrCell         <$> view (_dbrOutput . _1 . _entityVal)
           , sortable (Just "blocked-due")   (i18nCell MsgTableQualificationBlockedDue & cellTooltip MsgTableQualificationBlockedTooltip
                                                                                      )  $ qualificationBlockedCell  <$> view (_dbrOutput . _2 . _entityVal . _qualificationUserBlockedDue )
           , sortable (Just "valid-until")   (i18nCell MsgLmsQualificationValidUntil)    $ dayCell                   <$> view (_dbrOutput . _2 . _entityVal . _qualificationUserValidUntil )

src/Handler/SAP.hs

@@ -16,6 +16,7 @@ import Handler.Utils.Csv
 
 -- import qualified Data.CaseInsensitive as CI
 import qualified Data.Csv as Csv
+import           Database.Esqueleto.Experimental ((:&)(..))
 import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma
 -- import qualified Database.Esqueleto.Legacy as E
 import qualified Database.Esqueleto.Utils as E
@@ -69,12 +70,12 @@ sapRes2csv l = [ res | (Ex.Value (Just persNo), Ex.Value firstHeld, Ex.Value val
 getQualificationSAPDirectR :: Handler TypedContent
 getQualificationSAPDirectR = do
   qualUsers <- runDB $ Ex.select $ do
-    (qual Ex.:& qualUser Ex.:& user) <- 
+    (qual :& qualUser :& user) <- 
       Ex.from $ Ex.table @Qualification 
       `Ex.innerJoin` Ex.table @QualificationUser
-      `Ex.on` (\(qual Ex.:& qualUser) -> qual Ex.^. QualificationId Ex.==. qualUser Ex.^. QualificationUserQualification)
+      `Ex.on` (\(qual :& qualUser) -> qual Ex.^. QualificationId Ex.==. qualUser Ex.^. QualificationUserQualification)
       `Ex.innerJoin` Ex.table @User
-      `Ex.on` (\(_ Ex.:& qualUser Ex.:& user) -> qualUser Ex.^. QualificationUserUser Ex.==. user Ex.^. UserId)
+      `Ex.on` (\(_ :& qualUser :& user) -> qualUser Ex.^. QualificationUserUser Ex.==. user Ex.^. UserId)
     Ex.where_ $ E.isJust (qual Ex.^. QualificationSapId)
         Ex.&&.  E.isJust (user Ex.^. UserCompanyPersonalNumber)
     return 

src/Handler/Users/Add.hs

@@ -4,8 +4,9 @@
 
 module Handler.Users.Add
   ( getAdminUserAddR, postAdminUserAddR
-  -- , AdminUserForm(..), adminUserForm                 -- no longer needed elsewhere
+  , AdminUserForm(..), AuthenticationKind(..)
-  -- , AuthenticationKind(..), classifyAuth, mkAuthMode -- no longer needed elsewhere   
+  , addNewUser
+  --, adminUserForm , classifyAuth, mkAuthMode -- no longer needed elsewhere   
   ) where
 
 
@@ -74,66 +75,64 @@ adminUserForm template = renderAForm FormStandard
   <*> areq (textField & cfStrip & cfCI) (fslI MsgAdminUserIdent) (aufIdent <$> template)
   <*> areq (selectField optionsFinite)  (fslI MsgAdminUserAuth) (aufAuth <$> template <|> Just AuthKindLDAP)
   
+addNewUser :: AdminUserForm -> Handler (Maybe UserId)
+addNewUser AdminUserForm{..} = do 
+  now <- liftIO getCurrentTime
+  UserDefaultConf{..} <- getsYesod $ view _appUserDefaults
+  let 
+    newUser = User
+      { userIdent                   = aufIdent
+      , userMaxFavourites           = userDefaultMaxFavourites
+      , userMaxFavouriteTerms       = userDefaultMaxFavouriteTerms
+      , userTheme                   = userDefaultTheme
+      , userDateTimeFormat          = userDefaultDateTimeFormat
+      , userDateFormat              = userDefaultDateFormat
+      , userTimeFormat              = userDefaultTimeFormat
+      , userDownloadFiles           = userDefaultDownloadFiles
+      , userWarningDays             = userDefaultWarningDays
+      , userShowSex                 = userDefaultShowSex
+      , userExamOfficeGetSynced     = userDefaultExamOfficeGetSynced
+      , userExamOfficeGetLabels     = userDefaultExamOfficeGetLabels
+      , userNotificationSettings    = def
+      , userLanguages               = Nothing
+      , userCsvOptions              = def
+      , userTokensIssuedAfter       = Nothing
+      , userCreated                 = now
+      , userLastLdapSynchronisation = Nothing
+      , userLdapPrimaryKey          = aufFPersonalNumber
+      , userLastAuthentication      = Nothing
+      , userEmail                   = aufEmail
+      , userDisplayName             = aufDisplayName
+      , userDisplayEmail            = aufDisplayEmail
+      , userFirstName               = aufFirstName
+      , userSurname                 = aufSurname
+      , userTitle                   = aufTitle
+      , userSex                     = aufSex        
+      , userMobile                  = aufMobile
+      , userTelephone               = aufTelephone
+      , userCompanyPersonalNumber   = aufFPersonalNumber
+      , userCompanyDepartment       = aufFDepartment    
+      , userPostAddress             = aufPostAddress
+      , userPrefersPostal           = aufPrefersPostal
+      , userPinPassword             = aufPinPassword
+      , userMatrikelnummer          = aufMatriculation
+      , userAuthentication          = mkAuthMode aufAuth
+      }
+  runDBJobs . runMaybeT $ do
+    uid <- MaybeT $ insertUnique newUser
+    lift . queueDBJob $ JobSynchroniseLdapUser uid
+    lift . queueDBJob . JobQueueNotification $ NotificationUserAuthModeUpdate uid (newUser ^. _userAuthentication)
+    when (aufAuth == AuthKindPWHash) $
+      lift . queueDBJob $ JobSendPasswordReset uid
+    return uid
+
 
 getAdminUserAddR, postAdminUserAddR :: Handler Html
 getAdminUserAddR = postAdminUserAddR
 postAdminUserAddR = do
   ((userRes, userView), userEnctype) <- runFormPost $ adminUserForm Nothing
-
+  formResult userRes $ addNewUser >=> \case
-  formResult userRes $ \AdminUserForm{..} -> do
+      (Just uid) -> do
-    now <- liftIO getCurrentTime
-    UserDefaultConf{..} <- getsYesod $ view _appUserDefaults
-
-    let
-      newUser@User{..} = User
-        { userIdent                   = aufIdent
-        , userMaxFavourites           = userDefaultMaxFavourites
-        , userMaxFavouriteTerms       = userDefaultMaxFavouriteTerms
-        , userTheme                   = userDefaultTheme
-        , userDateTimeFormat          = userDefaultDateTimeFormat
-        , userDateFormat              = userDefaultDateFormat
-        , userTimeFormat              = userDefaultTimeFormat
-        , userDownloadFiles           = userDefaultDownloadFiles
-        , userWarningDays             = userDefaultWarningDays
-        , userShowSex                 = userDefaultShowSex
-        , userExamOfficeGetSynced     = userDefaultExamOfficeGetSynced
-        , userExamOfficeGetLabels     = userDefaultExamOfficeGetLabels
-        , userNotificationSettings    = def
-        , userLanguages               = Nothing
-        , userCsvOptions              = def
-        , userTokensIssuedAfter       = Nothing
-        , userCreated                 = now
-        , userLastLdapSynchronisation = Nothing
-        , userLdapPrimaryKey          = Nothing
-        , userLastAuthentication      = Nothing
-        , userEmail                   = aufEmail
-        , userDisplayName             = aufDisplayName
-        , userDisplayEmail            = aufDisplayEmail
-        , userFirstName               = aufFirstName
-        , userSurname                 = aufSurname
-        , userTitle                   = aufTitle
-        , userSex                     = aufSex        
-        , userMobile                  = aufMobile
-        , userTelephone               = aufTelephone
-        , userCompanyPersonalNumber   = aufFPersonalNumber
-        , userCompanyDepartment       = aufFDepartment    
-        , userPostAddress             = aufPostAddress
-        , userPrefersPostal           = aufPrefersPostal
-        , userPinPassword             = aufPinPassword
-        , userMatrikelnummer          = aufMatriculation
-        , userAuthentication          = mkAuthMode aufAuth
-        }
-
-    didInsert <- runDBJobs . runMaybeT $ do
-      uid <- MaybeT $ insertUnique newUser
-      lift . queueDBJob $ JobSynchroniseLdapUser uid
-      lift . queueDBJob . JobQueueNotification $ NotificationUserAuthModeUpdate uid userAuthentication
-      when (aufAuth == AuthKindPWHash) $
-        lift . queueDBJob $ JobSendPasswordReset uid
-      return uid
-
-    case didInsert of
-      Just uid -> do
         addMessageI Success MsgUserAdded
         cID <- encrypt uid
         redirect $ AdminUserR cID

src/Handler/Utils.hs

@@ -30,6 +30,7 @@ import Handler.Utils.Memcached  as Handler.Utils hiding (manageMemcachedLocalInv
 import Handler.Utils.Files      as Handler.Utils
 import Handler.Utils.Download   as Handler.Utils
 import Handler.Utils.AuthorshipStatement as Handler.Utils
+--import Handler.Utils.Company    as Handler.Utils
 
 import Handler.Utils.Term as Handler.Utils
 

src/Handler/Utils/Avs.hs

@@ -2,10 +2,12 @@
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
+{-# LANGUAGE TypeApplications #-}
+
+
 module Handler.Utils.Avs
-  ( -- upsertAvsUser
+  ( upsertAvsUser, upsertAvsUserById, upsertAvsUserByCard
-  --, checkLicences
+  , getLicence, getLicenceDB, getLicenceByAvsId
-    getLicence, getLicenceDB
   , setLicence, setLicenceAvs, setLicencesAvs
   , checkLicences
   , lookupAvsUser, lookupAvsUsers
@@ -20,8 +22,17 @@ import Utils.Avs
 
 import qualified Data.Set           as Set
 import qualified Data.Map           as Map
--- import qualified Data.Text          as Text
 
+import qualified Data.CaseInsensitive as CI
+-- import Auth.LDAP (ldapUserPrincipalName)
+import Foundation.Yesod.Auth (upsertCampusUserByCn,CampusUserConversionException())
+
+import Handler.Utils.Company
+import Handler.Users.Add
+
+import           Database.Esqueleto.Experimental ((:&)(..))
+import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
+import qualified Database.Esqueleto.Utils        as E
 
 
 --------------------
@@ -29,8 +40,13 @@ import qualified Data.Map           as Map
 --------------------
 
 data AvsException
-  = AvsInterfaceUnavailable
+  = AvsInterfaceUnavailable                   -- Interface to AVS was not configured at startup or does not respond
-  | AvsUserUnknown UserId
+  | AvsUserUnassociated UserId                -- Manipulating AVS Data for a user that is not linked to AVS yet
+  | AvsUserUnknownByAvs AvsPersonId           -- AvsPersonId not (or no longer) found in AVS DB
+  | AvsUserAmbiguous                          -- Multiple matching existing users found in our DB
+  | AvsPersonSearchEmpty                      -- AvsPersonSearch returned empty result
+  | AvsPersonSearchAmbiguous                  -- AvsPersonSearch returned more than one result
+  | AvsSetLicencesFailed Text                 -- AvsSetLicence total failure
   deriving (Show, Generic, Typeable)
 instance Exception AvsException
 
@@ -56,7 +72,7 @@ instance Exception AvsException
 getLicence :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, WithRunDB SqlReadBackend (HandlerFor UniWorX) m ) => UserId -> m (Maybe AvsLicence)
 getLicence uid = do
   AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery
-  Entity _ UserAvs{..} <- maybeThrowM (AvsUserUnknown uid) $ useRunDB $ getBy $ UniqueUserAvsUser uid
+  Entity _ UserAvs{..} <- maybeThrowM (AvsUserUnassociated uid) $ useRunDB $ getBy $ UniqueUserAvsUser uid
   AvsResponseGetLicences licences <- throwLeftM $ avsQueryGetLicences $ AvsQueryGetLicences $ Set.singleton $ AvsObjPersonId userAvsPersonId
   let ulicence = Set.lookupMax $ Set.filter ((userAvsPersonId ==) . avsLicencePersonID) licences
   return (avsLicenceRampLicence <$> ulicence)
@@ -64,86 +80,289 @@ getLicence uid = do
 getLicenceDB :: UserId -> DB (Maybe AvsLicence)
 getLicenceDB uid = do
   AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ liftHandler $ getsYesod $ view _appAvsQuery
-  Entity _ UserAvs{..} <- maybeThrowM (AvsUserUnknown uid) $ getBy $ UniqueUserAvsUser uid
+  Entity _ UserAvs{..} <- maybeThrowM (AvsUserUnassociated uid) $ getBy $ UniqueUserAvsUser uid
   AvsResponseGetLicences licences <- throwLeftM $ avsQueryGetLicences $ AvsQueryGetLicences $ Set.singleton $ AvsObjPersonId userAvsPersonId
   let ulicence = Set.lookupMax $ Set.filter ((userAvsPersonId ==) . avsLicencePersonID) licences
   return (avsLicenceRampLicence <$> ulicence)
 
+getLicenceByAvsId :: (MonadHandler m, MonadThrow m, MonadReader UniWorX ((->) (HandlerSite m)), HandlerSite m ~ UniWorX) =>
+                      AvsPersonId -> m (Maybe AvsLicence)
+getLicenceByAvsId aid = do
+  AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ liftHandler $ getsYesod $ view _appAvsQuery
+  AvsResponseGetLicences licences <- throwLeftM $ avsQueryGetLicences $ AvsQueryGetLicences $ Set.singleton $ AvsObjPersonId aid
+  let ulicence = Set.lookupMax $ Set.filter ((aid ==) . avsLicencePersonID) licences
+  return (avsLicenceRampLicence <$> ulicence)
 
-setLicence :: UserId -> AvsLicence -> DB ()
+
+-- setLicence :: (MonadHandler m, MonadThrow m, HandlerSite m ~ UniWorX) => UserId -> AvsLicence -> m Bool
+setLicence :: (PersistUniqueRead backend, MonadThrow m,
+                     MonadHandler m, HandlerSite m ~ UniWorX,
+                     BaseBackend backend ~ SqlBackend) =>
+                    UserId -> AvsLicence -> ReaderT backend m Bool
 setLicence uid lic = do
-  Entity _ UserAvs{..} <- maybeThrowM (AvsUserUnknown uid) $ getBy $ UniqueUserAvsUser uid
+  Entity _ UserAvs{..} <- maybeThrowM (AvsUserUnassociated uid) $ getBy $ UniqueUserAvsUser uid
   setLicenceAvs userAvsPersonId lic
 
-setLicenceAvs :: AvsPersonId -> AvsLicence -> DB ()
+setLicenceAvs :: (MonadHandler m, MonadThrow m, HandlerSite m ~ UniWorX) => 
+                  AvsPersonId -> AvsLicence -> m Bool
 setLicenceAvs apid lic = do
-  let req = Set.singleton $ AvsPersonLicence apid lic
+  let req = Set.singleton $ AvsPersonLicence { avsLicenceRampLicence = lic, avsLicencePersonID = apid }
   setLicencesAvs req
 
--- setLicencesAvs :: Set AvsPersonLicence -> DB ()
+--setLicencesAvs :: Set AvsPersonLicence -> Handler Bool
 setLicencesAvs :: (MonadHandler m, MonadThrow m, HandlerSite m ~ UniWorX) =>
-                  Set AvsPersonLicence -> m ()
+                  Set AvsPersonLicence -> m Bool
 setLicencesAvs pls = do
   AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery
-  AvsResponseSetLicences responses <- throwLeftM $ avsQuerySetLicences $ AvsQuerySetLicences pls
+  response <- throwLeftM $ avsQuerySetLicences $ AvsQuerySetLicences pls
-  forM_ responses $ \AvsLicenceResponse{..} ->
+  case response of
-    unless (sloppyBool avsResponseSuccess) $ 
+    AvsResponseSetLicencesError{..} -> do
-      -- TODO: create an Admin Problems overview page
+      let msg = "Set AVS licences failed utterly: " <> avsResponseSetLicencesStatus <> ". Details: " <> cropText avsResponseSetLicencesMessage
-      $logErrorS "AVS" $ "Set licence failed for " <> tshow avsResponsePersonID <> " due to " <> cropText avsResponseMessage
+      $logErrorS "AVS" msg
+      throwM $ AvsSetLicencesFailed avsResponseSetLicencesStatus
 
+    AvsResponseSetLicences msgs -> do
+      let (ok,bad) = Set.partition (sloppyBool . avsResponseSuccess) msgs
+      forM_ bad $ \AvsLicenceResponse { avsResponsePersonID=api, avsResponseMessage=msg} ->
+        $logErrorS "AVS" $ "Set AVS Licence failed for " <> tshow api <> " due to " <> cropText msg
+        -- TODO: Admin Error page
+      return $ length ok == length pls
 
 -- | Retrieve all currently valid driving licences and check against our database
 --   Only react to changes as compared to last seen status in avs.model
---   TODO: turn into a job, once the interface is actually available
+--   TODO: run in a background job, once the interface is actually available
-checkLicences :: Handler ()
+checkLicences :: Handler Bool
-checkLicences = do
+checkLicences = do        
+  AvsQuery{..}  <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery
+  allLicences   <- throwLeftM avsQueryGetAllLicences
+  deltaLicences <- computeDifferingLicences allLicences
+  setResponse   <- setLicencesAvs deltaLicences
+  if setResponse
+    then $logInfoS "AVS" "FRADrive Licences written to AVS successfully."
+    else $logWarnS "AVS" "Writing FRADrive Licences to AVS incomplete."
+  return setResponse
+
+computeDifferingLicences :: AvsResponseGetLicences -> Handler (Set AvsPersonLicence)
+computeDifferingLicences (AvsResponseGetLicences licences) = do
+  now <- liftIO getCurrentTime
+  --let (vorfeld, nonvorfeld) = Set.partition (`avsPersonLicenceIs` AvsLicenceVorfeld)  licences
+  --     rollfeld             = Set.filter    (`avsPersonLicenceIs` AvsLicenceRollfeld) nonvorfeld
+  -- Note: FRADrive users with 'R' also own 'F' qualification, but AvsGetResponseGetLicences yields only either 
+  let nowaday = utctDay now
+      noOne   = AvsPersonId 0
+      vorORrollfeld' = Set.dropWhileAntitone (`avsPersonLicenceIsLEQ` AvsNoLicence)      licences
+      rollfeld'      = Set.dropWhileAntitone (`avsPersonLicenceIsLEQ` AvsLicenceVorfeld) vorORrollfeld'
+      vorORrollfeld  = Set.map avsLicencePersonID vorORrollfeld'
+      rollfeld       = Set.map avsLicencePersonID rollfeld'
+
+      antijoinAvsLicences :: AvsLicence -> Set AvsPersonId -> DB (Set AvsPersonId,Set AvsPersonId)
+      antijoinAvsLicences lic avsLics = fmap unwrapIds $ 
+       E.select $ do
+        ((_qauli :& _qualUser :& usrAvs) :& excl) <-
+          E.from $ (      E.table @Qualification
+            `E.innerJoin` E.table @QualificationUser
+            `E.on` ( \(quali :& qualUser) -> 
+                    (quali E.^. QualificationId         E.==. qualUser E.^. QualificationUserQualification)
+                -- NOTE: filters on the innerJoin must be part of ON-condition in order for anti-join to work!
+              E.&&. (quali E.^. QualificationAvsLicence E.==. E.justVal lic)                  -- correct type of licence
+              E.&&. (E.val nowaday `E.between` (qualUser E.^. QualificationUserFirstHeld           
+                                               ,qualUser E.^. QualificationUserValidUntil))   -- currently valid
+              E.&&. E.isNothing (qualUser E.^. QualificationUserBlockedDue)                   -- no blocked 
+              )
+            `E.innerJoin` E.table @UserAvs
+            `E.on` (\(_ :& qualUser :& usrAvs) -> qualUser E.^. QualificationUserUser E.==. usrAvs E.^. UserAvsUser)
+          ) `E.fullOuterJoin` E.toValues (set2NonEmpty noOne avsLics) -- left-hand side produces all currently valid matching qualifications
+            `E.on` (\((_ :& _ :& usrAvs) :& excl) -> usrAvs E.?. UserAvsPersonId E.==. excl)
+        E.where_ $ E.isNothing excl E.||. E.isNothing (usrAvs E.?. UserAvsPersonId)           -- anti join
+        return (usrAvs E.?. UserAvsPersonId, excl)
+
+      unwrapIds :: [(E.Value (Maybe AvsPersonId), E.Value (Maybe AvsPersonId))] -> (Set AvsPersonId, Set AvsPersonId)        
+      unwrapIds = mapBoth (Set.delete noOne) . foldr aux mempty
+        where
+          aux (_, E.Value(Just api)) (l,r) = (l, Set.insert api r) -- we may assume here that each pair contains precisely one Just constructor
+          aux (E.Value(Just api), _) (l,r) = (Set.insert api l, r)             
+          aux _ acc = acc -- should never occur
+
+  ((vorfGrant, vorfRevoke), (rollGrant, rollRevoke)) <- runDB $ (,)
+    <$> antijoinAvsLicences AvsLicenceVorfeld  vorORrollfeld
+    <*> antijoinAvsLicences AvsLicenceRollfeld rollfeld
+  let setTo0 = vorfRevoke -- ready to use with SET 0 
+      setTo1 = (vorfGrant Set.\\ rollGrant ) `Set.union` (rollRevoke Set.\\ vorfRevoke)
+      setTo2 = (rollGrant Set.\\ vorfRevoke) `Set.intersection` (vorfGrant `Set.union` vorORrollfeld)
+      {-
+        Cases to consider (AVS_Licence,has_valid_F, has_valid_R) -> (vorfeld@(toset,unset), rollfeld@(toset,unset)) : 
+          A (0,0,0)  -> ((_,_),(_,_)) : nop; avs_id not returned from queries, no problem 
+          B (0,0,1)  -> ((_,_),(x,_)) : nop; do nothing     -- CHECK since id is returned by roll-query
+          C (0,1,0)  -> ((x,_),(_,_)) : set F for id 
+          D (0,1,1)  -> ((x,_),(x,_)) : set R for id
+          E (1,0,0)  -> ((_,x),(_,_)) : set 0 for id
+          F (1,0,1)  -> ((_,x),(x,_)) : set 0 for id 
+          G (1,1,0)  -> ((_,_),(_,_)) : nop
+          H (1,1,1)  -> ((_,_),(x,_)) : set R for id
+          I (2,0,0)  -> ((_,x),(_,x)) : set 0 for id
+          J (2,0,1)  -> ((_,x),(_,_)) : set 0 for id 
+          K (2,1,0)  -> ((_,_),(_,x)) : set F for id 
+          L (2,1,1)  -> ((_,_),(_,_)) : nop
+
+          PROBLEM: B & H in conflict! (Note that nop is automatic except for case B)
+          Results:
+              set to 0: determined by vorfeld-unset -- zuerst 
+              set to 1: vorfeld-set && nicht in rollfeld-set || rollfeld-unset && nicht in vorfeld-unset
+              set to 2: rollfeld-set && nicht in vorfeld-unset && (in vorfeld-set || AVS_Licence>0 == vorORrollfeld)              
+      -}
+  return $ Set.map (AvsPersonLicence AvsNoLicence)       setTo0
+        <> Set.map (AvsPersonLicence AvsLicenceVorfeld)  setTo1 
+        <> Set.map (AvsPersonLicence AvsLicenceRollfeld) setTo2
+
+
+upsertAvsUser :: Text -> Handler (Maybe UserId)
+upsertAvsUser (discernAvsCardPersonalNo -> Just someid) = upsertAvsUserByCard someid    -- Note: Right case is a number, it could be AvsCardNumber or AvsInternalPersonalNumber; we cannot know, but the latter is much more likely and useful to users!
+upsertAvsUser _other = return Nothing -- TODO: attempt LDAP lookup to find by eMail; merely for convenience, not necessary right now
+  {- maybe this code helps?
+  upsRes :: Either CampusUserConversionException (Entity User)
+    <- try $ upsertCampusUserByOther persNo
+  case upsRes of
+    Right Entity{entityKey=uid} -> insertUniqueEntity $ UserAvs api uid
+    _other -> return mbuid -- ==Nothing -- user could not be created somehow
+  -}
+
+
+-- | Given CardNo or internal Number, retrieve UserId. Create non-existing users, if possible.
+--   Throws errors if the avsInterface in unavailable or the user is non-unique within external AVS DB.
+upsertAvsUserByCard :: Either AvsFullCardNo AvsInternalPersonalNo -> Handler (Maybe UserId) -- Idee: Eingabe ohne Punkt is AvsInternalPersonalNo mit Punkt is Ausweisnummer?!
+upsertAvsUserByCard persNo = do
+  let qry = case persNo of
+              Left AvsFullCardNo{..} -> def{ avsPersonQueryCardNo = Just avsFullCardNo, avsPersonQueryVersionNo = Just avsFullCardVersion }
+              Right fpn -> def{ avsPersonQueryInternalPersonalNo = Just fpn }
   AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery
-  AvsResponseGetLicences _licences <- throwLeftM avsQueryGetAllLicences
+  AvsResponsePerson adps <- throwLeftM $ avsQueryPerson qry
-  --TODO this must be chunked into separate jobs/tasks
+  case Set.elems adps of
-  --forM licences $ \AvsPersonLicence{..} -> do
+    []      -> throwM AvsPersonSearchEmpty
-  error "CONTINUE HERE" -- TODO STUB
+    (_:_:_) -> throwM AvsPersonSearchAmbiguous
+    [AvsDataPerson{avsPersonPersonID=appi}] -> do
+      mbuid <- runDB $ getBy $ UniqueUserAvsId appi
+      case mbuid of
+        (Just (Entity _ UserAvs{userAvsUser=uau})) -> return $ Just uau
+        Nothing -> upsertAvsUserById appi
 
 
-{-
-upsertAvsUser :: AvsStatusPerson ->
 
-or
+-- | Retrieve and _always_ update user by AvsPersonId. Non-existing users are created. Ignore AVS Licence status! Updates Company, Address, PinPassword
-
+--   Throws errors if the avsInterface in unavailable or the user is non-unique within external AVS DB (should never happen).
--}
+upsertAvsUserById :: AvsPersonId -> Handler (Maybe UserId)
-
+upsertAvsUserById api = do
-{-
-upsertAvsUser :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) => 
-                AvsPersonId -> m ()
-upsertAvsUser api = do
-  mbuid <- getBy $ UniqueUserAvsId api 
   mbapd <- lookupAvsUser api
+  mbuid <- runDB $ do
+    mbuid <- getBy (UniqueUserAvsId api)
+    case (mbuid, mbapd) of
+      (Nothing, Just AvsDataPerson{..})                         -- FRADriver User does not exist yet, but found in AVS and has Internal Personal Number
+        | Just persNo <- avsPersonInternalPersonalNo -> do
+            candidates <- selectKeysList [UserCompanyPersonalNumber ==. avsPersonInternalPersonalNo] []
+            case candidates of
+              [uid] -> insertUniqueEntity $ UserAvs api uid
+              (_:_) -> throwM AvsUserAmbiguous
+              [] -> do
+                upsRes :: Either CampusUserConversionException (Entity User)
+                  <- try $ upsertCampusUserByCn persNo
+                case upsRes of
+                  Right Entity{entityKey=uid} -> insertUniqueEntity $ UserAvs api uid -- pin/addr are updated in next step anyway
+                  _other -> return mbuid -- ==Nothing -- user could not be created somehow
+      _other -> return mbuid
   case (mbuid, mbapd) of
-    ( _     , Nothing)    -> error "TODO" -- CONTINUE HERE   -- this should no happen
+    ( _     , Nothing               ) -> throwM $ AvsUserUnknownByAvs api -- User not found in AVS at all, i.e. no valid card exists yet
-    (Nothing, Just apd)   -> do   -- unknown user
+    (Nothing, Just AvsDataPerson{..}) -> do                               -- No LDAP User, but found in AVS; create new user
-      error "TODO" -- CONTINUE HERE
+      let firmAddress = guessLicenceAddress avsPersonPersonCards
-    (Just uid, Just apd)  -> do   -- known user 
+          mbCompany   = firmAddress ^? _Just . _1 . _Just
-      error "TODO" -- CONTINUE HERE
+          userFirmAddr= plaintextToStoredMarkup . mergeCompanyAddress <$> firmAddress
--}
+          addrCard    = firmAddress ^? _Just . _3 
+          pinCard     = Set.lookupMax avsPersonPersonCards
+          userPin     = tshowAvsFullCardNo . getFullCardNo <$> pinCard          
+          fakeIdent   = CI.mk $ "AVSID:" <> tshow api
+          newUsr = AdminUserForm
+            { aufTitle     = Nothing
+            , aufFirstName = avsPersonFirstName
+            , aufSurname   = avsPersonLastName
+            , aufDisplayName = avsPersonFirstName <> " " <> avsPersonLastName
+            , aufDisplayEmail = "" -- Email is unknown in this version of the avs query, to be updated later (FUTURE TODO)
+            , aufMatriculation = Nothing
+            , aufSex = Nothing
+            , aufMobile = Nothing
+            , aufTelephone = Nothing
+            , aufFPersonalNumber = avsPersonInternalPersonalNo
+            , aufFDepartment = Nothing
+            , aufPostAddress = userFirmAddr
+            , aufPrefersPostal = isJust firmAddress
+            , aufPinPassword = userPin
+            , aufEmail = fakeIdent -- Email is unknown in this version of the avs query, to be updated later (FUTURE TODO)
+            , aufIdent = fakeIdent -- use AvsPersonId instead
+            , aufAuth  = maybe AuthKindNoLogin (const AuthKindLDAP) avsPersonInternalPersonalNo -- FUTURE TODO: if email is known, use AuthKinfPWHash for email invite, if no internal personal number is known
+            }
+      mbUid <- addNewUser newUsr -- triggers JobSynchroniseLdapUser, JobSendPasswordReset and NotificationUserAutoModeUpdate -- TODO: check if these are failsafe      
+      whenIsJust mbUid $ \uid -> runDB $ do 
+        now <- liftIO getCurrentTime
+        insert_ $ UserAvs avsPersonPersonID uid
+        -- forM_ avsPersonPersonCards $ -- save all cards for later
+        let cs :: Set AvsDataPersonCard = Set.fromList $ catMaybes [pinCard, addrCard]
+        forM_ cs $  -- only save used cards for the postal address update detection
+            \avsCard -> insert_ $ UserAvsCard avsPersonPersonID (avsDataCardNo avsCard) avsCard now 
+        upsertUserCompany uid mbCompany                    
+      return mbUid
+    
+    (Just (Entity _ UserAvs{userAvsUser=uid}), Just AvsDataPerson{avsPersonPersonCards}) -> do -- known user, update address and pinPassword
+      let firmAddress = guessLicenceAddress avsPersonPersonCards
+          mbCompany   = firmAddress ^? _Just . _1 . _Just
+          userFirmAddr= plaintextToStoredMarkup . mergeCompanyAddress <$> firmAddress
+          addrCard    = firmAddress ^? _Just . _3 
+          pinCard     = Set.lookupMax avsPersonPersonCards
+          userPin     = tshowAvsFullCardNo . getFullCardNo <$> pinCard          
+      runDB $ do 
+        now <- liftIO getCurrentTime        
+        upsertUserCompany uid mbCompany
+        whenIsJust addrCard $ \aCard ->
+          getBy (UniqueAvsCard $ avsDataCardNo aCard) >>= \case
+            (Just (Entity uac UserAvsCard{..})) | aCard == userAvsCardCard -> -- address seen before, no change
+              update uac [UserAvsCardLastSynch =. now]
+            _ -> do -- possibly new address data 
+              void $ upsert UserAvsCard
+                      { userAvsCardPersonId = api
+                      , userAvsCardCardNo   = avsDataCardNo aCard
+                      , userAvsCardCard     = aCard
+                      , userAvsCardLastSynch= now
+                      }
+                      [ UserAvsCardCard      =. aCard
+                      , UserAvsCardLastSynch =. now
+                      ]            
+              when (isJust userFirmAddr) $ updateWhere [UserId ==. uid] [UserPostAddress =. userFirmAddr]
+        whenIsJust pinCard $ \pCard -> 
+          unlessM (exists [UserAvsCardCardNo ==. avsDataCardNo pCard]) $ do 
+            -- update pin, but only if it was unset or set to the value of an old card
+            oldCards <- selectList [UserAvsCardPersonId ==. api] []
+            let oldPins = Just . tshowAvsFullCardNo . getFullCardNo . userAvsCardCard . entityVal <$> oldCards
+            updateWhere [UserId ==. uid, UserPinPassword !=. userPin, UserPinPassword <-. Nothing:oldPins]
+                        [UserPinPassword =. userPin]
+            insert_ $ UserAvsCard api (avsDataCardNo pCard) pCard now
+      return $ Just uid
 
 
-lookupAvsUser :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) => 
+lookupAvsUser :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) =>
                   AvsPersonId -> m (Maybe AvsDataPerson)
 lookupAvsUser api = Map.lookup api <$> lookupAvsUsers (Set.singleton api)
 
 -- | retrieves complete avs user records for given AvsPersonIds.
---   Note that this requires several AVS-API queries, since 
+--   Note that this requires several AVS-API queries, since
 --    - avsQueryPerson does not support querying an AvsPersonId directly
 --    - avsQueryStatus only provides limited information
 --   avsQuery is used to obtain all card numbers, which are then queried separately an merged
 --   May throw Servant.ClientError or AvsExceptions
-lookupAvsUsers :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) => 
+--   Does not write to our own DB!
+lookupAvsUsers :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) =>
                    Set AvsPersonId -> m (Map AvsPersonId AvsDataPerson)
-lookupAvsUsers apis = do 
+lookupAvsUsers apis = do
   AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery
   AvsResponseStatus statuses <- throwLeftM . avsQueryStatus $ AvsQueryStatus apis
   let forFoldlM = $(permuteFun [3,2,1]) foldlM
-  forFoldlM statuses mempty $ \acc1 AvsStatusPerson{avsStatusPersonCardStatus=cards} -> 
+  forFoldlM statuses mempty $ \acc1 AvsStatusPerson{avsStatusPersonCardStatus=cards} ->
-    forFoldlM cards acc1 $ \acc2 AvsDataPersonCard{avsDataCardNo} -> do
+    forFoldlM cards acc1 $ \acc2 AvsDataPersonCard{avsDataCardNo, avsDataVersionNo} -> do
-      AvsResponsePerson adps <- throwLeftM . avsQueryPerson $ def{avsPersonQueryCardNo = Just avsDataCardNo}
+      AvsResponsePerson adps <- throwLeftM . avsQueryPerson $ def{avsPersonQueryCardNo = Just avsDataCardNo, avsPersonQueryVersionNo = Just avsDataVersionNo}
       return $ mergeByPersonId adps acc2
-    
+

src/Handler/Utils/Company.hs

@@ -0,0 +1,52 @@
+-- SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
+--
+-- SPDX-License-Identifier: AGPL-3.0-or-later
+
+module Handler.Utils.Company where
+
+import Import
+-- import Utils.PathPiece
+
+-- import Data.CaseInsensitive (CI)
+import qualified Data.CaseInsensitive as CI
+import qualified Data.Char as Char
+import qualified Data.Text as Text
+
+
+-- | Ensure that the given user is linked to the given company
+upsertUserCompany :: UserId -> Maybe Text -> DB ()
+upsertUserCompany uid (Just cName) | notNull cName = do 
+  cid <- upsertCompany cName
+  void $ upsertBy (UniqueUserCompany uid) 
+                  (UserCompany uid cid False) 
+                  [UserCompanyCompany =. cid, UserCompanySupervisor =. False]  
+upsertUserCompany uid _ = deleteBy (UniqueUserCompany uid) 
+
+upsertCompany :: Text -> DB CompanyId
+upsertCompany cName = 
+  let cName' = CI.mk cName in
+  getBy (UniqueCompanyName cName') >>= \case 
+    Just ent -> return $ entityKey ent
+    Nothing  -> getBy (UniqueCompanySynonym cName') >>= \case
+      Just ent -> return . CompanyKey . companySynonymCanonical $ entityVal ent
+      Nothing  -> do
+        let cShort  = companyShorthandFromName cName            
+        cShort' <- findShort cName' $ CI.mk cShort
+        let compy  = Company cName' cShort'
+        either entityKey id <$> insertBy compy
+  where 
+    findShort :: CompanyName -> CompanyShorthand -> DB CompanyShorthand    
+    findShort fna fsh = aux 0
+      where 
+        aux n = let fsh' = if n==0 then fsh else fsh <> CI.mk (tshow n) in
+                checkUnique (Company fna fsh') >>= \case
+                  Nothing -> return fsh'
+                  _other  -> aux (n+1)
+
+-- | Just a cheap heuristic, needs manual intervention anyway
+companyShorthandFromName :: Text -> Text
+companyShorthandFromName cName = 
+  let cpats = splitCamel cName
+      strip = Text.filter Char.isAlphaNum . Text.take 3
+      spats = strip <$> cpats
+  in Text.concat spats

src/Handler/Utils/DateTime.hs

@@ -13,8 +13,9 @@ module Handler.Utils.DateTime
   , formatTime'
   , formatTime, formatTimeUser, formatTimeW, formatTimeMail
   , formatTimeRange, formatTimeRangeW, formatTimeRangeMail
-  , getTimeLocale, getDateTimeFormat
+  , getTimeLocale
-  , getDateTimeFormatter
+  , getDateTimeFormat   , getDateTimeFormatUser   , getDateTimeFormatUser'
+  , getDateTimeFormatter, getDateTimeFormatterUser, getDateTimeFormatterUser'
   , validDateTimeFormats, dateTimeFormatOptions
   , addLocalDays
   , addDiffDaysClip, addDiffDaysRollOver
@@ -127,12 +128,30 @@ getDateTimeFormatUser sel mUser = do
           SelFormatTime     -> userDefaultTimeFormat
   return fmt
 
+getDateTimeFormatUser' :: SelDateTimeFormat -> User -> DateTimeFormat
+getDateTimeFormatUser' SelFormatDateTime usr = usr & userDateTimeFormat
+getDateTimeFormatUser' SelFormatDate     usr = usr & userDateFormat 
+getDateTimeFormatUser' SelFormatTime     usr = usr & userTimeFormat   
+
 getDateTimeFormatter :: (MonadHandler m, HandlerSite m ~ UniWorX, YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId) => m DateTimeFormatter
 getDateTimeFormatter = do
   locale <- getTimeLocale
   formatMap <- traverse getDateTimeFormat id
   return $ mkDateTimeFormatter locale formatMap appTZ
 
+getDateTimeFormatterUser :: (MonadHandler m, HandlerSite m ~ UniWorX) => Maybe (Entity User) -> m DateTimeFormatter
+getDateTimeFormatterUser mUser = do
+  locale <- getTimeLocale
+  formatMap <- traverse (`getDateTimeFormatUser` mUser) id
+  return $ mkDateTimeFormatter locale formatMap appTZ
+
+getDateTimeFormatterUser' :: (MonadHandler m) => User -> m DateTimeFormatter
+getDateTimeFormatterUser' usr = do 
+  locale <- getTimeLocale
+  let formatMap = flip getDateTimeFormatUser' usr
+  return $ mkDateTimeFormatter locale formatMap appTZ
+
+
 validDateTimeFormats :: TimeLocale -> SelDateTimeFormat -> Set DateTimeFormat
 -- ^ We use a whitelist instead of just letting the user specify their own format string since vulnerabilities in printf-like functions are not uncommon
 validDateTimeFormats tl SelFormatDateTime = Set.fromList $

src/Handler/Utils/I18n.hs

@@ -28,7 +28,9 @@ import qualified Data.Map as Map
 import System.Directory (listDirectory)
 import Text.Hamlet (hamletFile)
 
-
+-- | Produces: let ws = \case "de" -> <includeFile> <de-file-name>; ...
+--             in selectLanguage availableTranslations >>= ws l 
+--   D.h. Ergebnis hat Typ: MonadHandler m => m _
 i18nFile :: (FilePath -> Q Exp) -> FilePath -> Q Exp
 i18nFile includeFile basename = do
   -- Construct list of available translations (@de@, @en@, ...) at compile time
@@ -62,7 +64,25 @@ i18nWidgetFile :: FilePath -> Q Exp
 i18nWidgetFile = i18nFile widgetFile
 
 i18nHamletFile :: FilePath -> Q Exp
-i18nHamletFile basename = [e|$(i18nFile (hamletFile . ("templates" </>) . (<.> "hamlet")) basename) <$> getUrlRenderParams|]
+i18nHamletFile basename = [e|$(i18nFile' (hamletFile . ("templates" </>) . (<.> "hamlet")) basename) <$> getUrlRenderParams|]
+
+i18nFile' :: (FilePath -> Q Exp) -> FilePath -> Q Exp
+i18nFile' includeFile basename = do
+  -- Construct list of available translations (@de@, @en@, ...) at compile time
+  let i18nDirectory = "templates" </> "i18n" </> basename
+  availableFiles <- qRunIO $ listDirectory i18nDirectory
+  let availableTranslations = sortWith (NTop . flip List.elemIndex (NonEmpty.toList appLanguages)) . nubOrd $ pack . takeBaseName <$> availableFiles
+  availableTranslations' <- maybe (fail $ "‘" <> i18nDirectory <> "’ is empty") return $ NonEmpty.nonEmpty availableTranslations
+
+  -- Dispatch to correct language (depending on user settings via `selectLanguage`) at run time
+  ws <- newName "ws" -- Name for dispatch function
+  letE
+    [ funD ws $ [ clause [litP $ stringL l] (normalB . includeFile $ "i18n" </> basename </> l) []
+                | l <- unpack <$> NonEmpty.toList availableTranslations' -- One function definition for every available language
+                ] ++ [ clause [wildP] (normalB [e| error "selectLanguage returned an invalid translation" |]) [] ] -- Fallback mostly there so compiler does not complain about non-exhaustive pattern match
+    ] [e|selectLanguage availableTranslations' >>= withUrlRenderer . $(varE ws)|]
+
+
 
 i18nWidgetFiles :: FilePath -> Q Exp
 i18nWidgetFiles basename = do

src/Handler/Utils/LdapSystemFunctions.hs

@@ -18,4 +18,3 @@ determineSystemFunctions ldapFuncs = \case
     -- SJ: not sure this LDAP-specific key belongs here?
   SystemStudent -> False -- "student" `Set.member` ldapFuncs -- no such key identified at FraPort
   SystemPrinter -> False -- "department=IFM-IS2" zu viele Mitglieder
-  SystemSap     -> False

src/Handler/Utils/Mail.hs

@@ -5,16 +5,17 @@
 module Handler.Utils.Mail
   ( addRecipientsDB
   , userAddress, userAddressFrom
-  , userMailT
+  , userMailT, userMailTdirect
   , addFileDB
   , addHtmlMarkdownAlternatives
   , addHtmlMarkdownAlternatives'
-  , addHtmlMarkdownAlternatives''
   ) where
 
 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 qualified Data.CaseInsensitive as CI
 
@@ -22,7 +23,7 @@ import qualified Data.Conduit.Combinators as C
 
 import qualified Text.Pandoc as P
 
-import qualified Text.Hamlet as Hamlet (Translate)
+import qualified Text.Hamlet as Hamlet
 import qualified Text.Shakespeare as Shakespeare (RenderUrl)
 
 
@@ -48,12 +49,73 @@ userAddress :: User -> Address
 -- Uses `userEmail`
 userAddress User{userEmail, userDisplayName} = Address (Just userDisplayName) $ CI.original userEmail
 
+
+-- |Send an email to the given UserId or to all registered Supervisor with rerouteNotifications == True
 userMailT :: ( MonadHandler m
              , HandlerSite m ~ UniWorX
              , MonadThrow m
              , MonadUnliftIO m
-             ) => UserId -> MailT m a -> m a
+             ) => UserId -> MailT m () -> m ()
 userMailT uid mAct = do
+  (underling, receivers, undercopy) <- liftHandler . runDB $ getReceivers uid
+  let undername = underling ^. _userDisplayName -- nameHtml' underling
+      undermail = CI.original $ underling ^. _userEmail
+      infoSupervised :: Hamlet.HtmlUrlI18n UniWorXSendMessage (Route UniWorX) = [ihamlet|
+            <h2>_{MsgMailSupervisedNote}
+            <p>
+              _{MsgMailSupervisedBody}
+              <ul>
+                $forall svr <- receivers
+                  <li>
+                    #{nameHtml' svr}
+          |]
+  forM_ receivers $ \Entity
+      { entityKey = svr
+      , entityVal = supervisor@User{ userLanguages
+                                 , userDateTimeFormat
+                                 , userDateFormat
+                                 , userTimeFormat
+                                 , userCsvOptions
+                                 } 
+      } -> do
+    let ctx = MailContext
+                { mcLanguages = fromMaybe def userLanguages
+                , mcDateTimeFormat = \case
+                    SelFormatDateTime -> userDateTimeFormat
+                    SelFormatDate     -> userDateFormat
+                    SelFormatTime     -> userTimeFormat
+                , mcCsvOptions = userCsvOptions
+                }
+        supername = supervisor ^. _userDisplayName -- nameHtml' supervisor
+        infoSupervisor :: Hamlet.HtmlUrlI18n UniWorXSendMessage (Route UniWorX) = [ihamlet|
+            <h2>_{MsgMailSupervisorNote}
+            <p>
+              _{MsgMailSupervisorBody undername supername} #
+              <a href=@{NewsR}>
+                FRADrive
+              .
+              $if undercopy
+                _{MsgMailSupervisorCopy undermail}
+              $else
+                _{MsgMailSupervisorNoCopy}
+          |]
+    mailT ctx $ do
+      _mailTo .= pure (userAddress supervisor)
+      mAct
+      if uid==svr
+        then when (2 <= length receivers) $ addHtmlMarkdownAlternatives' "InfoSupervised" infoSupervised -- notify about supervisors
+        else do
+          mapSubject ("[SUPERVISOR]" <>)
+          addHtmlMarkdownAlternatives' "InfoSupervisor" infoSupervisor -- adding explanation why the supervisor received this email
+
+
+-- | like userMailT, but always sends a single mail to the given UserId, ignoring supervisors
+userMailTdirect :: ( MonadHandler m
+             , HandlerSite m ~ UniWorX
+             , MonadThrow m
+             , MonadUnliftIO m
+             ) => UserId -> MailT m a -> m a
+userMailTdirect uid mAct = do
   user@User
     { userLanguages
     , userDateTimeFormat
@@ -74,6 +136,7 @@ userMailT uid mAct = do
     _mailTo .= pure (userAddress user)
     mAct
 
+
 addFileDB :: ( MonadMail m
              , HandlerSite m ~ UniWorX
              ) => FileReference -> m (Maybe MailObjectId)
@@ -109,7 +172,7 @@ instance ToMailHtml site a => ToMailHtml site (Shakespeare.RenderUrl (Route site
     ur <- getUrlRenderParams
     toMailHtml $ act ur
 
-
+-- | Adds another Text part as Html AND Markdown (receiver's choice) to an email. Subsequently added parts create attachments named "Att#####.html" and "Att#####.txt"
 addHtmlMarkdownAlternatives :: ( MonadMail m
                                , ToMailPart (HandlerSite m) Html
                                , ToMailHtml (HandlerSite m) a
@@ -127,36 +190,18 @@ addHtmlMarkdownAlternatives html' = do
       { P.writerReferenceLinks = True
       }
 
--- | provide a name for the part 
+-- | Like @addHtmlMarkdownAlternatives, but adds subseqeunt parts with "content-disposition: inline" and the provided filename, if inline display is not permitted (receiver's choice)
 addHtmlMarkdownAlternatives' :: ( MonadMail m
                                 , ToMailPart (HandlerSite m) (NamedMailPart Html)
                                 , ToMailHtml (HandlerSite m) a
                                 ) => Text -> a -> m ()
-addHtmlMarkdownAlternatives' fn html' = do  
+addHtmlMarkdownAlternatives' fn html' = do
   html <- toMailHtml html'
   markdown <- runMaybeT $ renderMarkdownWith htmlReaderOptions writerOptions html
 
   addAlternatives $ do
-    providePreferredAlternative $ NamedMailPart { namedPart = html, disposition = AttachmentDisposition fn } 
+    providePreferredAlternative $ NamedMailPart { disposition = InlineDisposition $ fn <> ".html", namedPart = html }
-    whenIsJust markdown $ provideAlternative . NamedMailPart (AttachmentDisposition (fn <> ".txt"))
+    whenIsJust markdown $ provideAlternative . NamedMailPart (InlineDisposition (fn <> ".txt"))
-  where
-    writerOptions = markdownWriterOptions
-      { P.writerReferenceLinks = True
-      }
-
-
--- | provide a name for the part 
-addHtmlMarkdownAlternatives'' :: ( MonadMail m
-                                , ToMailPart (HandlerSite m) (NamedMailPart Html)
-                                , ToMailHtml (HandlerSite m) a
-                                ) => Text -> a -> m ()
-addHtmlMarkdownAlternatives'' fn html' = do  
-  html <- toMailHtml html'
-  markdown <- runMaybeT $ renderMarkdownWith htmlReaderOptions writerOptions html
-
-  addAlternatives $ do
-    providePreferredAlternative $ NamedMailPart { disposition = InlineDisposition fn, namedPart = html } 
-    whenIsJust markdown $ provideAlternative . NamedMailPart (AttachmentDisposition (fn <> ".txt"))
   where
     writerOptions = markdownWriterOptions
       { P.writerReferenceLinks = True

src/Handler/Utils/Table/Cells.hs

@@ -272,10 +272,14 @@ courseCell Course{..} = anchorCell link name `mappend` desc
               |]
 
 qualificationCell :: IsDBTable m a => Qualification -> DBCell m a
-qualificationCell Qualification{..} = anchorCell link name <> desc
+qualificationCell Qualification{..} = anchorCell link name
   where
     link = QualificationR qualificationSchool qualificationShorthand
     name = citext2widget qualificationName
+
+qualificationDescrCell :: IsDBTable m a => Qualification -> DBCell m a
+qualificationDescrCell q@Qualification{..} = qualificationCell q <> desc
+  where
     desc = case qualificationDescription of
             Nothing      -> mempty
             (Just descr) -> spacerCell <> markupCellLargeModal descr

src/Handler/Utils/Table/Pagination.hs

@@ -48,7 +48,7 @@ module Handler.Utils.Table.Pagination
   , linkEitherCell, linkEitherCellM, linkEitherCellM'
   , maybeAnchorCellM, maybeAnchorCellM', maybeLinkEitherCellM'
   , anchorCellC, anchorCellCM, anchorCellCM', linkEitherCellCM', maybeLinkEitherCellCM'
-  , cellTooltip
+  , cellTooltip, cellTooltipIcon
   , listCell, listCell', listCellOf, listCellOf'
   , ilistCell, ilistCell', ilistCellOf, ilistCellOf'
   , formCell, DBFormResult(..), getDBFormResult
@@ -1691,10 +1691,13 @@ i18nCell msg = cell $ do
   toWidget $ mr msg
 
 cellTooltip :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a -> DBCell m a
-cellTooltip msg = cellContents.mapped %~ (<> tipWdgt)
+cellTooltip = cellTooltipIcon Nothing
+
+cellTooltipIcon :: (RenderMessage UniWorX msg, IsDBTable m a) => Maybe Icon -> msg -> DBCell m a -> DBCell m a
+cellTooltipIcon icn msg = cellContents.mapped %~ (<> tipWdgt)
   where
-    tipWdgt = iconTooltip (msg2widget msg) Nothing True
+    tipWdgt = iconTooltip (msg2widget msg) icn True
-      
+
 -- | Always display widget; maybe a link if user is Authorized.
 --   Also see variant `linkEmptyCell`
 anchorCell :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a) => url -> wgt -> DBCell m a

src/Handler/Utils/Users.hs

@@ -13,7 +13,9 @@ module Handler.Utils.Users
   , UserAssimilateException(..), UserAssimilateExceptionReason(..)
   , assimilateUser
   , userPrefersEmail, userPrefersLetter
+  , getPostalAddress, getPostalPreferenceAndAddress
   , abbrvName
+  , getReceivers
   ) where
 
 import Import
@@ -58,17 +60,49 @@ abbrvName User{userDisplayName, userFirstName, userSurname} =
     assemble = Text.intercalate "."
 
 
+-- deprecated, used getPostalAddressIfPreferred
 userPrefersLetter :: User -> Bool
-userPrefersLetter User{..} 
+userPrefersLetter = fst . getPostalPreferenceAndAddress
-  = isJust userPostAddress &&
-    ( userPrefersPostal || 
-      isNothing userPinPassword ||
-      Text.null (CI.original userEmail)
-    )
 
+-- deprecated, used getPostalAddressIfPreferred
 userPrefersEmail :: User -> Bool
 userPrefersEmail = not . userPrefersLetter
 
+-- | result (True, Nothing) indicates that neither userEmail nor userPostAddress is known
+getPostalPreferenceAndAddress :: User -> (Bool, Maybe [Text])
+getPostalPreferenceAndAddress usr@User{..} =
+    (((userPrefersPostal || isNothing userPinPassword) && postPossible) || emailImpossible, pa)
+  where 
+    orgEmail        = CI.original userEmail
+    emailImpossible = not ('@' `textElem` orgEmail  &&  '.' `textElem` orgEmail)
+    postPossible    = isJust pa
+    pa = getPostalAddress usr    
+
+getPostalAddress :: User -> Maybe [Text]
+getPostalAddress User{..}
+  | Just pa <- userPostAddress
+    = Just $ userDisplayName : html2textlines pa
+  | Just abt <- userCompanyDepartment
+    = Just $ if | "BVD" `isPrefixOf` abt -> [userDisplayName, abt, "Bodenverkehrsdienste"]
+                | otherwise              -> [userDisplayName, abt, "Hausbriefkasten"     ]
+  | otherwise 
+    = Nothing
+
+-- | Return Entity User and all Supervisors with rerouteNotifications as well as 
+--   a boolean indicating if the user is own supervisor with rerouteNotifications
+getReceivers :: UserId -> DB (Entity User, [Entity User], Bool)
+getReceivers uid = do
+  underling <- getJustEntity uid
+  superVs <- selectList [UserSupervisorUser ==. uid, UserSupervisorRerouteNotifications ==. True] []
+  let superIds = userSupervisorSupervisor . entityVal <$> superVs
+  if null superIds 
+    then return (underling, [underling], True)
+    else do 
+      supers <- selectList [UserId <-. superIds] []
+      if null supers then return (underling, [underling], True)
+      else 
+        return (underling, supers, uid `elem` (entityKey <$> supers))
+
 
 computeUserAuthenticationDigest :: AuthenticationMode -> Digest SHA3_256
 computeUserAuthenticationDigest = hashlazy . JSON.encode
@@ -239,6 +273,7 @@ data UserAssimilateExceptionReason
   | UserAssimilatePersonalisedSheetFileDifferentContent (Entity PersonalisedSheetFile) (Entity PersonalisedSheetFile)
   | UserAssimilateTutorialParticipantCollidingRegGroups (Entity TutorialParticipant) (Entity TutorialParticipant)
   | UserAssimilateCouldNotDetermineUserIdents
+  | UserAssimilateConflictingLmsQualifications (Set.Set QualificationId)
   deriving (Eq, Ord, Show, Generic, Typeable)
 
 assimilateUser :: UserId -- ^ @newUserId@
@@ -247,7 +282,7 @@ assimilateUser :: UserId -- ^ @newUserId@
 -- ^ Move all relevant properties (submissions, corrections, grades, ...) from @oldUserId@ to @newUserId@
 --
 -- Fatal errors are thrown, non-fatal warnings are returned
-assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
+assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do  
   E.insertSelectWithConflict
     UniqueCourseFavourite 
     (E.from $ \courseFavourite -> do
@@ -783,7 +818,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
           E.<&> E.val newUserId
           E.<&> (systemMessageHidden E.^. SystemMessageHiddenTime)
     )
-    (\current excluded -> [ SystemMessageHiddenTime E.=. E.max (current E.^. SystemMessageHiddenTime) (excluded E.^. SystemMessageHiddenTime) ])
+    (\current excluded -> [ SystemMessageHiddenTime E.=. combineWith current excluded E.max SystemMessageHiddenTime])
   deleteWhere [ SystemMessageHiddenUser ==. oldUserId ]
 
   let getStudyFeatures = selectSource [ StudyFeaturesUser ==. oldUserId ] []
@@ -812,6 +847,80 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
             delete oldSFId
    in runConduit $ getStudyFeatures .| C.mapM_ upsertStudyFeatures
 
+  -- Qualifications and ongoing LMS   
+  -- LmsUser: insertSelectWithConflict impossible due to 2 simultaneous uniqueness constraints; UniqueLmsIdent requires proper update, prohibits insert and then delete
+  -- updateWhere [ LmsUserUser ==. oldUserId ] [ LmsUserUser =. newUserId ] -- might fail due to UniqueLmsQualficationUuser    
+  oldLms <- selectList [ LmsUserUser ==. oldUserId ] [ Asc LmsUserQualification ]
+  newLms <- selectList [ LmsUserUser ==. newUserId ] [ Asc LmsUserQualification ]
+  let projQ = lmsUserQualification . entityVal
+      oldQs = Set.fromList (projQ <$> oldLms)
+      newQs = Set.fromList (projQ <$> newLms)
+      qConflicts  = oldQs `Set.intersection` newQs
+      qResolvable = Set.fromList [ lmsUserQualification | Entity _ LmsUser{..} <- oldLms, isJust lmsUserEnded, lmsUserQualification `Set.member` qConflicts ] 
+      qProblems   = qConflicts `Set.difference` qResolvable 
+  unless (Set.null qProblems)   $ tellError $ UserAssimilateConflictingLmsQualifications qProblems
+  unless (Set.null qResolvable) $ deleteWhere [ LmsUserUser ==. oldUserId, LmsUserQualification <-. Set.toList qResolvable ] -- delete conflicting and finished LMS, which are still within auditDuration  
+  updateWhere [ LmsUserUser ==. oldUserId ] [ LmsUserUser =. newUserId ]
+  updateWhere [ QualificationEditUser ==. oldUserId ] [ QualificationEditUser =. newUserId ]
+  E.insertSelectWithConflict
+    UniqueQualificationUser
+    (E.from $ \qualificationUser -> do
+        E.where_ $ qualificationUser E.^. QualificationUserUser E.==. E.val oldUserId
+        return $ QualificationUser
+          E.<#  E.val newUserId
+          E.<&> (qualificationUser E.^. QualificationUserQualification)
+          E.<&> (qualificationUser E.^. QualificationUserValidUntil)
+          E.<&> (qualificationUser E.^. QualificationUserLastRefresh)
+          E.<&> (qualificationUser E.^. QualificationUserFirstHeld)
+          E.<&> (qualificationUser E.^. QualificationUserBlockedDue)
+    )
+    (\current excluded ->       
+      [ QualificationUserValidUntil  E.=. combineWith current excluded E.greatest QualificationUserValidUntil
+      , QualificationUserLastRefresh E.=. combineWith current excluded E.greatest QualificationUserLastRefresh
+      , QualificationUserFirstHeld   E.=. combineWith current excluded E.least    QualificationUserFirstHeld
+      , QualificationUserBlockedDue  E.=. combineWith current excluded E.greatest QualificationUserBlockedDue  -- Tested: PostgreSQL GREATEST/LEAST ignores NULL values
+      ] 
+    )
+  deleteWhere [ QualificationUserUser ==. oldUserId ]
+
+  -- Supervision is fully merged
+  E.insertSelectWithConflict
+    UniqueUserSupervisor
+    (E.from $ \userSupervisor -> do 
+      E.where_ $ userSupervisor E.^. UserSupervisorSupervisor E.==. E.val oldUserId
+      return $ UserSupervisor
+        E.<#  E.val newUserId
+        E.<&> (userSupervisor E.^. UserSupervisorUser)
+        E.<&> (userSupervisor E.^. UserSupervisorRerouteNotifications)
+    )
+    (\current excluded -> [ UserSupervisorRerouteNotifications E.=. (current E.^. UserSupervisorRerouteNotifications E.||. excluded E.^. UserSupervisorRerouteNotifications)  ] )
+  deleteWhere [ UserSupervisorSupervisor ==. oldUserId]    
+
+  E.insertSelectWithConflict
+    UniqueUserSupervisor
+    (E.from $ \userSupervisor -> do 
+      E.where_ $ userSupervisor E.^. UserSupervisorUser E.==. E.val oldUserId
+      return $ UserSupervisor
+        E.<#  (userSupervisor E.^. UserSupervisorSupervisor)
+        E.<&> E.val newUserId
+        E.<&> (userSupervisor E.^. UserSupervisorRerouteNotifications)
+    )
+    (\current excluded -> [ UserSupervisorRerouteNotifications E.=. (current E.^. UserSupervisorRerouteNotifications E.||. excluded E.^. UserSupervisorRerouteNotifications)  ] )
+  deleteWhere [ UserSupervisorUser ==. oldUserId]    
+
+  -- Companies, in conflict, keep the newUser-Company as is
+  E.insertSelectWithConflict
+    UniqueUserCompany
+    (E.from $ \userCompany -> do 
+      E.where_ $ userCompany E.^. UserCompanyUser E.==. E.val oldUserId
+      return $ UserCompany 
+        E.<#  E.val newUserId
+        E.<&> (userCompany E.^. UserCompanyCompany)
+        E.<&> (userCompany E.^. UserCompanySupervisor)
+    )
+    (\current _excluded -> [ UserCompanySupervisor E.=. (current E.^. UserCompanySupervisor)] )
+  deleteWhere [ UserCompanyUser ==. oldUserId]
+
   userIdents <- E.select . E.from $ \user -> do
     E.where_ $ user E.^. UserId `E.in_` E.valList [newUserId, oldUserId]
     return ( user E.^. UserId
@@ -831,3 +940,13 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
 
     tellError :: forall a. UserAssimilateExceptionReason -> ReaderT SqlBackend (WriterT (Set UserAssimilateException) Handler) a
     tellError = throwM . UserAssimilateException oldUserId newUserId
+
+
+
+combineWith :: (PersistEntity val, PersistField typ1) =>
+                     E.SqlExpr (Entity val)
+                     -> E.SqlExpr (Entity val)
+                     -> (E.SqlExpr (E.Value typ1) -> E.SqlExpr (E.Value typ1) -> E.SqlExpr (E.Value typ2))
+                     -> EntityField val typ1
+                     -> E.SqlExpr (E.Value typ2)
+combineWith x y f pj = f (x E.^. pj) (y E.^. pj)

src/Handler/Utils/Widgets.hs

@@ -89,6 +89,9 @@ nameHtml displayName surname
             |]
       [] -> error "Data.Text.splitOn returned empty list in violation of specification."
 
+nameHtml' :: HasUser u => u -> Html
+nameHtml' u = nameHtml (u ^. _userDisplayName) (u ^. _userSurname)
+
 -- | Like nameHtml just show a users displayname with hightlighted surname,
 --   but also wrap the name with a mailto-link
 nameEmailHtml :: UserEmail -> Text -> Text -> Html

src/Jobs/Handler/LMS.hs

@@ -17,6 +17,7 @@ import Import
 import Jobs.Queue
 
 -- import Jobs.Handler.Intervals.Utils
+import           Database.Esqueleto.Experimental ((:&)(..))
 import qualified Database.Esqueleto.Experimental as E
 --import qualified Database.Esqueleto.Legacy as E
 -- import qualified Database.Esqueleto.PostgreSQL as E -- for insertSelect variant
@@ -180,14 +181,14 @@ dispatchJobLmsResults qid = JobHandlerAtomic act
         -- otherwise there is nothing to do: we cannot renew s qualification  without a specified validDuration
         -- result :: [(Entity QualificationUser, Entity LmsUser, Entity LmsResult)]
         results <- E.select $ do
-          (quser E.:& luser E.:& lresult) <- E.from $
+          (quser :& luser :& lresult) <- E.from $
               E.table @QualificationUser  -- table not needed if renewal from lms completion day is used TODO: decide!
               `E.innerJoin` E.table @LmsUser
-              `E.on` (\(quser E.:& luser) ->
+              `E.on` (\(quser :& luser) ->
                               luser E.^. LmsUserUser           E.==. quser   E.^. QualificationUserUser
                         E.&&. luser E.^. LmsUserQualification  E.==. quser   E.^. QualificationUserQualification)
               `E.innerJoin` E.table @LmsResult
-              `E.on` (\(_ E.:& luser E.:& lresult) ->
+              `E.on` (\(_ :& luser :& lresult) ->
                               luser E.^. LmsUserIdent          E.==. lresult E.^. LmsResultIdent
                         E.&&. luser E.^. LmsUserQualification  E.==. lresult E.^. LmsResultQualification)
           E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid
@@ -232,9 +233,9 @@ dispatchJobLmsUserlist  qid = JobHandlerAtomic act
       now <- liftIO getCurrentTime
       -- result :: [(Entity LmsUser, Entity LmsUserlist)]
       results <- E.select $ do
-        (luser E.:& lulist) <- E.from $
+        (luser :& lulist) <- E.from $
             E.table @LmsUser `E.leftJoin` E.table @LmsUserlist
-            `E.on` (\(luser E.:& lulist) ->  luser E.^. LmsUserIdent         E.=?. lulist E.?. LmsUserlistIdent
+            `E.on` (\(luser :& lulist) ->  luser E.^. LmsUserIdent         E.=?. lulist E.?. LmsUserlistIdent
                                        E.&&. luser E.^. LmsUserQualification E.=?. lulist E.?. LmsUserlistQualification)
         E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid
                   E.&&. E.isNothing (luser E.^. LmsUserEnded) -- do not process closed learners

src/Jobs/Handler/SendNotification.hs

@@ -24,8 +24,7 @@ import Jobs.Handler.SendNotification.Allocation
 import Jobs.Handler.SendNotification.ExamOffice
 import Jobs.Handler.SendNotification.CourseRegistered
 import Jobs.Handler.SendNotification.SubmissionEdited
-import Jobs.Handler.SendNotification.Qualification 
+import Jobs.Handler.SendNotification.Qualification
-
 
 dispatchJobSendNotification :: UserId -> Notification -> JobHandler UniWorX
 dispatchJobSendNotification jRecipient jNotification = JobHandlerException $

src/Jobs/Handler/SendNotification/Qualification.hs

@@ -14,13 +14,8 @@ import Import
 
 import Utils.Print
 import Handler.Utils
-import Handler.Utils.Users
 import Jobs.Handler.SendNotification.Utils
 
-import qualified Data.ByteString.Lazy as LBS
-
-import qualified Data.Text as Text
-
 -- import Handler.Info (FAQItem(..))
 import qualified Data.CaseInsensitive as CI
 import Text.Hamlet
@@ -68,89 +63,35 @@ dispatchNotificationQualificationExpired nQualification dExpired jRecipient = us
   addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/qualificationExpired.hamlet")
 
 
--- NOTE: qualificationRenewal expects that LmsUser already exists for recipient
+-- NOTE: Renewal expects that LmsUser already exists for recipient
 dispatchNotificationQualificationRenewal :: QualificationId -> UserId -> Handler ()
 dispatchNotificationQualificationRenewal nQualification jRecipient = do
-  (recipient@User{..}, Qualification{..}, Entity _ QualificationUser{..}, Entity luid LmsUser{..}) <- runDB $ (,,,)
-    <$> getJust jRecipient
-    <*> getJust nQualification
-    <*> getJustBy (UniqueQualificationUser    nQualification jRecipient)
-    <*> getJustBy (UniqueLmsQualificationUser nQualification jRecipient)
-
   encRecipient :: CryptoUUIDUser <- encrypt jRecipient
-  let entRecipient = Entity jRecipient recipient
+  query <- runDB $ (,,,) 
-      qname = CI.original qualificationName
+    <$> get jRecipient
-
+    <*> get nQualification
-  $logInfoS "LMS" $ "Notify " <> tshow encRecipient <> " for renewal of qualification " <> qname
+    <*> getBy (UniqueQualificationUser    nQualification jRecipient)
-
+    <*> getBy (UniqueLmsQualificationUser nQualification jRecipient)
-  now <- liftIO getCurrentTime
+  case query of 
-  letterDate <- formatTimeUser SelFormatDate now                         $ Just entRecipient
+    (Just User{userDisplayName}, Just Qualification{..}, Just (Entity _ QualificationUser{..}), Just(Entity luid LmsUser{..})) -> do
-  expiryDate <- formatTimeUser SelFormatDate qualificationUserValidUntil $ Just entRecipient
+      let qname = CI.original qualificationName
-
+      let letter = LetterRenewQualificationF
-  let printJobName = "RenewalPin"
+            { lmsLogin     = lmsUserIdent
-      fileName  = printJobName <> "_" <> abbrvName recipient <> ".pdf"
+            , lmsPin       = lmsUserPin
-      lmsIdent  = lmsUserIdent & getLmsIdent
+            , qualHolder   = userDisplayName 
-      lmsUrl    = "https://drive.fraport.de"
+            , qualExpiry   = qualificationUserValidUntil
-      lmsLogin  = lmsUrl <> "/?login=" <> lmsIdent
+            , qualId       = nQualification
-      prepAddress upa = userDisplayName : (upa & html2textlines) -- TODO: use supervisor's address, once implemented
+            , qualName     = qname
-      pdfMeta   = mkMeta
+            , qualShort    = CI.original qualificationShorthand                                
-                  [ toMeta "date"           letterDate
+            , qualDuration = qualificationValidDuration
-                  , toMeta "lang"          (selectDeEn userLanguages)    -- select either German or English only, see Utils.Lang
+            }
-                  , toMeta "login"          lmsIdent
+      $logInfoS "LMS" $ "Notify " <> tshow encRecipient <> " for renewal of qualification " <> qname
-                  , toMeta "pin"            lmsUserPin
+      notifyOk <- sendEmailOrLetter jRecipient letter
-                  , toMeta "recipient"      userDisplayName
+      when notifyOk $ do 
-                  , mbMeta "address"       (prepAddress <$> userPostAddress)
+        now <- liftIO getCurrentTime
-                  , toMeta "expiry"         expiryDate
+        runDB $ update luid [ LmsUserNotified =. Just now]
-                  , mbMeta "validduration" (show <$> qualificationValidDuration)
+    (_, Nothing, _, _) -> $logErrorS "LMS" $ "Notify " <> tshow encRecipient <> " for renewal failed: Qualification " <> tshow nQualification <> " does not exist!"
-                  , toMeta "url-text"       lmsUrl
+    (Nothing, _, _, _) -> $logErrorS "LMS" $ "Notify " <> tshow encRecipient <> " for renewal failed: User does not exist!"
-                  , toMeta "url"            lmsLogin
+    (_, _, Nothing, _) -> $logErrorS "LMS" $ "Notify " <> tshow encRecipient <> " for renewal failed: QualificationUser does not exist, i.e. user does not have this qualification!"
-                  ]
+    (_, _, _, Nothing) -> $logWarnS  "LMS" $ "Notify " <> tshow encRecipient <> " for renewal failed: LmsUser does not exist!"
-      emailRenewal attachment
+    
-        | Text.null (CI.original userEmail) = do          -- if neither email nor postal address is known, we must abort!
-            let msg = "Notify " <> tshow encRecipient <> " failed: no email nor address for user known!"
-            $logErrorS "LMS" msg
-            return False
-        | otherwise = do
-            userMailT jRecipient $ do
-              replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
-              setSubjectI $ MsgMailSubjectQualificationRenewal qname
-              whenIsJust attachment $ \afile ->
-                addPart (File { fileTitle = Text.unpack fileName
-                              , fileModified = now
-                              , fileContent = Just $ yield $ LBS.toStrict afile
-                              } :: PureFile)
-              editNotifications <- mkEditNotifications jRecipient
-              addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/qualificationRenewal.hamlet")
-            return True
-
-  notifyOk <- pdfRenewal pdfMeta >>= \case
-    Right pdf | userPrefersLetter recipient ->          -- userPrefersLetter is false if both userEmail and userPostAddress are null
-      let printSender  = Nothing
-      in runDB (sendLetter printJobName pdf (Just jRecipient, printSender) Nothing (Just nQualification) (Just lmsUserIdent)) >>= \case
-        Left err -> do
-          let msg = "Notify " <> tshow encRecipient <> ": PDF printing to send letter failed with error " <> cropText err
-          $logErrorS "LMS" msg
-          return False
-        Right (msg,_)
-          | null msg  -> return True
-          | otherwise -> do
-              $logWarnS "LMS" $ "PDF printing to send letter with lpr returned ExitSucces and the following message: " <> msg
-              return True
-
-    Right pdf -> do
-      attch <- case userPinPassword of
-        Nothing   -> return $ Just pdf                  -- attach unencrypted, since there is no password set
-        Just passwd -> encryptPDF passwd pdf >>= \case
-          Right encPdf -> return $ Just encPdf          -- attach encrypted
-          Left err -> do                                -- send email without attachment, so that the user is at least notified about the expiry
-            let msg = "Notify " <> tshow encRecipient <> " PDF encryption failed with error: " <> cropText err
-            $logErrorS "LMS" msg
-            return Nothing
-      emailRenewal attch
-
-    Left err -> do
-      let msg = "Notify " <> tshow encRecipient <> " PDF generation failed with error: " <> cropText err
-      $logErrorS "LMS" msg
-      emailRenewal Nothing
-
-  when notifyOk $ runDB $ update luid [ LmsUserNotified =. Just now]

src/Jobs/Handler/SendTestEmail.hs

@@ -10,7 +10,9 @@ import Import
 
 import Handler.Utils.Mail
 import Handler.Utils.DateTime
+import Text.Hamlet
 -- import Handler.Utils.I18n
+-- import Text.Blaze.Internal
 
 dispatchJobSendTestEmail :: Email -> MailContext -> JobHandler UniWorX
 dispatchJobSendTestEmail jEmail jMailContext = JobHandlerException . mailT jMailContext $ do
@@ -21,7 +23,7 @@ dispatchJobSendTestEmail jEmail jMailContext = JobHandlerException . mailT jMail
   nDT <- formatTimeMail SelFormatDateTime now
   nD <- formatTimeMail SelFormatDate now
   nT <- formatTimeMail SelFormatTime now
-  addHtmlMarkdownAlternatives $ \(MsgRenderer mr) -> [shamlet|
+  addHtmlMarkdownAlternatives' "part1" $ \(MsgRenderer mr) -> [shamlet|
     <h2>
       #{mr MsgMailTestContent}
 
@@ -32,31 +34,30 @@ dispatchJobSendTestEmail jEmail jMailContext = JobHandlerException . mailT jMail
         <li>#{nD}
         <li>#{nT}
     |]
-  addHtmlMarkdownAlternatives' "addOne" $ \(MsgRenderer mr) -> [shamlet|
+  addHtmlMarkdownAlternatives' "part2" $ \(MsgRenderer _mr) -> [shamlet|
-    <h2>Repetition just for Testing
+    <h2>Second part, just for testing
     <p>
-      #{mr MsgMailTestContent}
+      Please ignore this part of the message.
-
+    |]
+  -- Compiles as well: let trdmsg :: HtmlUrlI18n _ (Route UniWorX) = [ihamlet|
+  let trdmsg :: HtmlUrlI18n UniWorXJobsHandlerMessage (Route UniWorX) = [ihamlet|
+    <h2>Third part, again only for tests
     <p>
-      #{mr MsgMailTestDateTime}
+      _{MsgMailTestDateTime}
       <ul>
         <li>#{nDT}
         <li>#{nD}
         <li>#{nT}
-    |]
-  addHtmlMarkdownAlternatives'' "addTwo" $ \(MsgRenderer mr) -> [shamlet|
-    <h2>Repetition just for Testing
     <p>
-      #{mr MsgMailTestContent}
+      Message was sent to you by
-
+        <a href=@{NewsR}>
-    <p>
+          FRADrive
-      #{mr MsgMailTestDateTime}
-      <ul>
-        <li>#{nDT}
-        <li>#{nD}
-        <li>#{nT}
     |]
-  -- let test = $(i18nHamletFile "test")
+  addHtmlMarkdownAlternatives' "part3" trdmsg
-  -- addHtmlMarkdownAlternatives' "addTest" (test :: Html) --  Text.Blaze.Internal.MarkupM  Text.Blaze.Internal.Markup
+  -- Html == Markup == MarkupM ()
-
+  --test <- liftHandler $ withUrlRenderer $(i18nHamletFile "test")
-  
+  test :: Html <- liftHandler $ withUrlRenderer $(hamletFile "templates/i18n/test/en-eu.hamlet")
+  addHtmlMarkdownAlternatives test
+  -- 
+  --test2 <- liftHandler $(i18nHamletFile "test")
+  --addHtmlMarkdownAlternatives test2

src/Mail.hs

@@ -29,9 +29,9 @@ module Mail
   , MonadHeader(..)
   , MailHeader
   , MailObjectId
-  , replaceMailHeader, addMailHeader, removeMailHeader, getMailHeaders, lookupMailHeader
+  , replaceMailHeader, addMailHeader, removeMailHeader, getMailHeaders, lookupMailHeader, mapMailHeader
   , replaceMailHeaderI, addMailHeaderI
-  , setSubjectI
+  , setSubjectI, mapSubject
   , setMailObjectUUID, setMailObjectIdRandom, setMailObjectIdCrypto, setMailObjectIdPseudorandom
   , getMailObjectId
   , setDate, setDateCurrent
@@ -78,7 +78,7 @@ import qualified Data.Text.Lazy.Builder as LTB
 import qualified Data.ByteString.Lazy as LBS
 import qualified Data.ByteString as BS
 
-import Utils (MsgRendererS(..), MonadSecretBox(..), YamlValue, maybeMonoid, insertAssoc, maybeT, guardM)
+import Utils (MsgRendererS(..), MonadSecretBox(..), YamlValue, maybeMonoid, insertAssoc, maybeT, guardM, adjustAssoc)
 import Utils.Lens.TH
 
 import Control.Lens hiding (from)
@@ -529,6 +529,8 @@ getMailHeaders header = stateHeaders $ \hdrs -> (, hdrs) . map (view _2) $ filte
 lookupMailHeader :: MonadHeader m => MailHeader -> m (Maybe Text)
 lookupMailHeader = fmap listToMaybe . getMailHeaders
 
+mapMailHeader ::  MonadHeader m => MailHeader -> (Text -> Text) -> m ()
+mapMailHeader header f = modifyHeaders $ adjustAssoc f header 
 
 replaceMailHeaderI :: ( RenderMessage site msg
                       , MonadMail m
@@ -548,6 +550,9 @@ addMailHeaderI header msg = addMailHeader header =<< (getMailMessageRender <*> p
 setSubjectI :: (RenderMessage site msg, MonadHandler m, HandlerSite m ~ site) => msg -> MailT m ()
 setSubjectI = replaceMailHeaderI "Subject"
 
+mapSubject ::  MonadHeader m => (Text -> Text) -> m ()
+mapSubject = mapMailHeader "Subject"
+
 setMailObjectUUID :: ( MonadHeader m
                      , YesodMail (HandlerSite m)
                      ) => UUID -> m MailObjectId

src/Model/Types/Avs.hs

@@ -18,6 +18,7 @@ import qualified Data.Csv as Csv
 import Utils.Lens.TH
 
 import Text.Read (Read(..))
+import qualified Data.Char          as Char
 import qualified Data.Text          as Text
 import qualified Data.Set           as Set
 
@@ -44,7 +45,7 @@ o .:?~ key = o .: key <|> maybe empty parseJSON go
 
 -- Like (.:?) but maps Just null to Nothing, ie. Nothing instead of Just ""
 (.:?!) :: (MonoFoldable a, FromJSON a) => Object -> Text -> Parser (Maybe a)
-(.:?!) o k = null2nothing <$> (o .:? k)
+(.:?!) o k = canonical <$> (o .:? k)
 
 
 -- | `SloppyBool` successfully parses different variations of true/false
@@ -80,15 +81,48 @@ instance FromJSON SloppyBool where
 -- AVS Datatypes --
 -------------------
 
+type AvsInternalPersonalNo = Text -- ought to be all digits, type synonym for clarity/documentation within types
+
+-- CompleteCardNo = xxxxxxxx.y 
+-- where x is an 8 digit AvsCardNo prefixed by zeros, see normalizeAvsCardNo
+--   and y is the 1 digit AvsVersionNo
+type AvsVersionNo = Text -- always 1 digit 
 newtype AvsCardNo = AvsCardNo { avsCardNo :: Text }  -- always 8 digits
   deriving (Eq, Ord, Show, Generic, Typeable)
   deriving newtype (NFData, PathPiece, PersistField, PersistFieldSql, Csv.ToField, Csv.FromField)
 instance E.SqlString AvsCardNo
 -- AvsCardNo is an untagged Text with respect to FromJSON/ToJSON, as needed by AVS API
 instance FromJSON AvsCardNo where
-  parseJSON x = AvsCardNo <$> parseJSON x
+  parseJSON x = AvsCardNo . normalizeAvsCardNo <$> parseJSON x
 instance ToJSON AvsCardNo where
-  toJSON (AvsCardNo cno) = toJSON cno
+  toJSON (AvsCardNo cno) = toJSON $ normalizeAvsCardNo cno
+normalizeAvsCardNo :: Text -> Text
+normalizeAvsCardNo = Text.justifyRight 8 '0'
+
+data AvsFullCardNo = AvsFullCardNo { avsFullCardNo :: AvsCardNo, avsFullCardVersion :: AvsVersionNo }
+  deriving (Eq, Ord, Generic, Typeable)
+
+tshowAvsFullCardNo :: AvsFullCardNo -> Text
+tshowAvsFullCardNo AvsFullCardNo{..} = avsCardNo avsFullCardNo <> Text.cons '.' avsFullCardVersion
+
+instance Show AvsFullCardNo where 
+  show = Text.unpack . tshowAvsFullCardNo
+
+readAvsFullCardNo :: Text -> Maybe AvsFullCardNo
+readAvsFullCardNo (Text.span Char.isDigit -> (c, Text.uncons -> Just ('.',v)))
+  | not $ Text.null c, Just (Char.isDigit -> True, "") <- Text.uncons v
+    = Just $ AvsFullCardNo (AvsCardNo c) v
+readAvsFullCardNo _ = Nothing
+
+discernAvsCardPersonalNo :: Text -> Maybe (Either AvsFullCardNo AvsInternalPersonalNo) -- Just implies it is a whole number or decimal with one digit after the point
+discernAvsCardPersonalNo (Text.span Char.isDigit -> (c, pv))
+  | Text.null pv 
+    = Just $ Right c
+  | not $ Text.null c
+  , Just ('.', v) <- Text.uncons pv
+  , Just (Char.isDigit -> True, "") <- Text.uncons v
+    = Just $ Left $ AvsFullCardNo (AvsCardNo c) v
+discernAvsCardPersonalNo _ = 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
@@ -119,8 +153,20 @@ deriveJSON defaultOptions
   } ''AvsObjPersonId
 
 
+discernAvsIds :: Text -> Maybe (Either AvsFullCardNo AvsPersonId)
+discernAvsIds someid = aux someid
+  where
+    aux (Text.uncons -> Just (h,t))
+      | Char.isDigit h = aux t
+      | h == '.', Just (h2, t2) <- Text.uncons t, Text.null t2, Char.isDigit h2
+      , let afcn = AvsFullCardNo (AvsCardNo $ Text.dropEnd 2 someid) (Text.singleton h2)
+        = Just $ Left afcn
+      | otherwise = Nothing
+    aux _ = Right . AvsPersonId <$> readMay someid -- must always succeed at that point      
+
+
 data AvsLicence = AvsNoLicence | AvsLicenceVorfeld | AvsLicenceRollfeld
-  deriving (Bounded, Enum, Eq, Ord, Read, Show, Generic, Typeable)
+  deriving (Bounded, Enum, Eq, Ord, Read, Show, Generic, Typeable, Finite, Universe, NFData)
 
 instance ToJSON AvsLicence where
     -- toJSON al = Number $ fromEnum AvsLicence -- would do, but...
@@ -129,10 +175,27 @@ instance ToJSON AvsLicence where
     toJSON AvsLicenceRollfeld = Number 2
 
 instance FromJSON AvsLicence where
-  parseJSON (Number n)  | n == 0 = pure AvsNoLicence
+  parseJSON (Number n)  | n == 1 = pure AvsLicenceVorfeld   -- ordered by occurrence, n==1 is most common case
-                        | n == 1 = pure AvsLicenceVorfeld
                         | n == 2 = pure AvsLicenceRollfeld
+                        | n == 0 = pure AvsNoLicence        -- n==0 never received from AVS, only sent to AVS                        
+#ifdef DEVELOPMENT
   parseJSON invalid = prependFailure "parsing AvsLicence failed, " $ fail $ "expected Int value being 0, 1 or 2. Found " ++ show invalid
+#else
+  parseJSON _ = pure AvsNoLicence     -- we simply ignore all other values
+#endif
+
+-- we assume that the Ord-Instance is respected by the SQL Backend!
+instance PersistField AvsLicence where
+  toPersistValue = PersistInt64 . fromIntegral . fromEnum
+  fromPersistValue (PersistInt64 v') 
+    | let v = fromIntegral v'
+    , v >= fromEnum (minBound::AvsLicence)
+    , v <= fromEnum (maxBound::AvsLicence) 
+      = Right $ toEnum v
+  fromPersistValue other = Left $ "Encoding of AvsLicence " <> tshow other <> " is out of range"
+
+instance PersistFieldSql AvsLicence where
+  sqlType _ = SqlInt64
 
 -- | Ought to be identical to QualificationShortname!
 licence2char :: AvsLicence -> Char
@@ -163,17 +226,17 @@ instance FromJSON AvsDataCardColor where
 
 
 data AvsDataPersonCard = AvsDataPersonCard
-      { avsDataValid     :: Bool        -- card currently valid? Note that AVS encodes booleans as JSON String "true" and "false" and not as JSON booleans
+      { avsDataValid     :: Bool          -- card currently valid? Note that AVS encodes booleans as JSON String "true" and "false" and not as JSON booleans
-      , avsDataValidTo   :: Maybe Day   -- Nothing if returned with AvsResponseStatus
+      , avsDataValidTo   :: Maybe Day     -- Nothing if returned with AvsResponseStatus
-      , avsDataIssueDate :: Maybe Day   -- Nothing if returned with AvsResponseStatus
+      , avsDataIssueDate :: Maybe Day     -- Nothing if returned with AvsResponseStatus
       , avsDataCardColor :: AvsDataCardColor
-      , avsDataCardAreas :: Set Char    -- logically a set of upper-case letters
+      , avsDataCardAreas :: Set Char      -- logically a set of upper-case letters
-      , avsDataStreet    :: Maybe Text  -- Nothing if returned with AvsResponseStatus
+      , avsDataStreet    :: Maybe Text    -- Nothing if returned with AvsResponseStatus
-      , avsDataPostalCode:: Maybe Text  -- Nothing if returned with AvsResponseStatus
+      , avsDataPostalCode:: Maybe Text    -- Nothing if returned with AvsResponseStatus
-      , avsDataCity      :: Maybe Text  -- Nothing if returned with AvsResponseStatus
+      , avsDataCity      :: Maybe Text    -- Nothing if returned with AvsResponseStatus
-      , avsDataFirm      :: Maybe Text  -- Nothing if returned with AvsResponseStatus
+      , avsDataFirm      :: Maybe Text    -- Nothing if returned with AvsResponseStatus
-      , avsDataCardNo    :: AvsCardNo   -- always 8 digits
+      , avsDataCardNo    :: AvsCardNo     -- always 8 digits number, prefixed with 0 
-      , avsDataVersionNo :: Text
+      , avsDataVersionNo :: AvsVersionNo  -- always 1 digit number
       }
   deriving (Eq, Ord, Show, Generic, Typeable)
   deriving anyclass (NFData)
@@ -193,18 +256,18 @@ instance Ord AvsDataPersonCard where
 makeLenses_ ''AvsDataPersonCard
 {-
 instance Canonical AvsDataPersonCard where
-  canonical proto = proto { avsDataStreet     = null2nothing $ avsDataStreet      proto
+  canonical proto = proto { avsDataStreet     = canonical $ avsDataStreet      proto
-                          , avsDataPostalCode = null2nothing $ avsDataPostalCode  proto
+                          , avsDataPostalCode = canonical $ avsDataPostalCode  proto
-                          , avsDataCity       = null2nothing $ avsDataCity        proto
+                          , avsDataCity       = canonical $ avsDataCity        proto
-                          , avsDataFirm       = null2nothing $ avsDataFirm        proto
+                          , avsDataFirm       = canonical $ avsDataFirm        proto
                           }
 -}
 instance Canonical AvsDataPersonCard where
   canonical proto =
-    proto & _avsDataStreet      %~ null2nothing
+    proto & _avsDataStreet      %~ canonical
-          & _avsDataPostalCode  %~ null2nothing
+          & _avsDataPostalCode  %~ canonical
-          & _avsDataCity        %~ null2nothing
+          & _avsDataCity        %~ canonical
-          & _avsDataFirm        %~ null2nothing
+          & _avsDataFirm        %~ canonical
 
 -- TODO: use canonical in FromJSON/ToJSON instances for consistency
 instance FromJSON AvsDataPersonCard where
@@ -226,10 +289,10 @@ instance ToJSON AvsDataPersonCard where
     catMaybes
     [ ("ValidTo"     .=) <$> avsDataValidTo
     , ("IssueDate"   .=) <$> avsDataIssueDate
-    , ("Street"      .=) <$> (avsDataStreet     & null2nothing)
+    , ("Street"      .=) <$> (avsDataStreet     & canonical)
-    , ("PostalCode"  .=) <$> (avsDataPostalCode & null2nothing)
+    , ("PostalCode"  .=) <$> (avsDataPostalCode & canonical)
-    , ("City"        .=) <$> (avsDataCity       & null2nothing)
+    , ("City"        .=) <$> (avsDataCity       & canonical)
-    , ("Firm"        .=) <$> (avsDataFirm       & null2nothing)
+    , ("Firm"        .=) <$> (avsDataFirm       & canonical)
     ]
     <>
     [ "Valid"       .= show avsDataValid
@@ -240,6 +303,8 @@ instance ToJSON AvsDataPersonCard where
     ]
 derivePersistFieldJSON ''AvsDataPersonCard
 
+getFullCardNo :: AvsDataPersonCard -> AvsFullCardNo
+getFullCardNo AvsDataPersonCard{avsDataCardNo, avsDataVersionNo} = AvsFullCardNo avsDataCardNo avsDataVersionNo
 
 data AvsStatusPerson = AvsStatusPerson
       { avsStatusPersonID         :: AvsPersonId
@@ -257,9 +322,9 @@ deriveJSON defaultOptions
 data AvsDataPerson = AvsDataPerson
       { avsPersonFirstName          :: Text
       , avsPersonLastName           :: Text
-      , avsPersonInternalPersonalNo :: Maybe Text   -- Fraport Personalnummer
+      , avsPersonInternalPersonalNo :: Maybe AvsInternalPersonalNo  -- Fraport Personalnummer
-      , avsPersonPersonNo           :: Int          -- AVS Personennummer, Bedeutung ist unklar
+      , avsPersonPersonNo           :: Int                          -- AVS Personennummer, Bedeutung ist unklar
-      , avsPersonPersonID           :: AvsPersonId  -- Eindeutige PersonenID, wichtig für die Schnittstelle!
+      , avsPersonPersonID           :: AvsPersonId                  -- Eindeutige PersonenID, wichtig für die Schnittstelle!
       , avsPersonPersonCards        :: Set AvsDataPersonCard
       }
     deriving (Eq, Ord, Show, Generic, Typeable)
@@ -267,7 +332,7 @@ data AvsDataPerson = AvsDataPerson
 makeLenses_ ''AvsDataPerson
 
 instance Canonical AvsDataPerson where
-  canonical = over _avsPersonInternalPersonalNo null2nothing
+  canonical = over _avsPersonInternalPersonalNo canonical
             . over _avsPersonPersonCards        canonical
 
 
@@ -282,7 +347,7 @@ instance FromJSON AvsDataPerson where
 
 instance ToJSON AvsDataPerson where
   toJSON AvsDataPerson{..} = object $
-    catMaybes [ ("InternalPersonalNo"  .=) <$> (avsPersonInternalPersonalNo & null2nothing) ]
+    catMaybes [ ("InternalPersonalNo"  .=) <$> (avsPersonInternalPersonalNo & canonical) ]
     <>
     [ "FirstName"           .= avsPersonFirstName
     , "LastName"            .= avsPersonLastName
@@ -291,7 +356,7 @@ instance ToJSON AvsDataPerson where
     , "personCards"         .= avsPersonPersonCards   -- starts with lower case letter!
     ]
 
-{- Dervied instance decodes empty Texts to Just "", which is annoying
+{- Derived instance decodes empty Texts to Just "", which is annoying
 deriveJSON defaultOptions
   { fieldLabelModifier = \case { "avsPersonPersonCards" -> "personCards"; others -> dropCamel 2 others }
   , omitNothingFields = True
@@ -301,9 +366,8 @@ deriveJSON defaultOptions
 -}
 
 data AvsPersonLicence = AvsPersonLicence
-      { avsLicencePersonID     :: AvsPersonId
+      { avsLicenceRampLicence  :: AvsLicence
-      , avsLicenceRampLicence  :: AvsLicence    -- Schnittstelle unklar: RampDrivingLicence oder RampLicence
+      , avsLicencePersonID     :: AvsPersonId
-      --, avsLicenceRampDrivingLicence  :: AvsLicence
       }
   deriving (Eq, Ord, Show, Generic, Typeable)
 deriveJSON defaultOptions
@@ -313,17 +377,24 @@ deriveJSON defaultOptions
   , rejectUnknownFields = False
   } ''AvsPersonLicence
 
+avsPersonLicenceIs :: AvsPersonLicence -> AvsLicence -> Bool
+avsPersonLicenceIs = (==) . avsLicenceRampLicence
+
+avsPersonLicenceIsLEQ :: AvsPersonLicence -> AvsLicence -> Bool
+avsPersonLicenceIsLEQ = (<=) . avsLicenceRampLicence
+
+
 data AvsLicenceResponse = AvsLicenceResponse
-      { avsResponsePersonID :: AvsPersonId
+        { avsResponsePersonID :: AvsPersonId
-      , avsResponseSuccess  :: SloppyBool
+        , avsResponseSuccess  :: SloppyBool
-      , avsResponseMessage  :: Text
+        , avsResponseMessage  :: Text
-      }
+        }
     deriving (Eq, Ord, Show, Generic, Typeable)
 deriveJSON defaultOptions
   { fieldLabelModifier = dropCamel 2
   , omitNothingFields = True
   , tagSingleConstructors = False
-  , rejectUnknownFields = False
+  , rejectUnknownFields = False  
   } ''AvsLicenceResponse
 
 
@@ -358,13 +429,18 @@ deriveJSON defaultOptions
   , rejectUnknownFields = False
   } ''AvsResponseGetLicences
 
-newtype AvsResponseSetLicences = AvsResponseSetLicences (Set AvsLicenceResponse)
+data AvsResponseSetLicences = AvsResponseSetLicences (Set AvsLicenceResponse)
+                            | AvsResponseSetLicencesError
+                                { avsResponseSetLicencesStatus   :: Text
+                                , avsResponseSetLicencesMessage  :: Text
+                                }
   deriving (Eq, Ord, Show, Generic, Typeable)
 deriveJSON defaultOptions
-  { fieldLabelModifier = dropCamel 2
+  { fieldLabelModifier = dropCamel 4
   , omitNothingFields = True
   , tagSingleConstructors = False
   , rejectUnknownFields = False
+  , sumEncoding = UntaggedValue
   } ''AvsResponseSetLicences
 
 
@@ -373,10 +449,10 @@ deriveJSON defaultOptions
 -------------
 data AvsQueryPerson = AvsQueryPerson
         { avsPersonQueryCardNo             :: Maybe AvsCardNo
+        , avsPersonQueryVersionNo          :: Maybe AvsVersionNo
         , avsPersonQueryFirstName          :: Maybe Text
         , avsPersonQueryLastName           :: Maybe Text
-        , avsPersonQueryInternalPersonalNo :: Maybe Text
+        , avsPersonQueryInternalPersonalNo :: Maybe AvsInternalPersonalNo
-        , avsPersonQueryVersionNo          :: Maybe Text
         }
   deriving (Eq, Ord, Show, Generic, Typeable)
 

src/Model/Types/Common.hs

@@ -22,13 +22,13 @@ type Points = Centi
 
 type Email = Text
 
-type UserTitle         = Text
+type UserTitle            = Text
-type UserFirstName     = Text
+type UserFirstName        = Text
-type UserSurname       = Text
+type UserSurname          = Text
-type UserDisplayName   = Text
+type UserDisplayName      = Text
-type UserIdent         = CI Text
+type UserIdent            = CI Text
-type UserMatriculation = Text
+type UserMatriculation    = Text
-type UserEmail         = CI Email
+type UserEmail            = CI Email
 
 type StudyDegreeName      = Text
 type StudyDegreeShorthand = Text
@@ -38,22 +38,25 @@ type StudyTermsShorthand  = Text
 type StudyTermsKey        = Int
 type StudySubTermsKey     = Int
 
-type SchoolName      = CI Text
+type SchoolName           = CI Text
-type SchoolShorthand = CI Text
+type SchoolShorthand      = CI Text
 
-type CourseName          = CI Text
+type CompanyName          = CI Text
-type CourseShorthand     = CI Text
+type CompanyShorthand     = CI Text 
-type MaterialName        = CI Text
-type TutorialName        = CI Text
-type SheetName           = CI Text
-type SubmissionGroupName = CI Text
 
-type ExamName           = CI Text
+type CourseName           = CI Text
-type ExamPartName       = CI Text
+type CourseShorthand      = CI Text
-type ExamOccurrenceName = CI Text
+type MaterialName         = CI Text
+type TutorialName         = CI Text
+type SheetName            = CI Text
+type SubmissionGroupName  = CI Text
 
-type AllocationName      = CI Text
+type ExamName             = CI Text
-type AllocationShorthand = CI Text
+type ExamPartName         = CI Text
+type ExamOccurrenceName   = CI Text
+
+type AllocationName       = CI Text
+type AllocationShorthand  = CI Text
 
 type PWHashAlgorithm = ByteString -> PWStore.Salt -> Int -> ByteString
 

src/Model/Types/Security.hs

@@ -81,7 +81,6 @@ data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prä
   | AuthExamOffice
   | AuthSystemExamOffice
   | AuthSystemPrinter
-  | AuthSystemSap
   | AuthEvaluation
   | AuthAllocationAdmin  
   | AuthAllocationRegistered
@@ -120,6 +119,7 @@ data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prä
   | AuthToken
   | AuthDeprecated
   | AuthDevelopment
+  | AuthSupervisor
   | AuthFree
   deriving (Eq, Ord, Enum, Bounded, Read, Show, Data, Generic, Typeable)
   deriving anyclass (Universe, Finite, Hashable, NFData)

src/Model/Types/User.hs

@@ -15,8 +15,7 @@ data SystemFunction
   = SystemExamOffice
   | SystemFaculty
   | SystemStudent
-  | SystemPrinter
+  | SystemPrinter  
-  | SystemSap
   deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
   deriving anyclass (Universe, Finite, Hashable, NFData)
 

src/Utils.hs

@@ -275,6 +275,10 @@ addAttrsClass cl attrs = ("class", cl') : noClAttrs
 -- tickmark :: IsString a => a
 -- tickmark = fromString "✔"
 
+-- | Deprecated, replace with Data.Text.elem, once a newer version of Data.Text is available
+textElem :: Char -> Text -> Bool
+textElem c = Text.any (c ==)
+
 -- | remove all whitespace from Text
 -- whereas Text.strip only removes leading and trailing whitespace
 stripAll :: Text -> Text
@@ -615,6 +619,10 @@ trd3 (_,_,z) = z
 mTuple :: Applicative f => f a -> f b -> f (a, b)
 mTuple = liftA2 (,)
 
+-- From Data.Tuple.Extra
+mapBoth :: (a -> b) -> (a,a) -> (b,b)
+mapBoth f ~(a,b) = (f a, f b)
+
 -----------
 -- Lists --
 -----------
@@ -812,10 +820,10 @@ toNothing = const Nothing
 toNothingS :: String -> Maybe b
 toNothingS = const Nothing
 
--- a more general formulation probably possible
+-- replaced by a more general formulation, see canonical
-null2nothing :: MonoFoldable a => Maybe a -> Maybe a
+-- null2nothing :: MonoFoldable a => Maybe a -> Maybe a
-null2nothing (Just x) | null x = Nothing
+-- null2nothing (Just x) | null x = Nothing
-null2nothing other = other
+-- null2nothing other = other
 
 -- | Swap 'Nothing' for 'Just' and vice versa
 -- This belongs into Module 'Utils' but we have a weird cyclic
@@ -1868,5 +1876,15 @@ makePrisms ''ExitCase
 class Canonical a where 
   canonical :: a -> a
 
+instance MonoFoldable mono => Canonical (Maybe mono) where
+  canonical (Just t) | null t = Nothing
+  canonical other = other
+
+-- instance (Canonical mono, MonoFoldable mono) => Canonical (Maybe mono) where
+--   canonical (Just t) | null t = Nothing
+--   canonical (Just t) = Just $ canonical t
+--   canonical other = other
+
+-- this instance is more of a convenient abuse of the class (expand to Foldable)
 instance (Ord a, Canonical a) => Canonical (Set a) where
   canonical = Set.map canonical

src/Utils/Avs.hs

@@ -43,7 +43,7 @@ data AvsQuery where
 
 data AvsQuery = AvsQuery
   { avsQueryPerson         :: forall m. MonadIO m => AvsQueryPerson      -> m (Either ClientError AvsResponsePerson)
-  , avsQueryStatus         :: forall m. MonadIO m => AvsQueryStatus      -> m (Either ClientError AvsResponseStatus)  
+  , avsQueryStatus         :: forall m. MonadIO m => AvsQueryStatus      -> m (Either ClientError AvsResponseStatus)
   , avsQuerySetLicences    :: forall m. MonadIO m => AvsQuerySetLicences -> m (Either ClientError AvsResponseSetLicences)
   , avsQueryGetLicences    :: forall m. MonadIO m => AvsQueryGetLicences -> m (Either ClientError AvsResponseGetLicences)
   , avsQueryGetAllLicences :: forall m. MonadIO m =>                        m (Either ClientError AvsResponseGetLicences)
@@ -59,7 +59,7 @@ avsQueryAllLicences = AvsQueryGetLicences $ Set.singleton $ AvsObjPersonId $ Avs
 mkAvsQuery :: BaseUrl -> BasicAuthData -> ClientEnv -> AvsQuery
 mkAvsQuery baseUrl basicAuth cliEnv = AvsQuery
     { avsQueryPerson      = \q -> liftIO $ catch404toEmpty <$> runClientM (rawQueryPerson      q)  cliEnv
-    , avsQueryStatus      = \q -> liftIO $                     runClientM (rawQueryStatus      q)  cliEnv        
+    , avsQueryStatus      = \q -> liftIO $                     runClientM (rawQueryStatus      q)  cliEnv
     , avsQuerySetLicences = \q -> liftIO $                     runClientM (rawQuerySetLicences q)  cliEnv
     , avsQueryGetLicences = \q -> liftIO $                     runClientM (rawQueryGetLicences q)  cliEnv
     , avsQueryGetAllLicences =    liftIO $                     runClientM (rawQueryGetLicences avsQueryAllLicences) cliEnv
@@ -71,7 +71,7 @@ mkAvsQuery baseUrl basicAuth cliEnv = AvsQuery
       | baseUrl == base = Right $ AvsResponsePerson mempty -- WORKAROUND: AVS server erroneously returns 404 if no matching person could be found in its database!
     catch404toEmpty other = other
 
-    
+
 -----------------------
 -- Utility Functions --
 -----------------------
@@ -87,16 +87,21 @@ getValidLicence cutoff licence' cards = Set.lookupMax validLicenceCards
     cardMatch AvsDataPersonCard{..} =
       avsDataValid && (avsDataValidTo >= cutoff) && (licence `Set.member` avsDataCardAreas)
 
-guessLicenceAddress :: Set AvsDataPersonCard -> Maybe (Maybe Text, Text)
+guessLicenceAddress :: Set AvsDataPersonCard -> Maybe (Maybe Text, Text, AvsDataPersonCard)
 guessLicenceAddress cards
   | Just c <- Set.lookupMax cards
-  , AvsDataPersonCard{..} <- Set.foldr pickLicenceAddress c cards
+  , card@AvsDataPersonCard{..} <- Set.foldr pickLicenceAddress c cards
   , Just street <- avsDataStreet
   , Just pcode  <- avsDataPostalCode
   , Just city   <- avsDataCity
-    = Just (avsDataFirm, Text.unlines [street, Text.unwords [pcode, city]])
+    = Just (avsDataFirm, Text.unlines [street, Text.unwords [pcode, city]], card)
   | otherwise = Nothing
 
+-- | Helper for guessLicenceAddress
+mergeCompanyAddress :: (Maybe Text, Text, a) -> Text
+mergeCompanyAddress (Nothing  , addr, _) = addr
+mergeCompanyAddress (Just firm, addr, _) = firm <> Text.cons '\n' addr
+
 hasAddress :: AvsDataPersonCard -> Bool
 hasAddress AvsDataPersonCard{..} = isJust avsDataStreet && isJust avsDataCity && isJust avsDataPostalCode
 
@@ -132,9 +137,10 @@ bestAddress :: AvsDataPersonCard -> AvsDataPersonCard -> Ordering
       compareBy f = compare `on` f a b
 -}
 
+-- Merges several answers by AvsPersonId, preserving all AvsPersonCards
 mergeByPersonId :: Set AvsDataPerson -> Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson
 mergeByPersonId = flip $ Set.foldr aux
-  where 
+  where
     aux :: AvsDataPerson -> Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson
     aux adp = mergeAvsDataPerson $ catalogueAvsDataPerson adp
 
@@ -142,13 +148,13 @@ catalogueAvsDataPerson :: AvsDataPerson -> Map AvsPersonId AvsDataPerson
 catalogueAvsDataPerson adp = Map.singleton (avsPersonPersonID adp) adp
 
 mergeAvsDataPerson :: Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson
-mergeAvsDataPerson = Map.unionWithKey merger 
+mergeAvsDataPerson = Map.unionWithKey merger
-  where 
+  where
     merger :: AvsPersonId -> AvsDataPerson -> AvsDataPerson -> AvsDataPerson
-    merger api pa pb = 
+    merger api pa pb =
       let pickBy' :: Ord b => (a -> b) -> (AvsDataPerson -> a) -> a
           pickBy' f p = pickBy f (p pa) (p pb) -- pickBy f `on` p pa pb
-      in AvsDataPerson 
+      in AvsDataPerson
         { avsPersonFirstName          = pickBy' Text.length avsPersonFirstName
         , avsPersonLastName           = pickBy' Text.length avsPersonLastName
         , avsPersonInternalPersonalNo = pickBy' (Text.length . fromMaybe mempty) avsPersonInternalPersonalNo
@@ -157,8 +163,8 @@ mergeAvsDataPerson = Map.unionWithKey merger
         , avsPersonPersonCards        = (Set.union `on` avsPersonPersonCards) pa pb
         }
 
-    pickBy :: Ord b => (a -> b) -> a -> a -> a 
+    pickBy :: Ord b => (a -> b) -> a -> a -> a
-    pickBy f x y  | f x >= f y = x 
+    pickBy f x y  | f x >= f y = x
                   | otherwise  = y
 
 

src/Utils/Form.hs

@@ -302,7 +302,11 @@ data FormIdentifier
   | FIDAllocationRegister
   | FIDAllocationNotification
   | FIDAvsQueryPerson
-  | FIDAvsQueryStatus  
+  | FIDAvsQueryStatus
+  | FIDAvsCreateUser
+  | FIDAvsQueryLicenceDiffs
+  | FIDAvsQueryLicence
+  | FIDAvsSetLicence
   | FIDLmsLetter
   deriving (Eq, Ord, Read, Show)
 

src/Utils/Lens.hs

@@ -56,6 +56,9 @@ _nullable = prism' toNullable fromNullable
 _SchoolId :: Iso' SchoolId SchoolShorthand
 _SchoolId = iso unSchoolKey SchoolKey
 
+_CompanyId :: Iso' CompanyId CompanyShorthand
+_CompanyId = iso unCompanyKey CompanyKey
+
 _TermId :: Iso' TermId TermIdentifier
 _TermId = iso unTermKey TermKey
 

src/Utils/Print.hs

@@ -6,15 +6,17 @@
 
 module Utils.Print
   ( pdfRenewal
-  , sendLetter   
+  , sendLetter, sendLetter'
+  , sendEmailOrLetter
   , encryptPDF
   , sanitizeCmdArg, validCmdArgument
   , templateDIN5008
   , templateRenewal
-  -- , compileTemplate, makePDF  
+  -- , compileTemplate, makePDF
   , _Meta, addMeta
   , toMeta, mbMeta                           -- single values
   , mkMeta, appMeta, applyMetas              -- multiple values
+  , LetterRenewQualificationF(..)
   ) where
 
 -- import Import.NoModel
@@ -32,10 +34,16 @@ import qualified Text.Pandoc         as P
 import qualified Text.Pandoc.PDF     as P
 import qualified Text.Pandoc.Builder as P
 
+import Text.Hamlet
+
 import System.Exit
 import System.Process.Typed -- for calling pdftk for pdf encryption
 
-import Handler.Utils.Users (abbrvName)
+import Handler.Utils.Users
+import Handler.Utils.DateTime
+import Handler.Utils.Mail
+import Handler.Utils.Widgets (nameHtml') 
+import Jobs.Handler.SendNotification.Utils
 
 -- import Model.Types.Markup -- TODO-QSV: should this module be moved accordingly?
 
@@ -105,14 +113,14 @@ appMeta f (P.Pandoc m bs) = P.Pandoc (f m) bs
 
 -- TODO: applyMetas is inconvenient since we cannot have an instance
 --         ToMetaValue a => ToMetaValue (Maybe a)
---       so apply Metas 
+--       so apply Metas
 
 -- For tests see module PandocSpec
 applyMetas :: (P.HasMeta p, Foldable t, P.ToMetaValue a) => t (Text, Maybe a) -> p -> p
 applyMetas metas doc = Fold.foldr act doc metas
-  where 
+  where
-    act (_, Nothing) acc = acc 
+    act (_, Nothing) acc = acc
-    act (k, Just v ) acc = P.setMeta k v acc 
+    act (k, Just v ) acc = P.setMeta k v acc
 
 
 -- | Add meta to pandoc. Existing variables will be overwritten.
@@ -151,7 +159,7 @@ defWriterOpts t = def { P.writerExtensions = P.pandocExtensions, P.writerTemplat
 --   An alternative Route would be to use Builders, but this prevents User-edited Markup Templates
 reTemplateLetter :: P.PandocMonad m => P.Meta -> StoredMarkup -> m Text
 reTemplateLetter meta StoredMarkup{..}  = do
-    tmpl <- compileTemplate    strictMarkupInput
+    tmpl <- compileTemplate   strictMarkupInput
     doc <- areader readerOpts strictMarkupInput
     let writerOpts = def { P.writerExtensions = P.pandocExtensions
                          , P.writerTemplate = Just tmpl }
@@ -183,6 +191,18 @@ reTemplateLetter' meta md  = do
                      , P.readerStripComments = True
                      }
 
+mdTemplating :: Text -> P.Meta -> HandlerFor UniWorX (Either P.PandocError Text)
+mdTemplating template meta = runExceptT $ do
+  let readerOpts = def  { P.readerExtensions    = P.pandocExtensions
+                        , P.readerStripComments = True
+                        }
+  doc  <- ExceptT $ $cachedHereBinary ("pandoc: \n"   <> template) (pure . P.runPure $ P.readMarkdown readerOpts template)
+  tmpl <- ExceptT $ $cachedHereBinary ("template: \n" <> template) (pure . P.runPure $ compileTemplate template)
+  let writerOpts = def { P.writerExtensions = P.pandocExtensions
+                       , P.writerTemplate = Just tmpl
+                       }
+  ExceptT . pure . P.runPure $ P.writeMarkdown writerOpts $ appMeta setIsDeFromLang
+                                                          $ addMeta meta doc
 
 --pdfDIN5008 :: P.PandocMonad m => Text -> m LBS.ByteString -- for pandoc > 2.18
 pdfDIN5008' :: P.Meta -> Text -> P.PandocIO LBS.ByteString
@@ -263,13 +283,42 @@ pdfRenewal' meta = do
   pdfDIN5008' meta doc
 
 
+-- Generic Version
+pdfLetter :: Text -> P.Meta -> HandlerFor UniWorX (Either Text LBS.ByteString)
+pdfLetter md meta = do
+  e_txt <- mdTemplating md meta
+  result <- actRight e_txt $ pdfDIN5008 meta
+  return $ over _Left P.renderError result
+
 
 ---------------
 -- PrintJobs --
 ---------------
 
-sendLetter :: Text -> LBS.ByteString -> (Maybe UserId, Maybe UserId) -> Maybe CourseId -> Maybe QualificationId -> Maybe LmsIdent -> DB (Either Text (Text, FilePath))
+data PrintJobIdentification = PrintJobIdentification
-sendLetter printJobName pdf (printJobRecipient, printJobSender) printJobCourse printJobQualification printJobLmsUser = do
+      { pjiName           :: Text
+      , pjiRecipient      :: Maybe UserId
+      , pjiSender         :: Maybe UserId
+      , pjiCourse         :: Maybe CourseId
+      , pjiQualification  :: Maybe QualificationId
+      , pjiLmsUser        :: Maybe LmsIdent
+      }
+  deriving (Eq, Show)
+
+-- DEPRECATED
+sendLetter' :: Text -> LBS.ByteString -> (Maybe UserId, Maybe UserId) -> Maybe CourseId -> Maybe QualificationId -> Maybe LmsIdent -> DB (Either Text (Text, FilePath))
+sendLetter' printJobName pdf (printJobRecipient, printJobSender) printJobCourse printJobQualification printJobLmsUser =
+  sendLetter pdf PrintJobIdentification
+    { pjiName = printJobName
+    , pjiRecipient = printJobRecipient
+    , pjiSender = printJobSender
+    , pjiCourse = printJobCourse
+    , pjiQualification = printJobQualification
+    , pjiLmsUser = printJobLmsUser
+    }
+
+sendLetter :: LBS.ByteString -> PrintJobIdentification -> DB (Either Text (Text, FilePath))
+sendLetter pdf PrintJobIdentification{pjiName = printJobName, pjiRecipient = printJobRecipient, pjiSender = printJobSender, pjiCourse = printJobCourse, pjiQualification = printJobQualification, pjiLmsUser = printJobLmsUser} = do
   recipient <- join <$> mapM get printJobRecipient
   sender    <- join <$> mapM get printJobSender
   course    <- join <$> mapM get printJobCourse
@@ -278,24 +327,24 @@ sendLetter printJobName pdf (printJobRecipient, printJobSender) printJobCourse p
       nameSender    = abbrvName <$> sender
       nameCourse    = CI.original . courseShorthand        <$> course
       nameQuali     = CI.original . qualificationShorthand <$> quali
-  let jobFullName          = text2asciiAlphaNum $ 
+  let jobFullName          = text2asciiAlphaNum $
-                             T.replace " " "-" (T.intercalate "_" . catMaybes $ [Just printJobName, nameQuali, nameCourse, nameSender, nameRecipient]) 
+                             T.replace " " "-" (T.intercalate "_" . catMaybes $ [Just printJobName, nameQuali, nameCourse, nameSender, nameRecipient])
       printJobFilename     = T.unpack $ jobFullName <> ".pdf"
       -- printJobFile <- sinkFileDB True $ yield $ LBS.toStrict pdf   -- for PrintJobFile :: FileContentReference use this code
-      printJobFile = LBS.toStrict pdf  
+      printJobFile = LBS.toStrict pdf
       printJobAcknowledged = Nothing
-  lprPDF jobFullName pdf >>= \case  
+  lprPDF jobFullName pdf >>= \case
-    Left err -> do       
+    Left err -> do
       return $ Left err
-    Right ok -> do      
+    Right ok -> do
       printJobCreated <- liftIO getCurrentTime
       -- updateWhere [PrintJobLmsUser ==. printJobLmsUser] [PrintJobLmsUser =. Nothing] -- only one printJob per LmsUser is allowed, since otherwise the qualification table contains double rows
       insert_ PrintJob {..}
       return $ Right (ok, printJobFilename)
 
 {-
-sendLetter' :: _ -> DB PureFile
+sendLetter'' :: _ -> DB PureFile
-sendLetter' _ = do
+sendLetter'' _ = do
   ...
   return $ File { fileTitle = printJobFilename
                 , fileModified = printJobCreated
@@ -304,6 +353,132 @@ sendLetter' _ = do
 -}
 
 
+{- Probably not needed:}
+data SomeUserTime where
+  SomeUserTime :: HasLocalTime t => SelDateTimeFormat -> t -> SomeUserTime
+
+data ProtoMeta = IsMeta P.MetaValue
+               | IsTime SomeUserTime
+
+convertProto :: DateTimeFormatter -> ProtoMeta -> P.MetaValue
+convertProto _ (IsMeta v) = v
+convertProto f (IsTime t) = P.toMetaValue $ f t
+-}
+
+class MDLetter l where
+  getTemplate     :: Proxy l -> Text
+  getMailSubject  :: l -> SomeMessage UniWorX -- only used if letter is sent by email as pdf attachment
+  getMailBody     :: l -> SomeMessage UniWorX -- only used if letter is sent by email as pdf attachment
+  letterMeta      :: l -> Lang -> DateTimeFormatter -> P.Meta
+  getPJId         :: l -> PrintJobIdentification
+
+data LetterRenewQualificationF = LetterRenewQualificationF
+    { lmsLogin      :: LmsIdent
+    , lmsPin        :: Text
+    , qualHolder    :: UserDisplayName
+    , qualExpiry    :: Day
+    , qualId        :: QualificationId      
+    , qualName      :: Text
+    , qualShort     :: Text
+    , qualDuration  :: Maybe Int
+    }
+  deriving (Eq, Show)
+
+instance MDLetter LetterRenewQualificationF where
+  getTemplate     _ = templateRenewal
+  getMailSubject  l = SomeMessage $ MsgMailSubjectQualificationRenewal $ qualShort l 
+  getMailBody     l = SomeMessage $ MsgMailBodyQualificationRenewal    $ qualName  l 
+  letterMeta LetterRenewQualificationF{..} _lang DateTimeFormatter{ format } = mkMeta
+      [ toMeta "login"          lmsIdent
+      , toMeta "pin"            lmsPin
+      , toMeta "examinee"       qualHolder
+      , toMeta "expiry"         (format SelFormatDate qualExpiry)
+      , mbMeta "validduration"  (show <$> qualDuration)
+      , toMeta "url-text"       lmsUrl
+      , toMeta "url"            lmsUrlLogin
+      ]
+    where
+      lmsUrl      = "https://drive.fraport.de"
+      lmsUrlLogin = lmsUrl <> "/?login=" <> lmsIdent
+      lmsIdent    = getLmsIdent lmsLogin
+  getPJId LetterRenewQualificationF{..} =
+    PrintJobIdentification
+      { pjiName             = "Renewal"
+      , pjiRecipient        = Nothing       -- to be filled later
+      , pjiSender           = Nothing
+      , pjiCourse           = Nothing
+      , pjiQualification    = Just qualId
+      , pjiLmsUser          = Just lmsLogin
+      }
+
+sendEmailOrLetter :: (MDLetter l) => UserId -> l -> Handler Bool
+sendEmailOrLetter recipient letter = do
+  (underling, receivers, undercopy) <- liftHandler . runDB $ getReceivers recipient
+  let tmpl = getTemplate $ pure letter
+      pjid = getPJId letter
+      -- Below are only needed if sent by email
+      mailSubject = getMailSubject letter
+      mailBody    = getMailBody    letter
+      undername = underling ^. _userDisplayName -- nameHtml' underling
+      undermail = CI.original $ underling ^. _userEmail
+  now <- liftIO getCurrentTime
+  oks <- forM receivers $ \Entity{ entityKey = svr, entityVal = rcvrUsr } -> do
+    formatter@DateTimeFormatter{ format } <- getDateTimeFormatterUser' rcvrUsr
+    let (preferPost, postal) = getPostalPreferenceAndAddress rcvrUsr
+        isSupervised = recipient /= svr
+        lang  = selectDeEn $ rcvrUsr & userLanguages   -- select either German or English only, default de; see Utils.Lang
+        lMeta = letterMeta letter lang formatter <> mkMeta
+                  [ toMeta "lang"         lang
+                  , toMeta "date"       $ format SelFormatDate now
+                  , toMeta "address"    $ fromMaybe [rcvrUsr & userDisplayName] postal
+                  , mbMeta "supervisor" $ toMaybe isSupervised (rcvrUsr & userDisplayName)
+                  ]
+    pdfLetter tmpl lMeta >>= \case
+      _ | preferPost, isNothing postal -> do -- neither email nor postal is known
+        encRecipient :: CryptoUUIDUser <- encrypt svr
+        let msg = "Notification failed for " <> tshow encRecipient <> ", who has neither a known email nor postal address. Notification: " <> tshow pjid
+        $logErrorS "LETTER" msg
+        return False
+      Left err -> do -- pdf generation failed
+        encRecipient :: CryptoUUIDUser <- encrypt svr
+        let msg = "Notification failed for " <> tshow encRecipient <> ". PDF generation failed: "<> cropText err <> "For Notification: " <> tshow pjid
+        $logErrorS "LETTER" msg
+        return False
+      Right pdf | preferPost -> -- send letter
+        runDB (sendLetter pdf pjid{ pjiRecipient = Just svr}) >>= \case
+          Left err -> do
+            encRecipient :: CryptoUUIDUser <- encrypt svr
+            let msg = "Notification failed for " <> tshow encRecipient <> ". PDF printing failed. The print job could not be sent: " <> cropText err
+            $logErrorS "LETTER" msg
+            return False
+          Right (msg,_)
+            | null msg  -> return True
+            | otherwise -> do
+                $logWarnS "LETTER" $ "PDF printing to send letter with lpr returned ExitSuccess and the following message: " <> msg
+                return True
+      Right pdf -> do -- send email
+        attachment <- case userPinPassword rcvrUsr of
+          Nothing     -> return pdf
+          Just passwd -> encryptPDF passwd pdf >>= \case
+            Right encPdf -> return encPdf
+            Left err -> do
+              encRecipient :: CryptoUUIDUser <- encrypt svr
+              let msg = "Notification for " <> tshow encRecipient <> " has unencrypted attachment. Encrypting PDF failed: " <> cropText err
+              $logWarnS "LETTER" msg
+              return pdf
+        userMailTdirect svr $ do
+          replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
+          setSubjectI mailSubject
+          editNotifications <- mkEditNotifications svr
+          let supername = rcvrUsr ^. _userDisplayName -- nameHtml' rcvrUsr
+          addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/genericMailLetter.hamlet")
+          addPart (File { fileTitle     = T.unpack $ pjiName pjid
+                        , fileModified  = now
+                        , fileContent   = Just $ yield $ LBS.toStrict attachment
+                        } :: PureFile)
+          return True
+  return $ or oks
+
 
 -----------------------------
 -- Typed Process Utilities --
@@ -312,9 +487,9 @@ sendLetter' _ = do
 -- | Converts Triple consisting of @ExitCode@, Success- and Failure-Value to Either Failue- or Success-Value.
 --   Returns @Right@  if the @ExitCode@ is @ExitsSuccess, entirely ignoring the Failure-Value, which might contain warning messages.
 --   To be used with 'System.Process.Typed.readProcess'
-exit2either :: (ExitCode, a, b) -> Either b a
+exit2either :: Monoid a => (ExitCode, a, a) -> Either a a
-exit2either (ExitSuccess   , ok,   _) = Right ok   -- warnings are ignored here!
+exit2either (ExitSuccess   , stdOut,  errOut) = Right $ stdOut <> errOut
-exit2either (ExitFailure _ ,  _, err) = Left err
+exit2either (ExitFailure _ , stdOut,  errOut) = Left  $ stdOut <> errOut
 
 
 readProcess' :: MonadIO m => ProcessConfig stdin stdoutIgnored stderrIgnored -> m (ExitCode, Text, Text)
@@ -325,10 +500,10 @@ readProcess' pc = do
   return (ec, st_err, st_out)
 
 
-sanitizeCmdArg :: Text -> Text 
+sanitizeCmdArg :: Text -> Text
 sanitizeCmdArg =  T.filter (\c -> c /= '\'' && c /= '"' && c/= '\\' && not (isSeparator c))
 -- | Returns Nothing if ok, otherwise the first mismatching character
---   Pin Password is used as a commandline argument in Utils.Print.encryptPDF and hence poses a security risk 
+--   Pin Password is used as a commandline argument in Utils.Print.encryptPDF and hence poses a security risk
 validCmdArgument :: Text -> Maybe Char
 validCmdArgument t = t `textDiff` sanitizeCmdArg t
 
@@ -372,11 +547,11 @@ encryptPDF pw bs = over _Left (decodeUtf8 . LBS.toStrict) . exit2either <$> read
 
 -- | Internal only, use `sendLetter` instead
 lprPDF :: (MonadHandler m, HasAppSettings (HandlerSite m)) => Text -> LBS.ByteString -> m (Either Text Text)
-lprPDF jb bs = do 
+lprPDF jb bs = do
-    lprServerArg <- $cachedHereBinary ("lprServer"::Text) getLprServerArg 
+    lprServerArg <- $cachedHereBinary ("lprServer"::Text) getLprServerArg
     let pc = setStdin (byteStringInput bs) $
-              proc "lpr" $ 
+              proc "lpr" $
-                jobname ++                                      -- -J jobname -- a name for job identification at printing site      
+                jobname ++                                      -- -J jobname -- a name for job identification at printing site
                 [ lprServerArg                                  -- -P queue@hostname:port
                 , "-"                                           -- read from stdin
                 ]
@@ -384,15 +559,15 @@ lprPDF jb bs = do
                 | otherwise = ["-J " <> jb']
         jb' = T.unpack $ sanitizeCmdArg jb
     exit2either <$> readProcess' pc
-  where 
+  where
-    getLprServerArg = do 
+    getLprServerArg = do
       LprConf{..} <- getsYesod $ view _appLprConf
       return $ "-P " <> lprQueue <> "@" <> lprHost <> ":" <> show lprPort
 
 
 {- -- Variant without caching
 lprPDF' :: (MonadHandler m, HasAppSettings (HandlerSite m)) => String -> LBS.ByteString -> m (Either Text Text)
-lprPDF' jb bs = do 
+lprPDF' jb bs = do
   LprConf{..} <- getsYesod $ view _appLprConf
   let lprServer = lprQueue <> "@" <> lprHost <> ":" <> show lprPort
       pc =  setStdin (byteStringInput bs) $

src/Utils/Set.hs

@@ -11,8 +11,10 @@ module Utils.Set
 , setPartitionEithers
 , setFromFunc
 , mapIntersectNotOne
+, set2NonEmpty
 ) where 
 
+import qualified Data.List.NonEmpty as NonEmpty
 import qualified Data.Set as Set
 import qualified Data.Map.Strict()
 import qualified Data.Map as Map
@@ -65,4 +67,10 @@ setPartitionEithers :: (Ord a, Ord b) => Set (Either a b) -> (Set a, Set b)
 setPartitionEithers = (,) <$> setMapMaybe (preview _Left) <*> setMapMaybe (preview _Right)
 
 setFromFunc :: (Finite k, Ord k) => (k -> Bool) -> Set k
-setFromFunc = Set.fromList . flip filter universeF
+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.:| []

templates/avs.hamlet

@@ -6,7 +6,39 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
 
 <section>
   <p> 
-    Person Search:
+    Upsert User by CardNo or Fraport Personnel Number:
+    ^{crUsrForm}
+  $maybe answer <- mbCrUser
+    <p>
+      ^{answer}  
+
+<section>
+  <p> 
+    Get Licence by AVS Person ID:
+    ^{getLicForm}
+  $maybe answer <- mbGetLic
+    <p>
+      ^{answer}  
+
+<section>
+  <p> 
+    Set Licence by AVS Person ID:
+    ^{setLicForm}
+  $maybe answer <- mbSetLic
+    <p>
+      ^{answer}  
+
+<section>
+  <p> 
+    Synchronize licences with AVS.
+    ^{qryLicForm}
+  $maybe answer <- mbQryLic
+    <p>
+      ^{answer}  
+
+<section>
+  <p> 
+    Person search:
     ^{personForm}
   $maybe answer <- mbPerson
     <p>
@@ -15,7 +47,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
 
 <section>
   <p> 
-    Person Status:
+    Person status:
     ^{statusForm}
   $maybe answer <- mbStatus
     <p>

templates/letter/fraport_renewal.md

@@ -9,7 +9,7 @@ email: fahrerausbildung@fraport.de
 place: Frankfurt am Main
 return-address: 
  - 60547 Frankfurt
-de-opening: Sehr geehrte Damen und Herren,
+de-opening: Liebe Fahrer,
 en-opening: Dear driver,
 de-closing: |
   Mit freundlichen Grüßen,
@@ -30,7 +30,7 @@ is-de: true
 login: 123456
 pin: abcdef
 # Emfpänger
-recipient: E. M. Pfänger
+examinee: E. M. Pfänger
 address:
  - Musterfirma GmbH
  - E. M. Pfänger
@@ -53,17 +53,32 @@ $endfor$
 $if(is-de)$
 
 <!-- deutsche Version des Briefes  -->
-die Gültigkeit Ihres Vorfeldführerscheins läuft demnächst ab, am $expiry$.
+die Gültigkeit 
-Durch die erfolgreiche Teilnahme an einem E-Learning können Sie die Gültigkeit
+$if(supervisor)$
+  des Vorfeldführerscheins von $examinee$ 
+$else$
+  Ihres Vorfeldführerscheins
+$endif$
+läuft bald ab.
+Durch die erfolgreiche Teilnahme an einem E-Learning kann die Gültigkeit
 $if(validduration)$
   um $validduration$ Monate
 $endif$
-verlängern. Verwenden Sie dazu die
+verlängert werden. 
-Login-Daten aus dem geschützen Sichtfenster weiter unten.
+$if(supervisor)$
+  Ansprechpartner werden gebeten, die Login-Daten aus dem geschützen Sichtfenster weiter unten
+  vertraulich an den Prüfling weiterzuleiten.
+$else$
+  Dazu bitte die Login-Daten aus dem geschützen Sichtfenster weiter unten verwenden.  
+$endif$
 
 Prüfling
 
-  : $recipient$
+  : $examinee$
+
+Ablaufdatum
+
+  : $expiry$
 
 URL
 
@@ -71,7 +86,7 @@ URL
 
 
 Sobald die Frist abgelaufen ist, muss zur Wiedererlangung der Fahrberechtigung "F"
-erneut der Grundkurs bei der Fahrerausbildung absolviert werden.
+erneut der komplette Grundkurs bei der Fahrerausbildung absolviert werden.
 
 
 Bei Fragen können Sie sich gerne an das Team der Fahrerausbildung wenden.
@@ -80,25 +95,40 @@ $else$
 
 <!-- englische Version des Briefes  -->
 
-your apron diving license is about to expire soon, on $expiry$.
+$if(supervisor)$
-You can extend the validity
+  the apron diving license of $examinee$ 
+$else$
+  your apron diving license 
+$endif$  
+is about to expire soon.
+The validity may be extended
 $if(validduration)$
   by $validduration$ months
 $endif$
 by successfully participating in
-an e-learning. Please use the login data from the protected area below.
+an e-learning. 
+$if(supervisor)$
+  Supervisors are kindly requested to confidentially forward the login data 
+  from the protected area below to the examinee.
+$else$
+  Please use the login data from the protected area below.
+$endif$  
 
 Examinee
 
-  : $recipient$
+  : $examinee$
+
+Expiry
+
+  : $expiry$
 
 URL
 
   :[$url-text$]($url$)
 
 
-Should your apron driving license expire before completing this 
+Should the apron driving license expire before completing this 
-e-learning course, then a renewal requires your full participation
+e-learning, a later renewal then requires full participation
 of the basic training course again.
 
 

templates/mail/genericMailLetter.hamlet

@@ -0,0 +1,44 @@
+$newline never
+
+$# SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
+$#
+$# SPDX-License-Identifier: AGPL-3.0-or-later
+
+\<!doctype html>
+<html>
+  <head>
+    <meta charset="UTF-8">
+    <style>
+      h1 {
+        font-size: 1.25em;
+        font-variant: small-caps;
+        font-weight: normal;
+      }
+  <body>
+    <h1>
+      _{mailSubject}
+
+    <p>
+      _{mailBody}      
+
+    $if isSupervised
+      <h2>_{SomeMessage MsgMailSupervisorNote}
+      <p>
+        _{SomeMessage (MsgMailSupervisorBody undername supername)} #
+        <a href=@{NewsR}>
+          FRADrive
+        .
+        $if undercopy
+          _{SomeMessage (MsgMailSupervisorCopy undermail)}
+        $else
+          _{SomeMessage MsgMailSupervisorNoCopy}
+    $else 
+      <h2>_{SomeMessage MsgMailSupervisedNote}
+      <p>
+        _{SomeMessage MsgMailSupervisedBody}
+        <ul>
+          $forall svr <- receivers
+            <li>
+              #{nameHtml' svr}
+        
+    ^{ihamletSomeMessage editNotifications}

templates/mail/qualificationRenewal.hamlet

@@ -1,41 +0,0 @@
-$newline never
-
-$# SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
-$#
-$# SPDX-License-Identifier: AGPL-3.0-or-later
-
-\<!doctype html>
-<html>
-  <head>
-    <meta charset="UTF-8">
-    <style>
-      h1 {
-        font-size: 1.25em;
-        font-variant: small-caps;
-        font-weight: normal;
-      }
-  <body>
-    <h1>
-      _{SomeMessage $ MsgMailSubjectQualificationRenewal qname}
-
-    <p>
-      _{SomeMessage MsgMailBodyQualificationRenewal}      
-
-    <p>
-      <dl>
-        <dt>_{SomeMessage MsgQualificationName}
-        <dd>
-          <a href=@{QualificationR qualificationSchool qualificationShorthand}>
-            #{qualificationName}
-        <dt>_{SomeMessage MsgLmsUser}
-        <dd>#{nameHtml userDisplayName userSurname}
-        <dt>_{SomeMessage MsgLmsQualificationValidUntil}
-        <dd>#{expiryDate}
-
-    <p>
-      _{SomeMessage MsgLmsRenewalInstructions} #
-
-      <a href=#{lmsLogin}>
-        _{SomeMessage MsgMppURL} #{lmsUrl}
-
-    ^{ihamletSomeMessage editNotifications}

test/Database/Fill.hs

@@ -113,7 +113,7 @@ fillDb = do
     , userShowSex = userDefaultShowSex
     , userTelephone = Nothing
     , userMobile = Nothing
-    , userCompanyPersonalNumber = Nothing
+    , userCompanyPersonalNumber = Just "00000"
     , userCompanyDepartment = Nothing
     , userPinPassword = Nothing
     , userPostAddress = Nothing
@@ -271,7 +271,7 @@ fillDb = do
     , userShowSex = userDefaultShowSex
     , userTelephone = Nothing
     , userMobile = Nothing
-    , userCompanyPersonalNumber = Nothing
+    , userCompanyPersonalNumber = Just "12345"
     , userCompanyDepartment = Nothing
     , userPinPassword = Nothing
     , userPostAddress = Nothing
@@ -478,6 +478,11 @@ fillDb = do
             I am aware that violations in the form plagiarism or collaboration with third parties will lead to expulsion from the course.
         |]
     }
+  _fraportAg <- insert' $ Company "Fraport AG"                                          "Fraport"
+  _fraGround <- insert' $ Company "Fraport Ground Handling Professionals GmbH"          "FraGround"
+  _nice      <- insert' $ Company "N*ICE Aircraft Services & Support GmbH"              "N*ICE"
+  _ffacil    <- insert' $ Company "Fraport Facility Services GmbH"                      "GCS"
+  _bpol      <- insert' $ Company "Bundespolizeidirektion Flughafen Frankfurt am Main"  "BPol"
   ifi <- insert' $ School "Institut für Informatik" "IfI" (Just $ 14 * nominalDay) (Just $ 10 * nominalDay) True (ExamModeDNF predDNFFalse) (ExamCloseOnFinished True) SchoolAuthorshipStatementModeOptional (Just ifiAuthorshipStatement) True SchoolAuthorshipStatementModeRequired (Just ifiAuthorshipStatement) False
   mi  <- insert' $ School "Institut für Mathematik" "MI" Nothing Nothing False (ExamModeDNF predDNFFalse) (ExamCloseOnFinished False) SchoolAuthorshipStatementModeNone Nothing True SchoolAuthorshipStatementModeOptional Nothing True
   avn <- insert' $ School "Fahrerausbildung" "FA" Nothing Nothing False (ExamModeDNF predDNFFalse) (ExamCloseOnFinished False) SchoolAuthorshipStatementModeNone Nothing True SchoolAuthorshipStatementModeOptional Nothing True
@@ -506,9 +511,9 @@ fillDb = do
   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.|]
   let l_descr = Just $ htmlToStoredMarkup [shamlet|<p>für unhabilitierte|]
-  qid_f  <- insert' $ Qualification avn "F" "Vorfeldführerschein"  f_descr (Just 24) (Just 6) (Just $ CalendarDiffDays 0 60) True  $ Just "F4466"
+  qid_f  <- insert' $ Qualification avn "F" "Vorfeldführerschein"  f_descr (Just 24) (Just 6) (Just $ CalendarDiffDays 0 60) True  (Just AvsLicenceVorfeld)  $ Just "F4466"
-  qid_r  <- insert' $ Qualification avn "R" "Rollfeldführerschein" r_descr (Just 24) (Just 6) (Just $ CalendarDiffDays 2 3)  False $ Just "R2801"
+  qid_r  <- insert' $ Qualification avn "R" "Rollfeldführerschein" r_descr (Just 24) (Just 6) (Just $ CalendarDiffDays 2 3)  False (Just AvsLicenceRollfeld) $ Just "R2801"
-  qid_l  <- insert' $ Qualification ifi "L" "Lehrbefähigung"       l_descr Nothing   (Just 6) Nothing True Nothing
+  qid_l  <- insert' $ Qualification ifi "L" "Lehrbefähigung"       l_descr Nothing   (Just 6) Nothing True Nothing Nothing
   void . insert' $ QualificationUser jost       qid_f (n_day    9) (n_day $   -1) (n_day $   -22) Nothing -- TODO: better dates!
   void . insert' $ QualificationUser jost       qid_r (n_day   99) (n_day $  -11) (n_day $  -222) (Just $ QualificationBlockedLms $ n_day $ -5)-- TODO: better dates!
   void . insert' $ QualificationUser jost       qid_l (n_day  999) (n_day $ -111) (n_day $ -2222) Nothing -- TODO: better dates!

test/Utils/TypesSpec.hs

@@ -7,6 +7,9 @@ module Utils.TypesSpec where
 import TestImport
 import Utils
 
+import qualified Data.Aeson as Aeson
+
+
 instance Arbitrary SloppyBool where 
   arbitrary = SloppyBool <$> arbitrary
   shrink (SloppyBool x) = SloppyBool <$> shrink x
@@ -16,8 +19,8 @@ instance Arbitrary AvsPersonId where
   shrink (AvsPersonId x) = AvsPersonId <$> shrink x
 
 instance Arbitrary AvsCardNo where 
-  arbitrary = AvsCardNo <$> arbitrary
+  arbitrary = AvsCardNo . normalizeAvsCardNo <$> arbitrary
-  shrink (AvsCardNo x) = AvsCardNo <$> shrink x
+  shrink (AvsCardNo x) = AvsCardNo . normalizeAvsCardNo <$> shrink x
 
 instance Arbitrary AvsLicence where 
   arbitrary = genericArbitrary
@@ -52,7 +55,7 @@ instance Arbitrary AvsLicenceResponse where
   shrink = genericShrink
 
 instance Arbitrary AvsResponsePerson where
-  arbitrary = genericArbitrary
+  arbitrary = resize 5 genericArbitrary
   shrink = genericShrink
 
 instance Arbitrary AvsResponseStatus where
@@ -95,6 +98,8 @@ spec = do
       [ eqLaws, ordLaws, showLaws, jsonLaws ]
     lawsCheckHspec (Proxy @AvsDataPerson)                        --iso failed
       [ eqLaws, ordLaws, showLaws, jsonLaws ]
+    lawsCheckHspec (Proxy @AvsLicence)
+      [ eqLaws, ordLaws, showLaws, jsonLaws, persistFieldLaws ]
     lawsCheckHspec (Proxy @AvsPersonLicence)
       [ eqLaws, ordLaws, showLaws, jsonLaws ]
     lawsCheckHspec (Proxy @AvsLicenceResponse)
@@ -116,6 +121,24 @@ spec = do
     lawsCheckHspec (Proxy @AvsQuerySetLicences)
       [ eqLaws, showLaws, jsonLaws]
 
+  describe "AvsLicence" $ do       
+    it "ordering is consistent with its PersistField instance" . property $ -- this assumption is used in Handler.Utils.Avs.checkLicences
+      \a (b :: AvsLicence) -> compare a b == compare (toPersistValue a) (toPersistValue b)
+    it "assigns AvsLicence fixed SQL values" . example $ do    -- ensure that DB encoding does not change unnoticed
+      toPersistValue AvsLicenceVorfeld  `shouldBe` toPersistValue (1::Int64)
+      toPersistValue AvsLicenceRollfeld `shouldBe` toPersistValue (2::Int64)
+    it "assigns AvsLicence fixed JSON values" . example $ do   -- ensure that SQL encoding does not change unnoticed
+      Aeson.toJSON AvsLicenceVorfeld  `shouldBe` Aeson.Number 1
+      Aeson.toJSON AvsLicenceRollfeld `shouldBe` Aeson.Number 2
+
+  describe "Ord AvsPersonLicence" $ do 
+    it "proritises avsLicenceRampLicence" . property $ 
+      \p0 p1@AvsPersonLicence{avsLicenceRampLicence=v1} ->
+        let p2@AvsPersonLicence{avsLicenceRampLicence=v2} = p0 in
+        (v1 /= v2) ==> compare p1 p2 == compare v1 v2
+    it "has antitone Function avsPersonLicenceIsGEQ" . property $ -- this assumption is used in Handler.Utils.Avs.checkLicences
+      \j k l -> j < k ==> avsPersonLicenceIsLEQ j l >= avsPersonLicenceIsLEQ k l
+
   describe "Ord AvsDataCard" $ do
     it "prioritises avsDataValid" . property $
       \p0 p1@AvsDataPersonCard{avsDataValid=v1} ->

testdata/test_letters.hs

@@ -28,7 +28,7 @@ mdTmpl = "---\nfoo: fooOrg\nbar: barOrg\n---\nHere is some text\n - foo: $foo$\n
 -- Current Function found in Handler.PrintCenter, but is no longer exported!
 mprToMeta :: MetaPinRenewal -> P.Meta
 mprToMeta MetaPinRenewal{..} = P.Meta $ mconcat
-  [ toMeta "recipient"  mppRecipient
+  [ toMeta "examinee"  mppExaminee
   , toMeta "address"   (mppAddress & html2textlines)
   , toMeta "login"      mppLogin
   , toMeta "pin"        mppPin