diff --git a/CHANGELOG.md b/CHANGELOG.md index 886ded3c3..94ff09a18 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,14 +2,28 @@ All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines. -## [27.1.6](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.1.5...v27.1.6) (2023-03-31) +## [27.2.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.1.6...v27.2.0) (2023-04-06) -## [27.1.5](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.1.4...v27.1.5) (2023-03-31) + +### Features + +* **letter:** allow printing of multiple course certificates at once ([768f03f](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/768f03f6727f54b7c7aa18ecef8bc67302ee27cd)) + +## [27.1.6](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.1.4...v27.1.6) (2023-04-05) ### Bug Fixes * **lms:** lms-direct/deletion-days setting now represent #days to presever lms (used to be #days+1) ([d02e62e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/d02e62ec20b8cdc9dd6144de558895885ad1e692)) +* **reachability:** account for e-users being assigned a useless company department ([bb27324](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/bb27324ee8dff257da09c1575468048d793bec8e)) + +## [27.1.5](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.1.4...v27.1.5) (2023-04-04) + + +### Bug Fixes + +* **lms:** lms-direct/deletion-days setting now represent #days to presever lms (used to be #days+1) ([d02e62e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/d02e62ec20b8cdc9dd6144de558895885ad1e692)) +* **reachability:** account for e-users being assigned a useless company department ([bb27324](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/bb27324ee8dff257da09c1575468048d793bec8e)) ## [27.1.4](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.1.3...v27.1.4) (2023-03-28) diff --git a/messages/uniworx/categories/authorization/de-de-formal.msg b/messages/uniworx/categories/authorization/de-de-formal.msg index a5e4e744c..e16240aa5 100644 --- a/messages/uniworx/categories/authorization/de-de-formal.msg +++ b/messages/uniworx/categories/authorization/de-de-formal.msg @@ -107,20 +107,19 @@ CampusUserInvalidDisplayName: Konnte anhand des Fraport Büko-Logins keinen voll CampusUserInvalidGivenName: Konnte anhand des Fraport Büko-Logins keinen Vornamen ermitteln CampusUserInvalidSurname: Konnte anhand des Fraport Büko-Logins keinen Nachname ermitteln CampusUserInvalidTitle: Konnte anhand des Fraport Büko-Logins keinen akademischen Titel ermitteln -CampusUserInvalidMatriculation: Konnte anhand des Fraport Büko-Logins keine Matrikelnummer ermitteln CampusUserInvalidFeaturesOfStudy parseErr@Text: Konnte anhand des Fraport Büko-Logins keine Studiengänge ermitteln CampusUserInvalidAssociatedSchools parseErr@Text: Konnte anhand des Fraport Büko-Logins keine Institute ermitteln InvalidCredentialsADNoSuchObject: Benutzereintrag existiert nicht InvalidCredentialsADLogonFailure: Ungültiges Passwort -InvalidCredentialsADAccountRestriction: Kontobeschränkungen verhindern Login +InvalidCredentialsADAccountRestriction: Beschränkungen des Fraport Accounts verhindern Login InvalidCredentialsADInvalidLogonHours: Benutzer:in darf sich zur aktuellen Tageszeit nicht anmelden InvalidCredentialsADInvalidWorkstation: Benutzer:in darf sich von diesem System aus nicht anmelden -InvalidCredentialsADPasswordExpired: Passwort abgelaufen -InvalidCredentialsADAccountDisabled: Benutzereintrag gesperrt +InvalidCredentialsADPasswordExpired: Passwort abgelaufen; ändern Sie Ihr Fraport Passwort auf dem üblichen Weg (z.B. E-Account Nutzer per Azure-Portal) +InvalidCredentialsADAccountDisabled: Ihr Fraport Account wurde gesperrt, bitte wenden Sie sich an den allgemeinen IT Support InvalidCredentialsADTooManyContextIds: Benutzereintrag trägt zu viele Sicherheitskennzeichen -InvalidCredentialsADAccountExpired: Benutzereintrag abgelaufen -InvalidCredentialsADPasswordMustChange: Passwort muss geändert werden -InvalidCredentialsADAccountLockedOut: Benutzereintrag wurde durch Eindringlingserkennung gesperrt +InvalidCredentialsADAccountExpired: Benutzereintrag abgelaufen, bitte wenden Sie sich an den allgemeinen IT Support +InvalidCredentialsADPasswordMustChange: Passwort muss geändert werden; ändern Sie Ihr Fraport Passwort auf dem üblichen Weg (z.B. E-Account Nutzer per Azure-Portal) +InvalidCredentialsADAccountLockedOut: Benutzereintrag wurde durch Eindringlingserkennung gesperrt, bitte wenden Sie sich an den allgemeinen IT Support LoginTitle: Authentifizierung @@ -137,4 +136,4 @@ FormHoneypotNameTip: Ihr Name oder Ihre E-Mail Adresse FormHoneypotNamePlaceholder: Name FormHoneypotComment: Kommentar FormHoneypotCommentPlaceholder: Kommentar -FormHoneypotFilled: Bitte füllen Sie keines der verstecken Felder aus \ No newline at end of file +FormHoneypotFilled: Bitte füllen Sie keines der verstecken Felder aus diff --git a/messages/uniworx/categories/authorization/en-eu.msg b/messages/uniworx/categories/authorization/en-eu.msg index 489a2e6ca..d2ad99d62 100644 --- a/messages/uniworx/categories/authorization/en-eu.msg +++ b/messages/uniworx/categories/authorization/en-eu.msg @@ -108,20 +108,19 @@ CampusUserInvalidDisplayName: Could not determine display name during Fraport B CampusUserInvalidGivenName: Could not determine given name during Fraport Büko login CampusUserInvalidSurname: Could not determine surname during Fraport Büko login CampusUserInvalidTitle: Could not determine title during Fraport Büko login -CampusUserInvalidMatriculation: Could not determine matriculation during Fraport Büko login CampusUserInvalidFeaturesOfStudy parseErr: Could not determine features of study during Fraport Büko login CampusUserInvalidAssociatedSchools parseErr: Could not determine associated departments during Fraport Büko login InvalidCredentialsADNoSuchObject: User entry does not exist -InvalidCredentialsADLogonFailure: Invalid passwod -InvalidCredentialsADAccountRestriction: Account restrictions are preventing login +InvalidCredentialsADLogonFailure: Invalid password +InvalidCredentialsADAccountRestriction: Restrictions on your Fraport account prevent a login InvalidCredentialsADInvalidLogonHours: User may not login at the current time of day InvalidCredentialsADInvalidWorkstation: User may not login from this system -InvalidCredentialsADPasswordExpired: Password expired -InvalidCredentialsADAccountDisabled: Account disabled +InvalidCredentialsADPasswordExpired: Password expired, please change your Fraport account password by the usual way (eg. E-account users via Azure portal) +InvalidCredentialsADAccountDisabled: Fraport account disabled, please contact general IT support InvalidCredentialsADTooManyContextIds: Account carries to many security identifiers -InvalidCredentialsADAccountExpired: Account expired -InvalidCredentialsADPasswordMustChange: Password needs to be changed -InvalidCredentialsADAccountLockedOut: Account disabled by intruder detection +InvalidCredentialsADAccountExpired: Account expired, please contact general IT support +InvalidCredentialsADPasswordMustChange: Password needs to be changed, please change your Fraport account password by the usual way (eg. E-account users via Azure portal) +InvalidCredentialsADAccountLockedOut: Account disabled by intruder detection, please contact general IT support LoginTitle: Authentication diff --git a/messages/uniworx/categories/avs/de-de-formal.msg b/messages/uniworx/categories/avs/de-de-formal.msg index 33f266aed..84c10e982 100644 --- a/messages/uniworx/categories/avs/de-de-formal.msg +++ b/messages/uniworx/categories/avs/de-de-formal.msg @@ -1,7 +1,7 @@ # SPDX-FileCopyrightText: 2022 Steffen Jost # # SPDX-License-Identifier: AGPL-3.0-or-later - +AvsPersonInfo: AVS Personendaten AvsPersonId: AVS Personen Id AvsPersonNo: AVS Personennummer AvsCardNo: Ausweiskartennummer @@ -29,4 +29,9 @@ RevokeUnknownLicencesFail: Nicht alle AVS Fahrberechtigungen unbekannter Fahrer AvsCommunicationError: AVS Schnittstelle lieferte einen unerwarteten Fehler. LicenceTableChangeAvs: Im AVS ändern LicenceTableGrantFDrive: In FRADrive erteilen -LicenceTableRevokeFDrive: In FRADrive entziehen \ No newline at end of file +LicenceTableRevokeFDrive: In FRADrive entziehen +TableAvsActiveCards: Gültige Ausweise +AvsCardColorGreen: Grün +AvsCardColorBlue: Blau +AvsCardColorRed: Rot +AvsCardColorYellow: Gelb \ 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 cadb045af..5cd51c3c3 100644 --- a/messages/uniworx/categories/avs/en-eu.msg +++ b/messages/uniworx/categories/avs/en-eu.msg @@ -1,7 +1,7 @@ # SPDX-FileCopyrightText: 2022 Steffen Jost # # SPDX-License-Identifier: AGPL-3.0-or-later - +AvsPersonInfo: AVS Person Info AvsPersonId: AVS Person Id AvsPersonNo: AVS Person Number AvsCardNo: Card number @@ -30,3 +30,8 @@ AvsCommunicationError: AVS interface returned an unexpected error. LicenceTableChangeAvs: Change in AVS LicenceTableGrantFDrive: Grant in FRADrive LicenceTableRevokeFDrive: Revoke in FRADrive +TableAvsActiveCards: Valid Cards +AvsCardColorGreen: Green +AvsCardColorBlue: Blue +AvsCardColorRed: Red +AvsCardColorYellow: Yellow \ No newline at end of file diff --git a/messages/uniworx/categories/courses/courses/de-de-formal.msg b/messages/uniworx/categories/courses/courses/de-de-formal.msg index 939bb0659..fa44ab8cc 100644 --- a/messages/uniworx/categories/courses/courses/de-de-formal.msg +++ b/messages/uniworx/categories/courses/courses/de-de-formal.msg @@ -132,7 +132,7 @@ CourseUserTutorials: Angemeldete Tutorien CourseUserExams: Angemeldete Prüfungen CourseUserSheets: Übungsblätter CsvColumnUserName: Voller Name des/der Teilnehmers/Teilnehmerin -CsvColumnUserMatriculation: Matrikelnummer des/der Teilnehmers/Teilnehmerin +CsvColumnUserMatriculation: AVS Nummer des/der Teilnehmers/Teilnehmerin CsvColumnUserSex: Geschlecht CsvColumnUserBirthday: Geburtstag CsvColumnUserEmail: E-Mail-Adresse des/der Teilnehmers/Teilnehmerin diff --git a/messages/uniworx/categories/courses/courses/en-eu.msg b/messages/uniworx/categories/courses/courses/en-eu.msg index 0625c9ccc..ae25a7187 100644 --- a/messages/uniworx/categories/courses/courses/en-eu.msg +++ b/messages/uniworx/categories/courses/courses/en-eu.msg @@ -132,7 +132,7 @@ CourseUserTutorials: Registered tutorials CourseUserExams: Registered exams CourseUserSheets: Exercise sheets CsvColumnUserName: Participant's full name -CsvColumnUserMatriculation: Participant's matriculation +CsvColumnUserMatriculation: Participant's AVS number CsvColumnUserSex: Participant's sex CsvColumnUserBirthday: Birthday CsvColumnUserEmail: Participant's email address diff --git a/messages/uniworx/categories/print/de-de-formal.msg b/messages/uniworx/categories/print/de-de-formal.msg index 2e0c55e2b..c5a134c12 100644 --- a/messages/uniworx/categories/print/de-de-formal.msg +++ b/messages/uniworx/categories/print/de-de-formal.msg @@ -20,5 +20,5 @@ PrintCourse: Kurse PrintQualification: Qualifikation PrintPDF !ident-ok: PDF PrintManualRenewal: Vorfeldführerschein Renewal-Brief testweise versenden -PrintLmsUser: E-Learning Id +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 8e1ee4b57..770a23725 100644 --- a/messages/uniworx/categories/print/en-eu.msg +++ b/messages/uniworx/categories/print/en-eu.msg @@ -20,5 +20,5 @@ PrintCourse: Course PrintQualification: Qualification PrintPDF: PDF PrintManualRenewal: Manual sending of an apron driver's licence renewal letter -PrintLmsUser: E-learning id +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 2d9e6af3c..6edfe9c1a 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -8,8 +8,8 @@ QualificationDescription: Beschreibung QualificationValidDuration: Gültigkeitsdauer QualificationAuditDuration: Aufbewahrung Audit Log QualificationRefreshWithin: Erneurerungszeitraum -QualificationRefreshWithinTooltip: Zeitraum für Versand einer Benachrichtigung oder für automatischen Start des E-Learning -QualificationElearningStart: Wird das E-Learning automatisch gestartet? +QualificationRefreshWithinTooltip: Zeitraum für Versand einer Benachrichtigung oder für automatischen Start des E‑Learning +QualificationElearningStart: Wird das E‑Learning automatisch gestartet? TableQualificationCountActive: Aktive TableQualificationCountActiveTooltip: Anzahl Personen mit momentan gültiger Qualifikation TableQualificationCountTotal: Gesamt @@ -29,7 +29,7 @@ QualificationUserNoRenewal: Läuft ohne Benachrichtigung aus QualificationUserNone: Für diese Person sind keine Qualifikationen registriert. QualificationBlockReason: Entzugsbegründung LmsUser: Inhaber -LmsURL: Link E-Learning +LmsURL: Link E‑Learning TableLmsEmail: E‑Mail TableLmsIdent: LMS Identifikation TableLmsElearning: E‑Learning @@ -41,20 +41,25 @@ TableLmsStaff: Interner Mitarbeiter? TableLmsStarted: Begonnen TableLmsReceived: Letzte Rückmeldung TableLmsNotified: Versand Benachrichtigung -TableLmsNotifiedTooltip: Benachrichtigungen werden erst versendet wenn das LMS bestätigt die Eröffnung des E-Learning für den Benutzer bestätigt hat, was ein paar Stunden dauern kann! +TableLmsNotifiedTooltip: Benachrichtigungen werden erst versendet wenn das LMS bestätigt die Eröffnung des E‑Learning für den Benutzer bestätigt hat, was ein paar Stunden dauern kann! TableLmsEnded: Beended TableLmsStatus: Status E‑Learning -TableLmsStatusTooltip mbMonth@(Maybe Int): Zeigt an, seit wann ein E-Learning offen ist oder wann es mit Bestanden oder Durchgefalen abgeschlossen wurde. #{maybeToMessage "Anzeige erlischt " (fmap (flip pluralDEeN "Monat") mbMonth) " nach Abschluss."} -TableLmsStatusDay: Datum letzte Statusänderung E-Learning +TableLmsStatusTooltip mbMonth@(Maybe Int): Zeigt #{maybeToMessage "bis zu " (fmap (flip pluralDEeN "Monat") mbMonth) " nach Abschluss"} den letzten Zustand eines E‑Learnings an: +TableLmsStatusDay: Datum letzte Statusänderung E‑Learning TableLmsSuccess: Bestanden TableLmsFailed: Gesperrt +LmsStatusBlocked: Durchgefallen wegen zu vieler Fehlversuche +LmsStatusExpired: Durchgefallen nach Fristablauf +LmsStatusSuccess: E#{nonBreakableDash}Learning bestanden +LmsStatusPlanned: E#{nonBreakableDash}Learning wird gerade eröffnet (nur für Admin sichtbar) +LmsStatusDelay: Hinweis: Statusänderung können in seltenen Fällen mehrere Stunden bis zur Anzeige benötigen. FilterLmsValid: Aktuell gültig FilterLmsRenewal: Erneuerung anstehend FilterLmsNotified: Benachrichtigt -CsvColumnLmsIdent: E-Learning Identifikator, einzigartig pro Qualifikation und Teilnehmer -CsvColumnLmsPin: PIN des E-Learning Zugangs +CsvColumnLmsIdent: E‑Learning Identifikator, einzigartig pro Qualifikation und Teilnehmer +CsvColumnLmsPin: PIN des E#{nonBreakableDash}Learning Zugangs CsvColumnLmsResetPin: Wird die PIN bei der nächsten Synchronisation zurückgesetzt? -CsvColumnLmsDelete: Wird der Identifikator in der E-Learning Plattform bei der nächsten Synchronisation gelöscht? +CsvColumnLmsDelete: Wird der Identifikator in der E‑Learning Plattform bei der nächsten Synchronisation gelöscht? CsvColumnLmsStaff: Handelt es sich um einen internen Mitarbeiter? (Aus historischen Gründen, wird momentan ignoriert.) CsvColumnLmsSuccess: Zeitstempel der erfolgreichen Teilnahme (UTC) CsvColumnLmsFailed: User was blocked by LMS, usually due to too many attempts @@ -65,32 +70,33 @@ LmsResultUpdate: LMS Ergebnis aktualisierung LmsResultCsvExceptionDuplicatedKey: CSV Import fand uneindeutigen Schlüssel LmsUserlistCsvExceptionDuplicatedKey: CSV Import fand uneindeutigen Schlüssel LmsDirectUpload: Direkter Upload für automatisierte Systeme -LmsErrorNoRefreshElearning: Fehler: E-Learning wird nicht automatisch gestartet, da die Zeitspanne für den Erneurerungszeitraum nicht festgelegt wurde. +LmsErrorNoRefreshElearning: Fehler: E‑Learning wird nicht automatisch gestartet, da die Zeitspanne für den Erneurerungszeitraum nicht festgelegt wurde. 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 qname@Text: Qualifikation #{qname} muss demnächst durch einen E-Learning erneuert werden. Ansprechpartner werden gebeten, die Anmeldedaten im Anhang vertraulich an den Prüfling zu übermitteln. +MailBodyQualificationRenewal qname@Text: Qualifikation #{qname} muss demnächst durch einen E‑Learning erneuert werden. Ansprechpartner werden gebeten, die Anmeldedaten im Anhang vertraulich an den Prüfling zu übermitteln. MailBodyQualificationExpiry: Diese Qualifikation läuft bald ab. Tätigkeiten, welche diese Qualifikation voraussetzen dürfen dann nicht länger ausgeübt werden! -MailBodyQualificationExpired: Diese Qualifikation 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. +MailBodyQualificationExpired: Diese Qualifikation 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. QualificationActExpire: Auslaufend markieren - keine Benachrichtigung zur Erneuerung senden QualificationActUnexpire: Auslaufend aufheben - kostenpflichtige Benachrichtigung bei anstehender Erneuerung senden -QualificationSetExpire n@Int64: Benachrichtigung bei anstehender Erneuerung und E-Learning abgeschaltet für #{n} #{pluralDE n "Person" "Personen"} -QualificationSetUnexpire n@Int64: Benachrichtigung bei anstehender Erneuerung und E-Learning aktiviert für #{n} #{pluralDE n "Person" "Personen"} +QualificationSetExpire n@Int64: Benachrichtigung bei anstehender Erneuerung und E‑Learning abgeschaltet für #{n} #{pluralDE n "Person" "Personen"} +QualificationSetUnexpire n@Int64: Benachrichtigung bei anstehender Erneuerung und E‑Learning aktiviert für #{n} #{pluralDE n "Person" "Personen"} QualificationActBlockSupervisor: Dauerhaft entziehen, mit sofortiger Wirkung QualificationActBlock: Entziehen QualificationActUnblock: Entzug löschen QualificationStatusBlock l@QualificationShorthand n@Int m@Int: #{n}/#{m} #{l} entzogen QualificationStatusUnblock l@QualificationShorthand n@Int m@Int: #{n}/#{m} #{l} reaktiviert LmsRenewalInstructions: Weitere Anweisungen zur Verlängerung finden Sie im angehängten PDF. Um Missbrauch zu verhindern wurde das PDF mit dem im FRADrive hinterlegten PDF-Passwort des Prüflings verschlüsselt. Falls kein PDF-Passwort manuell hinterlegt wurde, ist das PDF-Passwort die Flughafen Ausweisnummer, inklusive Punkt und der Ziffer danach. -LmsNoRenewal: Leider kann diese Qualifikation nicht alleine durch E-Learning verlängert werden. -LmsActNotify: Benachrichtigung E-Learning erneut per Post oder E-Mail versenden -LmsActRenewPin: Neue zufällige E-Learning PIN zuweisen -LmsActRenewNotify: Neue zufällige E-Learning PIN zuweisen und Benachrichtigung per Post oder E-Mail versenden -LmsNotificationSend n@Int: E-Learning Benachrichtigungen an #{n} #{pluralDE n "Prüfling" "Prüflinge"} werden per Post oder E-Mail versendet. -LmsPinRenewal n@Int: E-Learning Pin ausgetauscht für #{n} #{pluralDE n "Prüfling" "Prüflinge"}. +LmsNoRenewal: Leider kann diese Qualifikation nicht alleine durch E‑Learning verlängert werden. +LmsActNotify: Benachrichtigung E‑Learning erneut per Post oder E-Mail versenden +LmsActRenewPin: Neue zufällige E‑Learning PIN zuweisen +LmsActRenewNotify: Neue zufällige E‑Learning PIN zuweisen und Benachrichtigung per Post oder E-Mail versenden +LmsStatusNotificationSent: Anmeldedaten wurden an Prüfling oder Ansprechpartner per Post oder E#{nonBreakableDash}Mail versendet; E#{nonBreakableDash}Learning ist derzeit offen +LmsNotificationSend n@Int: E‑Learning Benachrichtigungen an #{n} #{pluralDE n "Prüfling" "Prüflinge"} werden per Post oder E-Mail versendet. +LmsPinRenewal n@Int: E‑Learning Pin ausgetauscht für #{n} #{pluralDE n "Prüfling" "Prüflinge"}. LmsActionFailed n@Int: Aktion nicht durchgeführt für #{n} #{pluralDE n "Person" "Personen"}, da diese derzeit nicht an einer Prüfung teilnehmen. -LmsStarted: E-Learning eröffnet +LmsStarted: E‑Learning eröffnet LmsAutomaticQueuing n@Natural: Die folgenden Funktionen werden normalerweise einmal pro Tag um #{show n} Uhr ausgeführt. LmsManualQueuing: Die folgenden Funktionen sollten einmal pro Tag ausgeführt werden. -BtnLmsEnqueue: Nutzer mit ablaufenden Qualifikationen zum E-Learning anmelden und benachrichtigen -BtnLmsDequeue: Nutzer mit beendetem E-Learning ggf. benachrichtigen und aufräumen +BtnLmsEnqueue: Nutzer mit ablaufenden Qualifikationen zum E‑Learning anmelden und benachrichtigen +BtnLmsDequeue: Nutzer mit beendetem E‑Learning ggf. benachrichtigen und aufräumen diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg index 0a3cc9eec..607189e1d 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/messages/uniworx/categories/qualification/en-eu.msg @@ -8,8 +8,8 @@ QualificationDescription: Description QualificationValidDuration: Validity period QualificationAuditDuration: Audit log keept QualificationRefreshWithin: Refresh within -QualificationRefreshWithinTooltip: Period before expiry to send a notification or to start e-learning -QualificationElearningStart: Is e-learning automatically started? +QualificationRefreshWithinTooltip: Period before expiry to send a notification or to start e‑learning +QualificationElearningStart: Is e‑learning automatically started? TableQualificationCountActive: Active TableQualificationCountActiveTooltip: Number of currently valid qualification holders TableQualificationCountTotal: Total @@ -41,19 +41,24 @@ TableLmsStaff: Staff? TableLmsStarted: Started TableLmsReceived: Last update TableLmsNotified: Notification sent -TableLmsNotifiedTooltip: Notfications are not sent before the LMS acknowledges the opening of the e-learning course for the user, which may take several hours! +TableLmsNotifiedTooltip: Notfications are not sent before the LMS acknowledges the opening of the e‑learning course for the user, which may take several hours! TableLmsEnded: Ended -TableLmsStatus: Status e-learning -TableLmsStatusTooltip mbMonth: Shows since when an e-learning is open or when it was closed, including the result. #{maybeToMessage "Shown for " (fmap (flip pluralENsN "month") mbMonth) " after closure."} -TableLmsStatusDay: Date of last e-learning status change +TableLmsStatus: Status e‑learning +TableLmsStatusTooltip mbMonth: Shows #{maybeToMessage "for up to " (fmap (flip pluralENsN "month") mbMonth) " after closure"} the last e#{nonBreakableDash}learning status change: +TableLmsStatusDay: Date of last e‑learning status change TableLmsSuccess: Completed TableLmsFailed: Blocked +LmsStatusBlocked: Failed after too many attempts +LmsStatusExpired: Failed due to expiry +LmsStatusSuccess: Passed +LmsStatusPlanned: E#{nonBreakableDash}learning is about to be opened (visible to Admins only) +LmsStatusDelay: Note that status changes may occassionaly require more than a hour to be displayed here. FilterLmsValid: Currently valid FilterLmsRenewal: Renewal due FilterLmsNotified: Notified -CsvColumnLmsIdent: E-learning identifier, unique for each qualification and user -CsvColumnLmsPin: PIN for e-learning access -CsvColumnLmsResetPin: Will the e-learning PIN be reset upon next synchronisation? +CsvColumnLmsIdent: E#{nonBreakableDash}learning identifier, unique for each qualification and user +CsvColumnLmsPin: PIN for e#{nonBreakableDash}learning access +CsvColumnLmsResetPin: Will the e#{nonBreakableDash}learning PIN be reset upon next synchronisation? CsvColumnLmsDelete: Will the identifier be deleted from the E-learning platfrom upon next synchronisation? CsvColumnLmsStaff: Is the user an internal staff member? (Legacy, currently ignored) CsvColumnLmsSuccess: Timestamp of successful completion (UTC) @@ -69,13 +74,13 @@ LmsErrorNoRefreshElearning: Error: E-learning will not be started automatically MailSubjectQualificationRenewal qname: Qualification #{qname} must be renewed shortly MailSubjectQualificationExpiry qname: Qualification #{qname} expires soon MailSubjectQualificationExpired qname: Qualification #{qname} is no longer valid -MailBodyQualificationRenewal qname: The qualification #{qname} must be renewed soon by completing an e-learning course, otherwise it will expire. Supervisors are kindly requested to forward the login data confidentially to the examinee. +MailBodyQualificationRenewal qname: The qualification #{qname} must be renewed soon by completing an e‑learning course, otherwise it will expire. Supervisors are kindly requested to forward the login data confidentially to the examinee. MailBodyQualificationExpiry: This qualification expires soon. You may then no longer execute any duties that require this qualification as a precondition! -MailBodyQualificationExpired: This qualification 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. +MailBodyQualificationExpired: This qualification 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. QualificationActExpire: Discontinue - qualification expires silently QualificationActUnexpire: Continue - send a possibly fee-paying notification upon due renewal -QualificationSetExpire n: Expiry notification and e-learning deactivated for #{n} #{pluralENs n "person"} -QualificationSetUnexpire n: Expiry notification and e-learning activated for #{n} #{pluralENs n "person"} +QualificationSetExpire n: Expiry notification and e‑learning deactivated for #{n} #{pluralENs n "person"} +QualificationSetUnexpire n: Expiry notification and e‑learning activated for #{n} #{pluralENs n "person"} QualificationActBlockSupervisor: Waive permanently, effective immediately QualificationActBlock: Revoke QualificationActUnblock: Clear revocation @@ -83,14 +88,15 @@ QualificationStatusBlock l n m: #{n}/#{m} #{l} revoked QualificationStatusUnblock l n m: #{n}/#{m} #{l} reactivated LmsRenewalInstructions: Instruction on how to accomplish the renewal are enclosed in the attached PDF. In order to avoid misuse, the PDF is encrypted with the FRADrive PDF-password of the examinee. If no PDF-password had been chosen yet, then the password is the Fraport id card number of the examinee, including the punctuation mark and the digit thereafter. LmsNoRenewal: Unfortunately, this particular qualification cannot be renewed through E-learning only. -LmsActNotify: Resend e-learning notification by post or email -LmsActRenewPin: Randomly replace e-learning PIN -LmsActRenewNotify: Randomly replace e-learning PIN and re-send notification by post or email +LmsActNotify: Resend e‑learning notification by post or email +LmsActRenewPin: Randomly replace e‑learning PIN +LmsActRenewNotify: Randomly replace e‑learning PIN and re-send notification by post or email +LmsStatusNotificationSent: E-learning pin has been sent to examinee or supervisor by letter post or by email; e‑learning is currently open LmsNotificationSend n: E-learning notifications will be sent to #{n} #{pluralENs n "examinee"} by letter post or by email. LmsPinRenewal n: E-learning pin replaced randomly for #{n} #{pluralENs n "examinee"}. LmsActionFailed n: No action for #{n} #{pluralENs n "person"}, since there was no ongoing examination. LmsStarted: E-learning open since LmsAutomaticQueuing n@Natural: The following functions are executed daily at #{show n} o'clock. LmsManualQueuing: The following functions should be executed daily. -BtnLmsEnqueue: Enqueue users with expiring qualifications for e-learning and notify them. -BtnLmsDequeue: Dequeue users with finished e-learning and notify, if appropriate. +BtnLmsEnqueue: Enqueue users with expiring qualifications for e‑learning and notify them. +BtnLmsDequeue: Dequeue users with finished e‑learning and notify, if appropriate. diff --git a/messages/uniworx/categories/user/de-de-formal.msg b/messages/uniworx/categories/user/de-de-formal.msg index 85ef0f47b..ab6cdb32b 100644 --- a/messages/uniworx/categories/user/de-de-formal.msg +++ b/messages/uniworx/categories/user/de-de-formal.msg @@ -11,7 +11,7 @@ AdminUserDisplayEmail: E-Mail-Adresse AdminUserIdent: Identifikation AdminUserAuth: Authentifizierung AdminUserAuthTooltip: Abhängig von der Auswahl werden neue Benutzer über ihr neues FRADrive Konto benachrichtigt. -AdminUserMatriculation: Matrikelnummer +AdminUserMatriculation: AVS Nummer AdminUserSex: Geschlecht AdminUserBirthday: Geburtsdatum AdminUserTelephone: Telefonnummer diff --git a/messages/uniworx/categories/user/en-eu.msg b/messages/uniworx/categories/user/en-eu.msg index 8fd7c0333..64145dcaf 100644 --- a/messages/uniworx/categories/user/en-eu.msg +++ b/messages/uniworx/categories/user/en-eu.msg @@ -11,7 +11,7 @@ AdminUserDisplayEmail: Email address AdminUserIdent: Identification AdminUserAuth: Authentication AdminUserAuthTooltip: New users may be notified about their FRADrive account depending on this choice. -AdminUserMatriculation: Matriculation +AdminUserMatriculation: AVS number AdminUserSex: Sex AdminUserBirthday: Date of Birth AdminUserTelephone: Phone diff --git a/messages/uniworx/utils/table_column/de-de-formal.msg b/messages/uniworx/utils/table_column/de-de-formal.msg index 681b63f78..f0ce25d50 100644 --- a/messages/uniworx/utils/table_column/de-de-formal.msg +++ b/messages/uniworx/utils/table_column/de-de-formal.msg @@ -16,7 +16,7 @@ TableTerm !ident-ok: Semester TableCourseSchool: Institut TableSubmissionGroup: Feste Abgabegruppe TableNoSubmissionGroup: Keine feste Abgabegruppe -TableMatrikelNr: Matrikelnummer +TableMatrikelNr: AVS Nr TableSex: Geschlecht TableBirthday: Geburtsdatum TableSchool: Institut @@ -56,7 +56,7 @@ TableTutorialTime: Zeit TableTutorialDeregisterUntil: Abmeldungen bis TableActionsHead: Aktionen TableNoFilter: Keine Einschränkung -TableUserMatriculation: Matrikelnummer +TableUserMatriculation: ASV Nummer TableColumnStudyFeatures: Studiendaten TableSchoolShort: Kürzel TableSchoolName !ident-ok: Name diff --git a/messages/uniworx/utils/table_column/en-eu.msg b/messages/uniworx/utils/table_column/en-eu.msg index 0c4162654..6eeed21d1 100644 --- a/messages/uniworx/utils/table_column/en-eu.msg +++ b/messages/uniworx/utils/table_column/en-eu.msg @@ -16,7 +16,7 @@ TableTerm: Semester TableCourseSchool: Department TableSubmissionGroup: Registered submission group TableNoSubmissionGroup: No registered submission group -TableMatrikelNr: Matriculation +TableMatrikelNr: AVS No TableSex: Sex TableBirthday: Birthday TableSchool: Department @@ -56,7 +56,7 @@ TableTutorialDeregisterUntil: Deregister until TableActionsHead: Actions TableTutorialTime: Time TableNoFilter: No restriction -TableUserMatriculation: Matriculation +TableUserMatriculation: AVS number TableColumnStudyFeatures: Features of study TableSchoolShort: Shorthand TableSchoolName: Name diff --git a/nix/docker/demo-version.json b/nix/docker/demo-version.json index b2e63f131..56758dcc8 100644 --- a/nix/docker/demo-version.json +++ b/nix/docker/demo-version.json @@ -1,3 +1,3 @@ { - "version": "27.1.6" + "version": "27.2.0" } diff --git a/nix/docker/version.json b/nix/docker/version.json index b2e63f131..56758dcc8 100644 --- a/nix/docker/version.json +++ b/nix/docker/version.json @@ -1,3 +1,3 @@ { - "version": "27.1.6" + "version": "27.2.0" } diff --git a/package-lock.json b/package-lock.json index 0a2b70581..4fe896578 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.1.6", + "version": "27.2.0", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 4d18a3c80..75550e181 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.1.6", + "version": "27.2.0", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 470b39391..3be4869eb 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 27.1.6 +version: 27.2.0 dependencies: - base - yesod diff --git a/routes b/routes index 7599239cb..e8067afcf 100644 --- a/routes +++ b/routes @@ -67,6 +67,7 @@ /admin/tokens AdminTokensR GET POST /admin/crontab AdminCrontabR GET /admin/avs AdminAvsR GET POST +/admin/avs/#CryptoUUIDUser AdminAvsUserR GET /admin/ldap AdminLdapR GET POST /admin/problems AdminProblemsR GET /admin/problems/no-contact ProblemUnreachableR GET diff --git a/src/Foundation/I18n.hs b/src/Foundation/I18n.hs index bab0c1d3a..c82adf9d4 100644 --- a/src/Foundation/I18n.hs +++ b/src/Foundation/I18n.hs @@ -251,6 +251,13 @@ embedRenderMessage ''UniWorX ''AvsLicence id -- required by UniWorXAvsMessages mkMessageAddition ''UniWorX "Qualification" "messages/uniworx/categories/qualification" "de-de-formal" mkMessageAddition ''UniWorX "Avs" "messages/uniworx/categories/avs" "de-de-formal" +instance RenderMessage UniWorX AvsDataCardColor where + renderMessage _foundation _ls (AvsCardColorMisc t) = Text.cons '*' t + renderMessage f ls AvsCardColorGrün = renderMessage f ls MsgAvsCardColorGreen + renderMessage f ls AvsCardColorBlau = renderMessage f ls MsgAvsCardColorBlue + renderMessage f ls AvsCardColorRot = renderMessage f ls MsgAvsCardColorRed + renderMessage f ls AvsCardColorGelb = renderMessage f ls MsgAvsCardColorYellow + instance RenderMessage UniWorX TermIdentifier where renderMessage _foundation _ls = termToText -- TODO: respect user selected Datetime Format diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 6e9986238..a4920014f 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -113,6 +113,7 @@ breadcrumb AdminErrMsgR = i18nCrumb MsgMenuAdminErrMsg $ Just breadcrumb AdminTokensR = i18nCrumb MsgMenuAdminTokens $ Just AdminR breadcrumb AdminCrontabR = i18nCrumb MsgBreadcrumbAdminCrontab $ Just AdminR breadcrumb AdminAvsR = i18nCrumb MsgMenuAvs $ Just AdminR +breadcrumb AdminAvsUserR{} = i18nCrumb MsgAvsPersonInfo $ Just AdminAvsR breadcrumb AdminLdapR = i18nCrumb MsgMenuLdap $ Just AdminR breadcrumb AdminProblemsR = i18nCrumb MsgProblemsHeading $ Just AdminR breadcrumb ProblemUnreachableR = i18nCrumb MsgProblemsUnreachableHeading $ Just AdminProblemsR diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs index aaa04294d..b3fbced9b 100644 --- a/src/Foundation/Yesod/Auth.hs +++ b/src/Foundation/Yesod/Auth.hs @@ -127,7 +127,7 @@ data CampusUserConversionException | CampusUserInvalidGivenName | CampusUserInvalidSurname | CampusUserInvalidTitle - | CampusUserInvalidMatriculation + -- | CampusUserInvalidMatriculation | CampusUserInvalidFeaturesOfStudy Text | CampusUserInvalidAssociatedSchools Text deriving (Eq, Ord, Read, Show, Generic) diff --git a/src/Foundation/Yesod/ErrorHandler.hs b/src/Foundation/Yesod/ErrorHandler.hs index fb330960b..769f65faf 100644 --- a/src/Foundation/Yesod/ErrorHandler.hs +++ b/src/Foundation/Yesod/ErrorHandler.hs @@ -9,9 +9,9 @@ module Foundation.Yesod.ErrorHandler import Import.NoFoundation hiding (errorHandler) import Foundation.Type -import Foundation.I18n +-- import Foundation.I18n import Foundation.Authorization -import Foundation.SiteLayout +-- import Foundation.SiteLayout import Foundation.Routes import Foundation.DB @@ -20,15 +20,15 @@ import qualified Data.Text as Text import qualified Network.Wai as W -import System.Exit -- DEBUG: just for testing -import System.Posix.Process -- DEBUG: just for testing +-- import System.Exit -- DEBUG: just for testing +-- import System.Posix.Process -- DEBUG: just for testing errorHandler :: ( MonadSecretBox (HandlerFor UniWorX) - , MonadSecretBox (WidgetFor UniWorX) + -- , MonadSecretBox (WidgetFor UniWorX) , MonadSecretBox (ExceptT EncodedSecretBoxException (HandlerFor UniWorX)) , MonadAuth (HandlerFor UniWorX) , BearerAuthSite UniWorX - , YesodPersistBackend UniWorX ~ SqlBackend + -- , YesodPersistBackend UniWorX ~ SqlBackend ) => ErrorResponse -> HandlerFor UniWorX TypedContent errorHandler err = do @@ -72,39 +72,51 @@ errorHandler err = do setSessionJson SessionError sessErr selectRep $ do - provideRep $ do - mr <- getMessageRender - let - encrypted :: Text -> WidgetFor UniWorX () -> WidgetFor UniWorX () - encrypted plaintextJson plaintext = do - let displayEncrypted ciphertext = - [whamlet| - $newline never -

