diff --git a/messages/uniworx/categories/authorization/de-de-formal.msg b/messages/uniworx/categories/authorization/de-de-formal.msg index 4fc80f977..15d5204e6 100644 --- a/messages/uniworx/categories/authorization/de-de-formal.msg +++ b/messages/uniworx/categories/authorization/de-de-formal.msg @@ -19,6 +19,7 @@ UnauthorizedTokenInvalidAuthorityGroup: Ihr Authorisierungs-Token basiert auf de UnauthorizedTokenInvalidAuthorityValue: Ihr Authorisierungs-Token basiert auf Rechten, deren Spezifikation nicht interpretiert werden konnte. UnauthorizedTokenInvalidImpersonation: Ihr Authorisierungs-Token enthält die Anweisung sich als ein Nutzer:in auszugeben, dies ist jedoch nicht allen Benutzer:innen, auf deren Rechten ihr Authorisierungs-Token basiert, erlaubt. UnauthorizedToken404: Authorisierungs-Tokens können nicht auf Fehlerseiten ausgewertet werden. +UnauthorizedSupervisor: Sie sind kein Ansprechpartner:in für diesen Benutzer:in. UnauthorizedSiteAdmin: Sie sind nicht System-weiter Administrator:in. UnauthorizedSchoolAdmin: Sie sind nicht als Administrator:in für dieses Institut eingetragen. UnauthorizedAdminEscalation: Sie sind nicht Administrator:in für alle Institute, für die dieser Nutzer/diese Nutzerin Administrator:in oder Veranstalter:in ist. @@ -27,7 +28,6 @@ UnauthorizedExamExamOffice: Es existieren keine Prüfungsergebnisse für Nutzer: UnauthorizedSchoolExamOffice: Sie sind nicht mit Prüfungsverwaltung für dieses Institut beauftragt. UnauthorizedSystemExamOffice: Sie sind nicht mit systemweiter Prüfungsverwaltung beauftragt. UnauthorizedSystemPrinter: Sie sind nicht mit systemweitem Druck und Briefversand beauftragt. -UnauthorizedSystemSap: Sie sind nicht mit der systemweitem SAP Schnittstellenverwaltung beauftragt. UnauthorizedExternalExamExamOffice: Es existieren keine Prüfungsergebnisse für Nutzer:innen, für die Sie mit der Prüfungsverwaltung beauftragt sind. UnauthorizedEvaluation: Sie sind nicht mit der Kursumfragenverwaltung beauftragt. UnauthorizedAllocationAdmin: Sie sind nicht mit der Administration von Zentralanmeldungen beauftragt. diff --git a/messages/uniworx/categories/authorization/en-eu.msg b/messages/uniworx/categories/authorization/en-eu.msg index 1a44a7088..79a050879 100644 --- a/messages/uniworx/categories/authorization/en-eu.msg +++ b/messages/uniworx/categories/authorization/en-eu.msg @@ -19,6 +19,7 @@ UnauthorizedTokenInvalidAuthorityGroup: Your authorisation-token is based in an UnauthorizedTokenInvalidAuthorityValue: The specification of the rights in which your authorisation-token is based, could not be interpreted. UnauthorizedTokenInvalidImpersonation: Your authorisation-token contains an instruction to impersonate an user. Not all users on whose rights your token is based however are permitted to do so. UnauthorizedToken404: Authorisation-tokens cannot be processed on error pages. +UnauthorizedSupervisor: You are not a supervisor for the requested user. UnauthorizedSiteAdmin: You are no system-wide administrator. UnauthorizedSchoolAdmin: You are no administrator for this department. UnauthorizedAdminEscalation: You aren't an administrator for all departments for which this user is an administrator. @@ -29,7 +30,6 @@ UnauthorizedExamExamOffice: You are not part of the appropriate exam office for UnauthorizedSchoolExamOffice: You are not part of an exam office for this school. UnauthorizedSystemExamOffice: You are not charged with system wide exam administration. UnauthorizedSystemPrinter: You are not charged with system wide letter printing. -UnauthorizedSystemSap: You are not charged with system wide SAP administration. UnauthorizedExternalExamExamOffice: You are not part of the appropriate exam office for any of the participants of this exam. UnauthorizedSchoolLecturer: You are no lecturer for this department. UnauthorizedLecturer: You are no administrator for this course. diff --git a/messages/uniworx/categories/avs/de-de-formal.msg b/messages/uniworx/categories/avs/de-de-formal.msg index ff4428e24..45e3c9131 100644 --- a/messages/uniworx/categories/avs/de-de-formal.msg +++ b/messages/uniworx/categories/avs/de-de-formal.msg @@ -10,4 +10,5 @@ AvsLastName: Nachname AvsInternalPersonalNo: Personalnummer (nur Fraport AG) AvsVersionNo: Versionsnummer AvsQueryEmpty: Bitte mindestens ein Anfragefeld ausfüllen! -AvsQueryStatusInvalid t@Text: Nur numerische IDs eingeben, durch Komma getrennt! Erhalten: #{show t} \ No newline at end of file +AvsQueryStatusInvalid t@Text: Nur numerische IDs eingeben, durch Komma getrennt! Erhalten: #{show t} +AvsLicence: Fahrberechtigung \ No newline at end of file diff --git a/messages/uniworx/categories/avs/en-eu.msg b/messages/uniworx/categories/avs/en-eu.msg index 831a371df..7660963b6 100644 --- a/messages/uniworx/categories/avs/en-eu.msg +++ b/messages/uniworx/categories/avs/en-eu.msg @@ -10,4 +10,5 @@ AvsLastName: Last name AvsInternalPersonalNo: Personnel number (Fraport AG only) AvsVersionNo: Version number AvsQueryEmpty: At least one query field must be filled! -AvsQueryStatusInvalid t: Numeric IDs only, comma seperated! #{show t} \ No newline at end of file +AvsQueryStatusInvalid t: Numeric IDs only, comma seperated! #{show t} +AvsLicence: Driving Licence \ No newline at end of file diff --git a/messages/uniworx/categories/model_types/de-de-formal.msg b/messages/uniworx/categories/model_types/de-de-formal.msg index be3831b8a..8d7aa361c 100644 --- a/messages/uniworx/categories/model_types/de-de-formal.msg +++ b/messages/uniworx/categories/model_types/de-de-formal.msg @@ -18,5 +18,4 @@ BothSubmissions: Abgabe direkt in Uni2work oder extern mit Pseudonym SystemExamOffice: Prüfungsverwaltung SystemFaculty: Fakultätsmitglied SystemStudent: Student:in -SystemPrinter: Drucker:in -SystemSap: SAP Verwalter:in +SystemPrinter: Drucker:in \ No newline at end of file diff --git a/messages/uniworx/categories/model_types/en-eu.msg b/messages/uniworx/categories/model_types/en-eu.msg index eafba769a..fe2c2418f 100644 --- a/messages/uniworx/categories/model_types/en-eu.msg +++ b/messages/uniworx/categories/model_types/en-eu.msg @@ -18,5 +18,4 @@ BothSubmissions: Submission either directly in Uni2work or externally via pseudo SystemExamOffice: Exam office SystemFaculty: Faculty member SystemStudent: Student -SystemPrinter: Printing staff -SystemSap: SAP Administrator \ No newline at end of file +SystemPrinter: Printing staff \ No newline at end of file diff --git a/messages/uniworx/categories/print/de-de-formal.msg b/messages/uniworx/categories/print/de-de-formal.msg index 7a865802b..29361a2cf 100644 --- a/messages/uniworx/categories/print/de-de-formal.msg +++ b/messages/uniworx/categories/print/de-de-formal.msg @@ -19,4 +19,5 @@ PrintCourse: Kurse PrintQualification: Qualifikation PrintPDF !ident-ok: PDF PrintManualRenewal: Vorfeldführerschein Renewal-Brief testweise versenden -PrintLmsUser: E-Learning Benachrichtigung? \ No newline at end of file +PrintLmsUser: E-Learning Id +PrintJobs: Druckaufräge \ No newline at end of file diff --git a/messages/uniworx/categories/print/en-eu.msg b/messages/uniworx/categories/print/en-eu.msg index 4b2aa442d..7f07a8f52 100644 --- a/messages/uniworx/categories/print/en-eu.msg +++ b/messages/uniworx/categories/print/en-eu.msg @@ -19,4 +19,5 @@ PrintCourse: Course PrintQualification: Qualification PrintPDF: PDF PrintManualRenewal: Manual sending of an apron driver's licence renewal letter -PrintLmsUser: E-learning notification? \ No newline at end of file +PrintLmsUser: E-learning id +PrintJobs: Print jobs \ No newline at end of file diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index 0a56aae47..d4211562f 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -13,7 +13,10 @@ QualificationElearningStart: E-Learning automatisch starten TableQualificationCountActive: Aktive TableQualificationCountActiveTooltip: Anzahl Personen mit momentan gültiger Qualifikation TableQualificationCountTotal: Gesamt -TableQualificationSapExport: Übermittlung SAP +TableQualificationIsAvsLicence: AVS +TableQualificationIsAvsLicenceTooltip: Wird die Qualifikation mit dem AVS synchronisiert? Wenn ja, als welche Qualifikation? Betrifft nur Benutzer mit AVS PersonenID. +TableQualificationSapExport: SAP +TableQualificationSapExportTooltip: Wird die Qualifikation an SAP übermittelt? Betrifft nur Benutzer mit Fraport Personalnummer. LmsQualificationValidUntil: Gültig bis TableQualificationLastRefresh: Zuletzt erneuert TableQualificationFirstHeld: Erstmalig @@ -56,7 +59,7 @@ LmsErrorNoRefreshElearning: Fehler: E-Learning wird nicht automatisch gestartet, MailSubjectQualificationRenewal qname@Text: Qualifikation #{qname} muss demnächst erneuert werden MailSubjectQualificationExpiry qname@Text: Qualifikation #{qname} läuft demnächst ab MailSubjectQualificationExpired qname@Text: Qualifikation #{qname} ist ab sofort ungültig -MailBodyQualificationRenewal: Sie müssen diese Qualifikaton demnächst durch einen E-Learning Kurs erneuern. +MailBodyQualificationRenewal qname@Text: Sie müssen Qualifikaton #{qname} demnächst durch einen E-Learning Kurs erneuern, siehe Anhang. MailBodyQualificationExpiry: Diese Qualifikaton läuft bald ab. Tätigkeiten, welche diese Qualifikation voraussetzen dürfen dann nicht länger ausgeübt werden! MailBodyQualificationExpired: Diese Qualifikaton is nun abgelaufen. Tätigkeiten, welche diese Qualifikation voraussetzen dürfen ab sofort nicht länger ausgeübt werden! Es ist möglich, dass die Qualifikation vorzeit ungültig wurde, z.B. wegen erfolgloser Teilnahme an einem verpflichtendem E-Learning. LmsRenewalInstructions: Anweisungen zur Verlängerung finden Sie im angehängten PDF. Um Missbrauch zu verhindern wurde das PDF dem von Ihnen in FRADrive hinterlegten PDF-Passwort verschlüsselt. Falls kein PDF-Passwort hinterlegt wurde, ist das PDF-Passwort Ihre Fraport Ausweisnummer, inklusive Punkt und der Ziffer danach. @@ -69,6 +72,7 @@ LmsPinRenewal n@Int: E-Learning Pin ausgetauscht für #{n} #{pluralDE n "Prüfli LmsActionFailed n@Int: Aktion nicht durchgeführt für #{n} #{pluralDE n "Person" "Personen"}, da diese derzeit nicht an einer Prüfung teilnehmen. MppOpening: Anrede MppClosing: Grußformel +MppSupervisor: Ansprechpartner MppDate: Datum MppURL: Link E-Learning MppLogin !ident-ok: Login diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg index d85e4fb4a..2e15e3c97 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/messages/uniworx/categories/qualification/en-eu.msg @@ -13,7 +13,10 @@ QualificationElearningStart: Start e-learning automatically TableQualificationCountActive: Active TableQualificationCountActiveTooltip: Number of currently valid qualification holders TableQualificationCountTotal: Total +TableQualificationIsAvsLicence: AVS Driving License +TableQualificationIsAvsLicenceTooltip: Under which name is this qualification synchronized with AVS, if any? Only applies to qualification holders having an AVS PersonID. TableQualificationSapExport: Sent to SAP +TableQualificationSapExportTooltip: Is this qualification transmitted to SAP? Only applies to qualification holder having a Fraport AG personnel number. LmsQualificationValidUntil: Valid until TableQualificationLastRefresh: Last renewed TableQualificationFirstHeld: First held @@ -53,10 +56,10 @@ LmsResultCsvExceptionDuplicatedKey: CSV import with ambiguous key LmsUserlistCsvExceptionDuplicatedKey: CSV import with ambiguous key LmsDirectUpload: Direct upload for automated Systems LmsErrorNoRefreshElearning: Error: E-learning will not be started automatically due to refresh-within time period not being set. -MailSubjectQualificationRenewal qname@Text: Qualification #{qname} must be renewed shortly -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 diff --git a/messages/uniworx/categories/send/send_notifications/de-de-formal.msg b/messages/uniworx/categories/send/send_notifications/de-de-formal.msg index 189bed625..50a25af92 100644 --- a/messages/uniworx/categories/send/send_notifications/de-de-formal.msg +++ b/messages/uniworx/categories/send/send_notifications/de-de-formal.msg @@ -148,3 +148,11 @@ MailUserSystemFunctionsNoFunctions: Keine #utils.hs + templates MailEditNotifications: Benachrichtigungen ein-/ausschalten + +#supervisor +MailSupervisorNote: Hinweis für Ansprechpartner +MailSupervisorBody undername@Text supername@Text: Sie erhalten diese Nachricht, da #{supername} als Ansprechpartner für #{undername} eingetragen ist in +MailSupervisorCopy undermail@Text: Diese Nachricht ist eine Kopie einer Nachricht, welche an #{undermail} gesendet wurde. +MailSupervisorNoCopy: Warnung: Diese Nachricht wurde nicht an den eingentlichen Empfänger versandt! Für die Weiterleitung sind alle für diesen Empfänger in FRADrive eingetragenen Ansprechpartner verantwortlich! +MailSupervisedNote: Hinweis +MailSupervisedBody: Eine Kopie dieser Nachricht wurde auch an folgende in FRADrive eingetragene Ansprechpartner gesendet: \ No newline at end of file diff --git a/messages/uniworx/categories/send/send_notifications/en-eu.msg b/messages/uniworx/categories/send/send_notifications/en-eu.msg index d6af818f2..8684f7085 100644 --- a/messages/uniworx/categories/send/send_notifications/en-eu.msg +++ b/messages/uniworx/categories/send/send_notifications/en-eu.msg @@ -148,3 +148,11 @@ MailUserSystemFunctionsNoFunctions: None #utils.hs + templates MailEditNotifications: Enable/Disable notifications + +#supervisor +MailSupervisorNote: Note to supervisor +MailSupervisorBody undername supername: You receive this message, since #{supername} is registered as supervisor for #{undername} in +MailSupervisorCopy undermail: This is a copy of a message originally sent to #{undermail}. +MailSupervisorNoCopy: Warning: This message was not sent to the original recipient! The FRADrive registered supervisor, i.e. you, is responsible for forwarding this message to the recipient! +MailSupervisedNote: Please Note +MailSupervisedBody: A copy of this message has been sent to all supervisors registered for you in FRADrive, namely: \ No newline at end of file diff --git a/messages/uniworx/categories/settings/auth_settings/de-de-formal.msg b/messages/uniworx/categories/settings/auth_settings/de-de-formal.msg index dd71f1917..bc0ccf58e 100644 --- a/messages/uniworx/categories/settings/auth_settings/de-de-formal.msg +++ b/messages/uniworx/categories/settings/auth_settings/de-de-formal.msg @@ -14,7 +14,6 @@ AuthTagAdmin: Nutzer:in ist Administrator:in AuthTagExamOffice: Nutzer:in ist mit Prüfungsverwaltung beauftragt AuthTagSystemExamOffice: Nutzer:in ist mit systemweiter Prüfungsverwaltung beauftragt AuthTagSystemPrinter: Nutzer:in ist mit systemweiten Druck von Briefen beauftragt -AuthTagSystemSap: Nutzer:in ist mit systemweiter SAP Schnittstellen-Administration beauftragt AuthTagEvaluation: Nutzer:in ist mit Kursumfragenverwaltung beauftragt AuthTagAllocationAdmin: Nutzer:in ist mit der Administration von Zentralanmeldungen beauftragt AuthTagToken: Nutzer:in präsentiert Authorisierungs-Token @@ -59,3 +58,4 @@ AuthTagSubmissionGroup: Nutzer:in ist Mitglied in registrierter Abgabegruppe AuthTagWorkflow: Nutzer:in hat passende Workflow-Rolle AuthTagStudent: Nutzer:in ist Student:in AuthTagExamTime: Zeitliche Einschränkungen durch relevante Prüfung sind erfüllt +AuthTagSupervisor: Nutzer:in ist Ansprechpartner für jemand anderes \ No newline at end of file diff --git a/messages/uniworx/categories/settings/auth_settings/en-eu.msg b/messages/uniworx/categories/settings/auth_settings/en-eu.msg index cb3036a79..5f61881c0 100644 --- a/messages/uniworx/categories/settings/auth_settings/en-eu.msg +++ b/messages/uniworx/categories/settings/auth_settings/en-eu.msg @@ -14,7 +14,6 @@ AuthTagAdmin: User is administrator AuthTagExamOffice: User is part of an exam office AuthTagSystemExamOffice: User is charged with system wide exam administration AuthTagSystemPrinter: User is responsible for system wide letter printing -AuthTagSystemSap: User is responsible for system wide SAP interface administration AuthTagEvaluation: User is charged with course evaluation AuthTagAllocationAdmin: User is charged with administration of central allocations AuthTagToken: User is presenting an authorisation-token @@ -59,3 +58,4 @@ AuthTagSubmissionGroup: User is part of a submission group AuthTagWorkflow: User has matching workflow role AuthTagStudent: User is a student AuthTagExamTime: Exam time restrictions are satisfied +AuthTagSupervisor: User is supervisor for someone else diff --git a/messages/uniworx/categories/settings/de-de-formal.msg b/messages/uniworx/categories/settings/de-de-formal.msg index 52f3ccf2d..3f9b5beb1 100644 --- a/messages/uniworx/categories/settings/de-de-formal.msg +++ b/messages/uniworx/categories/settings/de-de-formal.msg @@ -119,6 +119,7 @@ SettingsUpdate: Einstellungen erfolgreich gespeichert TokensResetSuccess: Authorisierungs-Tokens invalidiert ProfileTitle: Benutzereinstellungen HeadingProfileData: Persönliche Daten +HeadingForProfileData udn@UserDisplayName: Persönliche Daten von #{udn} ProfileRegistered: Angemeldet LastEditByUser: Ihre letzte Bearbeitung SubmissionGroupName: Gruppenname diff --git a/messages/uniworx/categories/settings/en-eu.msg b/messages/uniworx/categories/settings/en-eu.msg index 076cf43ae..c543e822f 100644 --- a/messages/uniworx/categories/settings/en-eu.msg +++ b/messages/uniworx/categories/settings/en-eu.msg @@ -119,6 +119,7 @@ SettingsUpdate: Successfully updated settings TokensResetSuccess: Successfully invalidated all authorisation tokens ProfileTitle: Settings HeadingProfileData: Personal information +HeadingForProfileData udn: Personal information of #{udn} ProfileRegistered: Registered LastEditByUser: Your last edit SubmissionGroupName: Group name diff --git a/messages/uniworx/categories/user/de-de-formal.msg b/messages/uniworx/categories/user/de-de-formal.msg index 6777920d1..e5572b77d 100644 --- a/messages/uniworx/categories/user/de-de-formal.msg +++ b/messages/uniworx/categories/user/de-de-formal.msg @@ -13,7 +13,7 @@ AdminUserAuth: Authentifizierung AdminUserMatriculation: Matrikelnummer AdminUserSex: Geschlecht AdminUserTelephone: Telefonnummer -AdminUserMobile: Mobiltelefonmummer +AdminUserMobile: Mobiltelefonnummer AdminUserFPersonalNumber: Personalnummer (nur Fraport AG) AdminUserFDepartment: Abteilung AdminUserPostAddress: Postalische Anschrift diff --git a/models/avs.model b/models/avs.model index daeb81d11..041c6aba0 100644 --- a/models/avs.model +++ b/models/avs.model @@ -3,16 +3,27 @@ -- SPDX-License-Identifier: AGPL-3.0-or-later -- Tables to save data received AVS --- Purpose is to detect external changes in qualifications and postal addresses + +-- When creating an AvsUser the following cases are possible: +-- 1. User does not exist, hence a new UserId ought to be created. +-- 2. User does exists and can be matched by UserCompanyPersonalNumber +-- 3. User does exists but cannot be matched now :( +-- How can the matching be performed later? +-- Do we need to merge users? +-- > Handler.Utils.UsersassimilateUser + + UserAvs - personId AvsPersonId -- unique identifier for user throughout avs - 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 diff --git a/models/company.model b/models/company.model new file mode 100644 index 000000000..da7b295e8 --- /dev/null +++ b/models/company.model @@ -0,0 +1,22 @@ +-- SPDX-FileCopyrightText: 2022 Sarah Vaupel ,Steffen Jost +-- +-- 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 \ No newline at end of file diff --git a/models/lms.model b/models/lms.model index cd34de744..4c8ae02ee 100644 --- a/models/lms.model +++ b/models/lms.model @@ -15,9 +15,13 @@ Qualification -- elearningOnly Bool -- successful E-learing automatically increases validity. NO! -- refreshInvitation StoredMarkup -- hard-coded I18N-MSGs used instead, but displayed on qualification page NO! -- expiryNotification StoredMarkup Maybe -- configurable user-profile-notifcations are used instead NO! + avsLicence AvsLicence Maybe -- if set, is synchronized to Avs as a driving licence sapId Text Maybe -- if set, all QualificationUsers with userCompanyPersonalNumber are transmitted via SAP interface under this id SchoolQualificationShort school shorthand -- must be unique per school and shorthand SchoolQualificationName school name -- must be unique per school and name + -- across all schools, only one qualification may be a driving licence: + UniqueQualificationAvsLicence avsLicence !force + -- NOTE: two NULL values are not equal for the purpose of Uniqueness constraints! deriving Generic -- TODOs: diff --git a/models/schools.model b/models/schools.model index 811d95fea..60c45cbbd 100644 --- a/models/schools.model +++ b/models/schools.model @@ -6,7 +6,7 @@ -- Each school must have a unique human-readable shorthand which is used as database row key School json name (CI Text) - shorthand (CI Text) -- SchoolKey :: SchoolShorthand -> SchoolId + shorthand SchoolShorthand -- type SchoolShorthand = (CI Text) -- SchoolKey :: SchoolShorthand -> SchoolId examMinimumRegisterBeforeStart NominalDiffTime Maybe examMinimumRegisterDuration NominalDiffTime Maybe examRequireModeForRegistration Bool default=false diff --git a/models/users.model b/models/users.model index e2afd01ab..8d3fc92ef 100644 --- a/models/users.model +++ b/models/users.model @@ -15,7 +15,7 @@ User json -- Each Uni2work user has a corresponding row in this table; create surname UserSurname -- Display user names always through 'nameWidget displayName surname' displayName UserDisplayName displayEmail UserEmail - email UserEmail -- Case-insensitive eMail address -- TODO: make this nullable + email UserEmail -- Case-insensitive eMail address, used for sending TODO: make this nullable ident UserIdent -- Case-insensitive user-identifier authentication AuthenticationMode -- 'AuthLDAP' or ('AuthPWHash'+password-hash) lastAuthentication UTCTime Maybe -- last login date @@ -40,7 +40,7 @@ User json -- Each Uni2work user has a corresponding row in this table; create sex Sex Maybe showSex Bool default=false telephone Text Maybe - mobile Text Maybe + mobile Text Maybe companyPersonalNumber Text Maybe -- Company will become a new table, but if company=fraport, some information is received via LDAP companyDepartment Text Maybe -- thus we store such information for ease of reference directly, if available pinPassword Text Maybe -- used to encrypt pins within emails @@ -80,9 +80,19 @@ UserGroupMember group UserGroupName user UserId primary Checkmark nullable - UniquePrimaryUserGroupMember group primary !force UniqueUserGroupMember group user - deriving Generic - +UserCompany + user UserId + company CompanyId + supervisor Bool -- is this user a company supervisor? + UniqueUserCompany user -- only one company per user is currently allowed + deriving Generic +UserSupervisor + supervisor UserId -- multiple supervisor per trainee possible + user UserId + rerouteNotifications Bool -- User can be his own supervisor to receive notifications as well + UniqueUserSupervisor supervisor user + deriving Generic + \ No newline at end of file diff --git a/routes b/routes index f3db6fd9a..090b2585f 100644 --- a/routes +++ b/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 diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index 161419e94..23c1eb341 100644 --- a/src/Auth/LDAP.hs +++ b/src/Auth/LDAP.hs @@ -64,9 +64,9 @@ findUser conf@LdapConf{..} ldap ident retAttrs = fromMaybe [] <$> findM (assertM | ident' <- [ident, [st|#{ident}@lmu.de|], [st|#{ident}@fraport.de|]] , ldapUserEmail' <- toList ldapUserEmail -- ] ++ - -- [ ldapUserDisplayName Ldap.:= Text.encodeUtf8 ident + -- [ ldapUserDisplayName Ldap.:= Text.encodeUtf8 ident -- for Fraport, userDisplayName has the pattern "Surname, Firstnames" ] ++ - [ ldapUserFraportPersonalnummer Ldap.:= Text.encodeUtf8 ident -- for Fraport, userDisplayname has pattern "Surname, Firstnames" + [ ldapUserFraportPersonalnummer Ldap.:= Text.encodeUtf8 ident ] findUserMatr :: LdapConf -> Ldap -> Text -> [Ldap.Attr] -> IO [Ldap.SearchEntry] diff --git a/src/Data/Time/Clock/Instances.hs b/src/Data/Time/Clock/Instances.hs index 84f23db4f..d08b8e6c4 100644 --- a/src/Data/Time/Clock/Instances.hs +++ b/src/Data/Time/Clock/Instances.hs @@ -99,7 +99,7 @@ instance PersistField CalendarDiffDays where coerceICcd :: Integer -> CDDdb coerceICcd = fromIntegral - -- placement in Utils impossivle due to cyclic dependencies + -- placement in Utils impossible due to cyclic dependencies -- Data.Tuple.Extra is not yet a dependency -- both = join (***) is still too cryptic for me both :: (a -> b) -> (a, a) -> (b, b) diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 236463675..128307869 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -7,7 +7,7 @@ module Database.Esqueleto.Utils ( true, false - , justVal, justValList + , justVal, justValList, toValues , isJust, alt , isInfixOf, hasInfix , strConcat, substring @@ -50,7 +50,9 @@ import Data.Universe import qualified Data.Set as Set import qualified Data.List as List import qualified Data.Foldable as F +import Data.List.NonEmpty (NonEmpty(..)) import qualified Database.Esqueleto.Legacy as E +import qualified Database.Esqueleto.Experimental as Ex import qualified Database.Esqueleto.PostgreSQL as E import qualified Database.Esqueleto.Internal.Internal as E import Database.Esqueleto.Utils.TH @@ -97,10 +99,15 @@ false = E.val False -- infinity = unsafeSqlValue "'infinity'" justVal :: PersistField typ => typ -> E.SqlExpr (E.Value (Maybe typ)) -justVal = E.val . Just +-- justVal = E.val . Just +justVal = E.just . E.val justValList :: PersistField typ => [typ] -> E.SqlExpr (E.ValueList (Maybe typ)) -justValList = E.valList . map Just +-- justValList = E.valList . map Just +justValList = E.justList . E.valList + +toValues :: PersistField typ => NonEmpty typ -> Ex.From (Ex.SqlExpr (Ex.Value typ)) -- E.From invalid here, requires Esqueleto.Experimental +toValues = E.values . fmap Ex.val infixl 4 =?. (=?.) :: PersistField typ => E.SqlExpr (E.Value typ) -> E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value Bool) @@ -430,6 +437,7 @@ bool onFalse onTrue val = E.case_ (E.else_ onFalse) -- called see greatest and least within postgresql +-- TODO: this is buggy! Both return always the first argument if any argument is NULL! max, min :: PersistField a => E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value a) @@ -437,7 +445,7 @@ max, min :: PersistField a max a b = bool a b $ b E.>. a min a b = bool a b $ b E.<. a --- these alternatives for max/min ought to be more efficient +-- these alternatives for max/min ought to be more efficient; note that NULL is avoided by greatest/least greatest :: PersistField a => E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value a) greatest a b = E.unsafeSqlFunction "GREATEST" $ E.toArgList (a,b) diff --git a/src/Foundation/Authorization.hs b/src/Foundation/Authorization.hs index 2ebfbcf63..1078158c9 100644 --- a/src/Foundation/Authorization.hs +++ b/src/Foundation/Authorization.hs @@ -550,6 +550,19 @@ tagAccessPredicate AuthAdmin = cacheAPSchoolFunction SchoolAdmin (Just $ Right d adrights <- lift $ selectFirst [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolAdmin] [] guardMExceptT (isJust adrights) (unauthorizedI MsgUnauthorizedSiteAdmin) return Authorized + +tagAccessPredicate AuthSupervisor = APDB $ \_ _ mAuthId route _ -> case route of + ForProfileR cID -> checkSupervisor (mAuthId, cID) + ForProfileDataR cID -> checkSupervisor (mAuthId, cID) + r -> $unsupportedAuthPredicate AuthSupervisor r + where + checkSupervisor sup@(mAuthId, cID) = $cachedHereBinary sup . exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + uid <- decrypt cID + isSupervisor <- lift . existsBy $ UniqueUserSupervisor authId uid + guardMExceptT isSupervisor (unauthorizedI MsgUnauthorizedSupervisor) + return Authorized + tagAccessPredicate AuthSystemExamOffice = cacheAPSystemFunction SystemExamOffice (Just $ Right diffHour) $ \mAuthId' _ _ examOfficeList -> if | maybe True (`Set.notMember` examOfficeList) mAuthId' -> Right $ if | is _Nothing mAuthId' -> return AuthenticationRequired @@ -568,15 +581,6 @@ tagAccessPredicate AuthSystemPrinter = cacheAPSystemFunction SystemPrinter (Just isPrinter <- lift $ exists [UserSystemFunctionUser ==. authId, UserSystemFunctionFunction ==. SystemPrinter, UserSystemFunctionIsOptOut ==. False] guardMExceptT isPrinter $ unauthorizedI MsgUnauthorizedSystemPrinter return Authorized -tagAccessPredicate AuthSystemSap = cacheAPSystemFunction SystemSap (Just $ Right diffHour) $ \mAuthId' _ _ sapList -> if - | maybe True (`Set.notMember` sapList) mAuthId' -> Right $ if - | is _Nothing mAuthId' -> return AuthenticationRequired - | otherwise -> unauthorizedI MsgUnauthorizedSystemSap - | otherwise -> Left $ APDB $ \_ _ mAuthId _ _ -> $cachedHereBinary mAuthId . exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - isPrinter <- lift $ exists [UserSystemFunctionUser ==. authId, UserSystemFunctionFunction ==. SystemSap, UserSystemFunctionIsOptOut ==. False] - guardMExceptT isPrinter $ unauthorizedI MsgUnauthorizedSystemSap - return Authorized tagAccessPredicate AuthStudent = cacheAPSystemFunction SystemStudent (Just $ Right diffHour) $ \mAuthId' _ _ studentList -> if | maybe True (`Set.notMember` studentList) mAuthId' -> Right $ if | is _Nothing mAuthId' -> return AuthenticationRequired @@ -1661,6 +1665,8 @@ tagAccessPredicate AuthSelf = APDB $ \_ _ mAuthId route _ -> exceptT return retu UserNotificationR cID -> return $ Left cID UserPasswordR cID -> return $ Left cID CourseR _ _ _ (CUserR cID) -> return $ Left cID + ForProfileR cID -> return $ Left cID + ForProfileDataR cID -> return $ Left cID CApplicationR _ _ _ cID _ -> do appId <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSelf) (const True :: CryptoIDError -> Bool) $ decrypt cID CourseApplication{..} <- maybeMExceptT (unauthorizedI MsgUnauthorizedSelf) . $cachedHereBinary appId $ get appId diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index abb2d3cb1..b17708671 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -182,14 +182,16 @@ breadcrumb (LmsResultUploadR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Jus breadcrumb (LmsResultDirectR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsResultR ssh qsh -- never displayed breadcrumb (LmsFakeR ssh qsh) = i18nCrumb MsgMenuLmsFake $ Just $ LmsR ssh qsh -- TODO: remove in production -breadcrumb ProfileR = i18nCrumb MsgBreadcrumbProfile Nothing -breadcrumb 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 diff --git a/src/Foundation/Types.hs b/src/Foundation/Types.hs index aaa45b153..7e8d9ae6a 100644 --- a/src/Foundation/Types.hs +++ b/src/Foundation/Types.hs @@ -14,7 +14,7 @@ import Import.NoFoundation data UpsertCampusUserMode = UpsertCampusUserLoginLdap | UpsertCampusUserLoginDummy { upsertCampusUserIdent :: UserIdent } - | UpsertCampusUserLoginOther { upsertCampusUserIdent :: UserIdent } + | UpsertCampusUserLoginOther { upsertCampusUserIdent :: UserIdent } -- erlaubt keinen späteren Login | UpsertCampusUserLdapSync { upsertCampusUserIdent :: UserIdent } | UpsertCampusUserGuessUser deriving (Eq, Ord, Read, Show, Generic, Typeable) diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs index 0bebc13b9..9d4bbb1f2 100644 --- a/src/Foundation/Yesod/Auth.hs +++ b/src/Foundation/Yesod/Auth.hs @@ -4,7 +4,7 @@ module Foundation.Yesod.Auth ( authenticate - , upsertCampusUser + , upsertCampusUser, upsertCampusUserByCn , decodeUserTest , CampusUserConversionException(..) , campusUserFailoverMode, updateUserLanguage @@ -152,6 +152,14 @@ _upsertCampusUserMode mMode cs@Creds{..} defaultOther = apHash +upsertCampusUserByCn :: forall m. + ( MonadHandler m, HandlerSite m ~ UniWorX + , MonadThrow m + ) + => Text -> SqlPersistT m (Entity User) +upsertCampusUserByCn persNo = upsertCampusUser UpsertCampusUserGuessUser [(ldapPrimaryKey,[Text.encodeUtf8 persNo])] + + upsertCampusUser :: forall m. ( MonadHandler m, HandlerSite m ~ UniWorX , MonadThrow m diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index 436de5a9c..b438803cd 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -14,9 +14,24 @@ import qualified Data.Text as Text import qualified Data.Set as Set import Handler.Utils +import Handler.Utils.Avs import Utils.Avs +-- Button needed only here +data ButtonAvsTest = BtnCheckLicences + deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) +instance Universe ButtonAvsTest +instance Finite ButtonAvsTest + +nullaryPathPiece ''ButtonAvsTest camelToPathPiece + +instance Button UniWorX ButtonAvsTest where + btnLabel BtnCheckLicences = "Check all licences" -- could be msg + btnClasses BtnCheckLicences = [BCIsButton, BCPrimary] +-- END Button + + avsCardNoField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m AvsCardNo avsCardNoField = convertField AvsCardNo avsCardNo textField @@ -57,6 +72,17 @@ validateAvsQueryStatus = do AvsQueryStatus ids <- State.get guardValidation (MsgAvsQueryStatusInvalid $ tshow ids) $ not (null ids) + +avsLicenceOptions :: OptionList AvsLicence +avsLicenceOptions = mkOptionList + [ Option + { optionDisplay = Text.singleton $ licence2char l + , optionInternalValue = l + , optionExternalValue = toJsonText l + } + | l <- universeF + ] + getAdminAvsR, postAdminAvsR :: Handler Html getAdminAvsR = postAdminAvsR postAdminAvsR = do @@ -81,16 +107,73 @@ postAdminAvsR = do Right jsn -> return . Just $ tshow jsn mbStatus <- formResultMaybe sresult procFormStatus + ((crUsrRes, crUsrWgt), crUsrEnctype) <- runFormPost $ identifyForm FIDAvsCreateUser $ \html -> + flip (renderAForm FormStandard) html $ areq textField (fslI MsgAvsCardNo) Nothing + let procFormCrUsr fr = do + res <- try $ upsertAvsUser fr + case res of + (Right (Just uid)) -> do + uuid :: CryptoUUIDUser <- encrypt uid + return $ Just [whamlet|

