Merge branch 'fradrive/api-avs'
This commit is contained in:
Steffen Jost
commit
8d97de096b
@ -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.
|
||||
|
||||
@ -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.
|
||||
|
||||
@ -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
|
||||
@ -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
|
||||
@ -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
|
||||
SystemSap: SAP Verwalter:in
|
||||
SystemPrinter: Drucker:in
|
||||
@ -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
|
||||
SystemSap: SAP Administrator
|
||||
SystemPrinter: Printing staff
|
||||
@ -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
|
||||
@ -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
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
MailSubjectQualificationExpiry qname@Text: Qualification #{qname} expires soon
|
||||
MailSubjectQualificationExpired qname@Text: Qualification #{qname} is no longer valid
|
||||
MailBodyQualificationRenewal: You will soon need to renew this qualficiation by completing an e-learning course.
|
||||
MailSubjectQualificationRenewal qname: Qualification #{qname} must be renewed shortly
|
||||
MailSubjectQualificationExpiry qname: Qualification #{qname} expires soon
|
||||
MailSubjectQualificationExpired qname: Qualification #{qname} is no longer valid
|
||||
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
|
||||
|
||||
@ -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:
|
||||
@ -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:
|
||||
@ -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
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
user UserId
|
||||
personId AvsPersonId -- unique identifier for user throughout avs; newtype for Int
|
||||
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
|
||||
|
||||
22
models/company.model
Normal file
22
models/company.model
Normal file
@ -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
|
||||
@ -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:
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
45
routes
45
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/password UserPasswordR GET POST !selfANDis-pw-hash
|
||||
!/users/functionary-invite/new AdminNewFunctionaryInviteR GET POST
|
||||
!/users/functionary-invite AdminFunctionaryInviteR GET POST
|
||||
/users/#CryptoUUIDUser/notifications UserNotificationR GET POST !self
|
||||
/users/#CryptoUUIDUser/password UserPasswordR GET POST !selfANDis-pw-hash
|
||||
!/users/functionary-invite/new AdminNewFunctionaryInviteR 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/profile ProfileDataR GET !free
|
||||
/user/authpreds AuthPredsR GET POST !free
|
||||
/user/set-display-email SetDisplayEmailR GET POST !free
|
||||
/user/csv-options CsvOptionsR GET POST !free
|
||||
/user/lang LangR POST !free
|
||||
/user/storage-key StorageKeyR POST !free
|
||||
/user ProfileR GET POST !free
|
||||
/user/profile ProfileDataR GET !free
|
||||
/user/authpreds AuthPredsR GET POST !free
|
||||
/user/set-display-email SetDisplayEmailR GET POST !free
|
||||
/user/csv-options CsvOptionsR GET POST !free
|
||||
/user/lang LangR 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/#SchoolId QualificationSchoolR GET !free -- TODO repurpose
|
||||
/qualification QualificationAllR GET -- 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/direct LmsUserlistDirectR POST
|
||||
/lms/#SchoolId/#QualificationShorthand/userlist/upload LmsUserlistUploadR GET POST -- development
|
||||
/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/direct LmsResultDirectR POST
|
||||
/lms/#SchoolId/#QualificationShorthand/fake LmsFakeR GET POST -- TODO: delete this testing URL
|
||||
/lms/#SchoolId/#QualificationShorthand/result/upload LmsResultUploadR GET POST -- development
|
||||
/lms/#SchoolId/#QualificationShorthand/result/direct LmsResultDirectR POST !token
|
||||
|
||||
/api ApiDocsR GET !free
|
||||
/swagger SwaggerR GET !free
|
||||
|
||||
@ -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]
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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)
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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 SetDisplayEmailR = i18nCrumb MsgUserDisplayEmail $ Just ProfileR
|
||||
breadcrumb ProfileDataR = i18nCrumb MsgMenuProfileData $ Just ProfileR
|
||||
breadcrumb AuthPredsR = i18nCrumb MsgMenuAuthPreds $ Just ProfileR
|
||||
breadcrumb CsvOptionsR = i18nCrumb MsgCsvOptions $ Just ProfileR
|
||||
breadcrumb LangR = i18nCrumb MsgMenuLanguage $ Just ProfileR
|
||||
breadcrumb ProfileR = i18nCrumb MsgBreadcrumbProfile Nothing
|
||||
breadcrumb ForProfileR{} = i18nCrumb MsgBreadcrumbProfile Nothing
|
||||
breadcrumb SetDisplayEmailR = i18nCrumb MsgUserDisplayEmail $ Just ProfileR
|
||||
breadcrumb ProfileDataR = i18nCrumb MsgMenuProfileData $ Just ProfileR
|
||||
breadcrumb (ForProfileDataR cID) = i18nCrumb MsgMenuProfileData $ Just (ForProfileR cID)
|
||||
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
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
{ formAction = Just $ SomeRoute actionUrl
|
||||
, formEncoding = penctype
|
||||
}
|
||||
statusForm = wrapForm swidget def
|
||||
{ formAction = Just $ SomeRoute actionUrl
|
||||
, formEncoding = senctype
|
||||
}
|
||||
let wrapFormHere fw fe = wrapForm fw def { formAction = Just $ SomeRoute actionUrl, formEncoding = fe }
|
||||
personForm = wrapFormHere pwidget penctype
|
||||
statusForm = wrapFormHere swidget senctype
|
||||
crUsrForm = wrapFormHere crUsrWgt crUsrEnctype
|
||||
getLicForm = wrapFormHere getLicWgt getLicEnctype
|
||||
setLicForm = wrapFormHere setLicWgt setLicEnctype
|
||||
qryLicForm = wrapForm qryLicWgt def { formAction = Just $ SomeRoute actionUrl, formEncoding = qryLicEnctype, formSubmit = FormNoSubmit }
|
||||
-- TODO: use i18nWidgetFile instead if this is to become permanent
|
||||
$(widgetFile "avs")
|
||||
|
||||
@ -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.PDF as P
|
||||
import qualified Text.Pandoc 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"
|
||||
|
||||
|
||||
|
||||
@ -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 = do
|
||||
mkLmsAllTable :: Bool -> DB (Any, Widget)
|
||||
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}>
|
||||
Link to PrintJob
|
||||
<a href=@{lu}>
|
||||
_{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)
|
||||
|
||||
|
||||
@ -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 (firstNames, userSurname, (userLanguages, userDateTimeFormat, userDateFormat, userTimeFormat), userPrefersPostal) =
|
||||
fakeUser :: ([Text], UserSurname, (Maybe Languages, DateTimeFormat, DateTimeFormat, DateTimeFormat), Bool, Int) -> User
|
||||
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)
|
||||
|
||||
@ -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]
|
||||
|
||||
@ -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
|
||||
[ toMeta "recipient" mppRecipient
|
||||
, toMeta "address" (mppRecipient : (mppAddress & html2textlines))
|
||||
-- formatTimeUser SelFormatDate mppDate mppExaminee
|
||||
[ toMeta "examinee" mppExaminee
|
||||
, 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 "pj-acknowledged") (i18nCell MsgPrintJobAcknowledged) $ \( view $ resultPrintJob . _entityVal . _printJobAcknowledged -> t) -> maybeDateTimeCell t
|
||||
, sortable (Just "pj-filename") (i18nCell MsgPrintPDF) $ \r -> let k = r ^. resultPrintJob . _entityKey
|
||||
t = r ^. resultPrintJob . _entityVal . _printJobFilename
|
||||
in anchorCellM (PrintDownloadR <$> encrypt k) (toWgt t)
|
||||
, sortable (Just "pj-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 "pj-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 "pj-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 "created") (i18nCell MsgPrintJobCreated) $ \( view $ resultPrintJob . _entityVal . _printJobCreated -> t) -> dateTimeCell t
|
||||
, sortable (Just "acknowledged") (i18nCell MsgPrintJobAcknowledged) $ \( view $ resultPrintJob . _entityVal . _printJobAcknowledged -> t) -> maybeDateTimeCell t
|
||||
, sortable (Just "filename") (i18nCell MsgPrintPDF) $ \r -> let k = r ^. resultPrintJob . _entityKey
|
||||
t = r ^. resultPrintJob . _entityVal . _printJobFilename
|
||||
in anchorCellM (PrintDownloadR <$> encrypt k) (toWgt t)
|
||||
, sortable (Just "name") (i18nCell MsgPrintJobName) $ \( view $ resultPrintJob . _entityVal . _printJobName -> n) -> textCell n
|
||||
, sortable (Just "recipient") (i18nCell MsgPrintRecipient) $ \(preview resultRecipient -> u) -> maybeCell u $ cellHasUserLink AdminUserR
|
||||
, sortable (Just "sender") (i18nCell MsgPrintSender) $ \(preview resultSender -> u) -> maybeCell u $ cellHasUserLink AdminUserR
|
||||
, sortable (Just "course") (i18nCell MsgPrintCourse) $ \(preview $ resultCourse . _entityVal -> c) -> maybeCell c courseCell
|
||||
, sortable (Just "qualification")(i18nCell MsgPrintQualification) $ \(preview $ resultQualification . _entityVal -> q) -> maybeCell q qualificationCell
|
||||
, sortable (Just "lmsid") (i18nCell MsgPrintLmsUser) $ \( view $ resultPrintJob . _entityVal . _printJobLmsUser -> l) -> foldMap textCell (getLmsIdent <$> l)
|
||||
]
|
||||
dbtSorting = mconcat
|
||||
[ single ("pj-name" , SortColumn $ queryPrintJob >>> (E.^. PrintJobName))
|
||||
, single ("pj-filename" , SortColumn $ queryPrintJob >>> (E.^. PrintJobFilename))
|
||||
, single ("pj-created" , SortColumn $ queryPrintJob >>> (E.^. PrintJobCreated))
|
||||
, single ("pj-acknowledged" , SortColumn $ queryPrintJob >>> (E.^. PrintJobAcknowledged))
|
||||
, single ("pj-recipient" , sortUserNameBareM queryRecipient)
|
||||
, single ("pj-sender" , sortUserNameBareM querySender )
|
||||
, single ("pj-course" , SortColumn $ queryCourse >>> (E.?. CourseName))
|
||||
, single ("pj-qualification", SortColumn $ queryQualification >>> (E.?. QualificationName))
|
||||
, single ("pj-lmsid" , SortColumn $ queryPrintJob >>> (E.^. PrintJobLmsUser))
|
||||
[ single ("name" , SortColumn $ queryPrintJob >>> (E.^. PrintJobName))
|
||||
, single ("filename" , SortColumn $ queryPrintJob >>> (E.^. PrintJobFilename))
|
||||
, single ("created" , SortColumn $ queryPrintJob >>> (E.^. PrintJobCreated))
|
||||
, single ("acknowledged" , SortColumn $ queryPrintJob >>> (E.^. PrintJobAcknowledged))
|
||||
, single ("recipient" , sortUserNameBareM queryRecipient)
|
||||
, single ("sender" , sortUserNameBareM querySender )
|
||||
, single ("course" , SortColumn $ queryCourse >>> (E.?. CourseName))
|
||||
, single ("qualification", SortColumn $ queryQualification >>> (E.?. QualificationName))
|
||||
, single ("lmsid" , SortColumn $ queryPrintJob >>> (E.^. PrintJobLmsUser))
|
||||
]
|
||||
dbtFilter = mconcat
|
||||
[ single ("pj-name" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobName))
|
||||
, single ("pj-filename" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobFilename))
|
||||
, single ("pj-created" , FilterColumn . E.mkDayFilter $ views (to queryPrintJob) (E.^. PrintJobCreated))
|
||||
--, single ("pj-created" , FilterColumn . E.mkDayBetweenFilter $ views (to queryPrintJob) (E.^. PrintJobCreated))
|
||||
, single ("pj-recipient" , FilterColumn . E.mkContainsFilterWith Just $ views (to queryRecipient) (E.?. UserDisplayName))
|
||||
, single ("pj-sender" , FilterColumn . E.mkContainsFilterWith Just $ views (to querySender) (E.?. UserDisplayName))
|
||||
, single ("pj-course" , FilterColumn . E.mkContainsFilterWith Just $ views (to queryCourse) (E.?. CourseName))
|
||||
, single ("pj-qualification", FilterColumn . E.mkContainsFilterWith Just $ views (to queryQualification) (E.?. QualificationName))
|
||||
, single ("pj-lmsid" , FilterColumn . E.mkContainsFilterWith Just $ views (to queryPrintJob) (E.^. PrintJobLmsUser))
|
||||
[ single ("name" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobName))
|
||||
, single ("filename" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobFilename))
|
||||
, single ("created" , FilterColumn . E.mkDayFilter $ views (to queryPrintJob) (E.^. PrintJobCreated))
|
||||
--, single ("created" , FilterColumn . E.mkDayBetweenFilter $ views (to queryPrintJob) (E.^. PrintJobCreated))
|
||||
, single ("recipient" , FilterColumn . E.mkContainsFilterWith Just $ views (to queryRecipient) (E.?. UserDisplayName))
|
||||
, single ("sender" , FilterColumn . E.mkContainsFilterWith Just $ views (to querySender) (E.?. UserDisplayName))
|
||||
, single ("course" , FilterColumn . E.mkContainsFilterWith Just $ views (to queryCourse) (E.?. CourseName))
|
||||
, single ("qualification", FilterColumn . E.mkContainsFilterWith Just $ views (to queryQualification) (E.?. QualificationName))
|
||||
, 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 "pj-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 "pj-created" . maybePrism _PathPiece) mPrev ((,) <$> aopt (hoistField lift dayField) (fslI MsgPrintJobCreated)
|
||||
[ prismAForm (singletonFilter "name" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintJobName)
|
||||
, prismAForm (singletonFilter "filename" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintJobFilename)
|
||||
, prismAForm (singletonFilter "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 "pj-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 "pj-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 "recipient" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintRecipient)
|
||||
, prismAForm (singletonFilter "sender" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintSender)
|
||||
, prismAForm (singletonFilter "course" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintCourse)
|
||||
, prismAForm (singletonFilter "qualification". maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintQualification)
|
||||
, 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
|
||||
|
||||
@ -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
|
||||
getProfileR = postProfileR
|
||||
postProfileR = do
|
||||
(uid, user@User{..}) <- requireAuthPair
|
||||
getForProfileR , postForProfileR :: CryptoUUIDUser -> Handler Html
|
||||
getForProfileR = postForProfileR
|
||||
postForProfileR cID = do
|
||||
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 )
|
||||
|
||||
@ -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
|
||||
|
||||
@ -4,8 +4,9 @@
|
||||
|
||||
module Handler.Users.Add
|
||||
( getAdminUserAddR, postAdminUserAddR
|
||||
-- , AdminUserForm(..), adminUserForm -- no longer needed elsewhere
|
||||
-- , AuthenticationKind(..), classifyAuth, mkAuthMode -- no longer needed elsewhere
|
||||
, AdminUserForm(..), AuthenticationKind(..)
|
||||
, 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 $ \AdminUserForm{..} -> 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
|
||||
formResult userRes $ addNewUser >=> \case
|
||||
(Just uid) -> do
|
||||
addMessageI Success MsgUserAdded
|
||||
cID <- encrypt uid
|
||||
redirect $ AdminUserR cID
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -2,10 +2,12 @@
|
||||
--
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
|
||||
module Handler.Utils.Avs
|
||||
( -- upsertAvsUser
|
||||
--, checkLicences
|
||||
getLicence, getLicenceDB
|
||||
( upsertAvsUser, upsertAvsUserById, upsertAvsUserByCard
|
||||
, getLicence, getLicenceDB, getLicenceByAvsId
|
||||
, 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
|
||||
| AvsUserUnknown UserId
|
||||
= AvsInterfaceUnavailable -- Interface to AVS was not configured at startup or does not respond
|
||||
| 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
|
||||
forM_ responses $ \AvsLicenceResponse{..} ->
|
||||
unless (sloppyBool avsResponseSuccess) $
|
||||
-- TODO: create an Admin Problems overview page
|
||||
$logErrorS "AVS" $ "Set licence failed for " <> tshow avsResponsePersonID <> " due to " <> cropText avsResponseMessage
|
||||
response <- throwLeftM $ avsQuerySetLicences $ AvsQuerySetLicences pls
|
||||
case response of
|
||||
AvsResponseSetLicencesError{..} -> do
|
||||
let msg = "Set AVS licences failed utterly: " <> avsResponseSetLicencesStatus <> ". Details: " <> cropText avsResponseSetLicencesMessage
|
||||
$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
|
||||
checkLicences :: Handler ()
|
||||
checkLicences = do
|
||||
-- TODO: run in a background job, once the interface is actually available
|
||||
checkLicences :: Handler Bool
|
||||
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
|
||||
--TODO this must be chunked into separate jobs/tasks
|
||||
--forM licences $ \AvsPersonLicence{..} -> do
|
||||
error "CONTINUE HERE" -- TODO STUB
|
||||
AvsResponsePerson adps <- throwLeftM $ avsQueryPerson qry
|
||||
case Set.elems adps of
|
||||
[] -> throwM AvsPersonSearchEmpty
|
||||
(_:_:_) -> 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
|
||||
|
||||
-}
|
||||
|
||||
{-
|
||||
upsertAvsUser :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) =>
|
||||
AvsPersonId -> m ()
|
||||
upsertAvsUser api = do
|
||||
mbuid <- getBy $ UniqueUserAvsId api
|
||||
-- | 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
|
||||
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, Just apd) -> do -- unknown user
|
||||
error "TODO" -- CONTINUE HERE
|
||||
(Just uid, Just apd) -> do -- known user
|
||||
error "TODO" -- CONTINUE HERE
|
||||
-}
|
||||
( _ , Nothing ) -> throwM $ AvsUserUnknownByAvs api -- User not found in AVS at all, i.e. no valid card exists yet
|
||||
(Nothing, Just AvsDataPerson{..}) -> do -- No LDAP User, but found in AVS; create new user
|
||||
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
|
||||
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 cards acc1 $ \acc2 AvsDataPersonCard{avsDataCardNo} -> do
|
||||
AvsResponsePerson adps <- throwLeftM . avsQueryPerson $ def{avsPersonQueryCardNo = Just avsDataCardNo}
|
||||
forFoldlM statuses mempty $ \acc1 AvsStatusPerson{avsStatusPersonCardStatus=cards} ->
|
||||
forFoldlM cards acc1 $ \acc2 AvsDataPersonCard{avsDataCardNo, avsDataVersionNo} -> do
|
||||
AvsResponsePerson adps <- throwLeftM . avsQueryPerson $ def{avsPersonQueryCardNo = Just avsDataCardNo, avsPersonQueryVersionNo = Just avsDataVersionNo}
|
||||
return $ mergeByPersonId adps acc2
|
||||
|
||||
|
||||
|
||||
52
src/Handler/Utils/Company.hs
Normal file
52
src/Handler/Utils/Company.hs
Normal file
@ -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
|
||||
@ -13,8 +13,9 @@ module Handler.Utils.DateTime
|
||||
, formatTime'
|
||||
, formatTime, formatTimeUser, formatTimeW, formatTimeMail
|
||||
, formatTimeRange, formatTimeRangeW, formatTimeRangeMail
|
||||
, getTimeLocale, getDateTimeFormat
|
||||
, getDateTimeFormatter
|
||||
, getTimeLocale
|
||||
, 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 $
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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 }
|
||||
whenIsJust markdown $ provideAlternative . NamedMailPart (AttachmentDisposition (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"))
|
||||
providePreferredAlternative $ NamedMailPart { disposition = InlineDisposition $ fn <> ".html", namedPart = html }
|
||||
whenIsJust markdown $ provideAlternative . NamedMailPart (InlineDisposition (fn <> ".txt"))
|
||||
where
|
||||
writerOptions = markdownWriterOptions
|
||||
{ P.writerReferenceLinks = True
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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{..}
|
||||
= isJust userPostAddress &&
|
||||
( userPrefersPostal ||
|
||||
isNothing userPinPassword ||
|
||||
Text.null (CI.original userEmail)
|
||||
)
|
||||
userPrefersLetter = fst . getPostalPreferenceAndAddress
|
||||
|
||||
-- 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)
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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 $
|
||||
|
||||
@ -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
|
||||
qname = CI.original qualificationName
|
||||
|
||||
$logInfoS "LMS" $ "Notify " <> tshow encRecipient <> " for renewal of qualification " <> qname
|
||||
|
||||
now <- liftIO getCurrentTime
|
||||
letterDate <- formatTimeUser SelFormatDate now $ Just entRecipient
|
||||
expiryDate <- formatTimeUser SelFormatDate qualificationUserValidUntil $ Just entRecipient
|
||||
|
||||
let printJobName = "RenewalPin"
|
||||
fileName = printJobName <> "_" <> abbrvName recipient <> ".pdf"
|
||||
lmsIdent = lmsUserIdent & getLmsIdent
|
||||
lmsUrl = "https://drive.fraport.de"
|
||||
lmsLogin = lmsUrl <> "/?login=" <> lmsIdent
|
||||
prepAddress upa = userDisplayName : (upa & html2textlines) -- TODO: use supervisor's address, once implemented
|
||||
pdfMeta = mkMeta
|
||||
[ toMeta "date" letterDate
|
||||
, toMeta "lang" (selectDeEn userLanguages) -- select either German or English only, see Utils.Lang
|
||||
, toMeta "login" lmsIdent
|
||||
, toMeta "pin" lmsUserPin
|
||||
, toMeta "recipient" userDisplayName
|
||||
, mbMeta "address" (prepAddress <$> userPostAddress)
|
||||
, toMeta "expiry" expiryDate
|
||||
, mbMeta "validduration" (show <$> qualificationValidDuration)
|
||||
, toMeta "url-text" lmsUrl
|
||||
, toMeta "url" lmsLogin
|
||||
]
|
||||
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]
|
||||
query <- runDB $ (,,,)
|
||||
<$> get jRecipient
|
||||
<*> get nQualification
|
||||
<*> getBy (UniqueQualificationUser nQualification jRecipient)
|
||||
<*> getBy (UniqueLmsQualificationUser nQualification jRecipient)
|
||||
case query of
|
||||
(Just User{userDisplayName}, Just Qualification{..}, Just (Entity _ QualificationUser{..}), Just(Entity luid LmsUser{..})) -> do
|
||||
let qname = CI.original qualificationName
|
||||
let letter = LetterRenewQualificationF
|
||||
{ lmsLogin = lmsUserIdent
|
||||
, lmsPin = lmsUserPin
|
||||
, qualHolder = userDisplayName
|
||||
, qualExpiry = qualificationUserValidUntil
|
||||
, qualId = nQualification
|
||||
, qualName = qname
|
||||
, qualShort = CI.original qualificationShorthand
|
||||
, qualDuration = qualificationValidDuration
|
||||
}
|
||||
$logInfoS "LMS" $ "Notify " <> tshow encRecipient <> " for renewal of qualification " <> qname
|
||||
notifyOk <- sendEmailOrLetter jRecipient letter
|
||||
when notifyOk $ do
|
||||
now <- liftIO getCurrentTime
|
||||
runDB $ update luid [ LmsUserNotified =. Just now]
|
||||
(_, Nothing, _, _) -> $logErrorS "LMS" $ "Notify " <> tshow encRecipient <> " for renewal failed: Qualification " <> tshow nQualification <> " does not exist!"
|
||||
(Nothing, _, _, _) -> $logErrorS "LMS" $ "Notify " <> tshow encRecipient <> " for renewal failed: User does not exist!"
|
||||
(_, _, 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!"
|
||||
|
||||
@ -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|
|
||||
<h2>Repetition just for Testing
|
||||
addHtmlMarkdownAlternatives' "part2" $ \(MsgRenderer _mr) -> [shamlet|
|
||||
<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}
|
||||
|
||||
<p>
|
||||
#{mr MsgMailTestDateTime}
|
||||
<ul>
|
||||
<li>#{nDT}
|
||||
<li>#{nD}
|
||||
<li>#{nT}
|
||||
Message was sent to you by
|
||||
<a href=@{NewsR}>
|
||||
FRADrive
|
||||
|]
|
||||
-- let test = $(i18nHamletFile "test")
|
||||
-- addHtmlMarkdownAlternatives' "addTest" (test :: Html) -- Text.Blaze.Internal.MarkupM Text.Blaze.Internal.Markup
|
||||
|
||||
|
||||
addHtmlMarkdownAlternatives' "part3" trdmsg
|
||||
-- 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
|
||||
11
src/Mail.hs
11
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
|
||||
|
||||
@ -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
|
||||
| n == 1 = pure AvsLicenceVorfeld
|
||||
parseJSON (Number n) | n == 1 = pure AvsLicenceVorfeld -- ordered by occurrence, n==1 is most common case
|
||||
| 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
|
||||
, avsDataValidTo :: Maybe Day -- Nothing if returned with AvsResponseStatus
|
||||
, avsDataIssueDate :: Maybe Day -- Nothing if returned with AvsResponseStatus
|
||||
{ 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
|
||||
, avsDataIssueDate :: Maybe Day -- Nothing if returned with AvsResponseStatus
|
||||
, avsDataCardColor :: AvsDataCardColor
|
||||
, avsDataCardAreas :: Set Char -- logically a set of upper-case letters
|
||||
, avsDataStreet :: Maybe Text -- Nothing if returned with AvsResponseStatus
|
||||
, avsDataPostalCode:: Maybe Text -- Nothing if returned with AvsResponseStatus
|
||||
, avsDataCity :: Maybe Text -- Nothing if returned with AvsResponseStatus
|
||||
, avsDataFirm :: Maybe Text -- Nothing if returned with AvsResponseStatus
|
||||
, avsDataCardNo :: AvsCardNo -- always 8 digits
|
||||
, avsDataVersionNo :: Text
|
||||
, avsDataCardAreas :: Set Char -- logically a set of upper-case letters
|
||||
, avsDataStreet :: Maybe Text -- Nothing if returned with AvsResponseStatus
|
||||
, avsDataPostalCode:: Maybe Text -- Nothing if returned with AvsResponseStatus
|
||||
, avsDataCity :: Maybe Text -- Nothing if returned with AvsResponseStatus
|
||||
, avsDataFirm :: Maybe Text -- Nothing if returned with AvsResponseStatus
|
||||
, avsDataCardNo :: AvsCardNo -- always 8 digits number, prefixed with 0
|
||||
, 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
|
||||
, avsDataPostalCode = null2nothing $ avsDataPostalCode proto
|
||||
, avsDataCity = null2nothing $ avsDataCity proto
|
||||
, avsDataFirm = null2nothing $ avsDataFirm proto
|
||||
canonical proto = proto { avsDataStreet = canonical $ avsDataStreet proto
|
||||
, avsDataPostalCode = canonical $ avsDataPostalCode proto
|
||||
, avsDataCity = canonical $ avsDataCity proto
|
||||
, avsDataFirm = canonical $ avsDataFirm proto
|
||||
}
|
||||
-}
|
||||
instance Canonical AvsDataPersonCard where
|
||||
canonical proto =
|
||||
proto & _avsDataStreet %~ null2nothing
|
||||
& _avsDataPostalCode %~ null2nothing
|
||||
& _avsDataCity %~ null2nothing
|
||||
& _avsDataFirm %~ null2nothing
|
||||
proto & _avsDataStreet %~ canonical
|
||||
& _avsDataPostalCode %~ canonical
|
||||
& _avsDataCity %~ canonical
|
||||
& _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)
|
||||
, ("PostalCode" .=) <$> (avsDataPostalCode & null2nothing)
|
||||
, ("City" .=) <$> (avsDataCity & null2nothing)
|
||||
, ("Firm" .=) <$> (avsDataFirm & null2nothing)
|
||||
, ("Street" .=) <$> (avsDataStreet & canonical)
|
||||
, ("PostalCode" .=) <$> (avsDataPostalCode & canonical)
|
||||
, ("City" .=) <$> (avsDataCity & canonical)
|
||||
, ("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
|
||||
, avsPersonPersonNo :: Int -- AVS Personennummer, Bedeutung ist unklar
|
||||
, avsPersonPersonID :: AvsPersonId -- Eindeutige PersonenID, wichtig für die Schnittstelle!
|
||||
, avsPersonInternalPersonalNo :: Maybe AvsInternalPersonalNo -- Fraport Personalnummer
|
||||
, avsPersonPersonNo :: Int -- AVS Personennummer, Bedeutung ist unklar
|
||||
, 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 -- Schnittstelle unklar: RampDrivingLicence oder RampLicence
|
||||
--, avsLicenceRampDrivingLicence :: AvsLicence
|
||||
{ avsLicenceRampLicence :: AvsLicence
|
||||
, avsLicencePersonID :: AvsPersonId
|
||||
}
|
||||
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
|
||||
, avsResponseSuccess :: SloppyBool
|
||||
, avsResponseMessage :: Text
|
||||
}
|
||||
{ avsResponsePersonID :: AvsPersonId
|
||||
, avsResponseSuccess :: SloppyBool
|
||||
, 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
|
||||
, avsPersonQueryVersionNo :: Maybe Text
|
||||
, avsPersonQueryInternalPersonalNo :: Maybe AvsInternalPersonalNo
|
||||
}
|
||||
deriving (Eq, Ord, Show, Generic, Typeable)
|
||||
|
||||
|
||||
@ -22,13 +22,13 @@ type Points = Centi
|
||||
|
||||
type Email = Text
|
||||
|
||||
type UserTitle = Text
|
||||
type UserFirstName = Text
|
||||
type UserSurname = Text
|
||||
type UserDisplayName = Text
|
||||
type UserIdent = CI Text
|
||||
type UserMatriculation = Text
|
||||
type UserEmail = CI Email
|
||||
type UserTitle = Text
|
||||
type UserFirstName = Text
|
||||
type UserSurname = Text
|
||||
type UserDisplayName = Text
|
||||
type UserIdent = CI Text
|
||||
type UserMatriculation = Text
|
||||
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 SchoolShorthand = CI Text
|
||||
type SchoolName = CI Text
|
||||
type SchoolShorthand = CI Text
|
||||
|
||||
type CourseName = CI Text
|
||||
type CourseShorthand = CI Text
|
||||
type MaterialName = CI Text
|
||||
type TutorialName = CI Text
|
||||
type SheetName = CI Text
|
||||
type SubmissionGroupName = CI Text
|
||||
type CompanyName = CI Text
|
||||
type CompanyShorthand = CI Text
|
||||
|
||||
type ExamName = CI Text
|
||||
type ExamPartName = CI Text
|
||||
type ExamOccurrenceName = CI Text
|
||||
type CourseName = CI Text
|
||||
type CourseShorthand = CI Text
|
||||
type MaterialName = CI Text
|
||||
type TutorialName = CI Text
|
||||
type SheetName = CI Text
|
||||
type SubmissionGroupName = CI Text
|
||||
|
||||
type AllocationName = CI Text
|
||||
type AllocationShorthand = CI Text
|
||||
type ExamName = 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
|
||||
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -15,8 +15,7 @@ data SystemFunction
|
||||
= SystemExamOffice
|
||||
| SystemFaculty
|
||||
| SystemStudent
|
||||
| SystemPrinter
|
||||
| SystemSap
|
||||
| SystemPrinter
|
||||
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
||||
deriving anyclass (Universe, Finite, Hashable, NFData)
|
||||
|
||||
|
||||
26
src/Utils.hs
26
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
|
||||
null2nothing :: MonoFoldable a => Maybe a -> Maybe a
|
||||
null2nothing (Just x) | null x = Nothing
|
||||
null2nothing other = other
|
||||
-- replaced by a more general formulation, see canonical
|
||||
-- null2nothing :: MonoFoldable a => Maybe a -> Maybe a
|
||||
-- null2nothing (Just x) | null x = Nothing
|
||||
-- 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
|
||||
|
||||
@ -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
|
||||
where
|
||||
mergeAvsDataPerson = Map.unionWithKey merger
|
||||
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 f x y | f x >= f y = x
|
||||
pickBy :: Ord b => (a -> b) -> a -> a -> a
|
||||
pickBy f x y | f x >= f y = x
|
||||
| otherwise = y
|
||||
|
||||
|
||||
|
||||
@ -302,7 +302,11 @@ data FormIdentifier
|
||||
| FIDAllocationRegister
|
||||
| FIDAllocationNotification
|
||||
| FIDAvsQueryPerson
|
||||
| FIDAvsQueryStatus
|
||||
| FIDAvsQueryStatus
|
||||
| FIDAvsCreateUser
|
||||
| FIDAvsQueryLicenceDiffs
|
||||
| FIDAvsQueryLicence
|
||||
| FIDAvsSetLicence
|
||||
| FIDLmsLetter
|
||||
deriving (Eq, Ord, Read, Show)
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
act (_, Nothing) acc = acc
|
||||
act (k, Just v ) acc = P.setMeta k v acc
|
||||
where
|
||||
act (_, Nothing) acc = 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))
|
||||
sendLetter printJobName pdf (printJobRecipient, printJobSender) printJobCourse printJobQualification printJobLmsUser = do
|
||||
data PrintJobIdentification = PrintJobIdentification
|
||||
{ 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 $
|
||||
T.replace " " "-" (T.intercalate "_" . catMaybes $ [Just printJobName, nameQuali, nameCourse, nameSender, nameRecipient])
|
||||
let jobFullName = text2asciiAlphaNum $
|
||||
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
|
||||
Left err -> do
|
||||
lprPDF jobFullName pdf >>= \case
|
||||
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' _ = do
|
||||
sendLetter'' :: _ -> DB PureFile
|
||||
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 (ExitSuccess , ok, _) = Right ok -- warnings are ignored here!
|
||||
exit2either (ExitFailure _ , _, err) = Left err
|
||||
exit2either :: Monoid a => (ExitCode, a, a) -> Either a a
|
||||
exit2either (ExitSuccess , stdOut, errOut) = Right $ stdOut <> errOut
|
||||
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
|
||||
lprServerArg <- $cachedHereBinary ("lprServer"::Text) getLprServerArg
|
||||
lprPDF jb bs = do
|
||||
lprServerArg <- $cachedHereBinary ("lprServer"::Text) getLprServerArg
|
||||
let pc = setStdin (byteStringInput bs) $
|
||||
proc "lpr" $
|
||||
jobname ++ -- -J jobname -- a name for job identification at printing site
|
||||
proc "lpr" $
|
||||
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
|
||||
getLprServerArg = do
|
||||
where
|
||||
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) $
|
||||
|
||||
@ -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.:| []
|
||||
|
||||
@ -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>
|
||||
|
||||
@ -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$.
|
||||
Durch die erfolgreiche Teilnahme an einem E-Learning können Sie die Gültigkeit
|
||||
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
|
||||
Login-Daten aus dem geschützen Sichtfenster weiter unten.
|
||||
verlängert werden.
|
||||
$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$.
|
||||
You can extend the validity
|
||||
$if(supervisor)$
|
||||
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
|
||||
e-learning course, then a renewal requires your full participation
|
||||
Should the apron driving license expire before completing this
|
||||
e-learning, a later renewal then requires full participation
|
||||
of the basic training course again.
|
||||
|
||||
|
||||
|
||||
44
templates/mail/genericMailLetter.hamlet
Normal file
44
templates/mail/genericMailLetter.hamlet
Normal file
@ -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}
|
||||
@ -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}
|
||||
@ -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_r <- insert' $ Qualification avn "R" "Rollfeldführerschein" r_descr (Just 24) (Just 6) (Just $ CalendarDiffDays 2 3) False $ Just "R2801"
|
||||
qid_l <- insert' $ Qualification ifi "L" "Lehrbefähigung" l_descr Nothing (Just 6) Nothing True Nothing
|
||||
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 AvsLicenceRollfeld) $ Just "R2801"
|
||||
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!
|
||||
|
||||
@ -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
|
||||
shrink (AvsCardNo x) = AvsCardNo <$> shrink x
|
||||
arbitrary = AvsCardNo . normalizeAvsCardNo <$> arbitrary
|
||||
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} ->
|
||||
|
||||
2
testdata/test_letters.hs
vendored
2
testdata/test_letters.hs
vendored
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user