_{MsgErrorResponseEncrypted} -

-                    #{ciphertext}
-                |]
-          if
-            | isEncrypted && shouldEncrypt -> displayEncrypted plaintextJson
-            | shouldEncrypt -> displayEncrypted =<< encodedSecretBox SecretBoxPretty plaintextJson
-            | otherwise -> plaintext
+    -- provideRep $ do
+    --   mr <- getMessageRender
+    --   let
+    --     encrypted :: Text -> WidgetFor UniWorX () -> WidgetFor UniWorX ()
+    --     encrypted plaintextJson plaintext = do
+    --       let displayEncrypted ciphertext = 
+    --             [whamlet|
+    --               $newline never
+    --               

_{MsgErrorResponseEncrypted} + --

+    --                 #{ciphertext}
+    --             |]
+    --       if
+    --         | isEncrypted && shouldEncrypt -> displayEncrypted plaintextJson
+    --         | shouldEncrypt -> displayEncrypted =<< encodedSecretBox SecretBoxPretty plaintextJson
+    --         | otherwise -> plaintext
 
-        errPage = case err of
-          NotFound -> [whamlet|

_{MsgErrorResponseNotFound}|] - InternalError err' - | "Crash Button" `isPrefixOf` err' -> liftIO $ exitImmediately ExitSuccess -- DEBUG: just for Testing - | otherwise -> encrypted err' [whamlet|