Success:

User created or updated.|] + (Right Nothing) -> + return $ Just [whamlet|

Warning:

No user found.|] + (Left e) -> do + let msg = tshow (e :: SomeException) + return $ Just [whamlet|

Error:

#{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|

Success:

Licence #{tshow lic}|] + (Right Nothing) -> + return $ Just [whamlet|

Warning:

User not found.|] + (Left e) -> do + let msg = tshow (e :: SomeException) + return $ Just [whamlet|

Error:

#{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|

Success:

Licence #{tshow (licence2char lic)} set for #{tshow aid}.|] + (Right False) -> + return $ Just [whamlet|

Error:

Licence could not be set for #{tshow aid}.|] + (Left e) -> do + let msg = tshow (e :: SomeException) + return $ Just [whamlet|

Error:

#{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|

Success:

Licences sychronized.|] + (Right False) -> + return $ Just [whamlet|

Error:

Licences could not be synchronized, see error log.|] + (Left e) -> do + let msg = tshow (e :: SomeException) + return $ Just [whamlet|

Error:

#{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") diff --git a/src/Handler/Admin/Test.hs b/src/Handler/Admin/Test.hs index 282f501d7..3b077240e 100644 --- a/src/Handler/Admin/Test.hs +++ b/src/Handler/Admin/Test.hs @@ -22,10 +22,14 @@ import qualified Data.ByteString.Lazy as LBS import qualified Data.Set as Set import qualified Data.Map as Map -import qualified Text.Pandoc as P -import qualified Text.Pandoc.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| +
+

Test i18nHamlet 1 + #{testHamlet1} +
+

Test i18nHamlet 2 + #{testHamlet2} + |] i18n $ MsgPrintDebugForStupid "DebugForStupid" diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 18107ca25..a5468f722 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -83,8 +83,9 @@ postLmsAllR = do FormMissing -> return () _other -> addMessage Warning "Kein korrekter LMS Knopf erkannt" + isAdmin <- hasReadAccessTo AdminR lmsTable <- runDB $ do - view _2 <$> mkLmsAllTable + view _2 <$> mkLmsAllTable isAdmin siteLayoutMsg MsgMenuQualifications $ do setTitleI MsgMenuQualifications $(widgetFile "lms-all") @@ -100,9 +101,10 @@ resultAllQualificationTotal :: Lens' AllQualificationTableData Word64 resultAllQualificationTotal = _dbrOutput . _3 . _unValue -mkLmsAllTable :: DB (Any, Widget) -mkLmsAllTable = 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|

@@ -511,10 +543,10 @@ postLmsR sid qsh = do ^{formatTimeW SelFormatDateTime ackdate} $nothing _{MsgPrintJobUnacknowledged} - $maybe _lu <- lmsident + $maybe lu <- lprLink

- - Link to PrintJob + + _{MsgPrintJobs} |] -- (PrintCenterR, [("pj-lmsid", toPathPiece lu)]) _ -> mempty @@ -528,7 +560,7 @@ postLmsR sid qsh = do where -- i18nLms :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a i18nLms msg = cell [whamlet|LMS #|] <> i18nCell msg - psValidator = def -- TODO: hier einen Filter für Schützlinge einbauen + psValidator = def & forceFilter "may-access" (Any True) tbl <- mkLmsTable qent acts (const E.true) colChoices psValidator return (tbl, qent) diff --git a/src/Handler/LMS/Fake.hs b/src/Handler/LMS/Fake.hs index a9b3b1703..00b470ba8 100644 --- a/src/Handler/LMS/Fake.hs +++ b/src/Handler/LMS/Fake.hs @@ -68,10 +68,20 @@ fakeQualificationUsers (Entity qid Qualification{qualificationRefreshWithin}) (u PWHashConf{..} <- getsYesod $ view _appAuthPWHash pwHash <- liftIO $ PWStore.makePasswordWith pwHashAlgorithm pw pwHashStrength return $ AuthPWHash $ TEnc.decodeUtf8 pwHash - let expiryOffsets = concatMap (replicate usersPerDay) [0..(diffDays dto dfrom)] + theSupervisor <- selectKeysList [UserSurname ==. "Jost", UserFirstName ==. "Steffen"] [Asc UserCreated, LimitTo 1] + let addSupervisor = case theSupervisor of + [s] -> \suid k -> case k of + 1 -> void $ insertBy $ UserSupervisor s suid True + 2 -> do + void $ insertBy $ UserSupervisor s suid True + void $ insertBy $ UserSupervisor suid suid True + 3 -> void $ insertBy $ UserSupervisor s suid True + _ -> return () + _ -> \_ _ -> return () + expiryOffsets = concatMap (replicate usersPerDay) [0..(diffDays dto dfrom)] expiryNotifyDay = addGregorianDurationClip (fromMaybe calendarDay qualificationRefreshWithin) dfrom - fakeUser :: ([Text], UserSurname, (Maybe Languages, DateTimeFormat, DateTimeFormat, DateTimeFormat), Bool) -> User - fakeUser (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) diff --git a/src/Handler/LMS/Users.hs b/src/Handler/LMS/Users.hs index 2127a0f09..28ca2613e 100644 --- a/src/Handler/LMS/Users.hs +++ b/src/Handler/LMS/Users.hs @@ -153,6 +153,7 @@ getLmsUsersR sid qsh = do getLmsUsersDirectR :: SchoolId -> QualificationShorthand -> Handler TypedContent getLmsUsersDirectR sid qsh = do + $logInfoS "LMS" $ "Direct Download Users for " <> tshow qsh <> " at " <> tshow sid lms_users <- runDB $ do qid <- getKeyBy404 $ SchoolQualificationShort sid qsh selectList [LmsUserQualification ==. qid, LmsUserEnded ==. Nothing] [Asc LmsUserStarted, Asc LmsUserIdent] diff --git a/src/Handler/PrintCenter.hs b/src/Handler/PrintCenter.hs index 8d3ecd0e4..eda7c05aa 100644 --- a/src/Handler/PrintCenter.hs +++ b/src/Handler/PrintCenter.hs @@ -45,7 +45,7 @@ single :: (k,a) -> Map k a single = uncurry Map.singleton data MetaPinRenewal = MetaPinRenewal - { mppRecipient :: Text + { mppExaminee :: Text , mppAddress :: StoredMarkup , mppLogin :: Text , mppPin :: Text @@ -54,13 +54,14 @@ data MetaPinRenewal = MetaPinRenewal , mppLang :: Lang , mppOpening :: Maybe Text , mppClosing :: Maybe Text + , mppSupervisor:: Maybe Text } deriving (Eq, Ord, Show, Generic, Typeable) -- TODO: just for testing, remove in production instance Default MetaPinRenewal where def = MetaPinRenewal - { mppRecipient = "Papa Schlumpf" + { mppExaminee = "Papa Schlumpf" , mppAddress = plaintextToStoredMarkup ("Erdbeerweg 42\n98726 Schlumpfhausen"::Text) , mppLogin = "keiner123" , mppPin = "89998a" @@ -69,13 +70,14 @@ instance Default MetaPinRenewal where , mppLang = "de-de" , mppOpening = Just "Lieber Schlumpfi," , mppClosing = Nothing + , mppSupervisor= Nothing } makeRenewalForm :: Maybe MetaPinRenewal -> Form MetaPinRenewal makeRenewalForm tmpl = identifyForm FIDLmsLetter . validateForm validateMetaPinRenewal $ \html -> do now_day <- utctDay <$> liftIO getCurrentTime flip (renderAForm FormStandard) html $ MetaPinRenewal - <$> areq textField (fslI MsgMppRecipient) (mppRecipient <$> tmpl) + <$> areq textField (fslI MsgMppRecipient) (mppExaminee <$> tmpl) <*> areq htmlField (fslI MsgMppAddress) (mppAddress <$> tmpl) <*> areq textField (fslI MsgMppLogin) (mppLogin <$> tmpl) <*> areq textField (fslI MsgMppPin) (mppPin <$> tmpl) @@ -84,6 +86,7 @@ makeRenewalForm tmpl = identifyForm FIDLmsLetter . validateForm validateMetaPinR <*> areq (langField True) (fslI MsgMppLang) ((mppLang <$> tmpl) <|> Just "de-de") <*> aopt textField (fslI MsgMppOpening) (mppOpening <$> tmpl) <*> aopt textField (fslI MsgMppClosing) (mppClosing <$> tmpl) + <*> aopt textField (fslI MsgMppSupervisor) (mppSupervisor<$> tmpl) validateMetaPinRenewal :: FormValidator MetaPinRenewal Handler () validateMetaPinRenewal = do @@ -93,9 +96,9 @@ validateMetaPinRenewal = do mprToMeta :: MetaPinRenewal -> P.Meta mprToMeta MetaPinRenewal{..} = mkMeta - -- formatTimeUser SelFormatDate mppDate mppRecipient - [ 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 diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index e982171f3..7c8660ee2 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -4,7 +4,9 @@ module Handler.Profile ( getProfileR, postProfileR - , getProfileDataR, makeProfileData + , getForProfileR, postForProfileR + , getProfileDataR, makeProfileData + , getForProfileDataR , getAuthPredsR, postAuthPredsR , getUserNotificationR, postUserNotificationR , getSetDisplayEmailR, postSetDisplayEmailR @@ -482,10 +484,19 @@ instance Finite ProfileAnchor nullaryPathPiece ''ProfileAnchor $ camelToPathPiece' 1 -getProfileR, postProfileR :: Handler Html -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 ) diff --git a/src/Handler/SAP.hs b/src/Handler/SAP.hs index 513070a82..543ef0a92 100644 --- a/src/Handler/SAP.hs +++ b/src/Handler/SAP.hs @@ -16,6 +16,7 @@ import Handler.Utils.Csv -- import qualified Data.CaseInsensitive as CI import qualified Data.Csv as Csv +import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma -- import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E @@ -69,12 +70,12 @@ sapRes2csv l = [ res | (Ex.Value (Just persNo), Ex.Value firstHeld, Ex.Value val getQualificationSAPDirectR :: Handler TypedContent getQualificationSAPDirectR = do qualUsers <- runDB $ Ex.select $ do - (qual Ex.:& qualUser Ex.:& user) <- + (qual :& qualUser :& user) <- Ex.from $ Ex.table @Qualification `Ex.innerJoin` Ex.table @QualificationUser - `Ex.on` (\(qual Ex.:& qualUser) -> qual Ex.^. QualificationId Ex.==. qualUser Ex.^. QualificationUserQualification) + `Ex.on` (\(qual :& qualUser) -> qual Ex.^. QualificationId Ex.==. qualUser Ex.^. QualificationUserQualification) `Ex.innerJoin` Ex.table @User - `Ex.on` (\(_ Ex.:& qualUser Ex.:& user) -> qualUser Ex.^. QualificationUserUser Ex.==. user Ex.^. UserId) + `Ex.on` (\(_ :& qualUser :& user) -> qualUser Ex.^. QualificationUserUser Ex.==. user Ex.^. UserId) Ex.where_ $ E.isJust (qual Ex.^. QualificationSapId) Ex.&&. E.isJust (user Ex.^. UserCompanyPersonalNumber) return diff --git a/src/Handler/Users/Add.hs b/src/Handler/Users/Add.hs index 2664e4c2e..d267bd85d 100644 --- a/src/Handler/Users/Add.hs +++ b/src/Handler/Users/Add.hs @@ -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 diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index 27416a072..b5b1547f2 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -30,6 +30,7 @@ import Handler.Utils.Memcached as Handler.Utils hiding (manageMemcachedLocalInv import Handler.Utils.Files as Handler.Utils import Handler.Utils.Download as Handler.Utils import Handler.Utils.AuthorshipStatement as Handler.Utils +--import Handler.Utils.Company as Handler.Utils import Handler.Utils.Term as Handler.Utils diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 2734ca649..d604e7ed9 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -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 - + diff --git a/src/Handler/Utils/Company.hs b/src/Handler/Utils/Company.hs new file mode 100644 index 000000000..9d55090a0 --- /dev/null +++ b/src/Handler/Utils/Company.hs @@ -0,0 +1,52 @@ +-- SPDX-FileCopyrightText: 2022 Steffen Jost +-- +-- 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 diff --git a/src/Handler/Utils/DateTime.hs b/src/Handler/Utils/DateTime.hs index 09c605930..c54cd7854 100644 --- a/src/Handler/Utils/DateTime.hs +++ b/src/Handler/Utils/DateTime.hs @@ -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 $ diff --git a/src/Handler/Utils/I18n.hs b/src/Handler/Utils/I18n.hs index d6146036b..8cc6d45f0 100644 --- a/src/Handler/Utils/I18n.hs +++ b/src/Handler/Utils/I18n.hs @@ -28,7 +28,9 @@ import qualified Data.Map as Map import System.Directory (listDirectory) import Text.Hamlet (hamletFile) - +-- | Produces: let ws = \case "de" -> ; ... +-- 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 diff --git a/src/Handler/Utils/LdapSystemFunctions.hs b/src/Handler/Utils/LdapSystemFunctions.hs index 7cb61a503..ada89b1b8 100644 --- a/src/Handler/Utils/LdapSystemFunctions.hs +++ b/src/Handler/Utils/LdapSystemFunctions.hs @@ -18,4 +18,3 @@ determineSystemFunctions ldapFuncs = \case -- SJ: not sure this LDAP-specific key belongs here? SystemStudent -> False -- "student" `Set.member` ldapFuncs -- no such key identified at FraPort SystemPrinter -> False -- "department=IFM-IS2" zu viele Mitglieder - SystemSap -> False diff --git a/src/Handler/Utils/Mail.hs b/src/Handler/Utils/Mail.hs index e2e15f12c..227e5ebf2 100644 --- a/src/Handler/Utils/Mail.hs +++ b/src/Handler/Utils/Mail.hs @@ -5,16 +5,17 @@ module Handler.Utils.Mail ( addRecipientsDB , userAddress, userAddressFrom - , userMailT + , userMailT, userMailTdirect , addFileDB , addHtmlMarkdownAlternatives , addHtmlMarkdownAlternatives' - , addHtmlMarkdownAlternatives'' ) where import Import import Handler.Utils.Pandoc import Handler.Utils.Files +import Handler.Utils.Widgets (nameHtml') -- TODO: how to use name widget here? +import Handler.Utils.Users (getReceivers) import qualified Data.CaseInsensitive as CI @@ -22,7 +23,7 @@ import qualified Data.Conduit.Combinators as C import qualified Text.Pandoc as P -import qualified Text.Hamlet as Hamlet (Translate) +import qualified Text.Hamlet as Hamlet import qualified Text.Shakespeare as Shakespeare (RenderUrl) @@ -48,12 +49,73 @@ userAddress :: User -> Address -- Uses `userEmail` userAddress User{userEmail, userDisplayName} = Address (Just userDisplayName) $ CI.original userEmail + +-- |Send an email to the given UserId or to all registered Supervisor with rerouteNotifications == True userMailT :: ( MonadHandler m , HandlerSite m ~ UniWorX , MonadThrow m , MonadUnliftIO m - ) => UserId -> MailT m a -> m a + ) => UserId -> MailT m () -> m () userMailT uid mAct = do + (underling, receivers, undercopy) <- liftHandler . runDB $ getReceivers uid + let undername = underling ^. _userDisplayName -- nameHtml' underling + undermail = CI.original $ underling ^. _userEmail + infoSupervised :: Hamlet.HtmlUrlI18n UniWorXSendMessage (Route UniWorX) = [ihamlet| +

_{MsgMailSupervisedNote} +

+ _{MsgMailSupervisedBody} +