#{fromMaybe err' decrypted}|] - InvalidArgs errs -> [whamlet| -

    - $forall err' <- errs -
  • - #{err'} - |] - NotAuthenticated -> [whamlet|

    _{MsgErrorResponseNotAuthenticated}|] - PermissionDenied err' -> [whamlet|

    #{err'}|] - BadMethod method -> [whamlet|

    _{MsgErrorResponseBadMethod (decodeUtf8 method)}|] - siteLayout (toWgt . mr $ ErrorResponseTitle err) $ do - errPage + -- errPage = case err of + -- NotFound -> [whamlet|

    _{MsgErrorResponseNotFound}|] + -- InternalError err' + -- | "Crash Button" `isPrefixOf` err' -> liftIO $ exitImmediately ExitSuccess -- DEBUG: just for Testing + -- | otherwise -> encrypted err' [whamlet|

    #{fromMaybe err' decrypted}|] + -- InvalidArgs errs -> [whamlet| + --

      + -- $forall err' <- errs + --
    • + -- #{err'} + -- |] + -- NotAuthenticated -> [whamlet|

      _{MsgErrorResponseNotAuthenticated}|] + -- PermissionDenied err' -> [whamlet|

      #{err'}|] + -- BadMethod method -> [whamlet|

      _{MsgErrorResponseBadMethod (decodeUtf8 method)}|] + -- siteLayout (toWgt . mr $ ErrorResponseTitle err) $ do + -- errPage + provideRep $ case err of + PermissionDenied err' -> return err' + InternalError err' + | isEncrypted && shouldEncrypt -> do + addHeader "Encrypted-Error-Message" "True" + return err' + | shouldEncrypt -> do + addHeader "Encrypted-Error-Message" "True" + encodedSecretBox SecretBoxPretty err' + | otherwise -> return $ fromMaybe err' decrypted + InvalidArgs errs -> return . Text.unlines . map (Text.replace "\n" "\n\t") $ errs + _other -> return Text.empty provideRep . fmap PrettyValue $ case err of PermissionDenied err' -> return $ object [ "message" JSON..= err' ] InternalError err' @@ -120,15 +132,3 @@ errorHandler err = do | otherwise -> return $ object [ "message" JSON..= fromMaybe err' decrypted ] InvalidArgs errs -> return $ object [ "messages" JSON..= errs ] _other -> return $ object [] - provideRep $ case err of - PermissionDenied err' -> return err' - InternalError err' - | isEncrypted && shouldEncrypt -> do - addHeader "Encrypted-Error-Message" "True" - return err' - | shouldEncrypt -> do - addHeader "Encrypted-Error-Message" "True" - encodedSecretBox SecretBoxPretty err' - | otherwise -> return $ fromMaybe err' decrypted - InvalidArgs errs -> return . Text.unlines . map (Text.replace "\n" "\n\t") $ errs - _other -> return Text.empty diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 077f197f5..59614fd5a 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -51,11 +51,12 @@ getAdminProblemsR = do diffLics <- try retrieveDifferingLicences <&> \case -- (Left (UnsupportedContentType "text/html" resp)) -> Left $ text2widget "Html received" (Left e) -> Left $ text2widget $ tshow (e :: SomeException) - (Right AvsLicenceDifferences{..}) -> Right ( Set.size avsLicenceDiffRevokeAll - , Set.size avsLicenceDiffGrantVorfeld - , Set.size avsLicenceDiffRevokeRollfeld - , Set.size avsLicenceDiffGrantRollfeld - ) + (Right AvsLicenceDifferences{..}) -> Right + ( Set.size avsLicenceDiffRevokeAll + , Set.size avsLicenceDiffGrantVorfeld + , Set.size avsLicenceDiffRevokeRollfeld + , Set.size avsLicenceDiffGrantRollfeld + ) -- Attempt to format results in a nicer way failed, since rendering Html within a modal destroyed the page layout itself -- let procDiffLics (to0, to1, to2) = Right (Set.size to0, Set.size to1, Set.size to2) -- diffLics <- (procDiffLics <$> retrieveDifferingLicences) `catches` @@ -85,7 +86,7 @@ getAdminProblemsR = do getProblemUnreachableR :: Handler Html getProblemUnreachableR = do - unreachables <- runDB retrieveUnreachableUsers' + unreachables <- runDB retrieveUnreachableUsers siteLayoutMsg MsgProblemsUnreachableHeading $ do setTitleI MsgProblemsUnreachableHeading [whamlet| @@ -94,7 +95,7 @@ getProblemUnreachableR = do

        $forall usr <- unreachables
      • - ^{linkUserWidget ForProfileR usr} (#{usr ^. _userDisplayEmail} / #{usr ^. _userEmail}) + ^{linkUserWidget ForProfileDataR usr} (#{usr ^. _userDisplayEmail} / #{usr ^. _userEmail}) |] getProblemFbutNoR :: Handler Html @@ -141,31 +142,30 @@ mkUnreachableUsersTable = do -} areAllUsersReachable :: DB Bool --- areAllUsersReachable = isNothing <$> E.selectOne retrieveUnreachableUsers -areAllUsersReachable = E.selectNotExists retrieveUnreachableUsers +-- areAllUsersReachable = isNothing <$> E.selectOne retrieveUnreachableUsers' +-- areAllUsersReachable = E.selectNotExists retrieveUnreachableUsers' +areAllUsersReachable = null <$> retrieveUnreachableUsers + +-- retrieveUnreachableUsers' :: E.SqlQuery (E.SqlExpr (Entity User)) +-- retrieveUnreachableUsers' = do +-- user <- E.from $ E.table @User +-- E.where_ $ E.isNothing (user E.^. UserPostAddress) +-- E.&&. (E.isNothing (user E.^. UserCompanyDepartment) E.||. user E.^. UserCompanyPersonalNumber `E.ilike` E.justVal "E%") +-- E.&&. E.not_ ((user E.^. UserDisplayEmail) `E.like` E.val "%@%.%") +-- E.&&. E.not_ ((user E.^. UserEmail) `E.like` E.val "%@%.%") +-- return user -retrieveUnreachableUsers :: E.SqlQuery (E.SqlExpr (Entity User)) -retrieveUnreachableUsers = do - user <- E.from $ E.table @User - E.where_ $ E.isNothing (user E.^. UserPostAddress) - E.&&. E.isNothing (user E.^. UserCompanyDepartment) - E.&&. E.not_ ((user E.^. UserDisplayEmail) `E.like` E.val "%@%.%") - E.&&. E.not_ ((user E.^. UserEmail) `E.like` E.val "%@%.%") - return user - -retrieveUnreachableUsers' :: DB [Entity User] -retrieveUnreachableUsers' = do - obviousUnreachable <- E.select retrieveUnreachableUsers - emailUsers <- E.select $ do - user <- E.from $ E.table @User - E.where_ $ E.isNothing (user E.^. UserPostAddress) - E.&&. E.isNothing (user E.^. UserCompanyDepartment) - E.&&. ( ((user E.^. UserDisplayEmail) `E.like` E.val "%@%.%") - E.||. ((user E.^. UserEmail) `E.like` E.val "%@%.%")) - pure user - let hasInvalidEmail = isNothing . getEmailAddress . entityVal - invaldEmail = filter hasInvalidEmail emailUsers - return $ obviousUnreachable ++ invaldEmail +retrieveUnreachableUsers :: DB [Entity User] +retrieveUnreachableUsers = do + emailOnlyUsers <- E.select $ do + user <- E.from $ E.table @User + E.where_ $ E.isNothing (user E.^. UserPostAddress) + E.&&. (E.isNothing (user E.^. UserCompanyDepartment) E.||. user E.^. UserCompanyPersonalNumber `E.ilike` E.justVal "E%") + return user + return $ filter hasInvalidEmail emailOnlyUsers + where + hasInvalidEmail = isNothing . getEmailAddress . entityVal + allDriversHaveAvsId :: Day -> DB Bool -- allDriversHaveAvsId = fmap isNothing . E.selectOne . retrieveDriversWithoutAvsId diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index 5d3c66a36..7d101e786 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -9,6 +9,7 @@ module Handler.Admin.Avs ( getAdminAvsR, postAdminAvsR + , getAdminAvsUserR , getProblemAvsSynchR, postProblemAvsSynchR ) where @@ -94,7 +95,7 @@ makeAvsStatusForm tmpl = identifyForm FIDAvsQueryStatus . validateForm validateA parseAvsIds txt = AvsQueryStatus $ Set.fromList ids where nonemptys = filter (not . Text.null) $ Text.strip <$> Text.split (==',') txt - ids = catMaybes $ readMay <$> nonemptys + ids = mapMaybe readMay nonemptys unparseAvsIds :: AvsQueryStatus -> Text unparseAvsIds (AvsQueryStatus ids) = Text.intercalate ", " $ tshow <$> Set.toAscList ids @@ -112,7 +113,7 @@ makeAvsContactForm tmpl = identifyForm FIDAvsQueryContact . validateForm validat parseAvsIds txt = AvsQueryContact $ Set.fromList ids where nonemptys = filter (not . Text.null) $ Text.strip <$> Text.split (==',') txt - ids = catMaybes $ fmap AvsObjPersonId . readMay <$> nonemptys + ids = mapMaybe (fmap AvsObjPersonId . readMay) nonemptys unparseAvsIds :: AvsQueryContact -> Text unparseAvsIds (AvsQueryContact ids) = Text.intercalate ", " $ tshow <$> Set.toAscList ids @@ -144,7 +145,7 @@ postAdminAvsR = do |] mAvsQuery <- getsYesod $ view _appAvsQuery case mAvsQuery of - Nothing -> return mempty + Nothing -> siteLayoutMsg MsgMenuAvs [whamlet|Error: AVS interface configuration is incomplete.|] -- should never occur after initilisation Just AvsQuery{..} -> do ((presult, pwidget), penctype) <- runFormPost $ makeAvsPersonForm Nothing @@ -365,7 +366,7 @@ postProblemAvsSynchR = getProblemAvsSynchR getProblemAvsSynchR = do let catchAllAvs' r = flip catch (\err -> addMessageModal Error (i18n MsgAvsCommunicationError) (Right (text2widget $ tshow (err :: SomeException))) >> redirect r) catchAllAvs = catchAllAvs' ProblemAvsSynchR -- == current route; use only in conditions that are not repeated upon reload; do not call redirect within catchAllAvs actions! - AvsLicenceDifferences{..} <- catchAllAvs' AdminR retrieveDifferingLicences + (AvsLicenceDifferences{..}, apidStatus) <- catchAllAvs' AdminR retrieveDifferingLicencesStatus -- unknownLicenceOwners' <- whenNonEmpty avsLicenceDiffRevokeAll $ \neZeros -> @@ -421,10 +422,10 @@ getProblemAvsSynchR = do -- licence differences ((tres0,tb0),(tres1up,tb1up),(tres1down,tb1down),(tres2,tb2)) <- runDB $ (,,,) - <$> mkLicenceTable "avsLicDiffRevokeVorfeld" AvsLicenceVorfeld avsLicenceDiffRevokeAll - <*> mkLicenceTable "avsLicDiffGrantVorfeld" AvsNoLicence avsLicenceDiffGrantVorfeld - <*> mkLicenceTable "avsLicDiffRevokeRollfeld" AvsLicenceRollfeld avsLicenceDiffRevokeRollfeld - <*> mkLicenceTable "avsLicDiffGrantRollfeld" AvsNoLicence avsLicenceDiffGrantRollfeld + <$> mkLicenceTable apidStatus "avsLicDiffRevokeVorfeld" AvsLicenceVorfeld avsLicenceDiffRevokeAll + <*> mkLicenceTable apidStatus "avsLicDiffGrantVorfeld" AvsNoLicence avsLicenceDiffGrantVorfeld + <*> mkLicenceTable apidStatus "avsLicDiffRevokeRollfeld" AvsLicenceRollfeld avsLicenceDiffRevokeRollfeld + <*> mkLicenceTable apidStatus "avsLicDiffGrantRollfeld" AvsNoLicence avsLicenceDiffGrantRollfeld now <- liftIO getCurrentTime let nowaday = utctDay now @@ -510,8 +511,8 @@ instance HasUser LicenceTableData where hasUser = resultUser . _entityVal -mkLicenceTable :: Text -> AvsLicence -> Set AvsPersonId -> DB (FormResult (LicenceTableActionData, Set AvsPersonId), Widget) -mkLicenceTable dbtIdent aLic apids = do +mkLicenceTable :: AvsPersonIdMapPersonCard -> Text -> AvsLicence -> Set AvsPersonId -> DB (FormResult (LicenceTableActionData, Set AvsPersonId), Widget) +mkLicenceTable apidStatus dbtIdent aLic apids = do currentRoute <- fromMaybe (error "mkLicenceTable called from 404-handler") <$> liftHandler getCurrentRoute avsQualifications <- selectList [QualificationAvsLicence !=. Nothing] [] now <- liftIO getCurrentTime @@ -535,7 +536,7 @@ mkLicenceTable dbtIdent aLic apids = do [ dbSelect (applying _2) id $ return . view (resultUserAvs . _userAvsPersonId) -- $ \DBRow{dbrOutput=(_,_,apid,_)} -> return apid -- return . view resultAvsPID -- does not type due to traversal , colUserNameLink AdminUserR - , sortable (Just "avspersonno") (i18nCell MsgAvsPersonNo) $ \(view resultUserAvs -> a) -> avsPersonNoCell a + , sortable (Just "avspersonno") (i18nCell MsgAvsPersonNo) $ \(view resultUserAvs -> a) -> avsPersonNoLinkedCell a -- , colUserCompany , sortable (Just "user-company") (i18nCell MsgTableCompany) $ \(view (resultUser . _entityKey) -> uid) -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX" companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do @@ -553,6 +554,7 @@ mkLicenceTable dbtIdent aLic apids = do , sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \(preview $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> cellMaybe dayCell d , sortable (Just "blocked-due") (i18nCell MsgTableQualificationBlockedDue & cellTooltip MsgTableQualificationBlockedTooltip ) $ \(preview $ resultQualUser . _entityVal . _qualificationUserBlockedDue -> b) -> cellMaybe qualificationBlockedCell b + , sortable Nothing (i18nCell MsgTableAvsActiveCards) $ \(view $ resultUserAvs . _userAvsPersonId -> apid) -> foldMap avsPersonCardCell $ Map.lookup apid apidStatus ] dbtSorting = mconcat [ single $ sortUserNameLink queryUser @@ -630,4 +632,53 @@ mkLicenceTable dbtIdent aLic apids = do let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap return (act, usrSet) - over _1 postprocess <$> dbTable validator DBTable{..} \ No newline at end of file + over _1 postprocess <$> dbTable validator DBTable{..} + + + +getAdminAvsUserR :: CryptoUUIDUser -> Handler Html +getAdminAvsUserR uuid = do + uid <- decrypt uuid + Entity{entityVal=UserAvs{..}} <- runDB $ getBy404 $ UniqueUserAvsUser uid + mAvsQuery <- getsYesod $ view _appAvsQuery + resWgt <- case mAvsQuery of + Nothing -> return [whamlet|Error: AVS interface configuration is incomplete.|] -- should never occur after initilisation + Just AvsQuery{..} -> do + mbContact <- avsQueryContact $ AvsQueryContact $ Set.singleton $ AvsObjPersonId userAvsPersonId + mbDataPerson <- lookupAvsUser userAvsPersonId + return [whamlet| +

        + Vorläufige Admin Ansicht AVS Daten. + Ansicht zeigt aktuelle Daten. + Es erfolgte damit aber noch kein Update der FRADrive Daten. +

        +

        +
        InfoPersonContact
        + (bevorzugt) +
        + $case mbContact + $of Left err + Fehler: #{tshow err} + $of Right contactInfo + #{decodeUtf8 (Pretty.encodePretty (toJSON contactInfo))} +
        PersonStatus und mehrere PersonSearch
        + (benötigt mehrere AVS Abfragen) +
        + $maybe dataPerson <- mbDataPerson + #{decodeUtf8 (Pretty.encodePretty (toJSON dataPerson))} + $nothing + Keine Daten erhalten. +

        + Provisorische formatierte Ansicht +

        + Generisch formatierte Ansicht, die zeigt, in welche Richtung die Endansicht gehen könnte. + In der Endansicht wären nur ausgewählte Felder mit besserer Bennenung in einer manuell gewählten Reihenfolge sichtbar. +

        + ^{foldMap jsonWidget mbContact} +

        + ^{foldMap jsonWidget mbDataPerson} + |] + let heading = [whamlet|_{MsgAvsPersonNo} #{userAvsNoPerson}|] + siteLayout heading $ do + setTitle $ toHtml $ show userAvsNoPerson + resWgt diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index f4a43fc61..8b3f3d9db 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -91,8 +91,8 @@ postLmsAllR = do lmsTable <- runDB $ do view _2 <$> mkLmsAllTable isAdmin - siteLayoutMsg MsgMenuQualifications $ do - setTitleI MsgMenuQualifications + siteLayoutMsg MsgMenuLms $ do + setTitleI MsgMenuLms $(widgetFile "lms-all") type AllQualificationTableData = DBRow (Entity Qualification, Ex.Value Word64, Ex.Value Word64) @@ -615,13 +615,13 @@ postLmsR sid qsh = do when (diffSelected /= 0) $ addMessageI Warning $ MsgLmsActionFailed diffSelected redirect currentRoute - let heading = citext2widget $ qualificationName quali + let heading = citext2widget $ "LMS " <> qualificationName quali siteLayout heading $ do - setTitle $ toHtml $ unSchoolKey sid <> "-" <> qsh + setTitle $ toHtml $ "LMS " <> unSchoolKey sid <> "-" <> qsh $(widgetFile "lms") --- intended to be viewed primarily in a modal, vie lmsStatusPlusCell' +-- intended to be viewed primarily in a modal, wie lmsStatusPlusCell getLmsUserR :: CryptoUUIDUser -> Handler Html getLmsUserR uuid = do uid <- decrypt uuid @@ -648,6 +648,6 @@ getLmsUserR uuid = do let heading = [whamlet|_{MsgMenuLmsUser} ^{userWidget user}|] siteLayout heading $ do - setTitle $ toHtml $ "Qualifkationen " <> userDisplayName + setTitle $ toHtml userDisplayName $(widgetFile "lms-user") -- $(i18nWidgetFile "lms-user") diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index bdea7efb9..242c3c355 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -18,7 +18,7 @@ import Import -- import Jobs import Handler.Utils -- import Handler.Utils.Csv --- import Handler.Utils.LMS +import Handler.Utils.LMS import qualified Data.Set as Set @@ -460,8 +460,8 @@ postQualificationR sid qsh = do -- , sortable (Just "lms-started") (i18nCell MsgTableLmsElearning <> spacerCell <> i18nCell MsgTableLmsStarted) -- $ \(preview $ resultLmsUser . _entityVal . _lmsUserStarted -> d) -> foldMap dateTimeCell d -- , sortable (Just "lms-status") (i18nCell MsgTableLmsStatus) $ \(preview $ resultLmsUser . _entityVal . _lmsUserStatus -> status) -> foldMap lmsStatusCell $ join status - , sortable (Just "lms-status-plus")(i18nCell MsgTableLmsStatus & cellTooltip (MsgTableLmsStatusTooltip auditMonths)) - $ \(preview $ resultLmsUser . _entityVal -> lu) -> foldMap (lmsStatusPlusCell' linkLmsUser) lu + , sortable (Just "lms-status-plus")(i18nCell MsgTableLmsStatus & cellTooltipWgt Nothing (lmsStatusInfoCell isAdmin auditMonths)) + $ \(preview $ resultLmsUser . _entityVal -> lu) -> foldMap (lmsStatusPlusCell linkLmsUser) lu ] psValidator = def & defaultSorting [SortDescBy "last-refresh"] tbl <- mkQualificationTable isAdmin qent acts colChoices psValidator diff --git a/src/Handler/SAP.hs b/src/Handler/SAP.hs index 368baebbf..5365b00fd 100644 --- a/src/Handler/SAP.hs +++ b/src/Handler/SAP.hs @@ -13,6 +13,7 @@ import Import import Handler.Utils import Handler.Utils.Csv +import Handler.Utils.Profile -- import qualified Data.CaseInsensitive as CI import qualified Data.Csv as Csv @@ -56,11 +57,11 @@ instance ToNamedRecord SapUserTableCsv where -- | Removes all personalNummer which are not numbers between 10000 and 99999 (also excludes E-Accounts), which should not be returned by the query anyway (only qualfications with sap id and users with internal personnel number must be transmitted) -- TODO: once temporary suspensions are implemented, a user must be transmitted to SAP in two rows: firstheld->suspensionFrom & suspensionTo->validTo sapRes2csv :: [(Ex.Value (Maybe Text), Ex.Value Day, Ex.Value Day, Ex.Value (Maybe Text))] -> [SapUserTableCsv] -sapRes2csv l = [ res | (Ex.Value (Just persNo), Ex.Value firstHeld, Ex.Value validUntil, Ex.Value (Just sapId)) <- l - , let persNoAsInt = readMay persNo - , persNoAsInt >= Just (10000::Int) -- filter E-accounts for SAP export - , persNoAsInt <= Just (99999::Int) -- filter E-accounts for SAP export - , let res = SapUserTableCsv +sapRes2csv l = [ res | (Ex.Value pn@(Just persNo), Ex.Value firstHeld, Ex.Value validUntil, Ex.Value (Just sapId)) <- l + -- , let persNoAsInt = readMay =<< persNo -- also see Handler.Utils.Profile.validFraportPersonalNumber + -- , persNoAsInt >= Just (10000::Int) -- filter E-accounts for SAP export + -- , persNoAsInt <= Just (99999::Int) -- filter E-accounts for SAP export + , let res = SapUserTableCsv { csvSUTpersonalNummer = persNo , csvSUTqualifikation = sapId , csvSUTgültigVon = firstHeld @@ -68,6 +69,7 @@ sapRes2csv l = [ res | (Ex.Value (Just persNo), Ex.Value firstHeld, Ex.Value val -- , csvSUTsupendiertBis = blocked , csvSUTausprägung = "J" } + , validFraportPersonalNumber pn ] -- | Deliver all employess with a successful LDAP synch within the last 3 months diff --git a/src/Handler/Tutorial/Users.hs b/src/Handler/Tutorial/Users.hs index d3a4333be..b32f1aeb8 100644 --- a/src/Handler/Tutorial/Users.hs +++ b/src/Handler/Tutorial/Users.hs @@ -11,6 +11,7 @@ module Handler.Tutorial.Users import Import import Utils.Form +import Utils.Print import Handler.Utils import Handler.Utils.Course import Handler.Utils.Tutorial @@ -20,7 +21,7 @@ import qualified Data.CaseInsensitive as CI import qualified Data.Set as Set import qualified Data.Map as Map - +import qualified Data.ByteString.Lazy as LBS -- import qualified Data.Time.Zones as TZ import Database.Esqueleto.Experimental ((:&)(..)) @@ -57,21 +58,19 @@ data TutorialUserActionData deriving (Eq, Ord, Read, Show, Generic) -getTUsersR, postTUsersR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler Html +getTUsersR, postTUsersR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler TypedContent getTUsersR = postTUsersR -postTUsersR tid ssh csh tutn = do - showSex <- getShowSex - (Entity tutid Tutorial{..}, (participantRes, participantTable), qualifications) <- runDB $ do +postTUsersR tid ssh csh tutn = do + (Entity tutid tut@Tutorial{..}, (participantRes, participantTable), qualifications) <- runDB $ do cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh - tut@(Entity tutid _) <- fetchTutorial tid ssh csh tutn + tutEnt@(Entity tutid _) <- fetchTutorial tid ssh csh tutn qualifications <- getCourseQualifications cid now <- liftIO getCurrentTime let minDur :: Maybe Int = minimumMaybe $ catMaybes (view _qualificationValidDuration <$> qualifications) -- no instance Ord CalendarDiffDays dayExpiry = flip addGregorianDurationClip (utctDay now) . fromMonths <$> minDur colChoices = mconcat $ catMaybes [ pure $ dbSelect (applying _2) id (return . view (hasEntity . _entityKey)) - , pure $ colUserNameModalHdr MsgTableCourseMembers ForProfileDataR - , guardOn showSex colUserSex' + , pure $ colUserNameModalHdr MsgTableCourseMembers ForProfileDataR , pure colUserEmail , pure colUserMatriclenr , pure colUserQualifications @@ -80,7 +79,7 @@ postTUsersR tid ssh csh tutn = do psValidator = def & defaultSortingByName & restrictSorting (\name _ -> none (== name) ["note", "registration", "tutorials", "exams", "submission-group", "state"]) -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information - & restrictFilter (\name _ -> none (== name) ["tutorial", "exam", "submission-group", "active", "has-personalised-sheet-files"]) + & restrictFilter (\name _ -> none (== name) ["tutorial", "exam", "submission-group", "active", "has-personalised-sheet-files"]) isInTut q = E.exists $ do tutorialParticipant <- E.from $ E.table @TutorialParticipant E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. queryUser q E.^. UserId @@ -118,14 +117,29 @@ postTUsersR tid ssh csh tutn = do , ( TutorialUserDeregister, pure TutorialUserDeregisterData ) ] table <- makeCourseUserTable cid acts isInTut colChoices psValidator (Just csvColChoices) - return (tut, table, qualifications) + return (tutEnt, table, qualifications) let courseQids = Set.fromList (entityKey <$> qualifications) - formResult participantRes $ \case - (TutorialUserPrintQualificationData{..}, _selectedUsers) + tcontent <- formResultMaybe participantRes $ \case + (TutorialUserPrintQualificationData{..}, selectedUsers) | tuQualification `Set.member` courseQids -> do - -- TODO Continue here - addMessageI Error MsgErrorUnknownFormAction + rcvr <- requireAuth + encRcvr <- encrypt $ entityKey rcvr + letters <- runDB $ makeCourseCertificates tut Nothing $ toList selectedUsers + let mbAletter = anyone letters + case mbAletter of + Nothing -> addMessageI Error MsgErrorUnknownFormAction >> return Nothing -- TODO: better error message + Just aletter -> do + now <- liftIO getCurrentTime + apcIdent <- letterApcIdent aletter encRcvr now + let fName = letterFileName aletter + renderLetters rcvr letters apcIdent >>= \case + Left err -> sendResponseStatus internalServerError500 $ "PDF generation failed: \n" <> err + Right pdf -> return $ Just (sendByteStringAsFile fName (LBS.toStrict pdf) now) + -- sendResponseByteStringFile "demoPDF.pdf" (LBS.toStrict pdf) + -- let typePDF :: ContentType + -- typePDF = "application/pdf" + -- sendResponse (typePDF, toContent pdf) (TutorialUserGrantQualificationData{..}, selectedUsers) | tuQualification `Set.member` courseQids -> do -- today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime @@ -148,16 +162,19 @@ postTUsersR tid ssh csh tutn = do ] addMessageI Success $ MsgTutorialUsersDeregistered nrDel redirect $ CTutorialR tid ssh csh tutn TUsersR - _other -> - addMessageI Error MsgErrorUnknownFormAction + _other -> addMessageI Error MsgErrorUnknownFormAction >> return Nothing - tutors <- runDB $ E.select $ do - (tutor :& user) <- E.from $ E.table @Tutor `E.innerJoin` E.table @User - `E.on` (\(tutor :& user) -> tutor E.^. TutorUser E.==. user E.^. UserId) - E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid - return user + case tcontent of + Just act -> act -- abort and return produced content + Nothing -> do + tutors <- runDB $ E.select $ do + (tutor :& user) <- E.from $ E.table @Tutor `E.innerJoin` E.table @User + `E.on` (\(tutor :& user) -> tutor E.^. TutorUser E.==. user E.^. UserId) + E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid + return user - let heading = prependCourseTitle tid ssh csh $ CI.original tutorialName - siteLayoutMsg heading $ do - setTitleI heading - $(widgetFile "tutorial-participants") + let heading = prependCourseTitle tid ssh csh $ CI.original tutorialName + html <- siteLayoutMsg heading $ do + setTitleI heading + $(widgetFile "tutorial-participants") + return $ toTypedContent html diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 29f3d71f3..2c68d028a 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -99,9 +99,7 @@ postUsersR = do , sortable (Just "name") (i18nCell MsgName) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM (AdminUserR <$> encrypt uid) (nameWidget userDisplayName userSurname) --- , sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM --- (AdminUserR <$> encrypt uid) --- (toWgt userMatrikelnummer) + , sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \DBRow{ dbrOutput = entUsr } -> cellHasMatrikelnummerLinked entUsr , sortable (Just "user-company") (i18nCell MsgTableCompany) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX" companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId @@ -215,6 +213,9 @@ postUsersR = do , ( "display-name" , SortColumn $ \user -> user E.^. UserDisplayName ) + , ( "matriculation" + , SortColumn $ \user -> user E.^. UserMatrikelnummer + ) , ( "personal-number" , SortColumn $ \user -> user E.^. UserCompanyPersonalNumber ) @@ -262,10 +263,10 @@ postUsersR = do Just needle -> (E.castString (user E.^. UserEmail) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%)) E.||. (E.castString (user E.^. UserDisplayEmail) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%)) ) --- , ( "matriculation", FilterColumn $ \user (criteria :: Set.Set Text) -> if --- | Set.null criteria -> E.true -- TODO: why can this be eFalse and work still? --- | otherwise -> E.any (\c -> user E.^. UserMatrikelnummer `E.hasInfix` E.val c) criteria --- ) + , ( "matriculation", FilterColumn $ \user (criteria :: Set.Set Text) -> if + | Set.null criteria -> E.true + | otherwise -> E.any (\c -> user E.^. UserMatrikelnummer `E.hasInfix` E.val c) criteria + ) , ( "personal-number", FilterColumn $ \user (criteria :: Set.Set Text) -> if | Set.null criteria -> E.true -- TODO: why can this be eFalse and work still? | otherwise -> E.any (\c -> user E.^. UserCompanyPersonalNumber `E.hasInfix` E.val c) criteria diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 9702307b3..b3e3dfd8f 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -14,11 +14,13 @@ module Handler.Utils.Avs -- , getLicence, getLicenceDB, getLicenceByAvsId -- not supported by interface , AvsLicenceDifferences(..) , setLicence, setLicenceAvs, setLicencesAvs - , retrieveDifferingLicences, computeDifferingLicences + , retrieveDifferingLicences, retrieveDifferingLicencesStatus + , computeDifferingLicences , synchAvsLicences , lookupAvsUser, lookupAvsUsers , AvsException(..) , updateReceivers + , AvsPersonIdMapPersonCard ) where import Import @@ -178,6 +180,18 @@ data AvsLicenceDifferences = AvsLicenceDifferences } deriving (Show) +#ifdef DEVELOPMENT +-- avsLicenceDifferences2LicenceIds is not used in DEVELOPMENT build +#else +avsLicenceDifferences2LicenceIds :: AvsLicenceDifferences -> Set AvsPersonId +avsLicenceDifferences2LicenceIds AvsLicenceDifferences{..} = Set.unions + [ avsLicenceDiffRevokeAll + , avsLicenceDiffGrantVorfeld + , avsLicenceDiffRevokeRollfeld + , avsLicenceDiffGrantRollfeld + ] +#endif + avsLicenceDifferences2personLicences :: AvsLicenceDifferences -> Set AvsPersonLicence avsLicenceDifferences2personLicences AvsLicenceDifferences{..} = Set.map (AvsPersonLicence AvsNoLicence) avsLicenceDiffRevokeAll @@ -188,24 +202,57 @@ avsLicenceDifferences2personLicences AvsLicenceDifferences{..} = computeDifferingLicences :: AvsResponseGetLicences -> Handler (Set AvsPersonLicence) computeDifferingLicences = fmap avsLicenceDifferences2personLicences . getDifferingLicences -retrieveDifferingLicences :: Handler AvsLicenceDifferences -retrieveDifferingLicences = do -#ifdef DEVELOPMENT - avsUsrs <- runDB $ selectList [] [LimitTo 444] - getDifferingLicences $ AvsResponseGetLicences $ Set.fromList $ - [ AvsPersonLicence AvsLicenceVorfeld $ AvsPersonId 77 -- AVS:1 FD:2 - , AvsPersonLicence AvsLicenceRollfeld $ AvsPersonId 12345678 -- AVS:2 FD:1 - , AvsPersonLicence AvsLicenceVorfeld $ AvsPersonId 5 -- AVS:1 FD:0 (nichts) - , AvsPersonLicence AvsLicenceVorfeld $ AvsPersonId 2 -- AVS:1 FD:0 (ungültig) - -- , AvsPersonLicence AvsLicenceVorfeld $ AvsPersonId 4 -- AVS:1 FD:1 - ] ++ [AvsPersonLicence AvsLicenceVorfeld avsid | Entity _ UserAvs{userAvsPersonId = avsid} <- avsUsrs] -#else - AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery - allLicences <- throwLeftM avsQueryGetAllLicences - getDifferingLicences allLicences -#endif - +type AvsPersonIdMapPersonCard = Map AvsPersonId (Set AvsDataPersonCard) +avsResponseStatusMap :: AvsResponseStatus -> AvsPersonIdMapPersonCard +avsResponseStatusMap (AvsResponseStatus status) = Map.fromDistinctAscList [(avsStatusPersonID,avsStatusPersonCardStatus) | AvsStatusPerson{..}<- Set.toAscList status] + +retrieveDifferingLicences :: Handler AvsLicenceDifferences +retrieveDifferingLicences = fst <$> retrieveDifferingLicences' False + +retrieveDifferingLicencesStatus :: Handler (AvsLicenceDifferences, AvsPersonIdMapPersonCard) +retrieveDifferingLicencesStatus = retrieveDifferingLicences' True + +retrieveDifferingLicences' :: Bool -> Handler (AvsLicenceDifferences, AvsPersonIdMapPersonCard) +retrieveDifferingLicences' getStatus = do +#ifdef DEVELOPMENT + avsUsrs <- runDB $ selectList [] [LimitTo 444] + let allLicences = AvsResponseGetLicences $ Set.fromList $ + [ AvsPersonLicence AvsLicenceVorfeld $ AvsPersonId 77 -- AVS:1 FD:2 + , AvsPersonLicence AvsLicenceRollfeld $ AvsPersonId 12345678 -- AVS:2 FD:1 + , AvsPersonLicence AvsLicenceVorfeld $ AvsPersonId 5 -- AVS:1 FD:0 (nichts) + , AvsPersonLicence AvsLicenceVorfeld $ AvsPersonId 2 -- AVS:1 FD:0 (ungültig) + -- , AvsPersonLicence AvsLicenceVorfeld $ AvsPersonId 4 -- AVS:1 FD:1 + ] ++ [AvsPersonLicence AvsLicenceVorfeld avsid | Entity _ UserAvs{userAvsPersonId = avsid} <- avsUsrs] +#else + AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery + allLicences <- throwLeftM avsQueryGetAllLicences +#endif + lDiff <- getDifferingLicences allLicences +#ifdef DEVELOPMENT + let mkAdpc valid color = AvsDataPersonCard valid Nothing Nothing color (Set.singleton 'F') Nothing Nothing Nothing Nothing (AvsCardNo "1234") "5" + lStat = AvsResponseStatus $ bool mempty fakes getStatus -- not really needed, but avoids unused variable error + fakes = Set.fromList $ + [ AvsStatusPerson (AvsPersonId 77 ) $ Set.singleton $ mkAdpc True AvsCardColorGelb + , AvsStatusPerson (AvsPersonId 12345678) $ Set.fromList [mkAdpc False AvsCardColorGrün, mkAdpc True AvsCardColorGelb, mkAdpc False AvsCardColorBlau, mkAdpc True AvsCardColorRot, mkAdpc True $ AvsCardColorMisc "Violett"] + , AvsStatusPerson (AvsPersonId 5 ) $ Set.fromList [mkAdpc True AvsCardColorGrün, mkAdpc False AvsCardColorGelb, mkAdpc True AvsCardColorBlau, mkAdpc False AvsCardColorRot, mkAdpc True $ AvsCardColorMisc "Pink"] + , AvsStatusPerson (AvsPersonId 2 ) $ Set.singleton $ mkAdpc True AvsCardColorGrün + ] <> + [ AvsStatusPerson avsid $ Set.singleton $ mkAdpc (even $ avsPersonId avsid) AvsCardColorGelb | Entity _ UserAvs{userAvsPersonId = avsid} <- avsUsrs ] +#else + let statQry = avsLicenceDifferences2LicenceIds lDiff + lStat <- if getStatus && notNull statQry + then -- throwLeftM $ avsQueryStatus $ AvsQueryStatus statQry -- don't throw up here, licence differences are too important! TODO: Warn in Problem-Handler + avsQueryStatus (AvsQueryStatus statQry) >>= \case + Left err -> do + addMessage Error $ toHtml $ "avsQueryStatus failed for " <> tshow (length statQry) <> " requests with: \n" <> tshow err <> "\nREQUEST:\n" <> tshow statQry + return $ AvsResponseStatus mempty + Right res -> return res + else return $ AvsResponseStatus mempty -- avoid unnecessary avs calls +#endif + return (lDiff, avsResponseStatusMap lStat) + + getDifferingLicences :: AvsResponseGetLicences -> Handler AvsLicenceDifferences getDifferingLicences (AvsResponseGetLicences licences) = do now <- liftIO getCurrentTime @@ -394,7 +441,7 @@ upsertAvsUserById api = do , audSurname = avsSurname , audDisplayName = avsFirstName <> Text.cons ' ' avsSurname , audDisplayEmail = "" -- Email is unknown in this version of the avs query, to be updated later (FUTURE TODO) - , audMatriculation = Nothing + , audMatriculation = Just $ tshow avsPersonPersonNo , audSex = Nothing , audBirthday = Nothing , audMobile = Nothing @@ -420,7 +467,7 @@ upsertAvsUserById api = do return mbUid (Just (Entity _ UserAvs{userAvsUser=uid}) - , Just AvsDataPerson{avsPersonPersonCards, avsPersonInternalPersonalNo, avsPersonFirstName= Text.strip -> avsFirstName, avsPersonLastName= Text.strip -> avsSurname}) -> do -- known user, update address and pinPassword + , Just AvsDataPerson{avsPersonPersonCards, avsPersonInternalPersonalNo, avsPersonPersonNo, avsPersonFirstName= Text.strip -> avsFirstName, avsPersonLastName= Text.strip -> avsSurname}) -> do -- known user, update address and pinPassword let (mbCompany, mbCoFirmAddr, _) = guessLicenceAddress avsPersonPersonCards userFirmAddr = plaintextToStoredMarkup <$> mbCoFirmAddr pinCard = Set.lookupMax avsPersonPersonCards @@ -430,6 +477,7 @@ upsertAvsUserById api = do update uid [ UserFirstName =. avsFirstName -- update in case of name changes via AVS; might be changed again through LDAP , UserSurname =. avsSurname , UserDisplayName =. avsFirstName <> Text.cons ' ' avsSurname + , UserMatrikelnummer =. Just (tshow avsPersonPersonNo) -- TODO: Deactivate this update after Q2/2023; this is only needed since UserMatrikelnummer was used for AVSNO later , UserCompanyPersonalNumber =. avsInternalPersonalNo <$> canonical avsPersonInternalPersonalNo ] oldCards <- selectList [UserAvsCardPersonId ==. api] [] @@ -483,9 +531,13 @@ lookupAvsUsers apis = do -- | Like `Handler.Utils.getReceivers`, but calls upsertAvsUserById on each user to ensure that postal address is up-to-date updateReceivers :: UserId -> Handler (Entity User, [Entity User], Bool) updateReceivers uid = do - (underling :: Entity User, avsUnderling :: Maybe (Entity UserAvs), avsSupers :: [(E.Value UserId, E.Value (Maybe AvsPersonId))]) <- runDB $ (,,) - <$> getJustEntity uid - <*> getBy (UniqueUserAvsUser uid) + -- First perform AVS update for receiver + runDB (getBy (UniqueUserAvsUser uid)) >>= \case + Just Entity{entityVal=UserAvs{userAvsPersonId = apid}} -> void . maybeCatchAll $ upsertAvsUserById apid + Nothing -> return () + -- Retrieve updated user and supervisors now + (underling :: Entity User, avsSupers :: [(E.Value UserId, E.Value (Maybe AvsPersonId))]) <- runDB $ (,) + <$> getJustEntity uid <*> (E.select $ do (usrSuper :& usrAvs) <- E.from $ E.table @UserSupervisor @@ -496,10 +548,9 @@ updateReceivers uid = do pure (usrSuper E.^. UserSupervisorSupervisor, usrAvs E.?. UserAvsPersonId) ) let (superVs, avsIds) = unzip avsSupers - receiverIDs :: [UserId] = E.unValue <$> superVs - underlingAvsId = userAvsPersonId . entityVal <$> avsUnderling - toUpdate = Set.fromList $ catMaybes (underlingAvsId : (E.unValue <$> avsIds)) - directResult = return (underling, pure underling, True) + receiverIDs :: [UserId] = E.unValue <$> superVs + toUpdate = Set.fromList $ mapMaybe E.unValue avsIds + directResult = return (underling, pure underling, True) -- already contains updated address forM_ toUpdate (void . maybeCatchAll . upsertAvsUserById) -- attempt to update postaddress from AVS if null receiverIDs then directResult diff --git a/src/Handler/Utils/Download.hs b/src/Handler/Utils/Download.hs index c80957efc..3c3a0d862 100644 --- a/src/Handler/Utils/Download.hs +++ b/src/Handler/Utils/Download.hs @@ -4,7 +4,8 @@ module Handler.Utils.Download ( sendThisFile - , sendByteStringAsFile + , sendByteStringAsFile --, sendByteStringAsFileAndExit + , sendResponseByteStringFile , sendFileReference , serveOneFile , serveSomeFiles @@ -176,6 +177,37 @@ sendByteStringAsFile fileTitle content fileModified = | null content = Nothing | otherwise = Just $ yield content +-- THIS DOES NOT WORK: +-- sendByteStringAsFileAndExit :: ( YesodAuthPersist UniWorX +-- , AuthEntity UniWorX ~ User +-- , AuthId UniWorX ~ UserId +-- , YesodPersistRunner UniWorX +-- , MonadCrypto (HandlerFor UniWorX), MonadCryptoKey (HandlerFor UniWorX) ~ CryptoIDKey +-- ) => FilePath -> ByteString -> UTCTime -> HandlerFor UniWorX a +-- sendByteStringAsFileAndExit fileTitle content fileModified= do +-- void $ sendByteStringAsFile fileTitle content fileModified +-- sendResponse () + + +-- | like sendByteStringAsFile, but uses sendResponse instead of respondSourceDB, ensuring that +-- remaining handler code is bybassed +sendResponseByteStringFile :: -- ( YesodAuthPersist UniWorX + -- , AuthEntity UniWorX ~ User + -- , AuthId UniWorX ~ UserId + -- , MonadCrypto (HandlerFor UniWorX), MonadCryptoKey (HandlerFor UniWorX) ~ CryptoIDKey + -- ) => + FilePath -> ByteString -> HandlerFor UniWorX a +sendResponseByteStringFile fileTitle fileContent = do + -- ensureApprootUserGeneratedMaybe' Nothing + when (null fileContent) $ sendResponseStatus noContent204 () + let cType = simpleContentType (mimeLookup $ pack fileTitle) <> "; charset=utf-8" + content = (cType, toContent fileContent) + -- setCSPSandbox + setContentDisposition ContentInline $ Just $ takeFileName fileTitle -- just displays, but cannot save + -- setContentDisposition ContentAttachment $ Just $ takeFileName fileTitle -- saves file pnly, no display + -- setContentDisposition' . Just $ takeFileName fileTitle + sendResponse content + sendFileReference :: forall file a. ( HasFileReference file , BearerAuthSite UniWorX diff --git a/src/Handler/Utils/LMS.hs b/src/Handler/Utils/LMS.hs index a444e6f68..5d815669e 100644 --- a/src/Handler/Utils/LMS.hs +++ b/src/Handler/Utils/LMS.hs @@ -20,6 +20,7 @@ module Handler.Utils.LMS , lmsDeletionDate , lmsUserToDelete, _lmsUserToDelete , lmsUserToDeleteExpr + , lmsStatusInfoCell , lmsStatusIcon, lmsUserStatusWidget , randomLMSIdent, randomLMSIdentBut , randomLMSpw, maxLmsUserIdentRetries @@ -103,15 +104,15 @@ makeLmsFilename ftag (citext2lower -> qsh) = do getYMTH :: MonadHandler m => m Text getYMTH = formatTime' "%Y%m%d%H" =<< liftIO getCurrentTime --- +-- lmsDeletionDate :: Handler Day -lmsDeletionDate = do +lmsDeletionDate = do LmsConf{lmsDeletionDays} <- getsYesod $ view _appLmsConf addDays (fromIntegral $ negate lmsDeletionDays) . utctDay <$> liftIO getCurrentTime -- | Decide whether LMS platform should delete an identifier lmsUserToDeleteExpr :: Day -> E.SqlExpr (Entity LmsUser) -> E.SqlExpr (E.Value Bool) -lmsUserToDeleteExpr cutoff lmslist = E.isNothing (lmslist E.^. LmsUserEnded) +lmsUserToDeleteExpr cutoff lmslist = E.isNothing (lmslist E.^. LmsUserEnded) E.&&. E.not_ (E.isNothing $ lmslist E.^. LmsUserStatus) E.&&. E.explicitUnsafeCoerceSqlExprValue "timestamp" ((lmslist E.^. LmsUserStatus) E.#>>. "{day}") E.<=. E.val cutoff @@ -154,29 +155,58 @@ randomLMSIdent = LmsIdent <$> randomText [] lengthIdent -- idents must not conta randomLMSIdentBut :: MonadIO m => Set LmsIdent -> m (Maybe LmsIdent) randomLMSIdentBut banList = untilJustMaxM maxLmsUserIdentRetries getIdentOk - where - getIdentOk = do + where + getIdentOk = do l <- randomLMSIdent return $ toMaybe (Set.notMember l banList) l randomLMSpw :: MonadIO m => m Text -- may contain all kinds of symbols, but our users had trouble with some, like ',' '.' ':' '_' -randomLMSpw = randomText extra lengthPassword +randomLMSpw = randomText extra lengthPassword where extra = "+=!?" -- you cannot distinguish ;: and ., in printed letters +lmsStatusInfoCell :: Bool -> Maybe Int -> Widget +lmsStatusInfoCell extendedInfo auditMonths = + [whamlet|$newline never +

        + _{MsgTableLmsStatusTooltip auditMonths} +

        +

        + $if extendedInfo +
        ^{icon IconPlanned} +
        _{MsgLmsStatusPlanned} +
        ^{icon IconNotificationSent} +
        _{MsgLmsStatusNotificationSent} +
        ^{icon IconNotOK} +
        _{MsgLmsStatusBlocked} +
        ^{icon IconExpired} +
        _{MsgLmsStatusExpired} +
        ^{icon IconOK} +
        _{MsgLmsStatusSuccess} +

        + _{MsgLmsStatusDelay} + |] + lmsStatusIcon :: LmsStatus -> Icon lmsStatusIcon LmsSuccess{} = IconOK lmsStatusIcon LmsExpired{} = IconExpired lmsStatusIcon _other = IconNotOK -lmsUserStatusWidget :: LmsUser -> Widget -lmsUserStatusWidget LmsUser{lmsUserStatus=Just lStat} = +lmsUserStatusWidget :: Bool -> LmsUser -> Widget +lmsUserStatusWidget _ LmsUser{lmsUserStatus=Just lStat} = [whamlet|$newline never - ^{formatTimeW SelFormatDate (lmsStatusDay lStat)} - \ ^{icon (lmsStatusIcon lStat)} + ^{formatTimeW SelFormatDate (lmsStatusDay lStat)} + \ ^{icon (lmsStatusIcon lStat)} |] -lmsUserStatusWidget LmsUser{lmsUserStarted} = +-- previously: IconWaitingForUser for lmsUserStatus==Nothing +lmsUserStatusWidget _ LmsUser{lmsUserNotified=Just d} = [whamlet|$newline never - ^{formatTimeW SelFormatDate lmsUserStarted} - \ ^{icon IconWaitingForUser} + ^{formatTimeW SelFormatDate d} + \ ^{icon IconNotificationSent} |] +lmsUserStatusWidget True LmsUser{lmsUserStarted} = -- E-Learning started, but not yet notified; only intended for Admins + [whamlet|$newline never + ^{formatTimeW SelFormatDate lmsUserStarted} + \ ^{icon IconPlanned} + |] +lmsUserStatusWidget _ _ = mempty diff --git a/src/Handler/Utils/Profile.hs b/src/Handler/Utils/Profile.hs index 22f7a8098..4f8e87546 100644 --- a/src/Handler/Utils/Profile.hs +++ b/src/Handler/Utils/Profile.hs @@ -5,12 +5,10 @@ -- TODO: why is this Handler.Utils.Profile instead of Utils.Profile? -- TODO: consider merging with Handler.Utils.Users? module Handler.Utils.Profile - ( checkDisplayName - , validDisplayName - , fixDisplayName + ( validDisplayName, checkDisplayName, fixDisplayName , validPostAddress - , validEmail, validEmail' - , pickValidEmail, pickValidEmail' + , validEmail, validEmail', pickValidEmail, pickValidEmail' + , validFraportPersonalNumber ) where import Import.NoFoundation @@ -85,7 +83,7 @@ validEmail :: Email -> Bool -- Email = Text validEmail email = validRFC5322 && not invalidFraport where validRFC5322 = Email.isValid $ encodeUtf8 email - invalidFraport = case Text.stripSuffix "@fraport.de" email of + invalidFraport = case Text.stripSuffix "@fraport.de" (foldCase email) of Just fralogin -> all isDigit $ drop 1 fralogin Nothing -> False @@ -103,4 +101,11 @@ pickValidEmail' :: UserEmail -> UserEmail -> Maybe UserEmail pickValidEmail' x y | validEmail' x = Just x | validEmail' y = Just y - | otherwise = Nothing \ No newline at end of file + | otherwise = Nothing + +validFraportPersonalNumber :: Maybe Text -> Bool +validFraportPersonalNumber Nothing = False +validFraportPersonalNumber (Just t) + | (Just pn) <- readMay t + = pn >= (10000::Int) && pn <= (99999::Int) -- used to filter for SAP export + | otherwise = False diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 4797a4bdf..c4fb8ea02 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -7,6 +7,7 @@ module Handler.Utils.Table.Cells where import Import hiding (link) import Text.Blaze (ToMarkup(..)) +import qualified Data.Set as Set import Handler.Utils.Table.Pagination import Handler.Utils.DateTime @@ -217,6 +218,16 @@ cellHasUserModal toLink user = cellHasMatrikelnummer :: (IsDBTable m a, HasUser u) => u -> DBCell m a cellHasMatrikelnummer = maybe mempty textCell . view _userMatrikelnummer +cellHasMatrikelnummerLinked :: (IsDBTable m a, HasEntity u User) => u -> DBCell m a +cellHasMatrikelnummerLinked usr + | Just matNr <- usrEntity ^. _userMatrikelnummer = cell $ do + uuid <- liftHandler $ encrypt $ usrEntity ^. _entityKey + modal (text2widget matNr) (Left $ SomeRoute $ AdminAvsUserR uuid) + | otherwise = mempty + where + usrEntity = usr ^. hasEntityUser + + cellHasEMail :: (IsDBTable m a, HasUser u) => u -> DBCell m a cellHasEMail = emailCell . view _userDisplayEmail @@ -356,15 +367,15 @@ cryptoidCell = addCellClass ("cryptoid" :: Text) . textCell . toPathPiece lmsStatusCell :: IsDBTable m a => LmsStatus -> DBCell m a lmsStatusCell ls = iconCell (lmsStatusIcon ls) <> spacerCell <> dayCell (lmsStatusDay ls) -lmsStatusPlusCell :: IsDBTable m a => LmsUser -> DBCell m a -lmsStatusPlusCell LmsUser{lmsUserStatus=Just lStat} = lmsStatusCell lStat -lmsStatusPlusCell LmsUser{lmsUserStarted} = iconCell IconWaitingForUser <> spacerCell <> dateCell lmsUserStarted +-- lmsStatusPlusCell :: IsDBTable m a => LmsUser -> DBCell m a +-- lmsStatusPlusCell LmsUser{lmsUserStatus=Just lStat} = lmsStatusCell lStat +-- lmsStatusPlusCell LmsUser{lmsUserStarted} = iconCell IconWaitingForUser <> spacerCell <> dateCell lmsUserStarted -lmsStatusPlusCell' :: IsDBTable m a => Maybe (CryptoUUIDUser -> Route UniWorX) -> LmsUser -> DBCell m a -lmsStatusPlusCell' Nothing lu = wgtCell $ lmsUserStatusWidget lu -lmsStatusPlusCell' (Just toLink) lu = cell $ do +lmsStatusPlusCell :: IsDBTable m a => Maybe (CryptoUUIDUser -> Route UniWorX) -> LmsUser -> DBCell m a +lmsStatusPlusCell Nothing lu = wgtCell $ lmsUserStatusWidget False lu +lmsStatusPlusCell (Just toLink) lu = cell $ do uuid <- liftHandler $ encrypt $ lu ^. _lmsUserUser - modal (lmsUserStatusWidget lu) (Left $ SomeRoute $ toLink uuid) + modal (lmsUserStatusWidget True lu) (Left $ SomeRoute $ toLink uuid) qualificationBlockedCellNoReason :: IsDBTable m a => Maybe QualificationBlocked -> DBCell m a qualificationBlockedCellNoReason Nothing = mempty @@ -379,5 +390,23 @@ qualificationBlockedCell (Just QualificationBlocked{..}) where mkCellWith c = c qualificationBlockedReason <> spacerCell <> iconCell IconBlocked <> spacerCell <> dayCell qualificationBlockedDay -avsPersonNoCell :: (IsDBTable m c, HasUserAvs a) => a -> DBCell m c +avsPersonNoCell :: (IsDBTable m c, HasUserAvs a) => a -> DBCell m c avsPersonNoCell = numCell . view _userAvsNoPerson + +avsPersonNoLinkedCell :: (IsDBTable m c, HasUserAvs a) => a -> DBCell m c +avsPersonNoLinkedCell a = cell $ do + uuid <- liftHandler $ encrypt $ a ^. _userAvsUser + modal (toWgt $ toMessage $ a ^. _userAvsNoPerson) (Left $ SomeRoute $ AdminAvsUserR uuid) + +avsPersonCardCell :: (IsDBTable m c) => Set AvsDataPersonCard -> DBCell m c +avsPersonCardCell cards = wgtCell + [whamlet| + $newline never +

          + $forall c <- validColors +
        • + _{c} + |] + where + validCards = Set.filter avsDataValid cards + validColors = Set.toDescList $ Set.map avsDataCardColor validCards \ No newline at end of file diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs index 83d391458..473b3c484 100644 --- a/src/Handler/Utils/Table/Columns.hs +++ b/src/Handler/Utils/Table/Columns.hs @@ -442,8 +442,8 @@ fltrUserMatriculationUI :: DBFilterUI fltrUserMatriculationUI mPrev = prismAForm (singletonFilter "user-matriculation") mPrev $ aopt textField (fslI MsgTableUserMatriculation) -colUserMatriclenr :: (IsDBTable m c, HasUser a) => Colonnade Sortable a (DBCell m c) -colUserMatriclenr = sortable (Just "user-matriclenumber") (i18nCell MsgTableMatrikelNr) cellHasMatrikelnummer +colUserMatriclenr :: (IsDBTable m c, HasEntity a User) => Colonnade Sortable a (DBCell m c) +colUserMatriclenr = sortable (Just "user-matriclenumber") (i18nCell MsgTableMatrikelNr) cellHasMatrikelnummerLinked sortUserMatriclenr :: IsString d => (t -> E.SqlExpr (Entity User)) -> (d, SortColumn t r') sortUserMatriclenr queryUser = ("user-matriclenumber", SortColumn $ queryUser >>> (E.^. UserMatrikelnummer)) diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 9f29e12f4..10b90e28f 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -48,7 +48,7 @@ module Handler.Utils.Table.Pagination , linkEitherCell, linkEitherCellM, linkEitherCellM' , maybeAnchorCellM, maybeAnchorCellM', maybeLinkEitherCellM' , anchorCellC, anchorCellCM, anchorCellCM', linkEitherCellCM', maybeLinkEitherCellCM' - , cellTooltip, cellTooltipIcon + , cellTooltip, cellTooltipIcon, cellTooltipWgt , listCell, listCell', listCellOf, listCellOf' , ilistCell, ilistCell', ilistCellOf, ilistCellOf' , formCell, DBFormResult(..), getDBFormResult @@ -1700,9 +1700,12 @@ cellTooltip :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a - cellTooltip = cellTooltipIcon Nothing cellTooltipIcon :: (RenderMessage UniWorX msg, IsDBTable m a) => Maybe Icon -> msg -> DBCell m a -> DBCell m a -cellTooltipIcon icn msg = cellContents.mapped %~ (<> tipWdgt) +cellTooltipIcon icn = cellTooltipWgt icn . msg2widget + +cellTooltipWgt :: (IsDBTable m a) => Maybe Icon -> Widget-> DBCell m a -> DBCell m a +cellTooltipWgt icn wgt = cellContents.mapped %~ (<> tipWdgt) where - tipWdgt = iconTooltip (msg2widget msg) icn True + tipWdgt = iconTooltip wgt icn True -- | Always display widget; maybe a link if user is Authorized. -- Also see variant `linkEmptyCell` diff --git a/src/Handler/Utils/Widgets.hs b/src/Handler/Utils/Widgets.hs index 6f70a5d57..0d50aaa20 100644 --- a/src/Handler/Utils/Widgets.hs +++ b/src/Handler/Utils/Widgets.hs @@ -13,7 +13,7 @@ import Text.Hamlet (shamletFile) import Handler.Utils.DateTime import qualified Data.Char as Char - +import qualified Data.HashMap.Strict as Aeson -- ON UPDATE replace with: import qualified Data.Aeson.KeyMap as Aeson --------- -- Simple utilities for consistent display @@ -198,3 +198,36 @@ roomReferenceWidget RoomReferenceLink{..} = $(widgetFile "widgets/room-reference where linkText = uriToString id roomRefLink mempty instrModal = modal (i18n MsgRoomReferenceLinkInstructions) $ Right $(widgetFile "widgets/room-reference/link-instructions-modal") + + +---------- +-- JSON -- +---------- + +-- Data.Aeson.Encode.Pretty.encodePretty did not render in Html properly, hence jsonWidget +jsonWidget :: ToJSON a => a -> Widget +jsonWidget x = jsonWidgetAux $ toJSON x + where + jsonWidgetAux :: Value -> Widget + jsonWidgetAux Null = [whamlet|Null|] + jsonWidgetAux (Bool b) = toWidget $ boolSymbol b + jsonWidgetAux (String s) = [whamlet|#{s}|] + jsonWidgetAux (Number n) = [whamlet|#{show n}|] + jsonWidgetAux (Array l) + | 1 >= length l = foldMap jsonWidgetAux l -- empty arrays don't show + | otherwise = + [whamlet| +
            + $forall x <- sort l +
          • ^{jsonWidgetAux x} + |] + jsonWidgetAux (Object o) = case Aeson.toList o of -- toAscList not supported + [ ] -> mempty -- empty objects don't show + [(_,v)] -> jsonWidgetAux v + r -> [whamlet| +
            + $forall (k,v) <- sort r +
            #{k} +
            ^{jsonWidgetAux v} + |] + \ No newline at end of file diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs index 64161ee41..bd9aaa0e9 100644 --- a/src/Model/Types/Avs.hs +++ b/src/Model/Types/Avs.hs @@ -100,7 +100,7 @@ instance FromJSON AvsInternalPersonalNo where instance ToJSON AvsInternalPersonalNo where toJSON (AvsInternalPersonalNo ipn) = toJSON $ normalizeAvsInternalPersonalNo ipn -type instance Element AvsInternalPersonalNo = Char +type instance Element AvsInternalPersonalNo = Char instance MonoFoldable AvsInternalPersonalNo where ofoldMap f = ofoldr (mappend . f) mempty . avsInternalPersonalNo ofoldr x y = Text.foldr x y . avsInternalPersonalNo @@ -207,7 +207,10 @@ instance ToJSON AvsPersonId where instance Show AvsPersonId where show = show . avsPersonId instance Read AvsPersonId where - readPrec = fmap AvsPersonId readPrec + readPrec = fmap AvsPersonId readPrec + +_AvsPersonId :: Iso AvsPersonId AvsPersonId Int Int +_AvsPersonId = iso avsPersonId AvsPersonId -- | Non-existing default, also needed for query all ramp driving licences avsPersonIdZero :: AvsPersonId @@ -281,12 +284,13 @@ licence2char AvsLicenceRollfeld = 'R' data AvsDataCardColor = AvsCardColorMisc Text | AvsCardColorGrün | AvsCardColorBlau | AvsCardColorRot | AvsCardColorGelb deriving (Eq, Ord, Read, Show, Generic) deriving anyclass (NFData) + -- instance RenderMessage declared in Foundation.I18n instance ToJSON AvsDataCardColor where - toJSON AvsCardColorGrün = "Grün" - toJSON AvsCardColorBlau = "Blau" - toJSON AvsCardColorRot = "Rot" - toJSON AvsCardColorGelb = "Gelb" + toJSON AvsCardColorGrün = "Grün" + toJSON AvsCardColorBlau = "Blau" + toJSON AvsCardColorRot = "Rot" + toJSON AvsCardColorGelb = "Gelb" toJSON (AvsCardColorMisc t) = String t instance FromJSON AvsDataCardColor where @@ -583,6 +587,7 @@ deriveJSON defaultOptions -- Responses -- --------------- +type AvsResponseStatus :: Type newtype AvsResponseStatus = AvsResponseStatus (Set AvsStatusPerson) deriving (Eq, Ord, Show, Generic) deriveJSON defaultOptions @@ -591,6 +596,8 @@ deriveJSON defaultOptions , tagSingleConstructors = False , rejectUnknownFields = False } ''AvsResponseStatus +instance Semigroup AvsResponseStatus where + (AvsResponseStatus a) <> (AvsResponseStatus b) = AvsResponseStatus (a <> b) newtype AvsResponsePerson = AvsResponsePerson (Set AvsDataPerson) deriving (Eq, Ord, Show, Generic) @@ -657,7 +664,7 @@ deriveJSON defaultOptions } ''AvsQueryPerson newtype AvsQueryStatus = AvsQueryStatus (Set AvsPersonId) - deriving (Eq, Ord, Show, Generic) + deriving (Eq, Ord, Show, Generic) deriveJSON defaultOptions ''AvsQueryStatus newtype AvsQueryContact = AvsQueryContact (Set AvsObjPersonId) -- note the difference to AvsQueryStatus, which receives a list of id, whereas here we sent a list of single-field object diff --git a/src/Model/Types/DateTime.hs b/src/Model/Types/DateTime.hs index a3ffb0ff6..f36420657 100644 --- a/src/Model/Types/DateTime.hs +++ b/src/Model/Types/DateTime.hs @@ -15,6 +15,7 @@ module Model.Types.DateTime import Import.NoModel +import qualified Data.Set as Set import Data.Ratio ((%)) import qualified Data.Text as Text -- import Data.Either.Combinators (maybeToRight, mapLeft) @@ -206,3 +207,16 @@ derivePersistFieldJSON ''Occurrences nullaryPathPiece ''DayOfWeek camelToPathPiece + + +-- | Get bounds for an Occurrences +-- TODO: unfinished function, only works for a few selected cases yet +occurrencesBounds :: Occurrences -> (Maybe Day, Maybe Day) +occurrencesBounds Occurrences{occurrencesScheduled=scd} | notNull scd = (Nothing, Nothing) -- TODO: case is not yet implemented +occurrencesBounds Occurrences{occurrencesExceptions=exc} = (Set.lookupMin occDays, Set.lookupMax occDays) + where + occDays = Set.foldr getOccDays mempty exc + + getOccDays :: OccurrenceException -> Set Day -> Set Day + getOccDays ExceptNoOccur{} acc = acc -- TODO: this case ignores ExceptNoOccur for now! + getOccDays ExceptOccur{exceptDay} acc = Set.insert exceptDay acc diff --git a/src/Utils.hs b/src/Utils.hs index e6c518358..0bafb212b 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -845,6 +845,11 @@ toNothing = const Nothing toNothingS :: String -> Maybe b toNothingS = const Nothing +-- | change second of maybe pair to Nothing, if both are Just and equal +eq2nothing :: Eq a => (Maybe a, Maybe a) -> (Maybe a, Maybe a) +eq2nothing (mx@(Just x), Just y) | x==y = (mx, Nothing) +eq2nothing p = p + -- replaced by a more general formulation, see canonical -- null2nothing :: MonoFoldable a => Maybe a -> Maybe a -- null2nothing (Just x) | null x = Nothing @@ -1297,6 +1302,12 @@ maxLength :: ( Integral n -- ^ @maxLegth n xs = length xs <= n@ maxLength l = not . minLength (succ l) +-- anyone :: (Foldable t) => t a -> Maybe a +-- | return any single element from a foldable, if it is not null +anyone :: (Foldable t, Alternative f) => t a -> f a +anyone = Fold.foldr ((<|>).pure) empty + + ------------ -- Writer -- ------------ diff --git a/src/Utils/Avs.hs b/src/Utils/Avs.hs index e1c3bc4f9..00580b26a 100644 --- a/src/Utils/Avs.hs +++ b/src/Utils/Avs.hs @@ -32,7 +32,11 @@ type AVSGetRampLicences = "RampDrivingLicenceInfo" :> ReqBody '[JSON] AvsQueryG type AVSSetRampLicences = "RampDrivingLicence" :> ReqBody '[JSON] AvsQuerySetLicences :> Post '[JSON] AvsResponseSetLicences avsMaxSetLicenceAtOnce :: Int -avsMaxSetLicenceAtOnce = 99 -- maximum input set size for avsQuerySetLicences as enforced by AVS +avsMaxSetLicenceAtOnce = 90 -- maximum input set size for avsQuerySetLicences as enforced by AVS + +avsMaxGetStatusAtOnce :: Int +avsMaxGetStatusAtOnce = 900 -- maximum input set size for avsQueryStatus as enforced by AVS + avsApi :: Proxy AVS avsApi = Proxy @@ -68,14 +72,14 @@ mkAvsQuery :: BaseUrl -> BasicAuthData -> ClientEnv -> AvsQuery mkAvsQuery _ _ _ = AvsQuery { avsQueryPerson = \_ -> return . Right $ AvsResponsePerson mempty , avsQueryStatus = \_ -> return . Right $ AvsResponseStatus mempty - , avsQueryContact = \_ -> return . Right $ AvsResponseContact $ Set.singleton $ AvsDataContact (AvsPersonId 1234567) (AvsPersonInfo "AVSNO:123" "Heribert" "Sumpfmeier" (-1) Nothing Nothing Nothing Nothing) (AvsFirmInfo "Lange Firma" 7 "Kurz" Nothing Nothing Nothing Nothing Nothing Nothing) + , avsQueryContact = \_ -> return . Right $ AvsResponseContact $ Set.singleton $ AvsDataContact (AvsPersonId 1234567) (AvsPersonInfo "123123123" "Heribert" "Sumpfmeier" (-1) Nothing Nothing Nothing Nothing) (AvsFirmInfo "Lange Firma" 7 "Kurz" Nothing Nothing Nothing Nothing Nothing Nothing) , avsQuerySetLicences = \_ -> return . Right $ AvsResponseSetLicences mempty , avsQueryGetAllLicences = return . Right $ AvsResponseGetLicences mempty } #else mkAvsQuery baseUrl basicAuth cliEnv = AvsQuery { avsQueryPerson = \q -> liftIO $ catch404toEmpty <$> runClientM (rawQueryPerson q) cliEnv - , avsQueryStatus = \q -> liftIO $ runClientM (rawQueryStatus q) cliEnv + , avsQueryStatus = \q -> liftIO $ runClientM (splitQueryStatus q) cliEnv , avsQueryContact = \q -> liftIO $ runClientM (rawQueryContact q) cliEnv , avsQuerySetLicences = \q -> liftIO $ runClientM (rawQuerySetLicences q) cliEnv -- , avsQueryGetLicences = \q -> liftIO $ runClientM (rawQueryGetLicences q) cliEnv @@ -91,6 +95,26 @@ mkAvsQuery baseUrl basicAuth cliEnv = AvsQuery catch404toEmpty (Left (FailureResponse (requestPath -> (base, _path)) (statusCode . responseStatusCode -> 404))) | baseUrl == base = Right $ AvsResponsePerson mempty -- WORKAROUND: AVS server erroneously returns 404 if no matching person could be found in its database! catch404toEmpty other = other + + -- TODO: make a generic implementation for this + splitQueryStatus :: AvsQueryStatus -> ClientM AvsResponseStatus + splitQueryStatus q@(AvsQueryStatus avids) + | Set.size avids <= avsMaxGetStatusAtOnce = rawQueryStatus q + | otherwise = do + let (avid_1,avid_2) = Set.splitAt avsMaxGetStatusAtOnce avids + res1 <- rawQueryStatus (AvsQueryStatus avid_1) + res2 <- splitQueryStatus (AvsQueryStatus avid_2) + return $ res1 <> res2 + + -- splitQuery :: (a -> Set b) -> (Set b -> a) -> (a -> ClientM c) -> a -> ClientM c + -- splitQuery toSet fromSet rawQuery q + -- | Set.size (toSet q) <= avsMaxGetStatusAtOnce = rawQueryStatus q + -- | otherwise = do + -- let (fromSet -> avid_1,fromSet -> avid_2) = Set.splitAt avsMaxGetStatusAtOnce (toSet q) + -- res1 <- rawQuery avid_1 + -- res2 <- splitQuery toSet fromSet rawQuery avid_2 + -- return $ fromSet (toSet res1 <> toSet res2) + #endif ----------------------- diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs index ce035510f..eda59372c 100644 --- a/src/Utils/Icon.hs +++ b/src/Utils/Icon.hs @@ -68,11 +68,14 @@ data Icon | IconRegisterTemplate | IconNoCorrectors | IconTooltipDefault - | IconNotificationSuccess + | IconNotificationSuccess -- used for popups | IconNotificationInfo | IconNotificationWarning | IconNotificationError | IconNotificationNonactive + | IconNotification -- used for email and lettes + | IconNoNotification + | IconNotificationSent | IconFavourite | IconLanguage | IconNavContainerClose | IconPageActionChildrenClose @@ -93,7 +96,6 @@ data Icon | IconFileUploadSession | IconStandaloneFieldError | IconFileUser - | IconNotification | IconNoNotification | IconPersonalIdentification | IconMenuWorkflows | IconVideo @@ -106,7 +108,7 @@ data Icon | IconLetter | IconAt | IconSupervisor - | IconWaitingForUser + -- | IconWaitingForUser | IconExpired deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic) deriving anyclass (Universe, Finite, NFData) @@ -180,6 +182,7 @@ iconText = \case IconStandaloneFieldError -> "exclamation" IconFileUser -> "file-user" IconNotification -> "envelope" + IconNotificationSent -> "envelope-open" -- "paper-plane", "shipping-fast", "hourglass-half" IconNoNotification -> "bell-slash" IconPersonalIdentification -> "id-card" IconMenuWorkflows -> "project-diagram" @@ -192,7 +195,7 @@ iconText = \case IconLetter -> "mail-bulk" -- Problem "envelope" already used for email as well IconAt -> "at" IconSupervisor -> "head-side" -- must be notably different to user - IconWaitingForUser -> "user-cog" -- Waiting on a user to do something + -- IconWaitingForUser -> "user-cog" -- Waiting on a user to do something IconExpired -> "hourglass-end" nullaryPathPiece ''Icon $ camelToPathPiece' 1 diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index aaa7aa63a..8d8108ee5 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -128,6 +128,9 @@ makeClassyFor_ ''LmsResult makeClassyFor_ ''UserAvs makeClassyFor_ ''UserAvsCard +makeClassyFor_ ''UserCompany +makeLenses_ ''Company + _entityKey :: Getter (Entity record) (Key record) -- ^ Not a `Lens'` for safety _entityKey = to entityKey diff --git a/src/Utils/Print.hs b/src/Utils/Print.hs index 55b81a0c8..7bd9e2c5d 100644 --- a/src/Utils/Print.hs +++ b/src/Utils/Print.hs @@ -6,16 +6,20 @@ module Utils.Print ( renderLetter -- used for generating letter pdfs + , renderLetters , sendEmailOrLetter -- directly print or sends by email , printLetter -- always send a letter , letterApcIdent -- create acknowledge string for APC + , letterFileName -- default filename , encryptPDF - , sanitizeCmdArg, validCmdArgument + , sanitizeCmdArg, sanitizeCmdArg', validCmdArgument -- , compileTemplate, makePDF , _Meta, addMeta , toMeta, mbMeta -- single values - , mkMeta, appMeta, applyMetas -- multiple values + , mkMeta, appMeta, applyMetas -- multiple values , LetterRenewQualificationF(..) + -- , LetterCourseCertificate() + , makeCourseCertificates ) where -- import Import.NoModel @@ -47,6 +51,7 @@ import Jobs.Handler.SendNotification.Utils import Utils.Print.Letters import Utils.Print.RenewQualification +import Utils.Print.CourseCertificate -- import Model.Types.Markup -- TODO-QSV: should this module be moved accordingly? @@ -103,7 +108,7 @@ import Utils.Print.RenewQualification -- | read and writes markdown, applying it as its own template to apply meta -mdTemplating :: Text -> P.Meta -> HandlerFor UniWorX (Either P.PandocError Text) +mdTemplating :: Text -> P.Meta -> HandlerFor UniWorX (Either P.PandocError P.Pandoc) mdTemplating template meta = runExceptT $ do let readerOpts = def { P.readerExtensions = P.pandocExtensions , P.readerStripComments = True @@ -113,21 +118,20 @@ mdTemplating template meta = runExceptT $ do let writerOpts = def { P.writerExtensions = P.pandocExtensions , P.writerTemplate = Just tmpl } - ExceptT . pure . P.runPure $ P.writeMarkdown writerOpts $ appMeta setIsDeFromLang - $ addMeta meta doc + ExceptT . pure . P.runPure $ do + md_txt <- P.writeMarkdown writerOpts $ appMeta setIsDeFromLang $ addMeta meta doc + P.readMarkdown readerOpts md_txt + -- | creates a PDF using a LaTeX template -pdfLaTeX :: LetterKind -> P.Meta -> Text -> HandlerFor UniWorX (Either P.PandocError LBS.ByteString) -pdfLaTeX lk meta md = do +pdfLaTeX :: LetterKind -> P.Pandoc -> HandlerFor UniWorX (Either P.PandocError LBS.ByteString) +pdfLaTeX lk doc = do e_tmpl <- $cachedHereBinary ("LetterKind:" <> tshow lk) (liftIO . P.runIO $ compileTemplate $ templateLatex lk) actRight e_tmpl $ \tmpl -> liftIO . P.runIO $ do - let readerOpts = def { P.readerExtensions = P.pandocExtensions } - writerOpts = def { P.writerExtensions = P.pandocExtensions - , P.writerTemplate = Just tmpl } - doc <- P.readMarkdown readerOpts md - makePDF writerOpts - $ appMeta setIsDeFromLang - $ addMeta meta doc + let writerOpts = def { P.writerExtensions = P.pandocExtensions + , P.writerTemplate = Just tmpl } + makePDF writerOpts $ appMeta setIsDeFromLang doc + renderLetter :: (MDLetter l) => Entity User -> l -> Text -> Handler (Either Text LBS.ByteString) @@ -136,20 +140,49 @@ renderLetter rcvrEnt@Entity{entityVal=rcvr} mdl apcIdent = do formatter@DateTimeFormatter{ format } <- getDateTimeFormatterUser' rcvr let lang = selectDeEn $ rcvr & userLanguages -- select either German or English only, default de; see Utils.Lang kind = getLetterKind $ pure mdl - tmpl = getTemplate $ pure mdl + tmpl = getTemplate mdl meta = addApcIdent apcIdent <> letterMeta mdl formatter lang rcvrEnt <> mkMeta - [ toMeta "lang" lang - , toMeta "date" $ format SelFormatDate now + [ -- toMeta "lang" lang -- receiver language is decided in MDLetter instance, since some letters have fixed languages + toMeta "date" $ format SelFormatDate now , toMeta "rcvr-name" $ rcvr & userDisplayName , toMeta "address" $ fromMaybe [rcvr & userDisplayName] $ getPostalAddress rcvr --, toMeta "rcvr-email" $ rcvr & userDisplayEmail -- note that some templates use "email" already otherwise ] e_md <- mdTemplating tmpl meta - result <- actRight e_md $ pdfLaTeX kind meta + result <- actRight e_md $ pdfLaTeX kind return $ over _Left P.renderError result +-- TODO: apcIdent does not make sense for multiple letters +renderLetters :: (MDLetter l, Foldable f) => Entity User -> f l -> Text -> Handler (Either Text LBS.ByteString) +renderLetters rcvrEnt@Entity{entityVal=rcvr} mdls apcIdent + | Just l <- anyone mdls = do + now <- liftIO getCurrentTime + formatter@DateTimeFormatter{ format } <- getDateTimeFormatterUser' rcvr + let lang = selectDeEn $ rcvr & userLanguages -- select either German or English only, default de; see Utils.Lang + kind = getLetterKind $ pure l + + templateCombine _ err@Left{} = pure err + templateCombine mdl (Right doc1) = + let tmpl = getTemplate mdl + meta = addApcIdent apcIdent + <> letterMeta mdl formatter lang rcvrEnt + <> mkMeta + [ -- toMeta "lang" lang -- receiver language is decided in MDLetter instance, since some letters have fixed languages + toMeta "date" $ format SelFormatDate now + , toMeta "rcvr-name" $ rcvr & userDisplayName + , toMeta "address" $ fromMaybe [rcvr & userDisplayName] $ getPostalAddress rcvr + --, toMeta "rcvr-email" $ rcvr & userDisplayEmail -- note that some templates use "email" already otherwise + ] + in mdTemplating tmpl meta >>= \case + err@Left{} -> pure err + Right doc2 -> pure $ Right $ doc1 <> doc2 + + doc <- foldrM templateCombine (Right mempty) mdls + result <- actRight doc $ pdfLaTeX kind + return $ over _Left P.renderError result + | otherwise = return $ Left "renderLetters received empty set of letters" --------------- @@ -183,22 +216,13 @@ printLetter' pji pdf = do , pjiCourse = printJobCourse , pjiQualification = printJobQualification , pjiLmsUser = printJobLmsUser + , pjiFileName = fName } = pji - recipient <- join <$> mapM get printJobRecipient - sender <- join <$> mapM get printJobSender - course <- join <$> mapM get printJobCourse - quali <- join <$> mapM get printJobQualification - let nameRecipient = abbrvName <$> recipient - nameSender = abbrvName <$> sender - nameCourse = CI.original . courseShorthand <$> course - nameQuali = CI.original . qualificationShorthand <$> quali - let jobFullName = text2asciiAlphaNum $ - T.replace " " "-" (T.intercalate "_" . catMaybes $ [Just printJobName, nameQuali, nameCourse, nameSender, nameRecipient]) - printJobFilename = T.unpack $ jobFullName <> ".pdf" + printJobFilename = T.unpack $ text2asciiAlphaNum fName <> ".pdf" -- printJobFile <- sinkFileDB True $ yield $ LBS.toStrict pdf -- for PrintJobFile :: FileContentReference use this code printJobFile = LBS.toStrict pdf printJobAcknowledged = Nothing - lprPDF jobFullName pdf >>= \case + lprPDF printJobFilename pdf >>= \case Left err -> do return $ Left err Right ok -> do @@ -217,11 +241,12 @@ printLetter'' _ = do } -} -sendEmailOrLetter :: (MDLetter l) => UserId -> l -> Handler Bool +sendEmailOrLetter :: (MDLetter l, MDMail l) => UserId -> l -> Handler Bool sendEmailOrLetter recipient letter = do (underling, receivers, undercopy) <- updateReceivers recipient -- TODO: check to avoid this almost circular dependency now <- liftIO getCurrentTime - let pjid = getPJId letter + let pjid = getPJId letter + fName = letterFileName letter mailSubject = getMailSubject letter -- these are only needed if sent by email, but we're lazy anyway undername = underling ^. _userDisplayName -- nameHtml' underling undermail = CI.original $ underling ^. _userEmail @@ -272,7 +297,7 @@ sendEmailOrLetter recipient letter = do setSubjectI mailSubject editNotifications <- mkEditNotifications svr addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/genericMailLetter.hamlet") - addPart (File { fileTitle = T.unpack $ pjiName pjid <> ".pdf" + addPart (File { fileTitle = fName , fileModified = now , fileContent = Just $ yield $ LBS.toStrict attachment } :: PureFile) @@ -302,6 +327,10 @@ readProcess' pc = do sanitizeCmdArg :: Text -> Text sanitizeCmdArg = T.filter (\c -> c /= '\'' && c /= '"' && c/= '\\' && not (isSeparator c)) + +sanitizeCmdArg' :: String -> String +sanitizeCmdArg' = filter (\c -> c /= '\'' && c /= '"' && c/= '\\' && not (isSeparator c)) + -- | Returns Nothing if ok, otherwise the first mismatching character -- Pin Password is used as a commandline argument in Utils.Print.encryptPDF and hence poses a security risk validCmdArgument :: Text -> Maybe Char @@ -346,8 +375,8 @@ encryptPDF pw bs = over _Left (decodeUtf8 . LBS.toStrict) . exit2either <$> read -- > lpr -P fradrive -H fravm017173.fra.fraport.de:515 -T printJobName - -- | Internal only, use `printLetter` instead -lprPDF :: (MonadHandler m, HasAppSettings (HandlerSite m)) => Text -> LBS.ByteString -> m (Either Text Text) -lprPDF jb bs = do +lprPDF :: (MonadHandler m, HasAppSettings (HandlerSite m)) => FilePath -> LBS.ByteString -> m (Either Text Text) +lprPDF (sanitizeCmdArg' -> jb) bs = do mbLprServerArg <- $cachedHereBinary ("lprServer"::Text) getLprServerArg case mbLprServerArg of Nothing -> return $ Right "Print command ignored due to setting 'mail-reroute-to' being set." @@ -359,8 +388,7 @@ lprPDF jb bs = do , "-" -- read from stdin ] jobname | null jb = [] - | otherwise = ["-J " <> jb'] - jb' = T.unpack $ sanitizeCmdArg jb + | otherwise = ["-J " <> jb] exit2either <$> readProcess' pc where getLprServerArg = do diff --git a/src/Utils/Print/CourseCertificate.hs b/src/Utils/Print/CourseCertificate.hs new file mode 100644 index 000000000..cbbe1f05d --- /dev/null +++ b/src/Utils/Print/CourseCertificate.hs @@ -0,0 +1,95 @@ +-- SPDX-FileCopyrightText: 2023 Steffen Jost +-- +-- SPDX-License-Identifier: AGPL-3.0-or-later + +{-# OPTIONS_GHC -fno-warn-unused-top-binds #-} + +module Utils.Print.CourseCertificate where + +import Import + +-- import Data.Char as Char +import qualified Data.Text as Text +import qualified Data.CaseInsensitive as CI + +import Data.FileEmbed (embedFile) + +import Utils.Print.Letters +import Handler.Utils.Profile + +data LetterCourseCertificate = LetterCourseCertificate + { ccCourseId :: CourseId + , ccCourseName :: Text + , ccCourseShorthand :: Text + , ccCourseSchool :: Text + , ccTutorialName :: Text + , ccCourseContent :: Maybe [Text] + , ccCourseBegin :: Maybe Day + , ccCourseEnd :: Maybe Day + , ccCourseLang :: Maybe Lang -- maybe fix language to fit course content language + , ccParticipant :: UserDisplayName + , ccFraNumber :: Maybe Text + , ccFraDepartment :: Maybe Text + , ccCompany :: Maybe Text + } + deriving (Eq, Show) + + +instance MDLetter LetterCourseCertificate where + encrypPDFfor _ = NoPassword + getLetterKind _ = Plain + getLetterEnvelope _ = 'c' + getTemplate LetterCourseCertificate{ccCourseContent = Just ccc} = + Text.replace "%%%course-content%%%" (unlines ccc) $ + decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/fraport_qualification.md") + getTemplate _ = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/fraport_qualification.md") + + letterMeta LetterCourseCertificate{..} DateTimeFormatter{ format } lang _rcvrEnt = + mkMeta + [ toMeta "participant" ccParticipant + , mbMeta "fra-number" ccFraNumber + , mbMeta "fra-department" ccFraDepartment + , mbMeta "company" ccCompany + , toMeta "course-name" ccCourseName + , mbMeta "course-content" ccCourseContent + , mbMeta "course-begin" (format SelFormatDate <$> ccCourseBegin) + , mbMeta "course-end" (format SelFormatDate <$> ccCourseEnd) + , toMeta "lang" (fromMaybe lang ccCourseLang) + ] + + getPJId LetterCourseCertificate{..} = + PrintJobIdentification + { pjiName = "Certificate" + , pjiApcAcknowledge = "cc-" <> ccCourseName + , pjiRecipient = Nothing + , pjiSender = Nothing + , pjiCourse = Just ccCourseId + , pjiQualification = Nothing + , pjiLmsUser = Nothing + , pjiFileName = "cert_" <> ccCourseSchool <> "-" <> ccCourseShorthand <> "-" <> ccTutorialName + } + + +makeCourseCertificates :: Traversable t => Tutorial -> Maybe Lang -> t UserId -> DB (t LetterCourseCertificate) +makeCourseCertificates Tutorial{ tutorialName = CI.original -> ccTutorialName + , tutorialCourse = ccCourseId + , tutorialTime = occurrences + } ccCourseLang participants = do + Course{ courseName = CI.original -> ccCourseName + , courseShorthand = CI.original -> ccCourseShorthand + , courseSchool = CI.original . unSchoolKey -> ccCourseSchool + , courseDescription = fmap html2textlines -> ccCourseContent + } <- get404 ccCourseId + let (ccCourseBegin, ccCourseEnd) = eq2nothing $ occurrencesBounds occurrences + forM participants $ \uid -> do + User{userDisplayName=ccParticipant, userCompanyDepartment, userCompanyPersonalNumber} <- get404 uid + (ccFraNumber, ccFraDepartment, ccCompany) <- + if isJust userCompanyDepartment && validFraportPersonalNumber userCompanyPersonalNumber + then + return (userCompanyPersonalNumber, userCompanyDepartment, Nothing) + else do + usrComp <- selectFirst [UserCompanyUser ==. uid] [Desc UserCompanyId] + comp <- forM usrComp (get . userCompanyCompany . entityVal) + let res = (comp ^? _Just . _Just . _companyName . _CI) <|> userCompanyDepartment -- if there is no company, use the department as fallback, if possible + return (Nothing, Nothing, res) + return LetterCourseCertificate{..} diff --git a/src/Utils/Print/Letters.hs b/src/Utils/Print/Letters.hs index 9a92a1ea8..2b4b94ac0 100644 --- a/src/Utils/Print/Letters.hs +++ b/src/Utils/Print/Letters.hs @@ -36,6 +36,8 @@ import Handler.Utils.DateTime -- import Model.Types.Markup -- TODO-QSV: should this module be moved accordingly? +-- instance P.ToMetaValue (CI Text) where +-- toMetaValue = P.MetaString . CI.original ---------------------- -- Pandoc Functions -- @@ -172,6 +174,7 @@ data PrintJobIdentification = PrintJobIdentification , pjiCourse :: Maybe CourseId , pjiQualification :: Maybe QualificationId , pjiLmsUser :: Maybe LmsIdent + , pjiFileName :: Text -- suggested filename, without suffix ".pdf" } deriving (Eq, Show) @@ -218,13 +221,12 @@ data EncryptPDFfor = NoPassword | PasswordSupervisor | PasswordUnderling deriving (Eq, Show) class MDLetter l where - getMailSubject :: l -> SomeMessage UniWorX -- only used if letter is sent by email as pdf attachment - getMailBody :: l -> DateTimeFormatter -> HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX) -- only used if letter is sent by email as pdf attachment - letterMeta :: l -> DateTimeFormatter -> Lang -> Entity User -> P.Meta + letterMeta :: l -> DateTimeFormatter -> Lang -> Entity User -> P.Meta -- formatter/lang for individual receiver, set Meta "lang" for individually translated letters + -- NOTE: METAs "date", "rcvr-name", "address" are set automatically by renderLetter for each receiver getPJId :: l -> PrintJobIdentification getLetterEnvelope :: l -> Char getLetterKind :: Proxy l -> LetterKind - getTemplate :: Proxy l -> Text + getTemplate :: l -> Text encrypPDFfor :: Proxy l -> EncryptPDFfor letterApcIdent :: (MDLetter l, MonadHandler m) => l -> CryptoUUIDUser -> UTCTime -> m Text @@ -233,9 +235,23 @@ letterApcIdent l uuid now = do tnow <- formatTime' "%y%m%d-%H" now return $ mkApcIdent uuid (getLetterEnvelope l) (getLetterKind $ pure l) tnow (pjiApcAcknowledge $ getPJId l) +letterFileName :: (MDLetter l) => l -> FilePath +letterFileName = Text.unpack . (<> ".pdf") . text2asciiAlphaNum . pjiFileName . getPJId + addApcIdent :: Text -> P.Meta addApcIdent = P.Meta . toMeta "apc-ident" getApcIdent :: P.Meta -> Maybe Text getApcIdent (P.lookupMeta "apc-ident" -> Just (P.MetaString t)) = Just t -getApcIdent _ = Nothing \ No newline at end of file +getApcIdent _ = Nothing + + +---------------- +-- Mail Class -- +---------------- + +-- this is for letters that may alternatively be sent as attachments to emails + +class MDMail l where -- + getMailSubject :: l -> SomeMessage UniWorX -- only used if letter is sent by email as pdf attachment + getMailBody :: l -> DateTimeFormatter -> HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX) -- only used if letter is sent by email as pdf attachment diff --git a/src/Utils/Print/RenewQualification.hs b/src/Utils/Print/RenewQualification.hs index 55496a840..fd953c40a 100644 --- a/src/Utils/Print/RenewQualification.hs +++ b/src/Utils/Print/RenewQualification.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Steffen Jost +-- SPDX-FileCopyrightText: 2023 Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -45,18 +45,20 @@ letterRenewalQualificationFData LetterRenewQualificationF{lmsLogin} = LetterRene lmsUrl = "https://drive.fraport.de" lmsUrlLogin = lmsUrl <> "/?login=" <> lmsIdent lmsIdent = getLmsIdent lmsLogin - -instance MDLetter LetterRenewQualificationF where - encrypPDFfor _ = PasswordUnderling - getLetterKind _ = PinLetter - getLetterEnvelope l = maybe 'q' (Char.toLower . fst) $ Text.uncons (qualShort l) - getTemplate _ = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/fraport_renewal.md") + +instance MDMail LetterRenewQualificationF where getMailSubject l = SomeMessage $ MsgMailSubjectQualificationRenewal $ qualShort l getMailBody l@LetterRenewQualificationF{..} DateTimeFormatter{ format } = let LetterRenewQualificationFData{..} = letterRenewalQualificationFData l in $(ihamletFile "templates/mail/body/qualificationRenewal.hamlet") - letterMeta l@LetterRenewQualificationF{..} DateTimeFormatter{ format } _lang Entity{entityKey=rcvrId, entityVal=User{userDisplayName}} = +instance MDLetter LetterRenewQualificationF where + encrypPDFfor _ = PasswordUnderling + getLetterKind _ = PinLetter + getLetterEnvelope l = maybe 'q' (Char.toLower . fst) $ Text.uncons (qualShort l) + getTemplate _ = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/fraport_renewal.md") + + letterMeta l@LetterRenewQualificationF{..} DateTimeFormatter{ format } lang Entity{entityKey=rcvrId, entityVal=User{userDisplayName}} = let LetterRenewQualificationFData{..} = letterRenewalQualificationFData l isSupervised = rcvrId /= qualHolderID in mkMeta $ @@ -65,7 +67,8 @@ instance MDLetter LetterRenewQualificationF where , toMeta "de-opening" ("Sehr geehrte Damen und Herren,"::Text) , toMeta "en-opening" ("Dear Sir or Madam,"::Text) ] <> - [ toMeta "login" lmsIdent + [ toMeta "lang" lang + , toMeta "login" lmsIdent , toMeta "pin" lmsPin , toMeta "examinee" qualHolderDN , toMeta "expiry" (format SelFormatDate qualExpiry) @@ -83,4 +86,10 @@ instance MDLetter LetterRenewQualificationF where , pjiCourse = Nothing , pjiQualification = Just qualId , pjiLmsUser = Just lmsLogin + , pjiFileName = "renew_" <> CI.original (unSchoolKey qualSchool) <> "-" <> qualShort <> "_" <> qualHolderSN + -- let nameRecipient = abbrvName <$> recipient + -- nameSender = abbrvName <$> sender + -- nameCourse = CI.original . courseShorthand <$> course + -- nameQuali = CI.original . qualificationShorthand <$> quali + -- in .. = T.replace " " "-" (T.intercalate "_" . catMaybes $ [Just printJobName, nameQuali, nameCourse, nameSender, nameRecipient]) } \ No newline at end of file diff --git a/templates/letter/fraport_qualification.md b/templates/letter/fraport_qualification.md index c29c2deb0..5f43711a5 100644 --- a/templates/letter/fraport_qualification.md +++ b/templates/letter/fraport_qualification.md @@ -1,15 +1,84 @@ --- ### Metaddaten, welche hier eingestellt werden: - +# keine ### Metadaten, welche automatisch ersetzt werden: lang: de-de is-de: true date: 11.11.1111 +test1: this **is really** a test +test2: 'this **is another** test' +test3: | +

            First

            +

            Here is some text with emphasis to see. ... +\renewcommand{\familydefault}{\sfdefault} $if(is-de)$ +\medskip + +\begin{huge}\sffamily\textbf{Teilnahmebescheinigung}\end{huge} + +\vspace{\fill} + +# $participant$ {-} +$if(fra-number)$ +## $fra-number$ $fra-department$ {-} +$endif$ +$if(company)$ +## $company$ {-} +$endif$ +hat +$if(course-begin)$ +$if(course-end)$ +von $course-begin$ bis $course-end$ +$else$ +am $course-begin$ +$endif$ +$endif$ +an der Veranstaltung +\centerline{\sffamily\LARGE{$course-name$}} +der Fahrerausbildung der Fraport AG teilgenommen. + +\vspace{\fill} +\vspace{\fill} + +$if(course-content)$ +## Inhalte: {-} + + +%%%course-content%%% + + +$endif$ + +\vspace{\fill} +\vspace{\fill} + +Mit Aushändigung der Teilnahmebescheinigung wird der erfolgreiche Abschluss des Kurses bestätigt. +Dieses Zertifikat wurde maschinell erstellt. + +\medskip + +Frankfurt am Main, $date$ +Fraport College + +\vspace{\fill} +\vspace{\fill} +\vspace{\fill} +\vspace{\fill} +\vspace{\fill} + $else$ - \ No newline at end of file + + +# Certificate of attendance + +**English version is not yet implemened.** +TODO + +$endif$ + +\clearpage \ No newline at end of file diff --git a/templates/letter/plain_article.latex b/templates/letter/plain_article.latex index ba833c37b..e95489125 100644 --- a/templates/letter/plain_article.latex +++ b/templates/letter/plain_article.latex @@ -1,8 +1,9 @@ %Based upon https://github.com/benedictdudel/pandoc-letter-din5008 \documentclass[ paper=A4, + version=last, firstfoot=false % first-page footer -]{scrlttr2} +]{scrartcl} \PassOptionsToPackage{hyphens}{url} \PassOptionsToPackage{unicode$for(hyperrefoptions)$,$hyperrefoptions$$endfor$}{hyperref} @@ -56,8 +57,9 @@ $endif$ \usepackage{DejaVuSansMono} % better monofont \else % if luatex or xetex - \usepackage{fontspec} + \usepackage{fontspec} \setmonofont{DejaVu Sans Mono} + %\renewcommand{\familydefault}{\sfdefault} \fi $if(mathspec)$ @@ -84,9 +86,9 @@ $endif$ \usepackage{enumitem} -\setlength{\oddsidemargin}{\useplength{toaddrhpos}} -\addtolength{\oddsidemargin}{-1in} -\setlength{\textwidth}{\useplength{firstheadwidth}} +%\setlength{\oddsidemargin}{\useplength{toaddrhpos}} +%\addtolength{\oddsidemargin}{-1in} +%\setlength{\textwidth}{\useplength{firstheadwidth}} \usepackage[absolute,quiet,overlay]{textpos}%,showboxes \setlength{\TPHorizModule}{1mm} @@ -95,6 +97,8 @@ $endif$ \providecommand{\tightlist}{% \setlength{\itemsep}{0pt}\setlength{\parskip}{0pt}} +\pagestyle{empty} + \begin{document}% $if(apc-ident)$ \begin{textblock}{200}(5,5)%hpos,vpos diff --git a/templates/lms-user.hamlet b/templates/lms-user.hamlet index 6108b47c1..a09a25886 100644 --- a/templates/lms-user.hamlet +++ b/templates/lms-user.hamlet @@ -34,7 +34,7 @@ $else

            ^{formatTimeW SelFormatDateTime (lmsUserStarted lmsUsr)} $maybe _ <- lmsUserStatus lmsUsr
            _{MsgTableLmsStatus} -
            ^{lmsUserStatusWidget lmsUsr} +
            ^{lmsUserStatusWidget True lmsUsr}
            _{MsgTableLmsIdent}
            #{getLmsIdent (lmsUserIdent lmsUsr)}
            _{MsgTableLmsPin} diff --git a/templates/profileData.hamlet b/templates/profileData.hamlet index 87dae8ebb..0c9783fd4 100644 --- a/templates/profileData.hamlet +++ b/templates/profileData.hamlet @@ -65,7 +65,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
            #{userEmail} $if not (validEmail' userEmail) - \ ^{messageTooltip tooltipInvalidEmail} + \ ^{messageTooltip tooltipInvalidEmail}
            _{MsgAdminUserPinPassword}
            diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 183a051ae..b5f4549ba 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -163,8 +163,8 @@ fillDb = do , userAuthentication = pwSimple , userLastAuthentication = Nothing , userTokensIssuedAfter = Nothing - , userMatrikelnummer = Nothing - , userEmail = "e12345@fraport.de" + , userMatrikelnummer = Just "94094094094" + , userEmail = "S.Jost@Fraport.de" , userDisplayEmail = "jost@tcs.ifi.lmu.de" , userDisplayName = "Steffen Jost" , userSurname = "Jost" @@ -358,7 +358,126 @@ fillDb = do , userExamOfficeGetSynced = False , userExamOfficeGetLabels = True } - + _stranger1 <- insert User + { userIdent = "AVSID:996699" + , userAuthentication = AuthLDAP + , userLastAuthentication = Nothing + , userTokensIssuedAfter = Nothing + , userMatrikelnummer = Nothing + , userEmail = "E996699@fraport.de" + , userDisplayEmail = "" + , userDisplayName = "Stranger One" + , userSurname = "One" + , userFirstName = "Stranger" + , userTitle = Nothing + , userMaxFavourites = userDefaultMaxFavourites + , userMaxFavouriteTerms = userDefaultMaxFavouriteTerms + , userTheme = ThemeMossGreen + , userDateTimeFormat = userDefaultDateTimeFormat + , userDateFormat = userDefaultDateFormat + , userTimeFormat = userDefaultTimeFormat + , userDownloadFiles = userDefaultDownloadFiles + , userWarningDays = userDefaultWarningDays + , userLanguages = Nothing + , userNotificationSettings = def + , userCreated = now + , userLastLdapSynchronisation = Nothing + , userLdapPrimaryKey = Nothing + , userCsvOptions = def + , userSex = Just SexMale + , userBirthday = Nothing + , userShowSex = userDefaultShowSex + , userTelephone = Nothing + , userMobile = Nothing + , userCompanyPersonalNumber = Just "E996699" + , userCompanyDepartment = Just "AVN-Strange" + , userPinPassword = Nothing + , userPostAddress = Nothing + , userPostLastUpdate = Nothing + , userPrefersPostal = False + , userExamOfficeGetSynced = False + , userExamOfficeGetLabels = True + } + _stranger2 <- insert User + { userIdent = "AVSID:669966" + , userAuthentication = AuthLDAP + , userLastAuthentication = Nothing + , userTokensIssuedAfter = Nothing + , userMatrikelnummer = Nothing + , userEmail = "E669966@fraport.de" + , userDisplayEmail = "" + , userDisplayName = "Stranger Two" + , userSurname = "Stranger" + , userFirstName = "Two" + , userTitle = Nothing + , userMaxFavourites = userDefaultMaxFavourites + , userMaxFavouriteTerms = userDefaultMaxFavouriteTerms + , userTheme = ThemeMossGreen + , userDateTimeFormat = userDefaultDateTimeFormat + , userDateFormat = userDefaultDateFormat + , userTimeFormat = userDefaultTimeFormat + , userDownloadFiles = userDefaultDownloadFiles + , userWarningDays = userDefaultWarningDays + , userLanguages = Nothing + , userNotificationSettings = def + , userCreated = now + , userLastLdapSynchronisation = Nothing + , userLdapPrimaryKey = Nothing + , userCsvOptions = def + , userSex = Just SexMale + , userBirthday = Nothing + , userShowSex = userDefaultShowSex + , userTelephone = Nothing + , userMobile = Nothing + , userCompanyPersonalNumber = Just "669966" + , userCompanyDepartment = Just "AVN-Strange" + , userPinPassword = Nothing + , userPostAddress = Nothing + , userPostLastUpdate = Nothing + , userPrefersPostal = False + , userExamOfficeGetSynced = False + , userExamOfficeGetLabels = True + } + _stranger3 <- insert User + { userIdent = "AVSID:6969" + , userAuthentication = AuthLDAP + , userLastAuthentication = Nothing + , userTokensIssuedAfter = Nothing + , userMatrikelnummer = Nothing + , userEmail = "E6969@fraport.de" + , userDisplayEmail = "" + , userDisplayName = "Stranger 3 Three" + , userSurname = "Three" + , userFirstName = "Stranger" + , userTitle = Nothing + , userMaxFavourites = userDefaultMaxFavourites + , userMaxFavouriteTerms = userDefaultMaxFavouriteTerms + , userTheme = ThemeMossGreen + , userDateTimeFormat = userDefaultDateTimeFormat + , userDateFormat = userDefaultDateFormat + , userTimeFormat = userDefaultTimeFormat + , userDownloadFiles = userDefaultDownloadFiles + , userWarningDays = userDefaultWarningDays + , userLanguages = Nothing + , userNotificationSettings = def + , userCreated = now + , userLastLdapSynchronisation = Nothing + , userLdapPrimaryKey = Nothing + , userCsvOptions = def + , userSex = Just SexMale + , userBirthday = Nothing + , userShowSex = userDefaultShowSex + , userTelephone = Nothing + , userMobile = Nothing + , userCompanyPersonalNumber = Just "E996699" + , userCompanyDepartment = Just "AVN-Strange" + , userPinPassword = Nothing + , userPostAddress = Just $ markdownToStoredMarkup ("Kartoffelweg 12 \n666 Höllensumpf \nFreiland"::Text) + , userPostLastUpdate = Nothing + , userPrefersPostal = False + , userExamOfficeGetSynced = False + , userExamOfficeGetLabels = True + } let firstNames = [ "James", "John", "Robert", "Michael" , "William", "David", "Mary", "Richard" @@ -419,8 +538,8 @@ fillDb = do , userShowSex = userDefaultShowSex , userTelephone = Nothing , userMobile = Nothing - , userCompanyPersonalNumber = Nothing - , userCompanyDepartment = Nothing + , userCompanyPersonalNumber = bool Nothing (Just "E123" ) (even $ length firstName) + , userCompanyDepartment = bool Nothing (Just "AVN-A") (even $ length userSurname) , userPinPassword = Nothing , userPostAddress = Nothing , userPostLastUpdate = Nothing @@ -823,11 +942,11 @@ fillDb = do , courseTerm = tk , courseSchool = avn , courseCapacity = capacity - , courseVisibleFrom = jtt TermDayStart 0 Nothing toMidnight - , courseVisibleTo = jtt TermDayEnd 0 Nothing beforeMidnight - , courseRegisterFrom = jtt TermDayStart 0 Nothing toMidnight - , courseRegisterTo = jtt TermDayLectureStart (-1) Nothing toMidnight - , courseDeregisterUntil = jtt TermDayLectureStart (-5) (Just Monday) toMidnight + , courseVisibleFrom = jtt TermDayStart 1 Nothing toMidnight + , courseVisibleTo = jtt TermDayEnd 10 Nothing beforeMidnight + , courseRegisterFrom = jtt TermDayLectureStart 0 Nothing toMidnight + , courseRegisterTo = jtt TermDayLectureStart 1 Nothing toMidnight + , courseDeregisterUntil = jtt TermDayLectureStart 5 (Just Monday) toMidnight , courseRegisterSecret = Nothing , courseMaterialFree = True }