fraport/fradrive-old
Archived
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge branch 'fradrive/localmaster'

Browse Source
This commit is contained in:
Steffen Jost 2023-03-22 16:36:07 +00:00
commit eafaccfbde
75 changed files with 1607 additions and 904 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
config/settings.yml
View File

@ -24,9 +24,9 @@ mail-from:
email: "_env:MAILFROM_EMAIL:uniworx@localhost" email: "_env:MAILFROM_EMAIL:uniworx@localhost"
mail-object-domain: "_env:MAILOBJECT_DOMAIN:localhost" mail-object-domain: "_env:MAILOBJECT_DOMAIN:localhost"
mail-use-replyto-instead-sender: "_env:MAIL_USES_REPLYTO:true" mail-use-replyto-instead-sender: "_env:MAIL_USES_REPLYTO:true"
#mail-reroute-to: mail-reroute-to:
# name: "_env:MAIL_REROUTE_TO_NAME:Steffen Jost" name: "_env:MAIL_REROUTE_TO_NAME:"
# email: "_env:MAIL_REROUTE_TO_EMAL:jost@tcs.ifi.lmu.de" email: "_env:MAIL_REROUTE_TO_EMAIL:"
#mail-verp: #mail-verp:
# separator: "_env:VERP_SEPARATOR:+" # separator: "_env:VERP_SEPARATOR:+"
# prefix: "_env:VERP_PREFIX:bounce" # prefix: "_env:VERP_PREFIX:bounce"
@ -150,6 +150,7 @@ lms-direct:
download-header: "_env:LMSDOWNLOADHEADER:true" download-header: "_env:LMSDOWNLOADHEADER:true"
download-delimiter: "_env:LMSDOWNLOADDELIMITER:," download-delimiter: "_env:LMSDOWNLOADDELIMITER:,"
download-cr-lf: "_env:LMSDOWNLOADCRLF:true" download-cr-lf: "_env:LMSDOWNLOADCRLF:true"
deletion-days: "_env:LMSDELETIONDAYS:7"
avs: avs:
host: "_env:AVSHOST:skytest.fra.fraport.de" host: "_env:AVSHOST:skytest.fra.fraport.de"

5
messages/uniworx/categories/avs/de-de-formal.msg
View File

@ -22,10 +22,11 @@ AvsImportAmbiguous n@Int: Import für #{show n} uneindeutige AVS IDs fehlgeschla
AvsImportUnknowns n@Int: Import für #{show n} unbekannte AVS IDs fehlgeschlagen AvsImportUnknowns n@Int: Import für #{show n} unbekannte AVS IDs fehlgeschlagen
AvsSetLicences alic@AvsLicence n@Int m@Int: _{alic} im AVS gesetzt: #{show n}/#{show m} AvsSetLicences alic@AvsLicence n@Int m@Int: _{alic} im AVS gesetzt: #{show n}/#{show m}
SetFraDriveLicences q@String n@Int: #{q} in FRADrive gewährt für #{show n} Benutzer SetFraDriveLicences q@String n@Int: #{q} in FRADrive gewährt für #{show n} Benutzer
RevokeFraDriveLicences alic@AvsLicence n@Int: _{alic} in FRADrive zum Vortag beendet für #{show n} Fahrer RevokeFraDriveLicencesError alic@AvsLicence: Entzug der _{alic} Lizenzen komplett fehlgeschlagen
RevokeFraDriveLicences alic@AvsLicence n@Int: _{alic} in FRADrive entzogen für #{show n} Fahrer
RevokeUnknownLicencesOk: AVS Fahrberechtigungen unbekannter Fahrer wurden gesperrt RevokeUnknownLicencesOk: AVS Fahrberechtigungen unbekannter Fahrer wurden gesperrt
RevokeUnknownLicencesFail: Nicht alle AVS Fahrberechtigungen unbekannter Fahrer konnten entzogen werden, siehe Log für Details RevokeUnknownLicencesFail: Nicht alle AVS Fahrberechtigungen unbekannter Fahrer konnten entzogen werden, siehe Log für Details
AvsCommunicationError: AVS Schnittstelle lieferte einen unerwarteten Fehler. AvsCommunicationError: AVS Schnittstelle lieferte einen unerwarteten Fehler.
LicenceTableChangeAvs: Im AVS ändern LicenceTableChangeAvs: Im AVS ändern
LicenceTableGrantFDrive: In FRADrive erteilen LicenceTableGrantFDrive: In FRADrive erteilen
LicenceTableRevokeFDrive: In FRADrive zum Vortag entziehen LicenceTableRevokeFDrive: In FRADrive entziehen

5
messages/uniworx/categories/avs/en-eu.msg
View File

@ -22,10 +22,11 @@ AvsImportAmbiguous n@Int: Import failed for #{show n} ambiguous AVS Ids
AvsImportUnknowns n@Int: Import failed for #{show n} unknown AVS Ids AvsImportUnknowns n@Int: Import failed for #{show n} unknown AVS Ids
AvsSetLicences alic n m: _{alic} set in AVS: #{show n}/#{show m} AvsSetLicences alic n m: _{alic} set in AVS: #{show n}/#{show m}
SetFraDriveLicences q@String n@Int: #{q} granted in FRADrive for #{show n} users SetFraDriveLicences q@String n@Int: #{q} granted in FRADrive for #{show n} users
RevokeFraDriveLicences alic@AvsLicence n@Int: _{alic} now ended yesterday in FRADrive for #{show n} drivers RevokeFraDriveLicencesError alic@AvsLicence: Revoking licences _{alic} failed entirely
RevokeFraDriveLicences alic@AvsLicence n@Int: _{alic} revoked in FRADrive for #{show n} drivers
RevokeUnknownLicencesOk: AVS driving licences of unknown drivers revoked RevokeUnknownLicencesOk: AVS driving licences of unknown drivers revoked
RevokeUnknownLicencesFail: Not all AVS driving licences of unknown drivers could be revoked, see log for details RevokeUnknownLicencesFail: Not all AVS driving licences of unknown drivers could be revoked, see log for details
AvsCommunicationError: AVS interface returned an unexpected error. AvsCommunicationError: AVS interface returned an unexpected error.
LicenceTableChangeAvs: Change in AVS LicenceTableChangeAvs: Change in AVS
LicenceTableGrantFDrive: Grant in FRADrive LicenceTableGrantFDrive: Grant in FRADrive
LicenceTableRevokeFDrive: Revoke yesterday in FRADrive LicenceTableRevokeFDrive: Revoke in FRADrive

2
messages/uniworx/categories/courses/courses/de-de-formal.msg
View File

@ -242,3 +242,5 @@ CourseAdministrator: Kursadministrator:in
CourseAvsRegisterTitle: Teilnehmer:innen anmelden CourseAvsRegisterTitle: Teilnehmer:innen anmelden
CourseAvsRegisterParticipants: Teilnehmer:innen CourseAvsRegisterParticipants: Teilnehmer:innen
CourseAvsRegisterParticipantsTip: Mehrere Teilnehmer:innen mit Komma separieren CourseAvsRegisterParticipantsTip: Mehrere Teilnehmer:innen mit Komma separieren
CourseQualifications n@Int: Assoziierte #{pluralDE n "Qualifikation" "Qualifikationen"}

2
messages/uniworx/categories/courses/courses/en-eu.msg
View File

@ -241,3 +241,5 @@ CourseAdministrator: Course administrator
CourseAvsRegisterTitle: Register participants CourseAvsRegisterTitle: Register participants
CourseAvsRegisterParticipants: Participants CourseAvsRegisterParticipants: Participants
CourseAvsRegisterParticipantsTip: Separate multiple participants with comma CourseAvsRegisterParticipantsTip: Separate multiple participants with comma
CourseQualifications n: Associated #{pluralENs n "Qualification"}

1
messages/uniworx/categories/courses/tutorial/de-de-formal.msg
View File

@ -44,6 +44,7 @@ TutorCorrectorInvitationAccepted shn@SheetName: Sie wurden als Korrektor:in für
TutorialUsersDeregistered count@Int64: #{show count} #{pluralDE count "-Tutorium-Teilnehmer:in" "Tutorium-Teilnehmer:innen" } abgemeldet TutorialUsersDeregistered count@Int64: #{show count} #{pluralDE count "-Tutorium-Teilnehmer:in" "Tutorium-Teilnehmer:innen" } abgemeldet
TutorialUserDeregister: Vom Tutorium Abmelden TutorialUserDeregister: Vom Tutorium Abmelden
TutorialUserSendMail: Mitteilung verschicken TutorialUserSendMail: Mitteilung verschicken
TutorialUserPrintQualification: Zertifikat drucken
TutorialUserGrantQualification: Qualifikation vergeben TutorialUserGrantQualification: Qualifikation vergeben
TutorialUserRenewQualification: Qualifikation regulär verlängern TutorialUserRenewQualification: Qualifikation regulär verlängern
TutorialUserRenewedQualification n@Int: Qualifikation für #{tshow n} Tutoriums-#{pluralDE n "Teilnehmer:in" "Teilnehmer:innen"} regulär verlängert TutorialUserRenewedQualification n@Int: Qualifikation für #{tshow n} Tutoriums-#{pluralDE n "Teilnehmer:in" "Teilnehmer:innen"} regulär verlängert

1
messages/uniworx/categories/courses/tutorial/en-eu.msg
View File

@ -45,6 +45,7 @@ TutorialUsersDeregistered count: Successfully deregistered #{show count} partici
TutorialUserDeregister: Deregister from tutorial TutorialUserDeregister: Deregister from tutorial
TutorialUserSendMail: Send mail TutorialUserSendMail: Send mail
TutorialUserPrintQualification: Print certificate
TutorialUserGrantQualification: Grant Qualification TutorialUserGrantQualification: Grant Qualification
TutorialUserRenewQualification: Renew Qualification TutorialUserRenewQualification: Renew Qualification
TutorialUserRenewedQualification n@Int: Successfully renewed qualification #{tshow n} tutorial #{pluralEN n "user" "users"} TutorialUserRenewedQualification n@Int: Successfully renewed qualification #{tshow n} tutorial #{pluralEN n "user" "users"}

2
messages/uniworx/categories/error/de-de-formal.msg
View File

@ -6,3 +6,5 @@ ErrorResponseNotFound: Unter der von Ihrem Browser angefragten URL wurde keine S
ErrorResponseNotAuthenticated: Um Zugriff auf einige Teile des Systems zu erhalten müssen Sie sich zunächst anmelden. ErrorResponseNotAuthenticated: Um Zugriff auf einige Teile des Systems zu erhalten müssen Sie sich zunächst anmelden.
ErrorResponseBadMethod requestMethodText@Text: Ihr Browser kann auf mehrere verschiedene Arten versuchen mit den vom System angebotenen Ressourcen zu interagieren. Die aktuell versuchte Methode (#{requestMethodText}) wird nicht unterstützt. ErrorResponseBadMethod requestMethodText@Text: Ihr Browser kann auf mehrere verschiedene Arten versuchen mit den vom System angebotenen Ressourcen zu interagieren. Die aktuell versuchte Methode (#{requestMethodText}) wird nicht unterstützt.
ErrorResponseEncrypted: Um keine sensiblen Daten preiszugeben wurden nähere Details verschlüsselt. Wenn Sie eine Anfrage an den Support schicken fügen Sie bitte die unten aufgeführten verschlüsselten Daten mit an. ErrorResponseEncrypted: Um keine sensiblen Daten preiszugeben wurden nähere Details verschlüsselt. Wenn Sie eine Anfrage an den Support schicken fügen Sie bitte die unten aufgeführten verschlüsselten Daten mit an.
ErrorUnknownFormAction: Unbekannte oder ungültige Formular Aktion wurde ignoriert.

2
messages/uniworx/categories/error/en-eu.msg
View File

@ -6,3 +6,5 @@ ErrorResponseNotFound: No page could be found under the url requested by your br
ErrorResponseNotAuthenticated: To be granted access to most parts of Uni2work you need to login first. ErrorResponseNotAuthenticated: To be granted access to most parts of Uni2work you need to login first.
ErrorResponseBadMethod requestMethodText: Your browser can interact in multiple ways with the resources offered by Uni2work. The requested method (#{requestMethodText}) is not supported here. ErrorResponseBadMethod requestMethodText: Your browser can interact in multiple ways with the resources offered by Uni2work. The requested method (#{requestMethodText}) is not supported here.
ErrorResponseEncrypted: In order not to reveal sensitive information further details have been encrypted. If you send a support request, please include the encrypted data listed below. ErrorResponseEncrypted: In order not to reveal sensitive information further details have been encrypted. If you send a support request, please include the encrypted data listed below.
ErrorUnknownFormAction: Unknown or invalid form action was ignored.

1
messages/uniworx/categories/print/de-de-formal.msg
View File

@ -7,6 +7,7 @@ PrintJobName: Bezeichnung
PrintJobFilename: Dateiname PrintJobFilename: Dateiname
PrintJobId !ident-ok: Id PrintJobId !ident-ok: Id
PrintJobCreated: Gesendet PrintJobCreated: Gesendet
PrintJobApcAcknowledge: Bestätigungs ID
PrintJobAcknowledged: Bestätigt PrintJobAcknowledged: Bestätigt
PrintJobUnacknowledged: Noch nicht gedruckt PrintJobUnacknowledged: Noch nicht gedruckt
PrintJobAcknowledge n@Int64: #{n} #{pluralDE n "Druckauftrag" "Druckaufräge"} als gedruckt und versendet bestätigt PrintJobAcknowledge n@Int64: #{n} #{pluralDE n "Druckauftrag" "Druckaufräge"} als gedruckt und versendet bestätigt

1
messages/uniworx/categories/print/en-eu.msg
View File

@ -7,6 +7,7 @@ PrintJobName: Description
PrintJobFilename: Filename PrintJobFilename: Filename
PrintJobId: Id PrintJobId: Id
PrintJobCreated: Created PrintJobCreated: Created
PrintJobApcAcknowledge: Acknowledge ID
PrintJobAcknowledged: Acknowledged PrintJobAcknowledged: Acknowledged
PrintJobUnacknowledged: Not yet printed PrintJobUnacknowledged: Not yet printed
PrintJobAcknowledge n: #{n} #{pluralENs n "print-job"} marked as printed and mailed PrintJobAcknowledge n: #{n} #{pluralENs n "print-job"} marked as printed and mailed

40
messages/uniworx/categories/qualification/de-de-formal.msg
View File

@ -20,18 +20,20 @@ TableQualificationSapExportTooltip: Wird die Qualifikation an das SAP übermitte
LmsQualificationValidUntil: Gültig bis LmsQualificationValidUntil: Gültig bis
TableQualificationLastRefresh: Zuletzt erneuert TableQualificationLastRefresh: Zuletzt erneuert
TableQualificationFirstHeld: Erstmalig TableQualificationFirstHeld: Erstmalig
TableQualificationBlockedDue: Suspendiert TableQualificationBlockedDue: Entzogen
TableQualificationBlockedTooltip: Wann wurde die Qualifikation vorübergehend außer Kraft gesetzt und warum wurde dies veranlasst? TableQualificationBlockedTooltip: Wann wurde die Qualifikation vorübergehend außer Kraft gesetzt und warum wurde dies veranlasst?
TableQualificationBlockedTooltipSimple: Wann wurde die Qualifikation aus besonderem Grund wiederrufen? TableQualificationBlockedTooltipSimple: Wann wurde die Qualifikation aus besonderem Grund wiederrufen?
TableQualificationNoRenewal: Storniert TableQualificationNoRenewal: Auslaufend
TableQualificationNoRenewalTooltip: Es wird keine Benachrichtigung mehr versendet, wenn diese Qualifikation ablaufen sollte. Die Qualifikation kann noch gültig sein. TableQualificationNoRenewalTooltip: Es wird keine Benachrichtigung mehr versendet, wenn diese Qualifikation ablaufen sollte. Die Qualifikation kann noch weiterhin gültig sein.
QualificationUserNoRenewal: Läuft ohne Benachrichtigung aus QualificationUserNoRenewal: Läuft ohne Benachrichtigung aus
QualificationUserNone: Für diese Person sind keine Qualifikationen registriert. QualificationUserNone: Für diese Person sind keine Qualifikationen registriert.
QualificationBlockReason: Entzugsbegründung
LmsUser: Inhaber LmsUser: Inhaber
TableLmsEmail: E-Mail LmsURL: Link E-Learning
TableLmsEmail: E‑Mail
TableLmsIdent: LMS Identifikation TableLmsIdent: LMS Identifikation
TableLmsElearning: E-Learning TableLmsElearning: E‑Learning
TableLmsPin: E-Learning Pin TableLmsPin: E‑Learning Pin
TableLmsResetPin: Pin zurücksetzen? TableLmsResetPin: Pin zurücksetzen?
TableLmsDatePin: Pin erstellt TableLmsDatePin: Pin erstellt
TableLmsDelete: Löschen? TableLmsDelete: Löschen?
@ -41,7 +43,7 @@ TableLmsReceived: Letzte Rückmeldung
TableLmsNotified: Versand Benachrichtigung 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 TableLmsEnded: Beended
TableLmsStatus: Status E-Learning 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."} 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 TableLmsStatusDay: Datum letzte Statusänderung E-Learning
TableLmsSuccess: Bestanden TableLmsSuccess: Bestanden
@ -67,14 +69,19 @@ LmsErrorNoRefreshElearning: Fehler: E-Learning wird nicht automatisch gestartet,
MailSubjectQualificationRenewal qname@Text: Qualifikation #{qname} muss demnächst erneuert werden MailSubjectQualificationRenewal qname@Text: Qualifikation #{qname} muss demnächst erneuert werden
MailSubjectQualificationExpiry qname@Text: Qualifikation #{qname} läuft demnächst ab MailSubjectQualificationExpiry qname@Text: Qualifikation #{qname} läuft demnächst ab
MailSubjectQualificationExpired qname@Text: Qualifikation #{qname} ist ab sofort ungültig MailSubjectQualificationExpired qname@Text: Qualifikation #{qname} ist ab sofort ungültig
MailBodyQualificationRenewal qname@Text: Sie müssen die Qualifikation #{qname} demnächst durch einen E-Learning Kurs erneuern, siehe Anhang. 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! 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: Qualifikation ohne Benachrichtigung auslaufen lassen QualificationActExpire: Auslaufend markieren - keine Benachrichtigung zur Erneuerung senden
QualificationActUnexpire: Benachrichtigung bei anstehender 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"} 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"} QualificationSetUnexpire n@Int64: Benachrichtigung bei anstehender Erneuerung und E-Learning aktiviert für #{n} #{pluralDE n "Person" "Personen"}
LmsRenewalInstructions: Anweisungen zur Verlängerung finden Sie im angehängten PDF. Um Missbrauch zu verhindern wurde das PDF dem von Ihnen in FRADrive hinterlegten PDF-Passwort verschlüsselt. Falls kein PDF-Passwort manuell hinterlegt wurde, ist das PDF-Passwort Ihre Flughafen Ausweisnummer, inklusive Punkt und der Ziffer danach. 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. LmsNoRenewal: Leider kann diese Qualifikation nicht alleine durch E-Learning verlängert werden.
LmsActNotify: Benachrichtigung E-Learning erneut per Post oder E-Mail versenden LmsActNotify: Benachrichtigung E-Learning erneut per Post oder E-Mail versenden
LmsActRenewPin: Neue zufällige E-Learning PIN zuweisen LmsActRenewPin: Neue zufällige E-Learning PIN zuweisen
@ -83,17 +90,6 @@ LmsNotificationSend n@Int: E-Learning Benachrichtigungen an #{n} #{pluralDE n "P
LmsPinRenewal n@Int: E-Learning Pin ausgetauscht für #{n} #{pluralDE n "Prüfling" "Prüflinge"}. 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. 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
MppOpening: Anrede
MppClosing: Grußformel
MppSupervisor: Ansprechpartner
MppDate: Datum
MppURL: Link E-Learning
MppLogin !ident-ok: Login
MppPin !ident-ok: Pin
MppRecipient: Empfänger
MppAddress: Adresse
MppLang: Sprache
MppBadLanguage: Sprache muss derzeit "de" oder "en" sein.
LmsAutomaticQueuing n@Natural: Die folgenden Funktionen werden normalerweise einmal pro Tag um #{show n} Uhr ausgeführt. 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. LmsManualQueuing: Die folgenden Funktionen sollten einmal pro Tag ausgeführt werden.
BtnLmsEnqueue: Nutzer mit ablaufenden Qualifikationen zum E-Learning anmelden und benachrichtigen BtnLmsEnqueue: Nutzer mit ablaufenden Qualifikationen zum E-Learning anmelden und benachrichtigen

34
messages/uniworx/categories/qualification/en-eu.msg
View File

@ -20,18 +20,20 @@ TableQualificationSapExportTooltip: Is this qualification transmitted to SAP? On
LmsQualificationValidUntil: Valid until LmsQualificationValidUntil: Valid until
TableQualificationLastRefresh: Last renewed TableQualificationLastRefresh: Last renewed
TableQualificationFirstHeld: First held TableQualificationFirstHeld: First held
TableQualificationBlockedDue: Suspended TableQualificationBlockedDue: Revoked
TableQualificationBlockedTooltip: Why and when was this qualification temporarily suspended? TableQualificationBlockedTooltip: Why and when was this qualification temporarily suspended?
TableQualificationBlockedTooltipSimple: When was this qualification revoked due to extraordinary reasons? TableQualificationBlockedTooltipSimple: When was this qualification revoked due to extraordinary reasons?
TableQualificationNoRenewal: Canceled TableQualificationNoRenewal: Discontinued
TableQualificationNoRenewalTooltip: No renewal notifications will be send for this qualification upon expiry. The qualification may still be valid. TableQualificationNoRenewalTooltip: No renewal notifications will be send for this qualification upon expiry. The qualification may still be valid.
QualificationUserNoRenewal: Expires without further notification QualificationUserNoRenewal: Expires without further notification
QualificationUserNone: No registered qualifications for this person. QualificationUserNone: No registered qualifications for this person.
QualificationBlockReason: Reason for revoking
LmsUser: Licensee LmsUser: Licensee
LmsURL: Link E-learning
TableLmsEmail: Email TableLmsEmail: Email
TableLmsIdent: LMS Identifier TableLmsIdent: LMS Identifier
TableLmsPin: E-learning pin TableLmsPin: E‑learning pin
TableLmsElearning: E-learning TableLmsElearning: E‑learning
TableLmsResetPin: Reset pin? TableLmsResetPin: Reset pin?
TableLmsDatePin: Pin created TableLmsDatePin: Pin created
TableLmsDelete: Delete? TableLmsDelete: Delete?
@ -67,14 +69,19 @@ LmsErrorNoRefreshElearning: Error: E-learning will not be started automatically
MailSubjectQualificationRenewal qname: Qualification #{qname} must be renewed shortly MailSubjectQualificationRenewal qname: Qualification #{qname} must be renewed shortly
MailSubjectQualificationExpiry qname: Qualification #{qname} expires soon MailSubjectQualificationExpiry qname: Qualification #{qname} expires soon
MailSubjectQualificationExpired qname: Qualification #{qname} is no longer valid MailSubjectQualificationExpired qname: Qualification #{qname} is no longer valid
MailBodyQualificationRenewal qname: You will soon need to renew qualification #{qname} by completing an e-learning course. For details see attachment. 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! 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: Qualification shall expire silently QualificationActExpire: Discontinue - qualification expires silently
QualificationActUnexpire: Notify upon due renewal QualificationActUnexpire: Continue - send a possibly fee-paying notification upon due renewal
QualificationSetExpire n: Expiry notification and e-learning deactivated 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"} QualificationSetUnexpire n: Expiry notification and e-learning activated for #{n} #{pluralENs n "person"}
LmsRenewalInstructions: Instruction on how to accomplish the renewal are enclosed in the attached PDF. In order to avoid misuse, the PDF is encrypted with your chosen FRADrive PDF-Password. If you have not yet chosen a PDF-Password yet, then the password is your Fraport id card number, inkluding the punctuation mark and the Digit thereafter. QualificationActBlockSupervisor: Waive permanently, effective immediately
QualificationActBlock: Revoke
QualificationActUnblock: Clear revocation
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. LmsNoRenewal: Unfortunately, this particular qualification cannot be renewed through E-learning only.
LmsActNotify: Resend e-learning notification by post or email LmsActNotify: Resend e-learning notification by post or email
LmsActRenewPin: Randomly replace e-learning PIN LmsActRenewPin: Randomly replace e-learning PIN
@ -83,17 +90,6 @@ LmsNotificationSend n: E-learning notifications will be sent to #{n} #{pluralENs
LmsPinRenewal n: E-learning pin replaced randomly for #{n} #{pluralENs n "examinee"}. 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. LmsActionFailed n: No action for #{n} #{pluralENs n "person"}, since there was no ongoing examination.
LmsStarted: E-learning open since LmsStarted: E-learning open since
MppOpening: Opening
MppClosing: Closing
MppSupervisor: Supervisor
MppDate: Date
MppURL: Link e-learning
MppLogin: Login
MppPin: Pin
MppRecipient: Recipient
MppAddress: Address
MppLang: Language
MppBadLanguage: Language currently restricted to "en" or "de".
LmsAutomaticQueuing n@Natural: The following functions are executed daily at #{show n} o'clock. LmsAutomaticQueuing n@Natural: The following functions are executed daily at #{show n} o'clock.
LmsManualQueuing: The following functions should be executed daily. LmsManualQueuing: The following functions should be executed daily.
BtnLmsEnqueue: Enqueue users with expiring qualifications for e-learning and notify them. BtnLmsEnqueue: Enqueue users with expiring qualifications for e-learning and notify them.

2
messages/uniworx/utils/buttons/de-de-formal.msg
View File

@ -38,7 +38,7 @@ BtnExamAutoOccurrenceCalculate: Verteilungstabelle berechnen
BtnExamAutoOccurrenceAccept: Verteilung akzeptieren BtnExamAutoOccurrenceAccept: Verteilung akzeptieren
BtnExamAutoOccurrenceNudgeUp !ident-ok: + BtnExamAutoOccurrenceNudgeUp !ident-ok: +
BtnExamAutoOccurrenceNudgeDown !ident-ok: - BtnExamAutoOccurrenceNudgeDown !ident-ok: -
BtnSetDisplayEmail: E-Mail-Adresse setzen BtnSetDisplayEmail: E‑Mail-Adresse setzen
BtnAuthLDAP: Auf Fraport AG Kennung (Büko) umstellen BtnAuthLDAP: Auf Fraport AG Kennung (Büko) umstellen
BtnAuthPWHash: Auf FRADrive interne Kennung umstellen BtnAuthPWHash: Auf FRADrive interne Kennung umstellen
BtnPasswordReset: Passwort zurücksetzen BtnPasswordReset: Passwort zurücksetzen

4
messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg
View File

@ -88,7 +88,7 @@ BreadcrumbVersion: Versionsgeschichte
BreadcrumbHelp: Hilfe BreadcrumbHelp: Hilfe
BreadcrumbHealth: Instanz-Zustand BreadcrumbHealth: Instanz-Zustand
BreadcrumbInstance: Instanz-Identifikation BreadcrumbInstance: Instanz-Identifikation
BreadcrumbUserDisplayEmail: E-Mail-Adresse BreadcrumbUserDisplayEmail: E‑Mail-Adresse
BreadcrumbProfileData: Persönliche Daten BreadcrumbProfileData: Persönliche Daten
BreadcrumbAuthPreds: Authorisierungseinstellungen BreadcrumbAuthPreds: Authorisierungseinstellungen
BreadcrumbTermShow: Semester BreadcrumbTermShow: Semester
@ -107,7 +107,7 @@ BreadcrumbSheetList: Übungsblätter
BreadcrumbSheetNew: Neues Übungsblatt anlegen BreadcrumbSheetNew: Neues Übungsblatt anlegen
BreadcrumbSheetCurrent: Aktuelles Übungsblatt BreadcrumbSheetCurrent: Aktuelles Übungsblatt
BreadcrumbSheetOldUnassigned: Abgaben ohne Korrektor:in BreadcrumbSheetOldUnassigned: Abgaben ohne Korrektor:in
BreadcrumbCourseCommunication: Kursmitteilung (E-Mail) BreadcrumbCourseCommunication: Kursmitteilung (E‑Mail)
BreadcrumbTutorialList: Tutorien BreadcrumbTutorialList: Tutorien
BreadcrumbTutorialNew: Neues Tutorium anlegen BreadcrumbTutorialNew: Neues Tutorium anlegen
BreadcrumbCourseDelete: Kurs löschen BreadcrumbCourseDelete: Kurs löschen

12
messages/uniworx/utils/navigation/menu/de-de-formal.msg
View File

@ -31,7 +31,7 @@ MenuCourseList: Kurse
MenuCourseMembers: Kursteilnehmer:innen MenuCourseMembers: Kursteilnehmer:innen
MenuCourseAddMembers: Kursteilnehmer:innen hinzufügen MenuCourseAddMembers: Kursteilnehmer:innen hinzufügen
MenuTutorialAddMembers: Tutorium Teilnehmer:innen hinzufügen MenuTutorialAddMembers: Tutorium Teilnehmer:innen hinzufügen
MenuCourseCommunication: Kursmitteilung (E-Mail) MenuCourseCommunication: Kursmitteilung (E‑Mail)
MenuCourseExamOffice: Prüfungsbeauftragte MenuCourseExamOffice: Prüfungsbeauftragte
MenuTermShow: Semester MenuTermShow: Semester
MenuSubmissionDelete: Abgabe löschen MenuSubmissionDelete: Abgabe löschen
@ -115,12 +115,12 @@ MenuCourseEventEdit: Kurstermin bearbeiten
MenuLanguage: Sprache MenuLanguage: Sprache
MenuQualifications: Qualifikationen MenuQualifications: Qualifikationen
MenuLms !ident-ok: E-Learning MenuLms !ident-ok: E‑Learning
MenuLmsEdit: Bearbeiten E-Learning MenuLmsEdit: Bearbeiten E‑Learning
MenuLmsUser: Benutzer Qualifikationen MenuLmsUser: Benutzer Qualifikationen
MenuLmsUsers: Export E-Learning Benutzer MenuLmsUsers: Export E‑Learning Benutzer
MenuLmsUserlist: Melden E-Learning Benutzer MenuLmsUserlist: Melden E‑Learning Benutzer
MenuLmsResult: Melden Ergebnisse E-Learning MenuLmsResult: Melden Ergebnisse E‑Learning
MenuLmsUpload: Hochladen MenuLmsUpload: Hochladen
MenuLmsDirectUpload: Direkter Upload MenuLmsDirectUpload: Direkter Upload
MenuLmsDirectDownload: Direkter Download MenuLmsDirectDownload: Direkter Download

10
messages/uniworx/utils/navigation/menu/en-eu.msg
View File

@ -116,12 +116,12 @@ MenuCourseEventEdit: Edit course occurrence
MenuLanguage: Language MenuLanguage: Language
MenuQualifications: Qualifications MenuQualifications: Qualifications
MenuLms: E-Learning MenuLms: E‑Learning
MenuLmsEdit: Edit E-Learning MenuLmsEdit: Edit E‑Learning
MenuLmsUser: User Qualifications MenuLmsUser: User Qualifications
MenuLmsUsers: Download E-Learning Users MenuLmsUsers: Download E‑Learning Users
MenuLmsUserlist: Upload E-Learning Users MenuLmsUserlist: Upload E‑Learning Users
MenuLmsResult: Upload E-Learning Results MenuLmsResult: Upload E‑Learning Results
MenuLmsUpload: Upload MenuLmsUpload: Upload
MenuLmsDirectUpload: Direct Upload MenuLmsDirectUpload: Direct Upload
MenuLmsDirectDownload: Direct Download MenuLmsDirectDownload: Direct Download

2
messages/uniworx/utils/table_column/de-de-formal.msg
View File

@ -4,7 +4,7 @@
ExamOccurrenceStart: Prüfungsbeginn ExamOccurrenceStart: Prüfungsbeginn
#general table-discriptions #general table-discriptions
TableEmail: E-Mail TableEmail: E‑Mail
TableStudyTerm: Studiengang TableStudyTerm: Studiengang
TableStudyFeatureAge: Fachsemester TableStudyFeatureAge: Fachsemester
TableStudyFeatureDegree: Abschluss TableStudyFeatureDegree: Abschluss

2
messages/uniworx/utils/utils/de-de-formal.msg
View File

@ -77,6 +77,8 @@ MultiUserFieldExplanationAnyUser: Dieses Eingabefeld sucht in den Adressen aller
MultiUserFieldInvitationExplanation: An Adressen, die so keinem Uni2work-Benutzer/keiner Uni2work-Benutzerin zugeordnet werden können, wird eine Einladung per E-Mail versandt. MultiUserFieldInvitationExplanation: An Adressen, die so keinem Uni2work-Benutzer/keiner Uni2work-Benutzerin zugeordnet werden können, wird eine Einladung per E-Mail versandt.
MultiUserFieldInvitationExplanationAlways: Es wird an alle Adressen, die Sie hier angeben, eine Einladung per E-Mail versandt. MultiUserFieldInvitationExplanationAlways: Es wird an alle Adressen, die Sie hier angeben, eine Einladung per E-Mail versandt.
AmbiguousEmail: E-Mail-Adresse nicht eindeutig AmbiguousEmail: E-Mail-Adresse nicht eindeutig
InvalidEmailAddress: E-Mail-Adresse ist ungültig
InvalidEmailAddressWith e@Text: E-Mail-Adresse #{show e} ist ungültig
UtilExamResultGrade: Note UtilExamResultGrade: Note
UtilExamResultPass: Bestanden/Nicht Bestanden UtilExamResultPass: Bestanden/Nicht Bestanden
UtilExamResultNoShow: Nicht erschienen UtilExamResultNoShow: Nicht erschienen

2
messages/uniworx/utils/utils/en-eu.msg
View File

@ -77,6 +77,8 @@ MultiUserFieldExplanationAnyUser: This input searches through the addresses of a
MultiUserFieldInvitationExplanation: For addresses, which are not found in this way, an invitation will be sent via email. MultiUserFieldInvitationExplanation: For addresses, which are not found in this way, an invitation will be sent via email.
MultiUserFieldInvitationExplanationAlways: An invitation will be sent via email to all addresses you enter here. MultiUserFieldInvitationExplanationAlways: An invitation will be sent via email to all addresses you enter here.
AmbiguousEmail: Email address is ambiguous AmbiguousEmail: Email address is ambiguous
InvalidEmailAddress: Email address is invalid
InvalidEmailAddressWith e: Email asdress #{show e} is invalid
UtilExamResultGrade: Grade UtilExamResultGrade: Grade
UtilExamResultPass: Passed/Failed UtilExamResultPass: Passed/Failed
UtilExamResultNoShow: Not present UtilExamResultNoShow: Not present

7
models/courses.model
View File

@ -90,3 +90,10 @@ CourseUserExamOfficeOptOut
school SchoolId school SchoolId
UniqueCourseUserExamOfficeOptOut course user school UniqueCourseUserExamOfficeOptOut course user school
deriving Generic deriving Generic
CourseQualification
course CourseId
qualification QualificationId
sortOrder Int default=0
UniqueCourseQualification course qualification
deriving Generic

2
models/lms.model
View File

@ -22,7 +22,7 @@ Qualification
-- across all schools, only one qualification may be a driving licence: -- across all schools, only one qualification may be a driving licence:
UniqueQualificationAvsLicence avsLicence !force UniqueQualificationAvsLicence avsLicence !force
-- NOTE: two NULL values are not equal for the purpose of Uniqueness constraints! -- NOTE: two NULL values are not equal for the purpose of Uniqueness constraints!
deriving Generic deriving Eq Generic
-- TODOs: -- TODOs:
-- - Enstehen Kosten, wenn Teilnehmer für KnowHow eingereiht werden, aber nicht am Kurs teilnehmen? -- - Enstehen Kosten, wenn Teilnehmer für KnowHow eingereiht werden, aber nicht am Kurs teilnehmen?

22
models/print.model
View File

@ -3,15 +3,17 @@
-- SPDX-License-Identifier: AGPL-3.0-or-later -- SPDX-License-Identifier: AGPL-3.0-or-later
PrintJob PrintJob
name Text name Text
filename FilePath apcIdent Text default='unknown'
file ByteString -- stores plain pdf; otherwise use FileContentReference Maybe filename FilePath
created UTCTime file ByteString -- stores plain pdf; otherwise use FileContentReference Maybe
acknowledged UTCTime Maybe created UTCTime
recipient UserId Maybe OnDeleteCascade OnUpdateCascade -- optional as some letters may contain just an address acknowledged UTCTime Maybe
sender UserId Maybe OnDeleteSetNull OnUpdateCascade -- senders and associations are optional recipient UserId Maybe OnDeleteCascade OnUpdateCascade -- optional as some letters may contain just an address
course CourseId Maybe OnDeleteCascade OnUpdateCascade sender UserId Maybe OnDeleteSetNull OnUpdateCascade -- senders and associations are optional
qualification QualificationId Maybe OnDeleteCascade OnUpdateCascade course CourseId Maybe OnDeleteCascade OnUpdateCascade
lmsUser LmsIdent Maybe OnDeleteCascade OnUpdateCascade -- allows tracking if recipient has been notified; must be unique qualification QualificationId Maybe OnDeleteCascade OnUpdateCascade
lmsUser LmsIdent Maybe OnDeleteCascade OnUpdateCascade -- allows tracking if recipient has been notified; must be unique
-- UniquePrintJobLmsUser lmsUser -- Note that in fact multiple print jobs per LMS user are possible! -- UniquePrintJobLmsUser lmsUser -- Note that in fact multiple print jobs per LMS user are possible!
-- UniquePrintJobApcIdent apcIdent -- TODO: not yet enforced, since LmsIdent is currently used
deriving Generic deriving Generic

22
src/Audit/Types.hs
View File

@ -197,20 +197,24 @@ data Transaction
, transactionNote :: Maybe Text , transactionNote :: Maybe Text
, transactionReceived :: UTCTime -- when was the csv file received? , transactionReceived :: UTCTime -- when was the csv file received?
} }
| TransactionQualificationUserEdit -- Note that a renewal always entails unblocking as well!
| TransactionQualificationUserEdit { transactionUser :: UserId -- qualification holder that is updated
{ transactionQualificationUser :: QualificationUserId , transactionQualificationUser :: QualificationUserId -- könnte entfernt werden
, transactionQualification :: QualificationId , transactionQualification :: QualificationId
, transactionUser :: UserId -- qualification holder that is updated
, transactionQualificationValidUntil :: Day , transactionQualificationValidUntil :: Day
, transactionQualificationScheduleRenewal :: Maybe Bool -- Maybe, because some update may leave it unchanged (also avoids DB Migration) , transactionQualificationScheduleRenewal :: Maybe Bool -- Maybe, because some update may leave it unchanged (also avoids DB Migration)
} }
| TransactionQualificationUserDelete | TransactionQualificationUserDelete
{ transactionQualificationUser :: QualificationUserId { transactionUser :: UserId
, transactionQualification :: QualificationId , transactionQualificationUser :: QualificationUserId
, transactionUser :: UserId , transactionQualification :: QualificationId
}
| TransactionQualificationUserBlocking
{ transactionUser :: UserId -- qualification holder that is updated
-- , transactionQualificationUser :: QualificationUserId -- not neccessary due to UniqueQualificationUser
, transactionQualification :: QualificationId
, transactionQualificationBlock :: Maybe QualificationBlocked -- Nothing indicates unblocking
} }
deriving (Eq, Ord, Read, Show, Generic) deriving (Eq, Ord, Read, Show, Generic)
deriveJSON defaultOptions deriveJSON defaultOptions

22
src/Handler/Admin.hs
View File

@ -23,6 +23,7 @@ import qualified Database.Esqueleto.Utils as E
import Handler.Utils.DateTime import Handler.Utils.DateTime
import Handler.Utils.Avs import Handler.Utils.Avs
import Handler.Utils.Widgets import Handler.Utils.Widgets
import Handler.Utils.Users
import Handler.Admin.Test as Handler.Admin import Handler.Admin.Test as Handler.Admin
import Handler.Admin.ErrorMessage as Handler.Admin import Handler.Admin.ErrorMessage as Handler.Admin
@ -83,7 +84,7 @@ getAdminProblemsR = do
getProblemUnreachableR :: Handler Html getProblemUnreachableR :: Handler Html
getProblemUnreachableR = do getProblemUnreachableR = do
unreachables <- runDB $ E.select retrieveUnreachableUsers unreachables <- runDB retrieveUnreachableUsers'
siteLayoutMsg MsgProblemsUnreachableHeading $ do siteLayoutMsg MsgProblemsUnreachableHeading $ do
setTitleI MsgProblemsUnreachableHeading setTitleI MsgProblemsUnreachableHeading
[whamlet| [whamlet|
@ -92,7 +93,7 @@ getProblemUnreachableR = do
<ul> <ul>
$forall usr <- unreachables $forall usr <- unreachables
<li> <li>
^{linkUserWidget ForProfileR usr} ^{linkUserWidget ForProfileR usr} (#{usr ^. _userDisplayEmail} / #{usr ^. _userEmail})
|] |]
getProblemFbutNoR :: Handler Html getProblemFbutNoR :: Handler Html
@ -147,9 +148,24 @@ retrieveUnreachableUsers = do
user <- E.from $ E.table @User user <- E.from $ E.table @User
E.where_ $ E.isNothing (user E.^. UserPostAddress) E.where_ $ E.isNothing (user E.^. UserPostAddress)
E.&&. E.isNothing (user E.^. UserCompanyDepartment) E.&&. E.isNothing (user E.^. UserCompanyDepartment)
E.&&. E.not_ ((user E.^. UserEmail) `E.like` E.val "%@%.%") E.&&. E.not_ ((user E.^. UserDisplayEmail) `E.like` E.val "%@%.%")
E.&&. E.not_ ((user E.^. UserEmail) `E.like` E.val "%@%.%")
return user 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
allDriversHaveAvsId :: Day -> DB Bool allDriversHaveAvsId :: Day -> DB Bool
-- allDriversHaveAvsId = fmap isNothing . E.selectOne . retrieveDriversWithoutAvsId -- allDriversHaveAvsId = fmap isNothing . E.selectOne . retrieveDriversWithoutAvsId
allDriversHaveAvsId = E.selectNotExists . retrieveDriversWithoutAvsId allDriversHaveAvsId = E.selectNotExists . retrieveDriversWithoutAvsId

57
src/Handler/Admin/Avs.hs
View File

@ -309,11 +309,15 @@ nullaryPathPiece ''LicenceTableAction $ camelToPathPiece' 2
embedRenderMessage ''UniWorX ''LicenceTableAction id embedRenderMessage ''UniWorX ''LicenceTableAction id
data LicenceTableActionData = LicenceTableChangeAvsData data LicenceTableActionData = LicenceTableChangeAvsData
| LicenceTableRevokeFDriveData --TODO: add { licenceTableChangeFDriveQId :: QualificationId to avoid lookup later | LicenceTableRevokeFDriveData
| LicenceTableGrantFDriveData { licenceTableChangeFDriveQId :: QualificationId { licenceTableChangeFDriveQId :: QualificationId
, licenceTableChangeFDriveEnd :: Day , licenceTableChangeFDriveReason :: Text
, licenceTableChangeFDriveRenew :: Maybe Bool }
} | LicenceTableGrantFDriveData
{ licenceTableChangeFDriveQId :: QualificationId
, licenceTableChangeFDriveEnd :: Day
, licenceTableChangeFDriveRenew :: Maybe Bool
}
deriving (Eq, Ord, Read, Show, Generic) deriving (Eq, Ord, Read, Show, Generic)
@ -321,7 +325,7 @@ postProblemAvsSynchR, getProblemAvsSynchR :: Handler Html
postProblemAvsSynchR = getProblemAvsSynchR postProblemAvsSynchR = getProblemAvsSynchR
getProblemAvsSynchR = do getProblemAvsSynchR = do
let catchAllAvs' r = flip catch (\err -> addMessageModal Error (i18n MsgAvsCommunicationError) (Right (text2widget $ tshow (err :: SomeException))) >> redirect r) 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 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{..} <- catchAllAvs' AdminR retrieveDifferingLicences
-- --
@ -336,8 +340,8 @@ getProblemAvsSynchR = do
numUnknownLicenceOwners = length unknownLicenceOwners numUnknownLicenceOwners = length unknownLicenceOwners
(btnImportUnknownWgt, btnImportUnknownRes) <- runButtonFormHash unknownLicenceOwners FIDBtnAvsImportUnknown (btnImportUnknownWgt, btnImportUnknownRes) <- runButtonFormHash unknownLicenceOwners FIDBtnAvsImportUnknown
ifMaybeM btnImportUnknownRes () $ \BtnAvsImportUnknown -> catchAllAvs $ do ifMaybeM btnImportUnknownRes () $ \BtnAvsImportUnknown -> do
res <- forM (take 500 unknownLicenceOwners) $ try . upsertAvsUserById -- TODO: turn this into a background job res <- catchAllAvs $ forM (take 500 unknownLicenceOwners) $ try . upsertAvsUserById -- TODO: turn this into a background job
let procRes (Right _) = (Sum 1, mempty :: Set.Set AvsPersonId, mempty :: Set.Set AvsPersonId, mempty) let procRes (Right _) = (Sum 1, mempty :: Set.Set AvsPersonId, mempty :: Set.Set AvsPersonId, mempty)
--TODO: continue here! --TODO: continue here!
--procRes (Left (AvsUserAmbiguous api)) = (Sum 0, Set.singleton api, mempty, mempty) --procRes (Left (AvsUserAmbiguous api)) = (Sum 0, Set.singleton api, mempty, mempty)
@ -367,10 +371,10 @@ getProblemAvsSynchR = do
^{revokeUnknownExecWgt} ^{revokeUnknownExecWgt}
|] |]
ifMaybeM btnRevokeUnknownRes () $ \BtnAvsRevokeUnknown -> catchAllAvs $ do ifMaybeM btnRevokeUnknownRes () $ \BtnAvsRevokeUnknown -> do
let revokes = Set.map (AvsPersonLicence AvsNoLicence) $ Set.fromList unknownLicenceOwners let revokes = Set.map (AvsPersonLicence AvsNoLicence) $ Set.fromList unknownLicenceOwners
no_revokes = Set.size revokes no_revokes = Set.size revokes
oks <- setLicencesAvs revokes oks <- catchAllAvs $ setLicencesAvs revokes
if oks < no_revokes if oks < no_revokes
then addMessageI Error MsgRevokeUnknownLicencesFail then addMessageI Error MsgRevokeUnknownLicencesFail
else addMessageI Info MsgRevokeUnknownLicencesOk else addMessageI Info MsgRevokeUnknownLicencesOk
@ -386,26 +390,33 @@ getProblemAvsSynchR = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
let nowaday = utctDay now let nowaday = utctDay now
procRes :: AvsLicence -> (LicenceTableActionData, Set AvsPersonId) -> Handler () procRes :: AvsLicence -> (LicenceTableActionData, Set AvsPersonId) -> Handler ()
procRes aLic (LicenceTableChangeAvsData , apids) = catchAllAvs $ do procRes aLic (LicenceTableChangeAvsData , apids) = do
oks <- setLicencesAvs $ Set.map (AvsPersonLicence aLic) apids oks <- catchAllAvs $ setLicencesAvs $ Set.map (AvsPersonLicence aLic) apids
let no_req = Set.size apids let no_req = Set.size apids
mkind = if oks < no_req then Warning else Success mkind = if oks < no_req then Warning else Success
addMessageI mkind $ MsgAvsSetLicences aLic oks no_req addMessageI mkind $ MsgAvsSetLicences aLic oks no_req
redirect ProblemAvsSynchR -- reload to update all tables redirect ProblemAvsSynchR -- reload to update all tables
procRes alic (LicenceTableRevokeFDriveData, apids) = do procRes alic (LicenceTableRevokeFDriveData{..}, apids) = do
nups <- runDB $ do oks <- runDB $ do
qId <- getKeyBy404 $ UniqueQualificationAvsLicence $ Just alic qId <- getKeyBy404 $ UniqueQualificationAvsLicence $ Just alic
selectedUsers <- view _userAvsUser <<$>> selectList [UserAvsPersonId <-. Set.toList apids] [] if qId /= licenceTableChangeFDriveQId
forM_ selectedUsers $ upsertQualificationUser qId nowaday (pred nowaday) Nothing then return (-1)
return $ length selectedUsers else do
addMessageI Success $ MsgRevokeFraDriveLicences alic nups uids <- view _userAvsUser <<$>> selectList [UserAvsPersonId <-. Set.toList apids] []
qualificationUserBlocking licenceTableChangeFDriveQId uids $
Just $ QualificationBlocked
{ qualificationBlockedDay = nowaday
, qualificationBlockedReason = licenceTableChangeFDriveReason
}
if | oks < 0 -> addMessageI Error $ MsgRevokeFraDriveLicencesError alic
| oks == length apids -> addMessageI Success $ MsgRevokeFraDriveLicences alic oks
| otherwise -> addMessageI Warning $ MsgRevokeFraDriveLicences alic oks
redirect ProblemAvsSynchR -- must be outside runDB redirect ProblemAvsSynchR -- must be outside runDB
procRes _alic (LicenceTableGrantFDriveData{..}, apids ) = do procRes _alic (LicenceTableGrantFDriveData{..}, apids ) = do
(n, Qualification{qualificationShorthand}) <- runDB $ do (n, Qualification{qualificationShorthand}) <- runDB $ do
uas <- selectList [UserAvsPersonId <-. Set.toList apids] [] uids <- view _userAvsUser <<$>> selectList [UserAvsPersonId <-. Set.toList apids] []
let uids = view _userAvsUser <$> uas
-- addMessage Info $ text2Html $ "UIDs: " <> tshow uids -- DEBUG -- addMessage Info $ text2Html $ "UIDs: " <> tshow uids -- DEBUG
forM_ uids $ upsertQualificationUser licenceTableChangeFDriveQId nowaday licenceTableChangeFDriveEnd licenceTableChangeFDriveRenew forM_ uids $ upsertQualificationUser licenceTableChangeFDriveQId nowaday licenceTableChangeFDriveEnd licenceTableChangeFDriveRenew
(length uids,) <$> get404 licenceTableChangeFDriveQId (length uids,) <$> get404 licenceTableChangeFDriveQId
@ -547,7 +558,9 @@ mkLicenceTable dbtIdent aLic apids = do
acts = mconcat acts = mconcat
[ singletonMap LicenceTableChangeAvs $ pure LicenceTableChangeAvsData [ singletonMap LicenceTableChangeAvs $ pure LicenceTableChangeAvsData
, if aLic == AvsNoLicence , if aLic == AvsNoLicence
then singletonMap LicenceTableRevokeFDrive $ pure LicenceTableRevokeFDriveData then singletonMap LicenceTableRevokeFDrive $ LicenceTableRevokeFDriveData
<$> apreq (selectField . fmap mkOptionList $ mapM qualOpt avsQualifications) (fslI MsgQualificationName) aLicQid
<*> apreq textField (fslI MsgQualificationBlockReason) Nothing
else singletonMap LicenceTableGrantFDrive $ LicenceTableGrantFDriveData else singletonMap LicenceTableGrantFDrive $ LicenceTableGrantFDriveData
<$> apreq (selectField . fmap mkOptionList $ mapM qualOpt avsQualifications) (fslI MsgQualificationName) aLicQid <$> apreq (selectField . fmap mkOptionList $ mapM qualOpt avsQualifications) (fslI MsgQualificationName) aLicQid
<*> apreq dayField (fslI MsgLmsQualificationValidUntil) Nothing -- apreq?! <*> apreq dayField (fslI MsgLmsQualificationValidUntil) Nothing -- apreq?!
@ -570,7 +583,7 @@ mkLicenceTable dbtIdent aLic apids = do
dbtCsvDecode = Nothing dbtCsvDecode = Nothing
dbtExtraReps = [] dbtExtraReps = []
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
validator = def -- & defaultSorting [SortDescBy "column-label"] validator = def & defaultSorting [SortAscBy "user-name"]
postprocess :: FormResult (First LicenceTableActionData, DBFormResult AvsPersonId Bool LicenceTableData) -- == DBFormResult (Map AvsPersonId (LicenceTableData, Bool -> Bool)) postprocess :: FormResult (First LicenceTableActionData, DBFormResult AvsPersonId Bool LicenceTableData) -- == DBFormResult (Map AvsPersonId (LicenceTableData, Bool -> Bool))
-> FormResult ( LicenceTableActionData, Set AvsPersonId) -> FormResult ( LicenceTableActionData, Set AvsPersonId)
postprocess inp = do postprocess inp = do

67
src/Handler/Admin/Test.hs
View File

@ -22,10 +22,6 @@ import qualified Data.ByteString.Lazy as LBS
import qualified Data.Set as Set import qualified Data.Set as Set
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Text.Pandoc as P
import qualified Text.Pandoc.PDF as P
import qualified Text.Pandoc.Builder as P
-- just to test i18nHamlet -- just to test i18nHamlet
import Text.Hamlet import Text.Hamlet
-- import Handler.Utils.I18n -- import Handler.Utils.I18n
@ -302,36 +298,33 @@ postAdminTestR = do
getAdminTestPdfR :: Handler TypedContent getAdminTestPdfR :: Handler TypedContent
getAdminTestPdfR = do getAdminTestPdfR = do
-- uUser <- maybeAuth -- to determine language for test usr <- requireAuth -- to determine language and recipient for test
templates <- liftIO $ do qual <- fromMaybeM
letter_tp <- P.compileTemplate "" templateRenewal (addMessage Error "Keine Qualifikation in der Datenbank zur Erzeugung eines Test-PDFs gefunden." >> redirect AdminTestR)
din5008 <- P.compileTemplate "" templateDIN5008 (runDB $ selectFirst [] [Asc QualificationAvsLicence, Asc QualificationShorthand])
now <- getCurrentTime encRecipient :: CryptoUUIDUser <- encrypt $ usr ^. _entityKey
return (now, letter_tp, din5008) now <- liftIO getCurrentTime
case templates of let nowaday = utctDay now
(_,Left err,_) -> sendResponseStatus internalServerError500 $ "Markdown template error: \n" <> err letter = LetterRenewQualificationF
(_,_,Left err) -> sendResponseStatus internalServerError500 $ "LaTeX template error: \n" <> err { lmsLogin = LmsIdent "abcdefgh"
(now, Right templ, Right latex) -> do , lmsPin = "12345678"
content <- liftIO . P.runIO $ do , qualHolderID = usr ^. _entityKey
let texopts = [] , qualHolderDN = usr ^. _userDisplayName
readeropts = def { P.readerExtensions = P.pandocExtensions } , qualHolderSN = usr ^. _userSurname
writeropts1 = def { P.writerTemplate = Just templ } , qualExpiry = succ nowaday
writeropts2 = def { P.writerTemplate = Just latex } , qualId = qual ^. _entityKey
-- https://github.com/jgm/pandoc/issues/1950 , qualName = qual ^. _qualificationName . _CI
-- using markdown as a template for itself for interpolation: , qualShort = qual ^. _qualificationShorthand . _CI
doc1 <- P.readMarkdown readeropts templateRenewal , qualSchool = qual ^. _qualificationSchool
doc2 <- P.writeMarkdown writeropts1 doc1 , qualDuration = qual ^. _qualificationValidDuration
doc3 <- P.readMarkdown readeropts doc2 }
P.makePDF "lualatex" texopts P.writeLaTeX writeropts2 $ apcIdent <- letterApcIdent letter encRecipient now
P.setDate (P.text . tshow $ utctDay now) doc3 renderLetter usr letter apcIdent >>= \case
case content of Left err -> sendResponseStatus internalServerError500 $ "PDF generation failed: \n" <> err
Right (Right bs) -> do Right pdf -> do
liftIO $ LBS.writeFile "/tmp/generated.pdf" bs liftIO $ LBS.writeFile "/tmp/generated.pdf" pdf
mbEncPdf <- encryptPDF "tomatenmarmelade" bs encryptPDF "tomatenmarmelade" pdf >>= \case
case mbEncPdf of Left err -> sendResponseStatus internalServerError500 $ "PDFtk error: \n" <> err
Left err -> sendResponseStatus internalServerError500 $ "PDFtk error: \n" <> err Right encPdf -> do
Right encPdf -> do liftIO $ LBS.writeFile "/tmp/crypted.pdf" encPdf
liftIO $ LBS.writeFile "/tmp/crypted.pdf" encPdf sendByteStringAsFile "demoPDF.pdf" (LBS.toStrict pdf) now
sendByteStringAsFile "demoPDF.pdf" (LBS.toStrict bs) now
Right (Left err) -> sendResponseStatus internalServerError500 $ decodeUtf8 $ LBS.toStrict $ "LaTeX compile error: \n" <> err
Left err -> sendResponseStatus internalServerError500 $ "Pandoc error: \n" <> P.renderError err

6
src/Handler/Course/Show.hs
View File

@ -31,7 +31,7 @@ getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCShowR tid ssh csh = do getCShowR tid ssh csh = do
mbAid <- maybeAuthId mbAid <- maybeAuthId
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
(cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,administrators,correctors,tutors,news,events,submissionGroup,_mayReRegister,(mayViewSheets, mayViewAnySheet), (mayViewMaterials, mayViewAnyMaterial)) <- runDB . maybeT notFound $ do (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,administrators,correctors,tutors,news,events,submissionGroup,_mayReRegister,(mayViewSheets, mayViewAnySheet), (mayViewMaterials, mayViewAnyMaterial),courseQualifications) <- runDB . maybeT notFound $ do
[(E.Entity cid course, E.Value courseVisible, E.Value schoolName, E.Value participants, fmap entityVal -> registration)] [(E.Entity cid course, E.Value courseVisible, E.Value schoolName, E.Value participants, fmap entityVal -> registration)]
<- lift . E.select . E.from $ <- lift . E.select . E.from $
\((school `E.InnerJoin` course) `E.LeftOuterJoin` participant) -> do \((school `E.InnerJoin` course) `E.LeftOuterJoin` participant) -> do
@ -128,7 +128,9 @@ getCShowR tid ssh csh = do
return $ material E.^. MaterialName return $ material E.^. MaterialName
mayViewAnyMaterial <- lift . anyM materials $ \(E.Value mnm) -> hasReadAccessTo $ CMaterialR tid ssh csh mnm MShowR mayViewAnyMaterial <- lift . anyM materials $ \(E.Value mnm) -> hasReadAccessTo $ CMaterialR tid ssh csh mnm MShowR
return (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,administrators,correctors,tutors,news,events,submissionGroup,mayReRegister, (mayViewSheets, mayViewAnySheet), (mayViewMaterials, mayViewAnyMaterial)) courseQualifications <- lift $ getCourseQualifications cid
return (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,administrators,correctors,tutors,news,events,submissionGroup,mayReRegister, (mayViewSheets, mayViewAnySheet), (mayViewMaterials, mayViewAnyMaterial), courseQualifications)
mDereg <- traverse (formatTime SelFormatDateTime) $ courseDeregisterUntil course mDereg <- traverse (formatTime SelFormatDateTime) $ courseDeregisterUntil course

24
src/Handler/LMS.hs
View File

@ -395,7 +395,12 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
, single ("lms-received" , SortColumnNullsInv $ queryLmsUser >>> (E.?. LmsUserReceived)) , single ("lms-received" , SortColumnNullsInv $ queryLmsUser >>> (E.?. LmsUserReceived))
, single ("lms-notified" , SortColumnNullsInv $ queryLmsUser >>> (E.?. LmsUserNotified)) -- cannot include printJob acknowledge date , single ("lms-notified" , SortColumnNullsInv $ queryLmsUser >>> (E.?. LmsUserNotified)) -- cannot include printJob acknowledge date
, single ("lms-ended" , SortColumnNullsInv $ queryLmsUser >>> (E.?. LmsUserEnded)) , single ("lms-ended" , SortColumnNullsInv $ queryLmsUser >>> (E.?. LmsUserEnded))
, single ( "user-company" , SortColumn $ \row -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId
E.orderBy [E.asc (comp E.^. CompanyName)]
return (comp E.^. CompanyName)
)
] ]
dbtFilter = mconcat dbtFilter = mconcat
[ single $ fltrUserNameEmail queryUser [ single $ fltrUserNameEmail queryUser
@ -514,6 +519,16 @@ postLmsR sid qsh = do
[ if not isAdmin then mempty else dbSelectIf (applying _2) id (return . view (resultUser . _entityKey)) (\r -> isJust $ r ^? resultLmsUser) -- TODO: refactor using function "is" [ if not isAdmin then mempty else dbSelectIf (applying _2) id (return . view (resultUser . _entityKey)) (\r -> isJust $ r ^? resultLmsUser) -- TODO: refactor using function "is"
, colUserNameModalHdr MsgLmsUser AdminUserR , colUserNameModalHdr MsgLmsUser AdminUserR
, colUserEmail , colUserEmail
, 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
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid
E.orderBy [E.asc (comp E.^. CompanyName)]
return (comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor)
let companies = intersperse (text2markup ", ") $
(\(E.Value cmpName, E.Value cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> companies'
icnSuper = text2markup " " <> icon IconSupervisor
pure $ toWgt $ mconcat companies
, sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \( view $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> dayCell d , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \( view $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> dayCell d
, sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d
, sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d , sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d
@ -608,8 +623,10 @@ postLmsR sid qsh = do
-- intended to be viewed primarily in a modal, vie lmsStatusPlusCell' -- intended to be viewed primarily in a modal, vie lmsStatusPlusCell'
getLmsUserR :: CryptoUUIDUser -> Handler Html getLmsUserR :: CryptoUUIDUser -> Handler Html
getLmsUserR uuid = do getLmsUserR uuid = do
uid <- decrypt uuid uid <- decrypt uuid
now <- liftIO getCurrentTime
let nowaday = utctDay now
(user@User{userDisplayName}, quals) <- runDB $ do (user@User{userDisplayName}, quals) <- runDB $ do
usr <- get404 uid usr <- get404 uid
qs <- Ex.select $ do qs <- Ex.select $ do
@ -625,7 +642,8 @@ getLmsUserR uuid = do
) )
Ex.where_ $ E.isJust (qualUsr E.?. QualificationUserUser) Ex.where_ $ E.isJust (qualUsr E.?. QualificationUserUser)
E.||. E.isJust ( lmsUsr E.?. LmsUserUser) E.||. E.isJust ( lmsUsr E.?. LmsUserUser)
pure (qual, qualUsr, lmsUsr) Ex.orderBy [Ex.asc $ qual E.^. QualificationShorthand]
pure (qual, qualUsr, lmsUsr, validQualification' nowaday qualUsr)
return (usr,qs) return (usr,qs)
let heading = [whamlet|_{MsgMenuLmsUser} ^{userWidget user}|] let heading = [whamlet|_{MsgMenuLmsUser} ^{userWidget user}|]

24
src/Handler/LMS/Users.hs
View File

@ -34,13 +34,13 @@ data LmsUserTableCsv = LmsUserTableCsv -- for csv export only
makeLenses_ ''LmsUserTableCsv makeLenses_ ''LmsUserTableCsv
-- | Mundane conversion needed for direct download without dbTable onlu -- | Mundane conversion needed for direct download without dbTable onlu
lmsUser2csv :: LmsUser -> LmsUserTableCsv lmsUser2csv :: Day -> LmsUser -> LmsUserTableCsv
lmsUser2csv lu@LmsUser{..} = LmsUserTableCsv lmsUser2csv cutoff lu@LmsUser{..} = LmsUserTableCsv
{ csvLUTident = lmsUserIdent { csvLUTident = lmsUserIdent
, csvLUTpin = lmsUserPin , csvLUTpin = lmsUserPin
, csvLUTresetPin = lmsUserResetPin & LmsBool , csvLUTresetPin = lmsUserResetPin & LmsBool
, csvLUTdelete = lmsUserToDelete lu & LmsBool , csvLUTdelete = lmsUserToDelete cutoff lu & LmsBool
, csvLUTstaff = False & LmsBool , csvLUTstaff = False & LmsBool
} }
-- csv without headers -- csv without headers
@ -84,7 +84,8 @@ instance CsvColumnsExplained LmsUserTableCsv where
mkUserTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget) mkUserTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget)
mkUserTable _sid qsh qid = do mkUserTable _sid qsh qid = do
dbtCsvName <- csvFilenameLmsUser qsh cutoff <- liftHandler lmsDeletionDate
dbtCsvName <- csvFilenameLmsUser qsh
let dbtCsvSheetName = dbtCsvName let dbtCsvSheetName = dbtCsvName
let let
userDBTable = DBTable{..} userDBTable = DBTable{..}
@ -100,14 +101,14 @@ mkUserTable _sid qsh qid = do
, sortable (Just csvLmsPin) (i18nCell MsgTableLmsPin & cellAttrs <>~ [("uw-hide-column-default-hidden",mempty)] , sortable (Just csvLmsPin) (i18nCell MsgTableLmsPin & cellAttrs <>~ [("uw-hide-column-default-hidden",mempty)]
) $ \(view $ _dbrOutput . _entityVal . _lmsUserPin -> pin ) -> textCell pin ) $ \(view $ _dbrOutput . _entityVal . _lmsUserPin -> pin ) -> textCell pin
, sortable (Just csvLmsResetPin) (i18nCell MsgTableLmsResetPin) $ \(view $ _dbrOutput . _entityVal . _lmsUserResetPin -> reset) -> ifIconCell reset IconReset , sortable (Just csvLmsResetPin) (i18nCell MsgTableLmsResetPin) $ \(view $ _dbrOutput . _entityVal . _lmsUserResetPin -> reset) -> ifIconCell reset IconReset
, sortable (Just csvLmsDelete) (i18nCell MsgTableLmsDelete) $ \(view $ _dbrOutput . _entityVal . _lmsUserToDelete -> del ) -> ifIconCell del IconRemoveUser , sortable (Just csvLmsDelete) (i18nCell MsgTableLmsDelete) $ \(view $ _dbrOutput . _entityVal . _lmsUserToDelete cutoff -> del ) -> ifIconCell del IconRemoveUser
, sortable Nothing (i18nCell MsgTableLmsStaff) $ const mempty , sortable Nothing (i18nCell MsgTableLmsStaff) $ const mempty
] ]
dbtSorting = Map.fromList dbtSorting = Map.fromList
[ (csvLmsIdent , SortColumn (E.^. LmsUserIdent)) [ (csvLmsIdent , SortColumn (E.^. LmsUserIdent))
, (csvLmsPin , SortColumn (E.^. LmsUserPin)) , (csvLmsPin , SortColumn (E.^. LmsUserPin))
, (csvLmsResetPin , SortColumn (E.^. LmsUserResetPin)) , (csvLmsResetPin , SortColumn (E.^. LmsUserResetPin))
, (csvLmsDelete , SortColumn lmsUserToDeleteExpr) , (csvLmsDelete , SortColumn (lmsUserToDeleteExpr cutoff))
] ]
dbtFilter = Map.fromList dbtFilter = Map.fromList
[ (csvLmsIdent , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsUserIdent )) [ (csvLmsIdent , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsUserIdent ))
@ -132,7 +133,7 @@ mkUserTable _sid qsh qid = do
<$> view (_dbrOutput . _entityVal . _lmsUserIdent) <$> view (_dbrOutput . _entityVal . _lmsUserIdent)
<*> view (_dbrOutput . _entityVal . _lmsUserPin) <*> view (_dbrOutput . _entityVal . _lmsUserPin)
<*> view (_dbrOutput . _entityVal . _lmsUserResetPin . _lmsBool) <*> view (_dbrOutput . _entityVal . _lmsUserResetPin . _lmsBool)
<*> view (_dbrOutput . _entityVal . _lmsUserToDelete . _lmsBool) <*> view (_dbrOutput . _entityVal . _lmsUserToDelete cutoff . _lmsBool)
<*> const (LmsBool False) <*> const (LmsBool False)
dbtCsvDecode = Nothing dbtCsvDecode = Nothing
@ -154,6 +155,7 @@ getLmsUsersR sid qsh = do
getLmsUsersDirectR :: SchoolId -> QualificationShorthand -> Handler TypedContent getLmsUsersDirectR :: SchoolId -> QualificationShorthand -> Handler TypedContent
getLmsUsersDirectR sid qsh = do getLmsUsersDirectR sid qsh = do
$logInfoS "LMS" $ "Direct Download Users for " <> tshow qsh <> " at " <> tshow sid $logInfoS "LMS" $ "Direct Download Users for " <> tshow qsh <> " at " <> tshow sid
cutoff <- lmsDeletionDate
lms_users <- runDB $ do lms_users <- runDB $ do
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
selectList [LmsUserQualification ==. qid, LmsUserEnded ==. Nothing] [Asc LmsUserStarted, Asc LmsUserIdent] selectList [LmsUserQualification ==. qid, LmsUserEnded ==. Nothing] [Asc LmsUserStarted, Asc LmsUserIdent]
@ -170,11 +172,11 @@ getLmsUsersDirectR sid qsh = do
, csvLUTstaff = LmsBool False , csvLUTstaff = LmsBool False
} }
-} -}
LmsConf{..} <- getsYesod $ view _appLmsConf LmsConf{..} <- getsYesod $ view _appLmsConf
let --csvRenderedData = toNamedRecord . lmsUser2csv . entityVal <$> lms_users let --csvRenderedData = toNamedRecord . lmsUser2csv . entityVal <$> lms_users
--csvRenderedHeader = lmsUserTableCsvHeader --csvRenderedHeader = lmsUserTableCsvHeader
--cvsRendered = CsvRendered {..} --cvsRendered = CsvRendered {..}
csvRendered = toCsvRendered lmsUserTableCsvHeader $ lmsUser2csv . entityVal <$> lms_users csvRendered = toCsvRendered lmsUserTableCsvHeader $ lmsUser2csv cutoff . entityVal <$> lms_users
fmtOpts = def { csvIncludeHeader = lmsDownloadHeader fmtOpts = def { csvIncludeHeader = lmsDownloadHeader
, csvDelimiter = lmsDownloadDelimiter , csvDelimiter = lmsDownloadDelimiter
, csvUseCrLf = lmsDownloadCrLf , csvUseCrLf = lmsDownloadCrLf

245
src/Handler/PrintCenter.hs
View File

@ -18,110 +18,74 @@ import Import
import qualified Data.Set as Set import qualified Data.Set as Set
import qualified Data.Map as Map import qualified Data.Map as Map
-- import qualified Data.Text as T
-- import qualified Data.Text.Lazy as LT
-- import qualified Data.ByteString.Lazy as LBS
import qualified Text.Pandoc as P
import qualified Text.Pandoc.Builder as P
import Database.Persist.Sql (updateWhereCount) import Database.Persist.Sql (updateWhereCount)
import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma
import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Legacy as E
import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Utils as E
import Database.Esqueleto.Utils.TH import Database.Esqueleto.Utils.TH
import qualified Control.Monad.State.Class as State
import Utils.Print import Utils.Print
-- import Data.Aeson (encode) -- import Data.Aeson (encode)
-- import qualified Data.Text as Text -- import qualified Data.Text as Text
-- import qualified Data.Set as Set -- import qualified Data.Set as Set
import Handler.Utils import Handler.Utils
import Handler.Utils.Csv -- import Handler.Utils.Csv
import qualified Data.Csv as Csv -- import qualified Data.Csv as Csv
-- avoids repetition of local definitions -- avoids repetition of local definitions
single :: (k,a) -> Map k a single :: (k,a) -> Map k a
single = uncurry Map.singleton single = uncurry Map.singleton
data MetaPinRenewal = MetaPinRenewal data LRQF = LRQF
{ mppExaminee :: Text { lrqfUser :: Either UserEmail UserId
, mppAddress :: StoredMarkup , lrqfSuper :: Maybe (Either UserEmail UserId)
, mppLogin :: Text , lrqfQuali :: Entity Qualification
, mppPin :: Text , lrqfIdent :: LmsIdent
, mppURL :: Maybe URI , lrqfPin :: Text
, mppDate :: Day , lrqfExpiry:: Day
, mppLang :: Lang } deriving (Eq, Generic)
, mppOpening :: Maybe Text
, mppClosing :: Maybe Text
, mppSupervisor:: Maybe Text
}
deriving (Eq, Ord, Show, Generic)
-- TODO: just for testing, remove in production makeRenewalForm :: Maybe LRQF -> Form LRQF
instance Default MetaPinRenewal where makeRenewalForm tmpl = identifyForm FIDLmsLetter . validateForm validateLetterRenewQualificationF $ \html -> do
def = MetaPinRenewal -- now_day <- utctDay <$> liftIO getCurrentTime
{ mppExaminee = "Papa Schlumpf" flip (renderAForm FormStandard) html $ LRQF
, mppAddress = plaintextToStoredMarkup ("Erdbeerweg 42\n98726 Schlumpfhausen"::Text) <$> areq (userField False Nothing) (fslI MsgLmsUser) (lrqfUser <$> tmpl)
, mppLogin = "keiner123" <*> aopt (userField False Nothing) (fslI MsgTableSupervisor) (lrqfSuper <$> tmpl)
, mppPin = "89998a" <*> areq qualificationFieldEnt (fslI MsgQualificationName) (lrqfQuali <$> tmpl)
, mppURL = Nothing <*> areq lmsField (fslI MsgTableLmsIdent) (lrqfIdent <$> tmpl)
, mppDate = fromGregorian 2022 07 27 <*> areq textField (fslI MsgTableLmsPin) (lrqfPin <$> tmpl)
, mppLang = "de-de" <*> areq dayField (fslI MsgLmsQualificationValidUntil) (lrqfExpiry <$> tmpl)
, mppOpening = Just "Lieber Schlumpfi," where
, mppClosing = Nothing lmsField = convertField LmsIdent getLmsIdent textField
, mppSupervisor= Nothing
validateLetterRenewQualificationF :: FormValidator LRQF Handler ()
validateLetterRenewQualificationF = -- do
-- LRQF{..} <- State.get
return ()
lrqf2letter :: LRQF -> DB (Entity User, LetterRenewQualificationF)
lrqf2letter LRQF{..} = do
usr <- getUser lrqfUser
rcvr <- mapM getUser lrqfSuper
let letter = LetterRenewQualificationF
{ lmsLogin = lrqfIdent
, lmsPin = lrqfPin
, qualHolderID = usr ^. _entityKey
, qualHolderDN = usr ^. _userDisplayName
, qualHolderSN = usr ^. _userSurname
, qualExpiry = lrqfExpiry
, qualId = lrqfQuali ^. _entityKey
, qualName = lrqfQuali ^. _qualificationName . _CI
, qualShort = lrqfQuali ^. _qualificationShorthand . _CI
, qualSchool = lrqfQuali ^. _qualificationSchool
, qualDuration = lrqfQuali ^. _qualificationValidDuration
} }
return (fromMaybe usr rcvr, letter)
makeRenewalForm :: Maybe MetaPinRenewal -> Form MetaPinRenewal where
makeRenewalForm tmpl = identifyForm FIDLmsLetter . validateForm validateMetaPinRenewal $ \html -> do getUser :: Either UserEmail UserId -> DB (Entity User)
now_day <- utctDay <$> liftIO getCurrentTime getUser (Right uid) = getEntity404 uid
flip (renderAForm FormStandard) html $ MetaPinRenewal getUser (Left mail) = getBy404 $ UniqueEmail mail
<$> areq textField (fslI MsgMppRecipient) (mppExaminee <$> tmpl)
<*> areq htmlField (fslI MsgMppAddress) (mppAddress <$> tmpl)
<*> areq textField (fslI MsgMppLogin) (mppLogin <$> tmpl)
<*> areq textField (fslI MsgMppPin) (mppPin <$> tmpl)
<*> aopt urlField (fslI MsgMppURL) (mppURL <$> tmpl)
<*> areq dayField (fslI MsgMppDate) ((mppDate <$> tmpl) <|> Just now_day)
<*> areq (langField True) (fslI MsgMppLang) ((mppLang <$> tmpl) <|> Just "de-de")
<*> aopt textField (fslI MsgMppOpening) (mppOpening <$> tmpl)
<*> aopt textField (fslI MsgMppClosing) (mppClosing <$> tmpl)
<*> aopt textField (fslI MsgMppSupervisor) (mppSupervisor<$> tmpl)
validateMetaPinRenewal :: FormValidator MetaPinRenewal Handler ()
validateMetaPinRenewal = do
MetaPinRenewal{..} <- State.get
guardValidation MsgMppBadLanguage $ isDe mppLang || isEn mppLang
mprToMeta :: MetaPinRenewal -> P.Meta
mprToMeta MetaPinRenewal{..} = mkMeta
-- formatTimeUser SelFormatDate mppDate mppExaminee
[ toMeta "examinee" mppExaminee
, toMeta "address" (mppExaminee : (mppAddress & html2textlines))
, toMeta "login" mppLogin
, toMeta "pin" mppPin
, mbMeta "url" (mppURL <&> tshow)
, toMeta "date" (mppDate & tshow) -- rendering according to user preference requires Handler Monad; deferred to Post-processing of P.Meta
, toMeta "lang" mppLang
, mbMeta keyOpening mppOpening
, mbMeta keyClosing mppClosing
, mbMeta "supervisor" mppSupervisor
]
where
deOrEn = if isDe mppLang then "de" else "en"
keyOpening = deOrEn <> "-opening"
keyClosing = deOrEn <> "-closing"
mprToMetaUser :: (MonadHandler m, HandlerSite m ~ UniWorX) => Entity User -> MetaPinRenewal -> m P.Meta
mprToMetaUser entUser@Entity{entityVal = u} mpr = do
let userLang = userLanguages u >>= (listToMaybe . view _Wrapped) -- auch möglich `op Languages` statt `view _Wrapped`
meta = mprToMeta mpr{ mppExaminee = userDisplayName u
-- , mppAddress = userDisplayName u : html2textlines userAddress --TODO once we have User addresses within the DB
, mppLang = fromMaybe (mppLang mpr) userLang -- check if this is the desired behaviour!
}
userDate <- formatTimeUser SelFormatDate (mppDate mpr) (Just entUser)
return $ P.setMeta "date" userDate meta
data PJTableAction = PJActAcknowledge data PJTableAction = PJActAcknowledge
@ -201,12 +165,13 @@ mkPJTable = do
dbtProj = dbtProjFilteredPostId dbtProj = dbtProjFilteredPostId
dbtColonnade = mconcat dbtColonnade = mconcat
[ dbSelectIf (applying _2) id (return . view (resultPrintJob . _entityKey)) (\r -> isNothing $ r ^. resultPrintJob . _entityVal . _printJobAcknowledged) [ dbSelectIf (applying _2) id (return . view (resultPrintJob . _entityKey)) (\r -> isNothing $ r ^. resultPrintJob . _entityVal . _printJobAcknowledged)
, sortable (Just "created") (i18nCell MsgPrintJobCreated) $ \( view $ resultPrintJob . _entityVal . _printJobCreated -> t) -> dateTimeCell t , sortable (Just "created") (i18nCell MsgPrintJobCreated) $ \( view $ resultPrintJob . _entityVal . _printJobCreated -> t) -> dateTimeCell t
, sortable (Just "acknowledged") (i18nCell MsgPrintJobAcknowledged) $ \( view $ resultPrintJob . _entityVal . _printJobAcknowledged -> t) -> maybeDateTimeCell t , sortable (Just "acknowledged") (i18nCell MsgPrintJobAcknowledged) $ \( view $ resultPrintJob . _entityVal . _printJobAcknowledged -> t) -> maybeDateTimeCell t
, sortable (Just "filename") (i18nCell MsgPrintPDF) $ \r -> let k = r ^. resultPrintJob . _entityKey , sortable (Just "filename") (i18nCell MsgPrintPDF) $ \r -> let k = r ^. resultPrintJob . _entityKey
t = r ^. resultPrintJob . _entityVal . _printJobFilename t = r ^. resultPrintJob . _entityVal . _printJobFilename
in anchorCellM (PrintDownloadR <$> encrypt k) (toWgt t) in anchorCellM (PrintDownloadR <$> encrypt k) (toWgt t)
, sortable (Just "name") (i18nCell MsgPrintJobName) $ \( view $ resultPrintJob . _entityVal . _printJobName -> n) -> textCell n , sortable (Just "apcid") (i18nCell MsgPrintJobApcAcknowledge)$ \( view $ resultPrintJob . _entityVal . _printJobApcIdent -> t) -> textCell t
, sortable (Just "name") (i18nCell MsgPrintJobName) $ \( view $ resultPrintJob . _entityVal . _printJobName -> n) -> textCell n
, sortable (Just "recipient") (i18nCell MsgPrintRecipient) $ \(preview resultRecipient -> u) -> maybeCell u $ cellHasUserLink AdminUserR , sortable (Just "recipient") (i18nCell MsgPrintRecipient) $ \(preview resultRecipient -> u) -> maybeCell u $ cellHasUserLink AdminUserR
, sortable (Just "sender") (i18nCell MsgPrintSender) $ \(preview resultSender -> u) -> maybeCell u $ cellHasUserLink AdminUserR , sortable (Just "sender") (i18nCell MsgPrintSender) $ \(preview resultSender -> u) -> maybeCell u $ cellHasUserLink AdminUserR
, sortable (Just "course") (i18nCell MsgPrintCourse) $ \(preview $ resultCourse . _entityVal -> c) -> maybeCell c courseCell , sortable (Just "course") (i18nCell MsgPrintCourse) $ \(preview $ resultCourse . _entityVal -> c) -> maybeCell c courseCell
@ -218,6 +183,7 @@ mkPJTable = do
, single ("filename" , SortColumn $ queryPrintJob >>> (E.^. PrintJobFilename)) , single ("filename" , SortColumn $ queryPrintJob >>> (E.^. PrintJobFilename))
, single ("created" , SortColumn $ queryPrintJob >>> (E.^. PrintJobCreated)) , single ("created" , SortColumn $ queryPrintJob >>> (E.^. PrintJobCreated))
, single ("acknowledged" , SortColumn $ queryPrintJob >>> (E.^. PrintJobAcknowledged)) , single ("acknowledged" , SortColumn $ queryPrintJob >>> (E.^. PrintJobAcknowledged))
, single ("apcid" , SortColumn $ queryPrintJob >>> (E.^. PrintJobApcIdent))
, single ("recipient" , sortUserNameBareM queryRecipient) , single ("recipient" , sortUserNameBareM queryRecipient)
, single ("sender" , sortUserNameBareM querySender ) , single ("sender" , sortUserNameBareM querySender )
, single ("course" , SortColumn $ queryCourse >>> (E.?. CourseName)) , single ("course" , SortColumn $ queryCourse >>> (E.?. CourseName))
@ -226,7 +192,8 @@ mkPJTable = do
] ]
dbtFilter = mconcat dbtFilter = mconcat
[ single ("name" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobName)) [ single ("name" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobName))
, single ("filename" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobFilename)) , single ("apcid" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobApcIdent))
, single ("filename" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobFilename))
, single ("created" , FilterColumn . E.mkDayFilter $ views (to queryPrintJob) (E.^. PrintJobCreated)) , single ("created" , FilterColumn . E.mkDayFilter $ views (to queryPrintJob) (E.^. PrintJobCreated))
--, single ("created" , FilterColumn . E.mkDayBetweenFilter $ views (to queryPrintJob) (E.^. PrintJobCreated)) --, single ("created" , FilterColumn . E.mkDayBetweenFilter $ views (to queryPrintJob) (E.^. PrintJobCreated))
, single ("recipient" , FilterColumn . E.mkContainsFilterWith Just $ views (to queryRecipient) (E.?. UserDisplayName)) , single ("recipient" , FilterColumn . E.mkContainsFilterWith Just $ views (to queryRecipient) (E.?. UserDisplayName))
@ -234,6 +201,7 @@ mkPJTable = do
, single ("course" , FilterColumn . E.mkContainsFilterWith Just $ views (to queryCourse) (E.?. CourseName)) , single ("course" , FilterColumn . E.mkContainsFilterWith Just $ views (to queryCourse) (E.?. CourseName))
, single ("qualification", FilterColumn . E.mkContainsFilterWith Just $ views (to queryQualification) (E.?. QualificationName)) , single ("qualification", FilterColumn . E.mkContainsFilterWith Just $ views (to queryQualification) (E.?. QualificationName))
, single ("lmsid" , FilterColumn . E.mkContainsFilterWith Just $ views (to queryPrintJob) (E.^. PrintJobLmsUser)) , single ("lmsid" , FilterColumn . E.mkContainsFilterWith Just $ views (to queryPrintJob) (E.^. PrintJobLmsUser))
, single ("acknowledged" , FilterColumn . E.mkExactFilterLast $ views (to queryPrintJob) (E.isJust . (E.^. PrintJobAcknowledged))) , single ("acknowledged" , FilterColumn . E.mkExactFilterLast $ views (to queryPrintJob) (E.isJust . (E.^. PrintJobAcknowledged)))
] ]
dbtFilterUI mPrev = mconcat dbtFilterUI mPrev = mconcat
@ -248,6 +216,7 @@ mkPJTable = do
, prismAForm (singletonFilter "course" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintCourse) , prismAForm (singletonFilter "course" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintCourse)
, prismAForm (singletonFilter "qualification". maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintQualification) , prismAForm (singletonFilter "qualification". maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintQualification)
, prismAForm (singletonFilter "lmsid" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintLmsUser) , prismAForm (singletonFilter "lmsid" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintLmsUser)
, prismAForm (singletonFilter "apcid" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintJobApcAcknowledge)
, prismAForm (singletonFilter "acknowledged" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgPrintJobAcknowledged) , prismAForm (singletonFilter "acknowledged" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgPrintJobAcknowledged)
] ]
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout} dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout}
@ -279,7 +248,7 @@ mkPJTable = do
(First (Just act), jobMap) <- inp (First (Just act), jobMap) <- inp
let jobSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) jobMap let jobSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) jobMap
return (act, jobSet) return (act, jobSet)
psValidator = def & defaultSorting [SortAscBy "created"] psValidator = def & defaultSorting [SortDescBy "created"]
-- & defaultFilter (singletonMap "acknowledged" [toPathPiece False]) -- TODO: sorting with Nothing restores this filter -- & defaultFilter (singletonMap "acknowledged" [toPathPiece False]) -- TODO: sorting with Nothing restores this filter
over _1 postprocess <$> dbTable psValidator DBTable{..} over _1 postprocess <$> dbTable psValidator DBTable{..}
@ -304,40 +273,34 @@ postPrintCenterR = do
getPrintSendR, postPrintSendR :: Handler Html getPrintSendR, postPrintSendR :: Handler Html
getPrintSendR = postPrintSendR getPrintSendR = postPrintSendR
postPrintSendR = do postPrintSendR = do
((sendResult, sendWidget), sendEnctype) <- runFormPost $ makeRenewalForm $ Just def usr <- requireAuth -- to determine language and recipient for test
let procFormSend mpr = do mbQual <- runDB $ selectFirst [] [Asc QualificationAvsLicence, Asc QualificationShorthand]
receivers <- runDB $ Ex.select $ do now <- liftIO getCurrentTime
user <- Ex.from $ Ex.table @User let nowaday = utctDay now
Ex.where_ $ E.val (mppExaminee mpr) `E.isInfixOf` (user E.^. UserIdent) uid = usr ^. _entityKey
pure user mkLetter qual = LRQF
letters <- case receivers of { lrqfUser = Right uid
[] -> pure . (Nothing ,) <$> pdfRenewal (mprToMeta mpr) , lrqfSuper = Nothing
_ -> forM receivers $ \usr -> do , lrqfQuali = qual
meta <- mprToMetaUser usr mpr , lrqfIdent = LmsIdent "stuvwxyz"
pdf <- pdfRenewal meta , lrqfPin = "76543210"
return (Just $ entityKey usr, pdf) , lrqfExpiry = succ nowaday
oks <- forM letters $ \case }
(mbRecipient, Right bs) -> do def_lrqf = mkLetter <$> mbQual
-- liftIO $ LBS.writeFile "/tmp/generated.pdf" bs -- DEBUGGING ONLY
-- addMessage Warning "PDF momentan nur gespeicher unter /tmp/generated.pdf" ((sendResult, sendWidget), sendEnctype) <- runFormPost $ makeRenewalForm def_lrqf
uID <- maybeAuthId let procFormSend lrqf = do
runDB (sendLetter' "Test-Brief" bs (mbRecipient, uID) Nothing Nothing Nothing) >>= \case -- calls lpr ok <- (runDB (lrqf2letter lrqf) >>= printLetter (Just uid)) >>= \case
Left err -> do Left err -> do
let msg = "PDF printing failed with error: " <> err let msg = "PDF printing failed with error: " <> err
$logErrorS "LPR" msg $logErrorS "LPR" msg
addMessage Error $ toHtml msg addMessage Error $ toHtml msg
pure False
Right (ok, fpath) -> do
let response = if null ok then mempty else " Response: " <> ok
addMessage Success $ toHtml $ "Druckauftrag angelegt: " <> pack fpath <> response
pure True
(Nothing, Left err) -> do
addMessage Error $ toHtml err
pure False pure False
(Just uid, Left err) -> do Right (ok, fpath) -> do
addMessage Error . toHtml $ "For uid " <> tshow uid <> ": " <> err let response = if null ok then mempty else " Response: " <> ok
pure False addMessage Success $ toHtml $ "Druckauftrag angelegt: " <> pack fpath <> response
when (or oks) $ redirect PrintCenterR pure True
when ok $ redirect PrintCenterR
formResult sendResult procFormSend formResult sendResult procFormSend
-- actionUrl <- fromMaybe AdminAvsR <$> getCurrentRoute -- actionUrl <- fromMaybe AdminAvsR <$> getCurrentRoute
siteLayoutMsg MsgPrintManualRenewal $ do siteLayoutMsg MsgPrintManualRenewal $ do
@ -410,7 +373,11 @@ postPrintAckR ackDay numAck chksm = do
ackForm ackForm
-- no header csv, containing a single column of lms identifiers (logins) -- no header csv, containing a single column of lms identifiers (logins)
instance Csv.FromRecord LmsIdent -- default suffices -- instance Csv.FromRecord LmsIdent -- default suffices
-- instance Csv.FromRecord Text where
-- parseRecord v
-- | length v >= 1 = v Csv..! 0
-- | otherwise = pure "ERROR"
postPrintAckDirectR :: Handler Html postPrintAckDirectR :: Handler Html
postPrintAckDirectR = do postPrintAckDirectR = do
@ -419,29 +386,37 @@ postPrintAckDirectR = do
[(fhead,file)] -> do [(fhead,file)] -> do
runDB $ do runDB $ do
enr <- try $ runConduit $ fileSource file enr <- try $ runConduit $ fileSource file
.| decodeCsvPositional Csv.NoHeader -- .| decodeCsvPositional Csv.NoHeader -- decode by separator position
.| decodeUtf8C -- no CSV, just convert each line to a single text
.| linesUnboundedC
.| sinkList .| sinkList
case enr of case enr of
Left (e :: SomeException) -> do -- catch all to avoid ok220 in case of any error Left (e :: SomeException) -> do -- catch all to avoid ok220 in case of any error
$logWarnS "APC" $ "Result upload failed parsing: " <> tshow e $logWarnS "APC" $ "Result upload failed parsing: " <> tshow e
return (badRequest400, "Error: " <> tshow e) return (badRequest400, "Error: " <> tshow e)
Right lids -> do Right reqIds -> do
let nrReq = length reqIds
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
nr <- updateWhereCount nrApcIds <- updateWhereCount
[PrintJobAcknowledged ==. Nothing, PrintJobLmsUser <-. (Just <$> lids)] [PrintJobAcknowledged ==. Nothing, PrintJobApcIdent <-. reqIds]
[PrintJobAcknowledged =. Just now] [PrintJobAcknowledged =. Just now]
let lenLids = length lids nrOk <- if nrApcIds <= 0 && nrReq > 0
if | lenLids <= 0 -> do then updateWhereCount -- for downwards compatibility only
let msg = "Error: No print job was acknowledged as printed, but " <> tshow lenLids <> " were requested to be, for file " <> fhead [PrintJobAcknowledged ==. Nothing, PrintJobLmsUser <-. (Just . LmsIdent . dropPrefixText "lms-" <$> reqIds)]
[PrintJobAcknowledged =. Just now]
else return nrApcIds
if | nrReq <= 0 -> do
let msg = "Error: No print job was acknowledged as printed, but " <> tshow nrReq <> " were requested to be, for file " <> fhead
$logErrorS "APC" msg $logErrorS "APC" msg
return (badRequest400, msg) return (badRequest400, msg)
| lenLids == fromIntegral nr -> do | nrReq == fromIntegral nrOk -> do
let msg = "Success: " <> tshow nr <> " print jobs were acknowledged as printed, for file " <> fhead let msg = "Success: " <> tshow nrOk <> " print jobs were acknowledged as printed, for file " <> fhead
$logInfoS "APC" msg $logInfoS "APC" msg
return (ok200, msg) return (ok200, msg)
| otherwise -> do | otherwise -> do
let msg = "Warning: Only " <> tshow nr <> " print jobs out of " <> tshow lenLids <> " were acknowledged as printed, for file " <> fhead forM_ reqIds $ \t -> $logInfoS "APC" $ "Received APC Identifier: \"" <> t <> "\""
$logWarnS "APC" msg let msg = "Warning: Only " <> tshow nrOk <> " print jobs out of " <> tshow nrReq <> " were acknowledged as printed, for file " <> fhead
$logWarnS "APC" msg
return (ok200, msg) return (ok200, msg)
[] -> do [] -> do
let msg = "Error: No file received. A file of lms identifiers must be supplied for print job acknowledging." let msg = "Error: No file received. A file of lms identifiers must be supplied for print job acknowledging."

7
src/Handler/Profile.hs
View File

@ -357,6 +357,10 @@ validateSettings User{..} = do
userDisplayName == userDisplayName' || -- unchanged or valid (invalid displayNames delivered by LDAP are preserved) userDisplayName == userDisplayName' || -- unchanged or valid (invalid displayNames delivered by LDAP are preserved)
validDisplayName userTitle userFirstName userSurname userDisplayName' validDisplayName userTitle userFirstName userSurname userDisplayName'
userDisplayEmail' <- use _stgDisplayEmail
guardValidation (MsgInvalidEmailAddressWith $ CI.original userDisplayEmail') $
validEmail' userDisplayEmail'
userPostAddress' <- use _stgPostAddress userPostAddress' <- use _stgPostAddress
let postalNotSet = isNothing userPostAddress' let postalNotSet = isNothing userPostAddress'
postalIsValid = validPostAddress userPostAddress' postalIsValid = validPostAddress userPostAddress'
@ -445,7 +449,7 @@ serveProfileR (uid, user@User{..}) = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
runDBJobs $ do runDBJobs $ do
update uid $ update uid $
[ UserDisplayEmail =. stgDisplayEmail | userDisplayEmail == stgDisplayEmail ] ++ -- SJ asks: what does this line achieve? [ UserDisplayEmail =. stgDisplayEmail | userDisplayEmail == stgDisplayEmail ] ++ -- Note that DisplayEmail changes must be confirmed, see 472
[ UserPostLastUpdate =. Just now | userPostAddress /= stgPostAddress ] ++ [ UserPostLastUpdate =. Just now | userPostAddress /= stgPostAddress ] ++
[ UserDisplayName =. stgDisplayName [ UserDisplayName =. stgDisplayName
, UserMaxFavourites =. stgMaxFavourites , UserMaxFavourites =. stgMaxFavourites
@ -617,6 +621,7 @@ makeProfileData (Entity uid User{..}) = do
mCRoute <- getCurrentRoute mCRoute <- getCurrentRoute
showAdminInfo <- pure (mCRoute == Just (AdminUserR cID)) `or2M` hasReadAccessTo (AdminUserR cID) showAdminInfo <- pure (mCRoute == Just (AdminUserR cID)) `or2M` hasReadAccessTo (AdminUserR cID)
tooltipAvsPersNo <- messageI Info MsgAvsPersonNoNotId tooltipAvsPersNo <- messageI Info MsgAvsPersonNoNotId
tooltipInvalidEmail <- messageI Error MsgInvalidEmailAddress
let profileRemarks = $(i18nWidgetFile "profile-remarks") let profileRemarks = $(i18nWidgetFile "profile-remarks")
return $(widgetFile "profileData") return $(widgetFile "profileData")

92
src/Handler/Qualification.hs
View File

@ -73,7 +73,7 @@ getSupervisees = do
mkQualificationAllTable :: DB (Any, Widget) mkQualificationAllTable :: DB (Any, Widget)
mkQualificationAllTable = do mkQualificationAllTable = do
svs <- getSupervisees svs <- getSupervisees
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
let let
resultDBTable = DBTable{..} resultDBTable = DBTable{..}
where where
@ -236,7 +236,12 @@ instance HasEntity QualificationTableData User where
instance HasUser QualificationTableData where instance HasUser QualificationTableData where
hasUser = resultUser . _entityVal hasUser = resultUser . _entityVal
data QualificationTableAction = QualificationActExpire | QualificationActUnexpire data QualificationTableAction
= QualificationActExpire
| QualificationActUnexpire
| QualificationActBlockSupervisor
| QualificationActBlock
| QualificationActUnblock
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
instance Universe QualificationTableAction instance Universe QualificationTableAction
@ -245,12 +250,24 @@ nullaryPathPiece ''QualificationTableAction $ camelToPathPiece' 2
embedRenderMessage ''UniWorX ''QualificationTableAction id embedRenderMessage ''UniWorX ''QualificationTableAction id
-- Not yet needed, since there is no additional data for now: -- Not yet needed, since there is no additional data for now:
data QualificationTableActionData = QualificationActExpireData | QualificationActUnexpireData data QualificationTableActionData
= QualificationActExpireData
| QualificationActUnexpireData
| QualificationActBlockSupervisorData
| QualificationActBlockData { qualTableActBlockReason :: Text}
| QualificationActUnblockData
deriving (Eq, Ord, Read, Show, Generic) deriving (Eq, Ord, Read, Show, Generic)
isExpiryAct :: QualificationTableActionData -> Bool -- const true, but this may change in the future isExpiryAct :: QualificationTableActionData -> Bool
isExpiryAct QualificationActExpireData = True isExpiryAct QualificationActExpireData = True
isExpiryAct QualificationActUnexpireData = True isExpiryAct QualificationActUnexpireData = True
isExpiryAct _ = False
isBlockAct :: QualificationTableActionData -> Bool
isBlockAct QualificationActBlockSupervisorData = True
isBlockAct QualificationActBlockData{} = True
isBlockAct QualificationActUnblockData = True
isBlockAct _ = False
qualificationTableQuery :: QualificationId -> (_ -> E.SqlExpr (E.Value Bool)) -> QualificationTableExpr qualificationTableQuery :: QualificationId -> (_ -> E.SqlExpr (E.Value Bool)) -> QualificationTableExpr
-> E.SqlQuery ( E.SqlExpr (Entity QualificationUser) -> E.SqlQuery ( E.SqlExpr (Entity QualificationUser)
@ -300,6 +317,13 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
-- , single ("lms-status" , SortColumn $ views (to queryLmsUser) (E.?. LmsUserStatus)) -- , single ("lms-status" , SortColumn $ views (to queryLmsUser) (E.?. LmsUserStatus))
, single ("lms-status-plus",SortColumn $ \row -> E.coalesce [E.explicitUnsafeCoerceSqlExprValue "timestamp" $ (queryLmsUser row E.?. LmsUserStatus) E.#>>. "{day}" , single ("lms-status-plus",SortColumn $ \row -> E.coalesce [E.explicitUnsafeCoerceSqlExprValue "timestamp" $ (queryLmsUser row E.?. LmsUserStatus) E.#>>. "{day}"
, queryLmsUser row E.?. LmsUserStarted]) , queryLmsUser row E.?. LmsUserStarted])
, single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal))
, single ( "user-company" , SortColumn $ \row -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId
E.orderBy [E.asc (comp E.^. CompanyName)]
return (comp E.^. CompanyName)
)
] ]
dbtFilter = mconcat dbtFilter = mconcat
[ single $ fltrUserNameEmail queryUser [ single $ fltrUserNameEmail queryUser
@ -323,7 +347,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
, Just True <- getLast criterion -> quser E.^. QualificationUserValidUntil E.<=. E.val renewal , Just True <- getLast criterion -> quser E.^. QualificationUserValidUntil E.<=. E.val renewal
E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday
| otherwise -> E.true | otherwise -> E.true
) )
] ]
dbtFilterUI mPrev = mconcat dbtFilterUI mPrev = mconcat
[ fltrUserNameEmailHdrUI MsgLmsUser mPrev [ fltrUserNameEmailHdrUI MsgLmsUser mPrev
@ -400,19 +424,36 @@ postQualificationR sid qsh = do
((lmsRes, qualificationTable), Entity qid quali) <- runDB $ do ((lmsRes, qualificationTable), Entity qid quali) <- runDB $ do
qent@Entity{entityVal=Qualification{qualificationAuditDuration=auditMonths}} <- getBy404 $ SchoolQualificationShort sid qsh qent@Entity{entityVal=Qualification{qualificationAuditDuration=auditMonths}} <- getBy404 $ SchoolQualificationShort sid qsh
let acts :: Map QualificationTableAction (AForm Handler QualificationTableActionData) let acts :: Map QualificationTableAction (AForm Handler QualificationTableActionData)
acts = mconcat acts = mconcat $
[ singletonMap QualificationActExpire $ pure QualificationActExpireData [ singletonMap QualificationActExpire $ pure QualificationActExpireData
, singletonMap QualificationActUnexpire $ pure QualificationActUnexpireData , singletonMap QualificationActUnexpire $ pure QualificationActUnexpireData
] ] ++ bool
linkLmsUser = toMaybe isAdmin LmsUserR [ singletonMap QualificationActBlockSupervisor $ pure QualificationActBlockSupervisorData ] -- nonAdmin Supervisor
[ singletonMap QualificationActUnblock $ pure QualificationActUnblockData
, singletonMap QualificationActBlock $ QualificationActBlockData
<$> apreq textField (fslI MsgQualificationBlockReason) Nothing
] isAdmin
linkLmsUser = toMaybe isAdmin LmsUserR
linkUserName = bool ForProfileR ForProfileDataR isAdmin
blockedDueCell = bool qualificationBlockedCellNoReason qualificationBlockedCell isAdmin
colChoices = mconcat colChoices = mconcat
[ dbSelect (applying _2) id (return . view (resultUser . _entityKey)) [ dbSelect (applying _2) id (return . view (resultUser . _entityKey))
, colUserNameModalHdr MsgLmsUser ForProfileR , colUserNameModalHdr MsgLmsUser linkUserName
, colUserEmail , colUserEmail
, 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
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid
E.orderBy [E.asc (comp E.^. CompanyName)]
return (comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor)
let companies = intersperse (text2markup ", ") $
(\(E.Value cmpName, E.Value cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> companies'
icnSuper = text2markup " " <> icon IconSupervisor
pure $ toWgt $ mconcat companies
, sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \( view $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> dayCell d , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \( view $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> dayCell d
, sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d
, sortable (Just "blocked-due") (i18nCell MsgTableQualificationBlockedDue & cellTooltip MsgTableQualificationBlockedTooltipSimple , sortable (Just "blocked-due") (i18nCell MsgTableQualificationBlockedDue & cellTooltip MsgTableQualificationBlockedTooltipSimple
) $ \( view $ resultQualUser . _entityVal . _qualificationUserBlockedDue -> b) -> qualificationBlockedCellNoReason b ) $ \( view $ resultQualUser . _entityVal . _qualificationUserBlockedDue -> b) -> blockedDueCell b
, sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip , sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip
) $ \( view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification ) $ \( view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification
-- , sortable (Just "lms-started") (i18nCell MsgTableLmsElearning <> spacerCell <> i18nCell MsgTableLmsStarted) -- , sortable (Just "lms-started") (i18nCell MsgTableLmsElearning <> spacerCell <> i18nCell MsgTableLmsStarted)
@ -425,18 +466,39 @@ postQualificationR sid qsh = do
tbl <- mkQualificationTable isAdmin qent acts colChoices psValidator tbl <- mkQualificationTable isAdmin qent acts colChoices psValidator
return (tbl, qent) return (tbl, qent)
formResult lmsRes $ \case formResult lmsRes $ \case
_ | not isAdmin -> addMessageI Error MsgUnauthorized -- only admins can use the form on this page for now (action, selectedUsers) | isExpiryAct action -> do
(action, selectedUsers) | isExpiryAct action -> do
let isUnexpire = action == QualificationActUnexpireData let isUnexpire = action == QualificationActUnexpireData
upd <- runDB $ updateWhereCount upd <- runDB $ updateWhereCount
[QualificationUserQualification ==. qid, QualificationUserUser <-. Set.toList selectedUsers] [QualificationUserQualification ==. qid, QualificationUserUser <-. Set.toList selectedUsers]
[QualificationUserScheduleRenewal =. isUnexpire] [QualificationUserScheduleRenewal =. isUnexpire]
let msgKind = if upd > 0 then Success else Warning let msgKind = if upd > 0 then Success else Warning
msgVal = upd & if isUnexpire then MsgQualificationSetUnexpire else MsgQualificationSetExpire msgVal = upd & if isUnexpire then MsgQualificationSetUnexpire else MsgQualificationSetExpire
addMessageI msgKind msgVal addMessageI msgKind msgVal
redirect currentRoute redirect currentRoute
_ -> return () (action, selectedUsers) | isBlockAct action && (isAdmin || action == QualificationActBlockSupervisorData) -> do
now <- liftIO getCurrentTime
let nowaday = utctDay now
qubr = case action of
QualificationActUnblockData -> Nothing
QualificationActBlockSupervisorData -> Just $ mkQualificationBlocked QualificationBlockReturnedByCompany nowaday
QualificationActBlockData{..} -> Just $ QualificationBlocked
{ qualificationBlockedDay = nowaday
, qualificationBlockedReason = qualTableActBlockReason
}
_ -> error "Handle.Qualification.isBlockAct returned non-block action"
oks <- runDB $ qualificationUserBlocking qid (Set.toList selectedUsers) qubr
let nrq = length selectedUsers
warnLevel = if
| oks < 0 -> Error
| oks == nrq -> Success
| otherwise -> Warning
fbmsg = if
| isNothing qubr -> MsgQualificationStatusUnblock
| otherwise -> MsgQualificationStatusBlock
addMessageI warnLevel $ fbmsg qsh oks nrq
redirect currentRoute
_ -> addMessageI Error MsgUnauthorized
let heading = citext2widget $ qualificationName quali let heading = citext2widget $ qualificationName quali
siteLayout heading $ do siteLayout heading $ do

26
src/Handler/Term.hs
View File

@ -77,20 +77,18 @@ getTermShowR = do
-> cell $ formatTime SelFormatDate termEnd >>= toWidget -> cell $ formatTime SelFormatDate termEnd >>= toWidget
, sortable Nothing (i18nCell MsgTermHolidays) $ \(Entity _ Term{..},_, _) , sortable Nothing (i18nCell MsgTermHolidays) $ \(Entity _ Term{..},_, _)
-> cell $ do -> cell $ do
let termHolidays' = groupHolidays termHolidays let termHolidays' = groupHolidays termHolidays
[whamlet| [whamlet|
$newline never $newline never
<ul .list--inline .list--comma-separated> <ul .list--inline .list--comma-separated>
$forall holiday <- termHolidays' $forall holiday <- termHolidays'
$case holiday <li>
$of Left singleHoliday $case holiday
<li>^{formatTimeW SelFormatDate singleHoliday} $of Left singleHoliday
$of Right (startD, endD) ^{formatTimeW SelFormatDate singleHoliday}
<li> $of Right (startD, endD)
^{formatTimeW SelFormatDate startD} ^{formatTimeRangeW SelFormatDate startD (Just endD)}
– |]
^{formatTimeW SelFormatDate endD}
|]
] ]
dbtSorting = Map.fromList dbtSorting = Map.fromList
[ ( "start" [ ( "start"

99
src/Handler/Tutorial/Users.hs
View File

@ -2,6 +2,8 @@
-- --
-- SPDX-License-Identifier: AGPL-3.0-or-later -- SPDX-License-Identifier: AGPL-3.0-or-later
{-# LANGUAGE TypeApplications #-}
module Handler.Tutorial.Users module Handler.Tutorial.Users
( getTUsersR, postTUsersR ( getTUsersR, postTUsersR
) where ) where
@ -10,6 +12,7 @@ import Import
import Utils.Form import Utils.Form
import Handler.Utils import Handler.Utils
import Handler.Utils.Course
import Handler.Utils.Tutorial import Handler.Utils.Tutorial
import Database.Persist.Sql (deleteWhereCount) import Database.Persist.Sql (deleteWhereCount)
@ -20,13 +23,15 @@ import qualified Data.Map as Map
-- import qualified Data.Time.Zones as TZ -- import qualified Data.Time.Zones as TZ
import qualified Database.Esqueleto.Legacy as E import Database.Esqueleto.Experimental ((:&)(..))
import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
import Handler.Course.Users import Handler.Course.Users
data TutorialUserAction data TutorialUserAction
= TutorialUserRenewQualification = TutorialUserPrintQualification
| TutorialUserRenewQualification
| TutorialUserGrantQualification | TutorialUserGrantQualification
| TutorialUserSendMail | TutorialUserSendMail
| TutorialUserDeregister | TutorialUserDeregister
@ -38,12 +43,15 @@ nullaryPathPiece ''TutorialUserAction $ camelToPathPiece' 2
embedRenderMessage ''UniWorX ''TutorialUserAction id embedRenderMessage ''UniWorX ''TutorialUserAction id
data TutorialUserActionData data TutorialUserActionData
= TutorialUserRenewQualificationData = TutorialUserPrintQualificationData
{ tuQualification :: QualificationId
}
| TutorialUserRenewQualificationData
{ tuQualification :: QualificationId } { tuQualification :: QualificationId }
| TutorialUserGrantQualificationData | TutorialUserGrantQualificationData
{ tuQualification :: QualificationId { tuQualification :: QualificationId
, tuValidUntil :: Day , tuValidUntil :: Day
} }
| TutorialUserSendMailData | TutorialUserSendMailData
| TutorialUserDeregisterData{} | TutorialUserDeregisterData{}
deriving (Eq, Ord, Read, Show, Generic) deriving (Eq, Ord, Read, Show, Generic)
@ -53,9 +61,10 @@ getTUsersR, postTUsersR :: TermId -> SchoolId -> CourseShorthand -> TutorialName
getTUsersR = postTUsersR getTUsersR = postTUsersR
postTUsersR tid ssh csh tutn = do postTUsersR tid ssh csh tutn = do
showSex <- getShowSex showSex <- getShowSex
(Entity tutid Tutorial{..}, (participantRes, participantTable)) <- runDB $ do (Entity tutid Tutorial{..}, (participantRes, participantTable), qualifications) <- runDB $ do
tut@(Entity tutid _) <- fetchTutorial tid ssh csh tutn cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
qualifications <- selectList [QualificationSchool ==. ssh] [Asc QualificationShorthand] tut@(Entity tutid _) <- fetchTutorial tid ssh csh tutn
qualifications <- getCourseQualifications cid
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
let minDur :: Maybe Int = minimumMaybe $ catMaybes (view _qualificationValidDuration <$> qualifications) -- no instance Ord CalendarDiffDays let minDur :: Maybe Int = minimumMaybe $ catMaybes (view _qualificationValidDuration <$> qualifications) -- no instance Ord CalendarDiffDays
dayExpiry = flip addGregorianDurationClip (utctDay now) . fromMonths <$> minDur dayExpiry = flip addGregorianDurationClip (utctDay now) . fromMonths <$> minDur
@ -71,12 +80,12 @@ postTUsersR tid ssh csh tutn = do
& defaultSortingByName & 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 & 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 . E.from $ \tutorialParticipant -> isInTut q = E.exists $ do
tutorialParticipant <- E.from $ E.table @TutorialParticipant
E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. queryUser q E.^. UserId E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. queryUser q E.^. UserId
E.&&. tutorialParticipant E.^. TutorialParticipantTutorial E.==. E.val tutid E.&&. tutorialParticipant E.^. TutorialParticipantTutorial E.==. E.val tutid
csvColChoices = flip elem ["name", "matriculation", "email", "qualifications"] csvColChoices = flip elem ["name", "matriculation", "email", "qualifications"]
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
let let
qualOpt :: Entity Qualification -> Handler (Option QualificationId) qualOpt :: Entity Qualification -> Handler (Option QualificationId)
qualOpt (Entity qualId qual) = do qualOpt (Entity qualId qual) = do
@ -87,33 +96,47 @@ postTUsersR tid ssh csh tutn = do
, optionExternalValue = tshow cQualId , optionExternalValue = tshow cQualId
} }
acts :: Map TutorialUserAction (AForm Handler TutorialUserActionData) acts :: Map TutorialUserAction (AForm Handler TutorialUserActionData)
acts = Map.fromList acts = Map.fromList $
[ ( TutorialUserRenewQualification (if null qualifications then mempty else
, TutorialUserRenewQualificationData [ ( TutorialUserPrintQualification
<$> apopt (selectField . fmap mkOptionList $ mapM qualOpt qualifications) (fslI MsgQualificationName) Nothing , TutorialUserPrintQualificationData
) <$> apopt (selectField . fmap mkOptionList $ mapM qualOpt qualifications) (fslI MsgQualificationName) Nothing
, ( TutorialUserGrantQualification )
, TutorialUserGrantQualificationData , ( TutorialUserRenewQualification
<$> apopt (selectField . fmap mkOptionList $ mapM qualOpt qualifications) (fslI MsgQualificationName) Nothing , TutorialUserRenewQualificationData
<*> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry <$> apopt (selectField . fmap mkOptionList $ mapM qualOpt qualifications) (fslI MsgQualificationName) Nothing
) )
, ( TutorialUserSendMail, pure TutorialUserSendMailData ) , ( TutorialUserGrantQualification
, TutorialUserGrantQualificationData
<$> apopt (selectField . fmap mkOptionList $ mapM qualOpt qualifications) (fslI MsgQualificationName) Nothing
<*> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry
)
]
) ++
[ ( TutorialUserSendMail, pure TutorialUserSendMailData )
, ( TutorialUserDeregister, pure TutorialUserDeregisterData ) , ( TutorialUserDeregister, pure TutorialUserDeregisterData )
] ]
table <- makeCourseUserTable cid acts isInTut colChoices psValidator (Just csvColChoices) table <- makeCourseUserTable cid acts isInTut colChoices psValidator (Just csvColChoices)
return (tut, table) return (tut, table, qualifications)
let courseQids = Set.fromList (entityKey <$> qualifications)
formResult participantRes $ \case formResult participantRes $ \case
(TutorialUserGrantQualificationData{..}, selectedUsers) -> do (TutorialUserPrintQualificationData{..}, _selectedUsers)
-- today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime | tuQualification `Set.member` courseQids -> do
today <- utctDay <$> liftIO getCurrentTime -- TODO Continue here
runDB . forM_ selectedUsers $ upsertQualificationUser tuQualification today tuValidUntil Nothing addMessageI Error MsgErrorUnknownFormAction
addMessageI Success . MsgTutorialUserGrantedQualification $ Set.size selectedUsers (TutorialUserGrantQualificationData{..}, selectedUsers)
redirect $ CTutorialR tid ssh csh tutn TUsersR | tuQualification `Set.member` courseQids -> do
(TutorialUserRenewQualificationData{..}, selectedUsers) -> do -- today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime
noks <- runDB $ renewValidQualificationUsers tuQualification $ Set.toList selectedUsers today <- utctDay <$> liftIO getCurrentTime
addMessageI (if noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks runDB . forM_ selectedUsers $ upsertQualificationUser tuQualification today tuValidUntil Nothing
redirect $ CTutorialR tid ssh csh tutn TUsersR addMessageI Success . MsgTutorialUserGrantedQualification $ Set.size selectedUsers
redirect $ CTutorialR tid ssh csh tutn TUsersR
(TutorialUserRenewQualificationData{..}, selectedUsers)
| tuQualification `Set.member` courseQids -> do
noks <- runDB $ renewValidQualificationUsers tuQualification $ Set.toList selectedUsers
addMessageI (if noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks
redirect $ CTutorialR tid ssh csh tutn TUsersR
(TutorialUserSendMailData{}, selectedUsers) -> do (TutorialUserSendMailData{}, selectedUsers) -> do
cids <- traverse encrypt $ Set.toList selectedUsers :: Handler [CryptoUUIDUser] cids <- traverse encrypt $ Set.toList selectedUsers :: Handler [CryptoUUIDUser]
redirect (CTutorialR tid ssh csh tutn TCommR, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cids]) redirect (CTutorialR tid ssh csh tutn TCommR, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cids])
@ -124,12 +147,14 @@ postTUsersR tid ssh csh tutn = do
] ]
addMessageI Success $ MsgTutorialUsersDeregistered nrDel addMessageI Success $ MsgTutorialUsersDeregistered nrDel
redirect $ CTutorialR tid ssh csh tutn TUsersR redirect $ CTutorialR tid ssh csh tutn TUsersR
_other ->
addMessageI Error MsgErrorUnknownFormAction
tutors <- runDB $ tutors <- runDB $ E.select $ do
E.select $ E.from $ \(tutor `E.InnerJoin` user) -> do (tutor :& user) <- E.from $ E.table @Tutor `E.innerJoin` E.table @User
E.on $ tutor E.^. TutorUser E.==. user E.^. UserId `E.on` (\(tutor :& user) -> tutor E.^. TutorUser E.==. user E.^. UserId)
E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid
return user return user
let heading = prependCourseTitle tid ssh csh $ CI.original tutorialName let heading = prependCourseTitle tid ssh csh $ CI.original tutorialName
siteLayoutMsg heading $ do siteLayoutMsg heading $ do

4
src/Handler/Users.hs
View File

@ -188,10 +188,10 @@ postUsersR = do
acts = mconcat acts = mconcat
[ singletonMap UserLdapSync $ pure UserLdapSyncData [ singletonMap UserLdapSync $ pure UserLdapSyncData
, singletonMap UserAddSupervisor $ UserAddSupervisorData , singletonMap UserAddSupervisor $ UserAddSupervisorData
<$> apopt (textField & cfAnySeparatedSet) (fslI MsgMppSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing <$> apopt (textField & cfAnySeparatedSet) (fslI MsgTableSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing
<*> apopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just True) <*> apopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just True)
, singletonMap UserSetSupervisor $ UserSetSupervisorData , singletonMap UserSetSupervisor $ UserSetSupervisorData
<$> apopt (textField & cfAnySeparatedSet) (fslI MsgMppSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing <$> apopt (textField & cfAnySeparatedSet) (fslI MsgTableSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing
<*> apopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just True) <*> apopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just True)
, singletonMap UserRemoveSupervisor $ pure UserRemoveSupervisorData , singletonMap UserRemoveSupervisor $ pure UserRemoveSupervisorData
] ]

2
src/Handler/Utils/Avs.hs
View File

@ -129,7 +129,7 @@ setLicenceAvs apid lic = do
--setLicencesAvs :: Set AvsPersonLicence -> Handler Bool --setLicencesAvs :: Set AvsPersonLicence -> Handler Bool
setLicencesAvs :: (MonadHandler m, MonadThrow m, HandlerSite m ~ UniWorX) => setLicencesAvs :: (MonadHandler m, MonadThrow m, HandlerSite m ~ UniWorX) =>
Set AvsPersonLicence -> m Int Set AvsPersonLicence -> m Int
setLicencesAvs persLics = do setLicencesAvs persLics = do -- exceptT (return 0 <$ addMessage Error . text2Html . tshow) return $ do
AvsQuery{avsQuerySetLicences=aqsl} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery AvsQuery{avsQuerySetLicences=aqsl} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery
aux aqsl 0 persLics aux aqsl 0 persLics
where where

17
src/Handler/Utils/Course.hs
View File

@ -2,6 +2,8 @@
-- --
-- SPDX-License-Identifier: AGPL-3.0-or-later -- SPDX-License-Identifier: AGPL-3.0-or-later
{-# LANGUAGE TypeApplications #-}
module Handler.Utils.Course where module Handler.Utils.Course where
import Import import Import
@ -10,6 +12,8 @@ import Handler.Utils.Memcached
import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Legacy as E
import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Utils as E
import Database.Esqueleto.Experimental ((:&)(..))
import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma
import qualified Data.Set as Set import qualified Data.Set as Set
@ -103,3 +107,16 @@ showCourseEventRoom uid courseEvent = E.or
E.where_ $ lecturer E.^. LecturerUser E.==. uid E.where_ $ lecturer E.^. LecturerUser E.==. uid
E.&&. E.unSqlProjectExpr (Proxy @CourseEvent) (Proxy @courseEvent) (lecturer E.^. LecturerCourse) E.==. courseEvent `E.sqlProject` CourseEventCourse E.&&. E.unSqlProjectExpr (Proxy @CourseEvent) (Proxy @courseEvent) (lecturer E.^. LecturerCourse) E.==. courseEvent `E.sqlProject` CourseEventCourse
] ]
getCourseQualifications :: ( MonadHandler m
, backend ~ SqlBackend
)
=> CourseId -> ReaderT backend m [Entity Qualification]
getCourseQualifications cid = Ex.select $ do
(qual :& courseQual) <-
Ex.from $ Ex.table @Qualification
`Ex.innerJoin` Ex.table @CourseQualification
`Ex.on` (\(qual :& courseQual) -> qual E.^. QualificationId E.==. courseQual E.^. CourseQualificationQualification)
Ex.where_ $ courseQual E.^. CourseQualificationCourse E.==. E.val cid
Ex.orderBy [E.asc $ courseQual E.^. CourseQualificationSortOrder]
pure qual

1
src/Handler/Utils/DateTime.hs
View File

@ -333,6 +333,7 @@ formatTimeRange' :: ( HasLocalTime t, HasLocalTime t'
-> t -- ^ Start -> t -- ^ Start
-> Maybe t' -- ^ End -> Maybe t' -- ^ End
-> m Text -> m Text
-- In order to abbreviate common same month time ranges, e.g. 24--26.12.23 on must take into account all DateFormatString, as some have the day on the end or feature a weekday
formatTimeRange' cont proj startT endT = do formatTimeRange' cont proj startT endT = do
startT' <- cont proj startT startT' <- cont proj startT
let let

3
src/Handler/Utils/Form.hs
View File

@ -594,6 +594,9 @@ degreeField = selectField $ optionsPersistKey [] [Asc StudyDegreeName, Asc Study
degreeFieldEnt :: Field Handler (Entity StudyDegree) degreeFieldEnt :: Field Handler (Entity StudyDegree)
degreeFieldEnt = selectField $ optionsPersist [] [Asc StudyDegreeName, Asc StudyDegreeShorthand, Asc StudyDegreeKey] id degreeFieldEnt = selectField $ optionsPersist [] [Asc StudyDegreeName, Asc StudyDegreeShorthand, Asc StudyDegreeKey] id
qualificationFieldEnt :: Field Handler (Entity Qualification)
qualificationFieldEnt = selectField $ optionsPersist [] [Asc QualificationName] qualificationName
-- | Select one of the user's primary active study features, or from a given list of StudyFeatures (regardless of user) -- | Select one of the user's primary active study features, or from a given list of StudyFeatures (regardless of user)
studyFeaturesPrimaryFieldFor :: Bool -- ^ Allow user to select `Nothing` (only applies if set of options is nonempty)? studyFeaturesPrimaryFieldFor :: Bool -- ^ Allow user to select `Nothing` (only applies if set of options is nonempty)?

32
src/Handler/Utils/LMS.hs
View File

@ -17,6 +17,7 @@ module Handler.Utils.LMS
, csvFilenameLmsUser , csvFilenameLmsUser
, csvFilenameLmsUserlist , csvFilenameLmsUserlist
, csvFilenameLmsResult , csvFilenameLmsResult
, lmsDeletionDate
, lmsUserToDelete, _lmsUserToDelete , lmsUserToDelete, _lmsUserToDelete
, lmsUserToDeleteExpr , lmsUserToDeleteExpr
, lmsUserStatusWidget , lmsUserStatusWidget
@ -33,6 +34,7 @@ import Data.Csv (HasHeader(..), FromRecord)
import qualified Data.Set as Set (notMember) import qualified Data.Set as Set (notMember)
import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Legacy as E
import qualified Database.Esqueleto.Utils as E
import Control.Monad.Random.Class (uniform) import Control.Monad.Random.Class (uniform)
import Control.Monad.Trans.Random (evalRandTIO) import Control.Monad.Trans.Random (evalRandTIO)
@ -101,15 +103,25 @@ makeLmsFilename ftag (citext2lower -> qsh) = do
getYMTH :: MonadHandler m => m Text getYMTH :: MonadHandler m => m Text
getYMTH = formatTime' "%Y%m%d%H" =<< liftIO getCurrentTime getYMTH = formatTime' "%Y%m%d%H" =<< liftIO getCurrentTime
--
lmsDeletionDate :: Handler Day
lmsDeletionDate = do
LmsConf{lmsDeletionDays} <- getsYesod $ view _appLmsConf
addDays (fromIntegral $ negate lmsDeletionDays) . utctDay <$> liftIO getCurrentTime
-- | Decide whether LMS platform should delete an identifier -- | Decide whether LMS platform should delete an identifier
lmsUserToDeleteExpr :: E.SqlExpr (Entity LmsUser) -> E.SqlExpr (E.Value Bool) lmsUserToDeleteExpr :: Day -> E.SqlExpr (Entity LmsUser) -> E.SqlExpr (E.Value Bool)
lmsUserToDeleteExpr lmslist = E.isNothing (lmslist E.^. LmsUserEnded) E.&&. E.not_ (E.isNothing $ lmslist E.^. LmsUserStatus) 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
-- | Is everything since cutoff day or before?
lmsUserToDelete :: Day -> LmsUser -> Bool
lmsUserToDelete cutoff LmsUser{lmsUserEnded=Nothing, lmsUserStatus= Just lstat} = lmsStatusDay lstat < cutoff
lmsUserToDelete _ _ = False
lmsUserToDelete :: LmsUser -> Bool _lmsUserToDelete :: Day -> Getter LmsUser Bool
lmsUserToDelete LmsUser{lmsUserEnded, lmsUserStatus} = isNothing lmsUserEnded && isJust lmsUserStatus _lmsUserToDelete cutoff = to $ lmsUserToDelete cutoff
_lmsUserToDelete :: Getter LmsUser Bool
_lmsUserToDelete = to lmsUserToDelete
-- random generation of LmsIdentifiers, maybe this should be in Model.Types.Lms since length specifications are type-y? -- random generation of LmsIdentifiers, maybe this should be in Model.Types.Lms since length specifications are type-y?
@ -138,7 +150,7 @@ randomText extra n = fmap pack . evalRandTIO . replicateM n $ uniform range
-- eopt = Elo.genOptions -- { genCapitals = False, genSpecials = False, genDigitis = True } -- eopt = Elo.genOptions -- { genCapitals = False, genSpecials = False, genDigitis = True }
randomLMSIdent :: MonadIO m => m LmsIdent randomLMSIdent :: MonadIO m => m LmsIdent
randomLMSIdent = LmsIdent <$> randomText [] lengthIdent randomLMSIdent = LmsIdent <$> randomText [] lengthIdent -- idents must not contain '_' nor '-'
randomLMSIdentBut :: MonadIO m => Set LmsIdent -> m (Maybe LmsIdent) randomLMSIdentBut :: MonadIO m => Set LmsIdent -> m (Maybe LmsIdent)
randomLMSIdentBut banList = untilJustMaxM maxLmsUserIdentRetries getIdentOk randomLMSIdentBut banList = untilJustMaxM maxLmsUserIdentRetries getIdentOk
@ -147,8 +159,8 @@ randomLMSIdentBut banList = untilJustMaxM maxLmsUserIdentRetries getIdentOk
l <- randomLMSIdent l <- randomLMSIdent
return $ toMaybe (Set.notMember l banList) l return $ toMaybe (Set.notMember l banList) l
randomLMSpw :: MonadIO m => m Text 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 where
extra = "+=!?" -- you cannot distinguish ;: and ., in printed letters extra = "+=!?" -- you cannot distinguish ;: and ., in printed letters

47
src/Handler/Utils/Mail.hs
View File

@ -16,7 +16,7 @@ import Handler.Utils.Pandoc
import Handler.Utils.Files import Handler.Utils.Files
import Handler.Utils.Widgets (nameHtml') -- TODO: how to use name widget here? import Handler.Utils.Widgets (nameHtml') -- TODO: how to use name widget here?
import Handler.Utils.Users (getReceivers) import Handler.Utils.Users (getReceivers)
import Handler.Utils.Profile (pickValidEmail) import Handler.Utils.Profile
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
@ -42,13 +42,13 @@ addRecipientsDB uFilter = runConduit $ transPipe (liftHandler . runDB) (selectSo
userAddressFrom :: User -> Address userAddressFrom :: User -> Address
-- ^ Format an e-mail address suitable for usage in a @From@-header -- ^ Format an e-mail address suitable for usage in a @From@-header
-- --
-- Uses `userDisplayEmail` -- Uses `userDisplayEmail` only
userAddressFrom User{userDisplayEmail, userDisplayName} = Address (Just userDisplayName) $ CI.original userDisplayEmail userAddressFrom User{userDisplayEmail, userDisplayName} = Address (Just userDisplayName) $ CI.original userDisplayEmail
userAddress :: User -> Address userAddress :: User -> Address
-- ^ Format an e-mail address suitable for usage as a recipient -- ^ Format an e-mail address suitable for usage as a recipient
-- --
-- Like userAddressFrom and no longer uses `userEmail`, since unlike Uni2work, userEmail from LDAP is untrustworthy. -- Like userAddressFrom, but prefers `userDisplayEmail` (if valid) and otherwise uses `userEmail`. Unlike Uni2work, userEmail from LDAP is untrustworthy.
userAddress User{userEmail, userDisplayEmail, userDisplayName} userAddress User{userEmail, userDisplayEmail, userDisplayName}
= Address (Just userDisplayName) $ CI.original $ pickValidEmail userDisplayEmail userEmail = Address (Just userDisplayName) $ CI.original $ pickValidEmail userDisplayEmail userEmail
@ -98,15 +98,21 @@ userMailT uid mAct = do
$else $else
_{MsgMailSupervisorNoCopy} _{MsgMailSupervisorNoCopy}
|] |]
mailT ctx $ do mailtoAddr = userAddress supervisor
_mailTo .= pure (userAddress supervisor) if validEmail $ addressEmail mailtoAddr
mAct then
if uid==svr mailT ctx $ do
then when (2 <= length receivers) $ addHtmlMarkdownAlternatives' "InfoSupervised" infoSupervised -- notify about supervisors -- TODO: ensure that the Email is VALID HERE!
else do _mailTo .= pure mailtoAddr
mapSubject ("[SUPERVISOR] " <>) mAct
addHtmlMarkdownAlternatives' "InfoSupervisor" infoSupervisor -- adding explanation why the supervisor received this email if uid==svr
then when (length receivers > 1) $ addHtmlMarkdownAlternatives' "InfoSupervised" infoSupervised -- notify about supervisors
else do
mapSubject ("[SUPERVISOR] " <>)
addHtmlMarkdownAlternatives' "InfoSupervisor" infoSupervisor -- adding explanation why the supervisor received this email
else -- do
-- failedSubject <- lookupMailHeader "Subject"
$logErrorS "Mail" $ "Attempt to email invalid address: " <> tshow mailtoAddr -- <> " with subject " <> tshow failedSubject
-- | like userMailT, but always sends a single mail to the given UserId, ignoring supervisors -- | like userMailT, but always sends a single mail to the given UserId, ignoring supervisors
userMailTdirect :: ( MonadHandler m userMailTdirect :: ( MonadHandler m
@ -131,9 +137,22 @@ userMailTdirect uid mAct = do
SelFormatTime -> userTimeFormat SelFormatTime -> userTimeFormat
, mcCsvOptions = userCsvOptions , mcCsvOptions = userCsvOptions
} }
mailtoAddr = userAddress user
mailT ctx $ do mailT ctx $ do
_mailTo .= pure (userAddress user) failedSubject <- lookupMailHeader "Subject"
mAct unless (validEmail $ addressEmail mailtoAddr) ($logErrorS "Mail" $ "Attempt to email invalid address: " <> tshow mailtoAddr <> " with subject " <> tshow failedSubject)
_mailTo .= pure mailtoAddr
mAct
{- Problematic due to return type a
if validEmail $ addressEmail mailtoAddr
then mailT ctx $ do
_mailTo .= pure mailtoAddr
mAct
else
-- failedSubject <- lookupMailHeader "Subject"
$logErrorS "Mail" $ "Attempt to email invalid address: " <> tshow mailtoAdd -- <> " with subject " <> tshow failedSubject
-}
addFileDB :: ( MonadMail m addFileDB :: ( MonadMail m

26
src/Handler/Utils/Profile.hs
View File

@ -9,7 +9,8 @@ module Handler.Utils.Profile
, validDisplayName , validDisplayName
, fixDisplayName , fixDisplayName
, validPostAddress , validPostAddress
, validEmail, validEmail', pickValidEmail , validEmail, validEmail'
, pickValidEmail, pickValidEmail'
) where ) where
import Import.NoFoundation import Import.NoFoundation
@ -79,14 +80,27 @@ validPostAddress (Just StoredMarkup {markupInput = addr})
= True = True
validPostAddress _ = False validPostAddress _ = False
-- also see `Handler.Utils.Users.getEmailAddress` for Tests accepting User Type
validEmail :: Email -> Bool -- Email = Text validEmail :: Email -> Bool -- Email = Text
validEmail = Email.isValid . encodeUtf8 validEmail email = validRFC5322 && not invalidFraport
where
validRFC5322 = Email.isValid $ encodeUtf8 email
invalidFraport = case Text.stripSuffix "@fraport.de" email of
Just fralogin -> all isDigit $ drop 1 fralogin
Nothing -> False
validEmail' :: UserEmail -> Bool -- UserEmail = CI Text validEmail' :: UserEmail -> Bool -- UserEmail = CI Text
validEmail' = Email.isValid . encodeUtf8 . CI.original validEmail' = validEmail . CI.original
-- | returns first argument, if it is a valid email address; returns second argument untested otherwise; convenience function -- | returns first argument, if it is a valid email address; returns second argument untested otherwise; convenience function
pickValidEmail :: UserEmail -> UserEmail -> UserEmail pickValidEmail :: UserEmail -> UserEmail -> UserEmail
pickValidEmail x y pickValidEmail x y
| validEmail' x = x | validEmail' x = x
| otherwise = y | otherwise = y
-- | returns first valid email address or none if none are valid
pickValidEmail' :: UserEmail -> UserEmail -> Maybe UserEmail
pickValidEmail' x y
| validEmail' x = Just x
| validEmail' y = Just y
| otherwise = Nothing

39
src/Handler/Utils/Qualification.hs
View File

@ -10,6 +10,7 @@ module Handler.Utils.Qualification
import Import import Import
-- import Data.Time.Calendar (CalendarDiffDays(..)) -- import Data.Time.Calendar (CalendarDiffDays(..))
import Database.Persist.Sql (updateWhereCount)
import qualified Database.Esqueleto.Experimental as E -- might need TypeApplications Lang-Pragma import qualified Database.Esqueleto.Experimental as E -- might need TypeApplications Lang-Pragma
import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Utils as E
@ -100,4 +101,40 @@ renewValidQualificationUsers qid uids =
, transactionQualificationScheduleRenewal = Nothing , transactionQualificationScheduleRenewal = Nothing
} }
return $ length quEnts return $ length quEnts
_ -> return (-1) -- qualificationId not found, isNothing qualificationValidDuration, etc. _ -> return (-1) -- qualificationId not found, isNothing qualificationValidDuration, etc.
-- qualificationUserBlocking :: QualificationId -> [UserId] -> Maybe QualificationBlocked -> DB Int64
qualificationUserBlocking ::
( AuthId (HandlerSite m) ~ Key User
, IsPersistBackend (YesodPersistBackend (HandlerSite m))
, BaseBackend (YesodPersistBackend (HandlerSite m)) ~ SqlBackend
, BackendCompatible SqlBackend (YesodPersistBackend (HandlerSite m))
, PersistQueryWrite (YesodPersistBackend (HandlerSite m))
, PersistUniqueWrite (YesodPersistBackend (HandlerSite m))
, HasInstanceID (HandlerSite m) InstanceId
, YesodAuthPersist (HandlerSite m)
, HasAppSettings (HandlerSite m)
, MonadHandler m
, MonadCatch m
, Num n
) => QualificationId -> [UserId] -> Maybe QualificationBlocked -> ReaderT (YesodPersistBackend (HandlerSite m)) m n
qualificationUserBlocking qid uids qb = do
oks <- updateWhereCount -- prevents storage of transactionQualificatioUser
( [ QualificationUserBlockedDue !=. Nothing | isNothing qb -- only unblock blocked qualification; allow overwrite for existing blocks
] ++
[ QualificationUserQualification ==. qid
, QualificationUserUser <-. uids
]
)
[ QualificationUserBlockedDue =. qb
]
forM_ uids $ \uid -> do
audit TransactionQualificationUserBlocking
{ -- transactionQualificationUser = quid
transactionQualification = qid
, transactionUser = uid
, transactionQualificationBlock = qb
}
return $ fromIntegral oks

2
src/Handler/Utils/Table/Cells.hs
View File

@ -370,7 +370,7 @@ qualificationBlockedCellNoReason (Just QualificationBlocked{qualificationBlocked
qualificationBlockedCell :: IsDBTable m a => Maybe QualificationBlocked -> DBCell m a qualificationBlockedCell :: IsDBTable m a => Maybe QualificationBlocked -> DBCell m a
qualificationBlockedCell Nothing = mempty qualificationBlockedCell Nothing = mempty
qualificationBlockedCell (Just QualificationBlocked{..}) qualificationBlockedCell (Just QualificationBlocked{..})
| 12 >= length qualificationBlockedReason = mkCellWith textCell | 32 >= length qualificationBlockedReason = mkCellWith textCell
| otherwise = mkCellWith modalCell | otherwise = mkCellWith modalCell
where where
mkCellWith c = c qualificationBlockedReason <> spacerCell <> iconCell IconBlocked <> spacerCell <> dayCell qualificationBlockedDay mkCellWith c = c qualificationBlockedReason <> spacerCell <> iconCell IconBlocked <> spacerCell <> dayCell qualificationBlockedDay

14
src/Handler/Utils/Users.hs
View File

@ -14,6 +14,7 @@ module Handler.Utils.Users
, UserAssimilateException(..), UserAssimilateExceptionReason(..) , UserAssimilateException(..), UserAssimilateExceptionReason(..)
, assimilateUser , assimilateUser
, userPrefersEmail, userPrefersLetter , userPrefersEmail, userPrefersLetter
, getEmailAddress
, getPostalAddress, getPostalPreferenceAndAddress , getPostalAddress, getPostalPreferenceAndAddress
, abbrvName , abbrvName
, getReceivers , getReceivers
@ -71,13 +72,16 @@ userPrefersEmail = not . userPrefersLetter
-- | result (True, Nothing) indicates that neither userEmail nor userPostAddress is known -- | result (True, Nothing) indicates that neither userEmail nor userPostAddress is known
getPostalPreferenceAndAddress :: User -> (Bool, Maybe [Text]) getPostalPreferenceAndAddress :: User -> (Bool, Maybe [Text])
getPostalPreferenceAndAddress usr@User{..} = getPostalPreferenceAndAddress usr@User{userPrefersPostal} =
((userPrefersPostal && postPossible) || not emailPossible, pa) ((userPrefersPostal && postPossible) || not emailPossible, pa)
-- (((userPrefersPostal || isNothing userPinPassword) && postPossible) || not emailPossible, pa) -- ignore email/post preference if no pinPassword is set -- (((userPrefersPostal || isNothing userPinPassword) && postPossible) || not emailPossible, pa) -- ignore email/post preference if no pinPassword is set
where where
emailPossible = validEmail' userEmail
postPossible = isJust pa
pa = getPostalAddress usr pa = getPostalAddress usr
postPossible = isJust pa
emailPossible = isJust $ getEmailAddress usr
getEmailAddress :: User -> Maybe UserEmail
getEmailAddress User{userDisplayEmail, userEmail} = pickValidEmail' userDisplayEmail userEmail
getPostalAddress :: User -> Maybe [Text] getPostalAddress :: User -> Maybe [Text]
getPostalAddress User{..} getPostalAddress User{..}
@ -89,7 +93,7 @@ getPostalAddress User{..}
| otherwise | otherwise
= Nothing = Nothing
-- | DEPRECATED, use Handler.Utils.Avs.updateReceivers instead -- | Consider using Handler.Utils.Avs.updateReceivers instead
-- Return Entity User and all Supervisors with rerouteNotifications as well as -- Return Entity User and all Supervisors with rerouteNotifications as well as
-- a boolean indicating if the user is own supervisor with rerouteNotifications -- a boolean indicating if the user is own supervisor with rerouteNotifications
getReceivers :: UserId -> DB (Entity User, [Entity User], Bool) getReceivers :: UserId -> DB (Entity User, [Entity User], Bool)

43
src/Jobs/Handler/LMS.hs
View File

@ -28,13 +28,11 @@ import qualified Data.Set as Set
import qualified Data.Time.Zones as TZ import qualified Data.Time.Zones as TZ
import Handler.Utils.DateTime import Handler.Utils.DateTime
import Handler.Utils.LMS (randomLMSIdentBut, randomLMSpw, maxLmsUserIdentRetries) import Handler.Utils.LMS (randomLMSIdentBut, randomLMSpw, maxLmsUserIdentRetries)
import Handler.Utils.Qualification
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
blockedByElearning :: Text
blockedByElearning = "E-Learning durchgefallen"
dispatchJobLmsQualificationsEnqueue :: JobHandler UniWorX dispatchJobLmsQualificationsEnqueue :: JobHandler UniWorX
dispatchJobLmsQualificationsEnqueue = JobHandlerAtomic $ fetchRefreshQualifications JobLmsEnqueue dispatchJobLmsQualificationsEnqueue = JobHandlerAtomic $ fetchRefreshQualifications JobLmsEnqueue
@ -182,10 +180,6 @@ dispatchJobLmsResults qid = JobHandlerAtomic act
where where
-- act :: YesodJobDB UniWorX () -- act :: YesodJobDB UniWorX ()
act = hoist lift $ do act = hoist lift $ do
quali <- getJust qid
whenIsJust (qualificationValidDuration quali) $ \renewalMonths -> do
-- otherwise there is nothing to do: we cannot renew s qualification without a specified validDuration
-- result :: [(Entity QualificationUser, Entity LmsUser, Entity LmsResult)]
results <- E.select $ do results <- E.select $ do
(quser :& luser :& lresult) <- E.from $ (quser :& luser :& lresult) <- E.from $
E.table @QualificationUser -- table not needed if renewal from lms completion day is used TODO: decide! E.table @QualificationUser -- table not needed if renewal from lms completion day is used TODO: decide!
@ -204,33 +198,24 @@ dispatchJobLmsResults qid = JobHandlerAtomic act
return (quser, luser, lresult) return (quser, luser, lresult)
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
let locDay = localDay $ TZ.utcToLocalTimeTZ appTZ now let locDay = localDay $ TZ.utcToLocalTimeTZ appTZ now
forM_ results $ \(Entity quid QualificationUser{..}, Entity luid LmsUser{..}, Entity lrid LmsResult{..}) -> do forM_ results $ \(Entity _quid QualificationUser{..}, Entity luid LmsUser{..}, Entity lrid LmsResult{..}) -> do
-- three separate DB operations per result is not so nice. All within one transaction though. -- three separate DB operations per result is not so nice. All within one transaction though.
let lmsUserStartedDay = localDay $ TZ.utcToLocalTimeTZ appTZ lmsUserStarted let lmsUserStartedDay = localDay $ TZ.utcToLocalTimeTZ appTZ lmsUserStarted
saneDate = lmsResultSuccess `inBetween` (lmsUserStartedDay, min qualificationUserValidUntil locDay) saneDate = lmsResultSuccess `inBetween` (lmsUserStartedDay, min qualificationUserValidUntil locDay)
&& qualificationUserLastRefresh <= utctDay lmsUserStarted && qualificationUserLastRefresh <= utctDay lmsUserStarted
newStatus = LmsSuccess lmsResultSuccess newStatus = LmsSuccess lmsResultSuccess
newValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) qualificationUserValidUntil -- renew from old validUntil onwards -- newValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) qualificationUserValidUntil -- renew from old validUntil onwards
note <- if saneDate && isLmsSuccess newStatus note <- if saneDate && isLmsSuccess newStatus
then do then do
-- TODO: refactor using functions from Handler.Utils.Qualification to ensure nothing is forgotten! _ok <- renewValidQualificationUsers qid [qualificationUserUser] -- blocked is unaffected
qUsr <- updateGet quid -- when (ok==1) $ update luid -- we end lms regardless of wether a regular renewal was successful, since BPol users may simultaneoysly have on-premise renewal courses and E-Learnings
[ QualificationUserValidUntil =. newValidTo update luid
, QualificationUserLastRefresh =. lmsResultSuccess [ LmsUserStatus =. Just newStatus
] , LmsUserReceived =. Just lmsResultTimestamp
-- WORKAROUND LMS-Bug: sometimes we receive success and failure simultaneously; success is correct, hence we must unblock if the reason was e-learning ]
when (Just blockedByElearning == qUsr ^? _qualificationUserBlockedDue . _Just . _qualificationBlockedReason) $ -- WORKAROUND LMS-Bug [supposedly fixed now]: sometimes we receive success and failure simultaneously; success is correct, hence we must unblock if the reason was e-learning
update quid [ QualificationUserBlockedDue =. Nothing ] -- when (Just (qualificationBlockedReasonText QualificationBlockFailedELearning) == qUsr ^? _qualificationUserBlockedDue . _Just . _qualificationBlockedReason) $
update luid [ LmsUserStatus =. Just newStatus -- update quid [ QualificationUserBlockedDue =. Nothing ]
, LmsUserReceived =. Just lmsResultTimestamp
]
audit TransactionQualificationUserEdit
{ transactionQualificationUser = quid
, transactionQualification = qualificationUserQualification
, transactionUser = qualificationUserUser
, transactionQualificationValidUntil = newValidTo
, transactionQualificationScheduleRenewal = Nothing
}
return Nothing return Nothing
else do else do
let errmsg = [st|LMS success with insane date #{tshow lmsResultSuccess} received for #{tshow lmsUserIdent}|] let errmsg = [st|LMS success with insane date #{tshow lmsResultSuccess} received for #{tshow lmsUserIdent}|]
@ -295,9 +280,7 @@ dispatchJobLmsUserlist qid = JobHandlerAtomic act
, transactionReceived = lReceived , transactionReceived = lReceived
} }
update luid [LmsUserStatus =. (oldStatus <> Just newStatus)] update luid [LmsUserStatus =. (oldStatus <> Just newStatus)]
updateBy (UniqueQualificationUser qid (lmsUserUser luser)) void $ qualificationUserBlocking qid [lmsUserUser luser] $ Just $ mkQualificationBlocked QualificationBlockFailedELearning blockedDay
[QualificationUserBlockedDue =. Just (QualificationBlocked { qualificationBlockedDay = blockedDay
, qualificationBlockedReason = blockedByElearning } )]
queueDBJob JobSendNotification queueDBJob JobSendNotification
{ jRecipient = lmsUserUser luser { jRecipient = lmsUserUser luser
, jNotification = NotificationQualificationExpired { nQualification = qid, nExpiry = blockedDay } , jNotification = NotificationQualificationExpired { nQualification = qid, nExpiry = blockedDay }

6
src/Jobs/Handler/QueueNotification.hs
View File

@ -15,7 +15,7 @@ import Jobs.Queue
import qualified Data.Set as Set import qualified Data.Set as Set
import Handler.Utils.Profile (validEmail') import Handler.Utils.Profile (pickValidEmail')
import Handler.Utils.ExamOffice.Exam import Handler.Utils.ExamOffice.Exam
import Handler.Utils.ExamOffice.ExternalExam import Handler.Utils.ExamOffice.ExternalExam
@ -26,8 +26,8 @@ dispatchJobQueueNotification :: Notification -> JobHandler UniWorX
dispatchJobQueueNotification jNotification = JobHandlerAtomic $ dispatchJobQueueNotification jNotification = JobHandlerAtomic $
runConduit $ yield jNotification runConduit $ yield jNotification
.| transPipe (hoist lift) determineNotificationCandidates .| transPipe (hoist lift) determineNotificationCandidates
.| C.filterM (\(notification', override, Entity _ User{userNotificationSettings,userEmail}) -> .| C.filterM (\(notification', override, Entity _ User{userNotificationSettings,userDisplayEmail,userEmail}) ->
and2M (return $ validEmail' userEmail) $ and2M (return $ isJust $ pickValidEmail' userDisplayEmail userEmail) $
or2M (return override) $ notificationAllowed userNotificationSettings <$> hoist lift (classifyNotification notification')) or2M (return override) $ notificationAllowed userNotificationSettings <$> hoist lift (classifyNotification notification'))
.| C.map (\(notification', _, Entity uid _) -> JobSendNotification uid notification') .| C.map (\(notification', _, Entity uid _) -> JobSendNotification uid notification')
.| sinkDBJobs .| sinkDBJobs

3
src/Jobs/Handler/SendNotification/Qualification.hs
View File

@ -78,7 +78,8 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do
let letter = LetterRenewQualificationF let letter = LetterRenewQualificationF
{ lmsLogin = lmsUserIdent { lmsLogin = lmsUserIdent
, lmsPin = lmsUserPin , lmsPin = lmsUserPin
, qualHolder = userDisplayName , qualHolderID = jRecipient
, qualHolderDN = userDisplayName
, qualHolderSN = userSurname , qualHolderSN = userSurname
, qualExpiry = qualificationUserValidUntil , qualExpiry = qualificationUserValidUntil
, qualId = nQualification , qualId = nQualification

1
src/Model/Types/Changelog.hs
View File

@ -53,6 +53,7 @@ classifyChangelogItem = \case
changelogItemDays :: Map ChangelogItem Day changelogItemDays :: Map ChangelogItem Day
changelogItemDays = Map.fromListWithKey (\k d1 d2 -> bool (error $ "Duplicate changelog days for " <> show k) d1 $ d1 /= d2) changelogItemDays = Map.fromListWithKey (\k d1 d2 -> bool (error $ "Duplicate changelog days for " <> show k) d1 $ d1 /= d2)
[ (ChangelogFradriveInitialRelease, [day|2022-12-12|]) [ (ChangelogFradriveInitialRelease, [day|2022-12-12|])
, (ChangelogSupervisorsMayRevokeLicences, [day|2023-03-27|])
] ]
{- FOR REFERENCE, PREVIOUS CHANGELOG (delete in the future, along with all translation files): {- FOR REFERENCE, PREVIOUS CHANGELOG (delete in the future, along with all translation files):

27
src/Model/Types/Lms.hs
View File

@ -11,6 +11,8 @@ module Model.Types.Lms
) where ) where
import Import.NoModel import Import.NoModel
import qualified Data.Map as Map
import Data.Map ((!))
import Database.Persist.Sql import Database.Persist.Sql
import qualified Database.Esqueleto.Experimental as E import qualified Database.Esqueleto.Experimental as E
import qualified Data.Csv as Csv import qualified Data.Csv as Csv
@ -46,7 +48,7 @@ instance Ord LmsStatus where
isLmsSuccess :: LmsStatus -> Bool isLmsSuccess :: LmsStatus -> Bool
isLmsSuccess LmsSuccess{} = True isLmsSuccess LmsSuccess{} = True
isLmsSuccess _other = False isLmsSuccess _other = False
makeLenses_ ''LmsStatus makeLenses_ ''LmsStatus
@ -87,6 +89,25 @@ instance Csv.ToField QualificationBlocked where
-- instance ToMessage QualificationBlocked where -- no longer used -- instance ToMessage QualificationBlocked where -- no longer used
-- toMessage QualificationBlocked{..} = qualificationBlockedReason -- toMessage QualificationBlocked{..} = qualificationBlockedReason
data QualificationBlockStandardReason
= QualificationBlockFailedELearning
| QualificationBlockReturnedByCompany
deriving (Eq, Ord, Enum, Bounded, Universe, Finite)
instance Show QualificationBlockStandardReason where
show QualificationBlockFailedELearning = "E-Learning durchgefallen"
show QualificationBlockReturnedByCompany = "Rückgabe Firma"
qualificationBlockedReasonText :: QualificationBlockStandardReason -> Text
qualificationBlockedReasonText =
let dictionary :: Map.Map QualificationBlockStandardReason Text = Map.fromList [(r, tshow r) | r <- universeF]
in (dictionary !) -- cannot fail due to universeF
mkQualificationBlocked :: QualificationBlockStandardReason -> Day -> QualificationBlocked
mkQualificationBlocked reason qualificationBlockedDay = QualificationBlocked{..}
where
qualificationBlockedReason = qualificationBlockedReasonText reason
-- | LMS interface requires Bool to be encoded by 0 or 1 only -- | LMS interface requires Bool to be encoded by 0 or 1 only
newtype LmsBool = LmsBool { lms2bool :: Bool } newtype LmsBool = LmsBool { lms2bool :: Bool }
deriving (Eq, Ord, Read, Show, Generic) deriving (Eq, Ord, Read, Show, Generic)
@ -113,10 +134,10 @@ _lmsDay = iso LmsDay lms2day
-- | Format for day for LMS interface -- | Format for day for LMS interface
lmsDayFormat :: String lmsDayFormat :: String
lmsDayFormat = "%d-%m-%Y" lmsDayFormat = "%d-%m-%Y" -- fixed in LMS interface desctiption, due defaultTimeLocale, should not use named entities like weekdays or month names
instance Csv.ToField LmsDay where instance Csv.ToField LmsDay where
toField (LmsDay d) = Csv.toField $ Time.formatTime Time.defaultTimeLocale lmsDayFormat d -- TimeLocale should not matter; getTimeLocale requires MonadHandler toField (LmsDay d) = Csv.toField $ Time.formatTime Time.defaultTimeLocale lmsDayFormat d -- TimeLocale should not matter since format string does not use names; getTimeLocale requires MonadHandler
instance Csv.FromField LmsDay where instance Csv.FromField LmsDay where
-- parseField = fmap LmsDay . parseLmsDay <=< Csv.parseField -- parseField = fmap LmsDay . parseLmsDay <=< Csv.parseField

4
src/Settings.hs
View File

@ -317,6 +317,7 @@ data LmsConf = LmsConf
, lmsDownloadHeader :: Bool , lmsDownloadHeader :: Bool
, lmsDownloadDelimiter :: Char , lmsDownloadDelimiter :: Char
, lmsDownloadCrLf :: Bool , lmsDownloadCrLf :: Bool
, lmsDeletionDays :: Int
} deriving (Show) } deriving (Show)
data AvsConf = AvsConf data AvsConf = AvsConf
@ -516,6 +517,7 @@ instance FromJSON LmsConf where
lmsDownloadHeader <- o .: "download-header" lmsDownloadHeader <- o .: "download-header"
lmsDownloadDelimiter <- o .: "download-delimiter" lmsDownloadDelimiter <- o .: "download-delimiter"
lmsDownloadCrLf <- o .: "download-cr-lf" lmsDownloadCrLf <- o .: "download-cr-lf"
lmsDeletionDays <- o .: "deletion-days"
return LmsConf{..} return LmsConf{..}
makeLenses_ ''LmsConf makeLenses_ ''LmsConf
@ -657,7 +659,7 @@ instance FromJSON AppSettings where
appMailVerp <- fromMaybe VerpNone . join <$> (o .:? "mail-verp" <|> pure Nothing) appMailVerp <- fromMaybe VerpNone . join <$> (o .:? "mail-verp" <|> pure Nothing)
appMailRetainSent <- o .: "mail-retain-sent" appMailRetainSent <- o .: "mail-retain-sent"
appMailSupport <- o .: "mail-support" appMailSupport <- o .: "mail-support"
appMailRerouteTo <- o .:? "mail-reroute-to" appMailRerouteTo <- join <$> (o .:? "mail-reroute-to" <|> pure Nothing)
appJobWorkers <- o .: "job-workers" appJobWorkers <- o .: "job-workers"
appJobFlushInterval <- o .:? "job-flush-interval" appJobFlushInterval <- o .:? "job-flush-interval"

9
src/Utils.hs
View File

@ -275,6 +275,9 @@ addAttrsClass cl attrs = ("class", cl') : noClAttrs
-- tickmark :: IsString a => a -- tickmark :: IsString a => a
-- tickmark = fromString "✔" -- tickmark = fromString "✔"
nonBreakableDash :: Text -- used directly in several messages
nonBreakableDash = "‑"
-- | Deprecated, replace with Data.Text.elem, once a newer version of Data.Text is available -- | Deprecated, replace with Data.Text.elem, once a newer version of Data.Text is available
textElem :: Char -> Text -> Bool textElem :: Char -> Text -> Bool
textElem c = Text.any (c ==) textElem c = Text.any (c ==)
@ -284,6 +287,12 @@ textElem c = Text.any (c ==)
stripAll :: Text -> Text stripAll :: Text -> Text
stripAll = Text.filter (not . isSpace) stripAll = Text.filter (not . isSpace)
-- | Strips an optional prefix. Like `Data.Text.stripPrefix` but returns input text if the prefix is not matched, micking the behaviour of `dropPrefix` for `Data.Text`
dropPrefixText :: Text -> Text -> Text
-- dropPrefixText p t = fromMaybe t $ stripPrefix p t
dropPrefixText p (stripPrefix p -> Just t) = t
dropPrefixText _ other = other
-- | take first line, only -- | take first line, only
cropText :: Text -> Text cropText :: Text -> Text
cropText (Text.take 255 -> t) = headDef t $ Text.lines t cropText (Text.take 255 -> t) = headDef t $ Text.lines t

482
src/Utils/Print.hs
View File

@ -5,13 +5,12 @@
{-# OPTIONS_GHC -fno-warn-unused-top-binds #-} {-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
module Utils.Print module Utils.Print
( pdfRenewal ( renderLetter -- used for generating letter pdfs
, sendLetter, sendLetter' , sendEmailOrLetter -- directly print or sends by email
, sendEmailOrLetter , printLetter -- always send a letter
, letterApcIdent -- create acknowledge string for APC
, encryptPDF , encryptPDF
, sanitizeCmdArg, validCmdArgument , sanitizeCmdArg, validCmdArgument
, templateDIN5008
, templateRenewal
-- , compileTemplate, makePDF -- , compileTemplate, makePDF
, _Meta, addMeta , _Meta, addMeta
, toMeta, mbMeta -- single values , toMeta, mbMeta -- single values
@ -23,16 +22,16 @@ module Utils.Print
import Data.Char (isSeparator) import Data.Char (isSeparator)
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
import qualified Data.Foldable as Fold -- import qualified Data.Foldable as Fold
import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Lazy as LBS
import Control.Monad.Except import Control.Monad.Except
import Import hiding (embedFile) import Import hiding (embedFile)
import Data.FileEmbed (embedFile) -- import Data.FileEmbed (embedFile)
import qualified Text.Pandoc as P import qualified Text.Pandoc as P
import qualified Text.Pandoc.PDF as P -- import qualified Text.Pandoc.PDF as P
import qualified Text.Pandoc.Builder as P -- import qualified Text.Pandoc.Builder as P
import Text.Hamlet import Text.Hamlet
@ -42,10 +41,14 @@ import System.Process.Typed -- for calling pdftk for pdf encryption
import Handler.Utils.Users import Handler.Utils.Users
import Handler.Utils.DateTime import Handler.Utils.DateTime
import Handler.Utils.Mail import Handler.Utils.Mail
import Handler.Utils.Widgets (nameHtml, nameHtml') import Handler.Utils.Widgets (nameHtml')
import Handler.Utils.Avs (updateReceivers) import Handler.Utils.Avs (updateReceivers)
import Jobs.Handler.SendNotification.Utils import Jobs.Handler.SendNotification.Utils
import Utils.Print.Letters
import Utils.Print.RenewQualification
-- import Model.Types.Markup -- TODO-QSV: should this module be moved accordingly? -- import Model.Types.Markup -- TODO-QSV: should this module be moved accordingly?
{- Recall: {- Recall:
@ -56,100 +59,6 @@ import Jobs.Handler.SendNotification.Utils
-------------------------
-- Hardcoded Templates --
-------------------------
templateRenewal :: Text
templateRenewal = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/fraport_renewal.md")
templateDIN5008 :: Text
templateDIN5008 = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/din5008.latex")
----------------------
-- Pandoc Functions --
----------------------
-- Either I don't understand how pandoc works or
-- I don't understand why these are not included
compileTemplate :: (P.PandocMonad m) => Text -> m (P.Template Text)
compileTemplate tmpl = do
let partialPath = "" -- no partials used, see Text.DocTemplates
mbTemplate <- P.runWithDefaultPartials $ P.compileTemplate partialPath tmpl
liftEither $ str2pandocError mbTemplate
where
str2pandocError = over _Left $ P.PandocTemplateError . pack
makePDF :: P.WriterOptions -> P.Pandoc -> P.PandocIO LBS.ByteString
-- makePDF :: (PandocMonad m, MonadIO m, MonadMask m) => P.WriterOptions -> P.Pandoc -> m LBS.ByteString -- only pandoc >= 2.18
makePDF wopts doc = do
mbPdf <- P.makePDF "lualatex" texopts P.writeLaTeX wopts doc
liftEither $ bs2pandocError mbPdf
where
texopts = []
bs2pandocError = over _Left (P.PandocMakePDFError . decodeUtf8 . LBS.toStrict)
_Meta :: Lens' P.Pandoc P.Meta
_Meta = lens mget mput
where
mget (P.Pandoc m _) = m
mput (P.Pandoc _ b) m = P.Pandoc m b
toMeta :: P.ToMetaValue a => Text -> a -> Map Text P.MetaValue
toMeta k = singletonMap k . P.toMetaValue
mbMeta :: P.ToMetaValue a => Text -> Maybe a -> Map Text P.MetaValue
mbMeta = foldMap . toMeta
-- | For convenience and to avoid importing Pandoc
mkMeta :: [Map Text P.MetaValue] -> P.Meta
mkMeta = P.Meta . mconcat
-- | Modify the Meta-Block of Pandoc
appMeta :: (P.Meta -> P.Meta) -> P.Pandoc -> P.Pandoc
appMeta f (P.Pandoc m bs) = P.Pandoc (f m) bs
-- appMeta f = _Meta %~ f -- lens version. Not sure this is better
-- TODO: applyMetas is inconvenient since we cannot have an instance
-- ToMetaValue a => ToMetaValue (Maybe a)
-- so apply Metas
-- For tests see module PandocSpec
applyMetas :: (P.HasMeta p, Foldable t, P.ToMetaValue a) => t (Text, Maybe a) -> p -> p
applyMetas metas doc = Fold.foldr act doc metas
where
act (k, Just v) acc | notNull k = P.setMeta k v acc
act _ acc = acc
-- | Add meta to pandoc. Existing variables will be overwritten.
-- For specification, see module PandocSpec
addMeta :: P.Meta -> P.Pandoc -> P.Pandoc
addMeta m = appMeta (<> m) -- Data.Map says: (<>) == union and union should prefer the left operand, but somehow it does not!
--addMeta m p = meta <> p
-- where meta = P.Pandoc m mempty
-- | Pandoc conditionals only test if a variable is set or isn't set.
-- Variable "is-de" will be set to True if the "lang" variable starts with "de"
-- and will be unset otherwise
setIsDeFromLang :: P.Meta -> P.Meta
setIsDeFromLang m
| (Just (P.MetaString t)) <- P.lookupMeta "lang" m
, isDe t = P.setMeta isde True m
| otherwise = P.deleteMeta isde m
where
isde = "is-de"
defReaderOpts :: P.ReaderOptions
defReaderOpts = def { P.readerExtensions = P.pandocExtensions, P.readerStripComments = True }
defWriterOpts :: P.Template Text -> P.WriterOptions
defWriterOpts t = def { P.writerExtensions = P.pandocExtensions, P.writerTemplate = Just t }
------------------------- -------------------------
-- Readers and writers -- -- Readers and writers --
------------------------- -------------------------
@ -158,40 +67,42 @@ defWriterOpts t = def { P.writerExtensions = P.pandocExtensions, P.writerTemplat
-- This is a hack to allow variable interpolation within a document. -- This is a hack to allow variable interpolation within a document.
-- Pandoc currently only allows interpolation within templates. -- Pandoc currently only allows interpolation within templates.
-- An alternative Route would be to use Builders, but this prevents User-edited Markup Templates -- An alternative Route would be to use Builders, but this prevents User-edited Markup Templates
reTemplateLetter :: P.PandocMonad m => P.Meta -> StoredMarkup -> m Text -- reTemplateLetter :: P.PandocMonad m => P.Meta -> StoredMarkup -> m Text
reTemplateLetter meta StoredMarkup{..} = do -- reTemplateLetter meta StoredMarkup{..} = do
tmpl <- compileTemplate strictMarkupInput -- tmpl <- compileTemplate strictMarkupInput
doc <- areader readerOpts strictMarkupInput -- doc <- areader readerOpts strictMarkupInput
let writerOpts = def { P.writerExtensions = P.pandocExtensions -- let writerOpts = def { P.writerExtensions = P.pandocExtensions
, P.writerTemplate = Just tmpl } -- , P.writerTemplate = Just tmpl }
P.writeMarkdown writerOpts -- P.writeMarkdown writerOpts
$ appMeta setIsDeFromLang -- $ appMeta setIsDeFromLang
$ addMeta meta doc -- $ addMeta meta doc
where -- where
strictMarkupInput = toStrict markupInput -- strictMarkupInput = toStrict markupInput
readerOpts = def { P.readerExtensions = P.pandocExtensions -- readerOpts = def { P.readerExtensions = P.pandocExtensions
, P.readerStripComments = True -- , P.readerStripComments = True
} -- }
-- reader :: (P.PandocMonad m, P.ToSources a) => P.ReaderOptions -> a -> m P.Pandoc -- -- reader :: (P.PandocMonad m, P.ToSources a) => P.ReaderOptions -> a -> m P.Pandoc
areader = case markupInputFormat of -- areader = case markupInputFormat of
MarkupHtml -> P.readHtml -- MarkupHtml -> P.readHtml
MarkupMarkdown -> P.readMarkdown -- MarkupMarkdown -> P.readMarkdown
MarkupPlaintext -> P.readMarkdown -- MarkupPlaintext -> P.readMarkdown
reTemplateLetter' :: P.PandocMonad m => P.Meta -> Text -> m Text -- reTemplateLetter' :: P.PandocMonad m => P.Meta -> Text -> m Text
reTemplateLetter' meta md = do -- reTemplateLetter' meta md = do
tmpl <- compileTemplate md -- tmpl <- compileTemplate md
doc <- P.readMarkdown readerOpts md -- doc <- P.readMarkdown readerOpts md
let writerOpts = def { P.writerExtensions = P.pandocExtensions -- let writerOpts = def { P.writerExtensions = P.pandocExtensions
, P.writerTemplate = Just tmpl } -- , P.writerTemplate = Just tmpl }
P.writeMarkdown writerOpts -- P.writeMarkdown writerOpts
$ appMeta setIsDeFromLang -- $ appMeta setIsDeFromLang
$ addMeta meta doc -- $ addMeta meta doc
where -- where
readerOpts = def { P.readerExtensions = P.pandocExtensions -- readerOpts = def { P.readerExtensions = P.pandocExtensions
, P.readerStripComments = True -- , P.readerStripComments = True
} -- }
-- | 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 Text)
mdTemplating template meta = runExceptT $ do mdTemplating template meta = runExceptT $ do
let readerOpts = def { P.readerExtensions = P.pandocExtensions let readerOpts = def { P.readerExtensions = P.pandocExtensions
@ -205,22 +116,10 @@ mdTemplating template meta = runExceptT $ do
ExceptT . pure . P.runPure $ P.writeMarkdown writerOpts $ appMeta setIsDeFromLang ExceptT . pure . P.runPure $ P.writeMarkdown writerOpts $ appMeta setIsDeFromLang
$ addMeta meta doc $ addMeta meta doc
--pdfDIN5008 :: P.PandocMonad m => Text -> m LBS.ByteString -- for pandoc > 2.18 -- | creates a PDF using a LaTeX template
pdfDIN5008' :: P.Meta -> Text -> P.PandocIO LBS.ByteString pdfLaTeX :: LetterKind -> P.Meta -> Text -> HandlerFor UniWorX (Either P.PandocError LBS.ByteString)
pdfDIN5008' meta md = do pdfLaTeX lk meta md = do
tmpl <- compileTemplate templateDIN5008 e_tmpl <- $cachedHereBinary ("LetterKind:" <> tshow lk) (liftIO . P.runIO $ compileTemplate $ templateLatex lk)
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
-- | creates a PDF using the din5008 template
pdfDIN5008 :: P.Meta -> Text -> HandlerFor UniWorX (Either P.PandocError LBS.ByteString)
pdfDIN5008 meta md = do
e_tmpl <- $cachedHereBinary ("din5008"::Text) (liftIO . P.runIO $ compileTemplate templateDIN5008)
actRight e_tmpl $ \tmpl -> liftIO . P.runIO $ do actRight e_tmpl $ \tmpl -> liftIO . P.runIO $ do
let readerOpts = def { P.readerExtensions = P.pandocExtensions } let readerOpts = def { P.readerExtensions = P.pandocExtensions }
writerOpts = def { P.writerExtensions = P.pandocExtensions writerOpts = def { P.writerExtensions = P.pandocExtensions
@ -231,95 +130,60 @@ pdfDIN5008 meta md = do
$ addMeta meta doc $ addMeta meta doc
renderLetter :: (MDLetter l) => Entity User -> l -> Text -> Handler (Either Text LBS.ByteString)
------------------------- renderLetter rcvrEnt@Entity{entityVal=rcvr} mdl apcIdent = do
-- Specialized Letters -- now <- liftIO getCurrentTime
------------------------- formatter@DateTimeFormatter{ format } <- getDateTimeFormatterUser' rcvr
let lang = selectDeEn $ rcvr & userLanguages -- select either German or English only, default de; see Utils.Lang
-- | like 'reTemplateLetter' but uses 'templateRenewal' and caches the result kind = getLetterKind $ pure mdl
mdRenewal' :: P.Meta -> HandlerFor UniWorX (Either P.PandocError Text) tmpl = getTemplate $ pure mdl
mdRenewal' meta = do meta = addApcIdent apcIdent
let readerOpts = def { P.readerExtensions = P.pandocExtensions <> letterMeta mdl formatter lang rcvrEnt
, P.readerStripComments = True <> mkMeta
} [ toMeta "lang" lang
e_doc <- $cachedHereBinary ("renewal-pandoc"::Text) (liftIO . P.runIO $ P.readMarkdown readerOpts templateRenewal) , toMeta "date" $ format SelFormatDate now
e_tmpl <- $cachedHereBinary ("renewal-template"::Text) (liftIO . P.runIO $ compileTemplate templateRenewal) , toMeta "rcvr-name" $ rcvr & userDisplayName
case (e_doc, e_tmpl) of , toMeta "address" $ fromMaybe [rcvr & userDisplayName] $ getPostalAddress rcvr
(Left err, _) -> pure $ Left err --, toMeta "rcvr-email" $ rcvr & userDisplayEmail -- note that some templates use "email" already otherwise
(_, Left err) -> pure $ Left err ]
(Right md_doc, Right md_tmpl) -> do e_md <- mdTemplating tmpl meta
let writerOpts = def { P.writerExtensions = P.pandocExtensions result <- actRight e_md $ pdfLaTeX kind meta
, P.writerTemplate = Just md_tmpl
}
liftIO . P.runIO $ P.writeMarkdown writerOpts $ appMeta setIsDeFromLang
$ addMeta meta md_doc
-- | like 'reTemplateLetter' but uses 'templateRenewal' and caches the result
mdRenewal :: P.Meta -> HandlerFor UniWorX (Either P.PandocError Text)
mdRenewal meta = runExceptT $ do
let readerOpts = def { P.readerExtensions = P.pandocExtensions
, P.readerStripComments = True
}
doc <- ExceptT $ $cachedHereBinary ("renewal-pandoc"::Text) (pure . P.runPure $ P.readMarkdown readerOpts templateRenewal)
tmpl <- ExceptT $ $cachedHereBinary ("renewal-template"::Text) (pure . P.runPure $ compileTemplate templateRenewal)
let writerOpts = def { P.writerExtensions = P.pandocExtensions
, P.writerTemplate = Just tmpl
}
ExceptT . pure . P.runPure $ P.writeMarkdown writerOpts $ appMeta setIsDeFromLang
$ addMeta meta doc
-- | combines 'mdRenewal' and 'pdfDIN5008'
pdfRenewal :: P.Meta -> HandlerFor UniWorX (Either Text LBS.ByteString)
pdfRenewal meta = do
e_txt <- mdRenewal' meta
--actRight e_txt (pdfDIN5008 . appMeta setIsDeFromLang . addMeta meta) -- try this
result <- actRight e_txt $ pdfDIN5008 meta
return $ over _Left P.renderError result return $ over _Left P.renderError result
-- | like pdfRenewal but without caching
pdfRenewal' :: P.Meta -> P.PandocIO LBS.ByteString
pdfRenewal' meta = do
doc <- reTemplateLetter' meta templateRenewal
pdfDIN5008' meta doc
-- Generic Version
pdfLetter :: Text -> P.Meta -> HandlerFor UniWorX (Either Text LBS.ByteString)
pdfLetter md meta = do
e_txt <- mdTemplating md meta
result <- actRight e_txt $ pdfDIN5008 meta
return $ over _Left P.renderError result
--------------- ---------------
-- PrintJobs -- -- PrintJobs --
--------------- ---------------
data PrintJobIdentification = PrintJobIdentification -- Only used in print-test-handler for PrintSendR
{ pjiName :: Text printLetter :: (MDLetter l) => Maybe UserId -> (Entity User, l) -> Handler (Either Text (Text, FilePath))
, pjiRecipient :: Maybe UserId printLetter senderId (rcvr, letter) = do
, pjiSender :: Maybe UserId let rcvrId = rcvr ^. _entityKey
, pjiCourse :: Maybe CourseId encRecipient :: CryptoUUIDUser <- encrypt rcvrId
, pjiQualification :: Maybe QualificationId now <- liftIO getCurrentTime
, pjiLmsUser :: Maybe LmsIdent apcIdent <- letterApcIdent letter encRecipient now
} pdf <- renderLetter rcvr letter apcIdent
deriving (Eq, Show) let protoPji = getPJId letter
pji = protoPji
{ pjiRecipient = Just rcvrId
, pjiSender = senderId
, pjiName = "TEST_" <> pjiName protoPji
, pjiApcAcknowledge = apcIdent
}
actRight pdf $ runDB . printLetter' pji
-- DEPRECATED printLetter' :: PrintJobIdentification -> LBS.ByteString -> DB (Either Text (Text, FilePath))
sendLetter' :: Text -> LBS.ByteString -> (Maybe UserId, Maybe UserId) -> Maybe CourseId -> Maybe QualificationId -> Maybe LmsIdent -> DB (Either Text (Text, FilePath)) printLetter' pji pdf = do
sendLetter' printJobName pdf (printJobRecipient, printJobSender) printJobCourse printJobQualification printJobLmsUser = let PrintJobIdentification
sendLetter pdf PrintJobIdentification { pjiName = printJobName
{ pjiName = printJobName , pjiApcAcknowledge = printJobApcIdent
, pjiRecipient = printJobRecipient , pjiRecipient = printJobRecipient
, pjiSender = printJobSender , pjiSender = printJobSender
, pjiCourse = printJobCourse , pjiCourse = printJobCourse
, pjiQualification = printJobQualification , pjiQualification = printJobQualification
, pjiLmsUser = printJobLmsUser , pjiLmsUser = printJobLmsUser
} } = pji
sendLetter :: LBS.ByteString -> PrintJobIdentification -> DB (Either Text (Text, FilePath))
sendLetter pdf PrintJobIdentification{pjiName = printJobName, pjiRecipient = printJobRecipient, pjiSender = printJobSender, pjiCourse = printJobCourse, pjiQualification = printJobQualification, pjiLmsUser = printJobLmsUser} = do
recipient <- join <$> mapM get printJobRecipient recipient <- join <$> mapM get printJobRecipient
sender <- join <$> mapM get printJobSender sender <- join <$> mapM get printJobSender
course <- join <$> mapM get printJobCourse course <- join <$> mapM get printJobCourse
@ -344,8 +208,8 @@ sendLetter pdf PrintJobIdentification{pjiName = printJobName, pjiRecipient = pri
return $ Right (ok, printJobFilename) return $ Right (ok, printJobFilename)
{- {-
sendLetter'' :: _ -> DB PureFile printLetter'' :: _ -> DB PureFile
sendLetter'' _ = do printLetter'' _ = do
... ...
return $ File { fileTitle = printJobFilename return $ File { fileTitle = printJobFilename
, fileModified = printJobCreated , fileModified = printJobCreated
@ -353,127 +217,31 @@ sendLetter'' _ = do
} }
-} -}
{- Probably not needed:}
data SomeUserTime where
SomeUserTime :: HasLocalTime t => SelDateTimeFormat -> t -> SomeUserTime
data ProtoMeta = IsMeta P.MetaValue
| IsTime SomeUserTime
convertProto :: DateTimeFormatter -> ProtoMeta -> P.MetaValue
convertProto _ (IsMeta v) = v
convertProto f (IsTime t) = P.toMetaValue $ f t
-}
class MDLetter l where
getTemplate :: Proxy l -> Text
getMailSubject :: l -> SomeMessage UniWorX -- only used if letter is sent by email as pdf attachment
getMailBody :: l -> DateTimeFormatter -> HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX) -- only used if letter is sent by email as pdf attachment
letterMeta :: l -> DateTimeFormatter -> Lang -> P.Meta
getPJId :: l -> PrintJobIdentification
data LetterRenewQualificationF = LetterRenewQualificationF
{ lmsLogin :: LmsIdent
, lmsPin :: Text
, qualHolder :: UserDisplayName
, qualHolderSN :: UserSurname
, qualExpiry :: Day
, qualId :: QualificationId
, qualName :: Text
, qualShort :: Text
, qualSchool :: SchoolId
, qualDuration :: Maybe Int
}
deriving (Eq, Show)
-- this type is specific to this letter to avoid code duplication for derived data or constants
data LetterRenewQualificationFData = LetterRenewQualificationFData { lmsUrl, lmsUrlLogin, lmsIdent :: Text }
deriving (Eq, Show)
letterRenewalQualificationFData :: LetterRenewQualificationF -> LetterRenewQualificationFData
letterRenewalQualificationFData LetterRenewQualificationF{lmsLogin} = LetterRenewQualificationFData{..}
where
lmsUrl = "https://drive.fraport.de"
lmsUrlLogin = lmsUrl <> "/?login=" <> lmsIdent
lmsIdent = getLmsIdent lmsLogin
instance MDLetter LetterRenewQualificationF where
getTemplate _ = templateRenewal
getMailSubject l = SomeMessage $ MsgMailSubjectQualificationRenewal $ qualShort l
-- getMailBody l = SomeMessage $ MsgMailBodyQualificationRenewal $ qualName l
getMailBody l@LetterRenewQualificationF{..} DateTimeFormatter{ format } =
let LetterRenewQualificationFData{..} = letterRenewalQualificationFData l
in $(ihamletFile "templates/mail/body/qualificationRenewal.hamlet")
letterMeta l@LetterRenewQualificationF{..} DateTimeFormatter{ format } _lang =
let LetterRenewQualificationFData{..} = letterRenewalQualificationFData l
in mkMeta
[ toMeta "login" lmsIdent
, toMeta "pin" lmsPin
, toMeta "examinee" qualHolder
, toMeta "expiry" (format SelFormatDate qualExpiry)
, mbMeta "validduration" (show <$> qualDuration)
, toMeta "url-text" lmsUrl
, toMeta "url" lmsUrlLogin
]
getPJId LetterRenewQualificationF{..} =
PrintJobIdentification
{ pjiName = "Renewal"
, pjiRecipient = Nothing -- to be filled later
, pjiSender = Nothing
, pjiCourse = Nothing
, pjiQualification = Just qualId
, pjiLmsUser = Just lmsLogin
}
sendEmailOrLetter :: (MDLetter l) => UserId -> l -> Handler Bool sendEmailOrLetter :: (MDLetter l) => UserId -> l -> Handler Bool
sendEmailOrLetter recipient letter = do sendEmailOrLetter recipient letter = do
(underling, receivers, undercopy) <- updateReceivers recipient -- TODO: check to avoid this almost circular dependency (underling, receivers, undercopy) <- updateReceivers recipient -- TODO: check to avoid this almost circular dependency
let tmpl = getTemplate $ pure letter now <- liftIO getCurrentTime
pjid = getPJId letter let pjid = getPJId letter
-- Below are only needed if sent by email mailSubject = getMailSubject letter -- these are only needed if sent by email, but we're lazy anyway
mailSubject = getMailSubject letter
undername = underling ^. _userDisplayName -- nameHtml' underling undername = underling ^. _userDisplayName -- nameHtml' underling
undermail = CI.original $ underling ^. _userEmail undermail = CI.original $ underling ^. _userEmail
now <- liftIO getCurrentTime oks <- forM receivers $ \rcvrEnt@Entity{ entityKey = svr, entityVal = rcvrUsr } -> do
oks <- forM receivers $ \Entity{ entityKey = svr, entityVal = rcvrUsr } -> do encRecipient :: CryptoUUIDUser <- encrypt svr
formatter@DateTimeFormatter{ format } <- getDateTimeFormatterUser' rcvrUsr apcIdent <- letterApcIdent letter encRecipient now
let (preferPost, postal) = getPostalPreferenceAndAddress rcvrUsr let (preferPost, postal) = getPostalPreferenceAndAddress rcvrUsr
isSupervised = recipient /= svr -- mailBody = getMailBody letter formatter
lang = selectDeEn $ rcvrUsr & userLanguages -- select either German or English only, default de; see Utils.Lang renderLetter rcvrEnt letter apcIdent >>= \case
mailBody = getMailBody letter formatter _ | preferPost, isNothing postal -> do -- neither email nor postal is known
lMeta = letterMeta letter formatter lang <> mkMeta (
( if isSupervised
then
[ toMeta "supervisor" (rcvrUsr & userDisplayName)
, toMeta "de-opening" ("Sehr geehrte Damen und Herren,"::Text)
, toMeta "en-opening" ("Dear Sir or Madam,"::Text)
]
else []
) <>
[ toMeta "lang" lang
, toMeta "date" $ format SelFormatDate now
, toMeta "address" $ fromMaybe [rcvrUsr & userDisplayName] postal
]
)
pdfLetter tmpl lMeta >>= \case
_ | preferPost, isNothing postal -> do -- neither email nor postal is known
encRecipient :: CryptoUUIDUser <- encrypt svr
let msg = "Notification failed for " <> tshow encRecipient <> ", who has neither a known email nor postal address. Notification: " <> tshow pjid let msg = "Notification failed for " <> tshow encRecipient <> ", who has neither a known email nor postal address. Notification: " <> tshow pjid
$logErrorS "LETTER" msg $logErrorS "LETTER" msg
return False return False
Left err -> do -- pdf generation failed Left err -> do -- pdf generation failed
encRecipient :: CryptoUUIDUser <- encrypt svr
let msg = "Notification failed for " <> tshow encRecipient <> ". PDF generation failed: "<> cropText err <> "For Notification: " <> tshow pjid let msg = "Notification failed for " <> tshow encRecipient <> ". PDF generation failed: "<> cropText err <> "For Notification: " <> tshow pjid
$logErrorS "LETTER" msg $logErrorS "LETTER" msg
return False return False
Right pdf | preferPost -> -- send printed letter Right pdf | preferPost -> -- send printed letter
runDB (sendLetter pdf pjid{ pjiRecipient = Just svr}) >>= \case runDB (printLetter' pjid{pjiRecipient = Just svr, pjiApcAcknowledge = apcIdent} pdf) >>= \case
Left err -> do Left err -> do
encRecipient :: CryptoUUIDUser <- encrypt svr
let msg = "Notification failed for " <> tshow encRecipient <> ". PDF printing failed. The print job could not be sent: " <> cropText err let msg = "Notification failed for " <> tshow encRecipient <> ". PDF printing failed. The print job could not be sent: " <> cropText err
$logErrorS "LETTER" msg $logErrorS "LETTER" msg
return False return False
@ -483,20 +251,26 @@ sendEmailOrLetter recipient letter = do
$logWarnS "LETTER" $ "PDF printing to send letter with lpr returned ExitSuccess and the following message: " <> msg $logWarnS "LETTER" $ "PDF printing to send letter with lpr returned ExitSuccess and the following message: " <> msg
return True return True
Right pdf -> do -- send email Right pdf -> do -- send email
attachment <- case userPinPassword rcvrUsr of let pdfPass = case encrypPDFfor (pure letter) of
NoPassword -> Nothing
PasswordSupervisor -> rcvrUsr ^. _userPinPassword
PasswordUnderling -> underling ^. _userPinPassword
attachment <- case pdfPass of
Nothing -> return pdf Nothing -> return pdf
Just passwd -> encryptPDF passwd pdf >>= \case Just passwd -> encryptPDF passwd pdf >>= \case
Right encPdf -> return encPdf Right encPdf -> return encPdf
Left err -> do Left err -> do
encRecipient :: CryptoUUIDUser <- encrypt svr
let msg = "Notification for " <> tshow encRecipient <> " has unencrypted attachment. Encrypting PDF failed: " <> cropText err let msg = "Notification for " <> tshow encRecipient <> " has unencrypted attachment. Encrypting PDF failed: " <> cropText err
$logWarnS "LETTER" msg $logWarnS "LETTER" msg
return pdf return pdf
formatter <- getDateTimeFormatterUser' rcvrUsr -- not too expensive, only calls getTimeLocale
let isSupervised = recipient /= svr
supername = rcvrUsr ^. _userDisplayName -- nameHtml' rcvrUsr
mailBody = getMailBody letter formatter
userMailTdirect svr $ do userMailTdirect svr $ do
replaceMailHeader "Auto-Submitted" $ Just "auto-generated" replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
setSubjectI mailSubject setSubjectI mailSubject
editNotifications <- mkEditNotifications svr editNotifications <- mkEditNotifications svr
let supername = rcvrUsr ^. _userDisplayName -- nameHtml' rcvrUsr
addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/genericMailLetter.hamlet") addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/genericMailLetter.hamlet")
addPart (File { fileTitle = T.unpack $ pjiName pjid <> ".pdf" addPart (File { fileTitle = T.unpack $ pjiName pjid <> ".pdf"
, fileModified = now , fileModified = now
@ -571,13 +345,13 @@ encryptPDF pw bs = over _Left (decodeUtf8 . LBS.toStrict) . exit2either <$> read
-- The cups version of lpr is instead used like so: -- The cups version of lpr is instead used like so:
-- > lpr -P fradrive -H fravm017173.fra.fraport.de:515 -T printJobName - -- > lpr -P fradrive -H fravm017173.fra.fraport.de:515 -T printJobName -
-- | Internal only, use `sendLetter` instead -- | Internal only, use `printLetter` instead
lprPDF :: (MonadHandler m, HasAppSettings (HandlerSite m)) => Text -> LBS.ByteString -> m (Either Text Text) lprPDF :: (MonadHandler m, HasAppSettings (HandlerSite m)) => Text -> LBS.ByteString -> m (Either Text Text)
lprPDF jb bs = do lprPDF jb bs = do
mbLprServerArg <- $cachedHereBinary ("lprServer"::Text) getLprServerArg mbLprServerArg <- $cachedHereBinary ("lprServer"::Text) getLprServerArg
case mbLprServerArg of case mbLprServerArg of
Nothing -> return $ Right "Print command ignored due to setting 'mail-reroute-to' being set." Nothing -> return $ Right "Print command ignored due to setting 'mail-reroute-to' being set."
Just lprServerArg -> do Just lprServerArg -> do
let pc = setStdin (byteStringInput bs) $ let pc = setStdin (byteStringInput bs) $
proc "lpr" $ proc "lpr" $
jobname ++ -- -J jobname -- a name for job identification at printing site jobname ++ -- -J jobname -- a name for job identification at printing site
@ -590,10 +364,10 @@ lprPDF jb bs = do
exit2either <$> readProcess' pc exit2either <$> readProcess' pc
where where
getLprServerArg = do getLprServerArg = do
rerouteMail <- getsYesod $ view _appMailRerouteTo rerouteMail <- getsYesod $ view _appMailRerouteTo
case rerouteMail of case rerouteMail of
Just _ -> return Nothing Just _ -> return Nothing
Nothing -> do Nothing -> do
LprConf{..} <- getsYesod $ view _appLprConf LprConf{..} <- getsYesod $ view _appLprConf
return . Just $ "-P " <> lprQueue <> "@" <> lprHost <> ":" <> show lprPort return . Just $ "-P " <> lprQueue <> "@" <> lprHost <> ":" <> show lprPort

241
src/Utils/Print/Letters.hs Normal file
View File

@ -0,0 +1,241 @@
-- SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
module Utils.Print.Letters where
-- import Import.NoModel
import Import hiding (embedFile)
import Data.FileEmbed (embedFile)
import Data.Char as Char
import qualified Data.Text as Text
-- import qualified Data.CaseInsensitive as CI
import qualified Data.Foldable as Fold
import qualified Data.ByteString.Lazy as LBS
import Control.Monad.Except
import qualified Text.Pandoc as P
import qualified Text.Pandoc.PDF as P
import qualified Text.Pandoc.Builder as P
import Text.Hamlet
-- import System.Exit
-- import System.Process.Typed -- for calling pdftk for pdf encryption
-- import Handler.Utils.Users
import Handler.Utils.DateTime
-- import Handler.Utils.Mail
-- import Handler.Utils.Widgets (nameHtml, nameHtml')
-- import Handler.Utils.Avs (updateReceivers)
-- import Jobs.Handler.SendNotification.Utils
-- import Model.Types.Markup -- TODO-QSV: should this module be moved accordingly?
----------------------
-- Pandoc Functions --
----------------------
-- Either I don't understand how pandoc works or
-- I don't understand why these are not included
compileTemplate :: (P.PandocMonad m) => Text -> m (P.Template Text)
compileTemplate tmpl = do
let partialPath = "" -- no partials used, see Text.DocTemplates
mbTemplate <- P.runWithDefaultPartials $ P.compileTemplate partialPath tmpl
liftEither $ str2pandocError mbTemplate
where
str2pandocError = over _Left $ P.PandocTemplateError . pack
makePDF :: P.WriterOptions -> P.Pandoc -> P.PandocIO LBS.ByteString
-- makePDF :: (PandocMonad m, MonadIO m, MonadMask m) => P.WriterOptions -> P.Pandoc -> m LBS.ByteString -- only pandoc >= 2.18
makePDF wopts doc = do
mbPdf <- P.makePDF "lualatex" texopts P.writeLaTeX wopts doc
liftEither $ bs2pandocError mbPdf
where
texopts = []
bs2pandocError = over _Left (P.PandocMakePDFError . decodeUtf8 . LBS.toStrict)
_Meta :: Lens' P.Pandoc P.Meta
_Meta = lens mget mput
where
mget (P.Pandoc m _) = m
mput (P.Pandoc _ b) m = P.Pandoc m b
toMeta :: P.ToMetaValue a => Text -> a -> Map Text P.MetaValue
toMeta k = singletonMap k . P.toMetaValue
mbMeta :: P.ToMetaValue a => Text -> Maybe a -> Map Text P.MetaValue
mbMeta = foldMap . toMeta
-- | For convenience and to avoid importing Pandoc
mkMeta :: [Map Text P.MetaValue] -> P.Meta
mkMeta = P.Meta . mconcat
-- | Modify the Meta-Block of Pandoc
appMeta :: (P.Meta -> P.Meta) -> P.Pandoc -> P.Pandoc
appMeta f (P.Pandoc m bs) = P.Pandoc (f m) bs
-- appMeta f = _Meta %~ f -- lens version. Not sure this is better
-- TODO: applyMetas is inconvenient since we cannot have an instance
-- ToMetaValue a => ToMetaValue (Maybe a)
-- so apply Metas
-- For tests see module PandocSpec
applyMetas :: (P.HasMeta p, Foldable t, P.ToMetaValue a) => t (Text, Maybe a) -> p -> p
applyMetas metas doc = Fold.foldr act doc metas
where
act (k, Just v) acc | notNull k = P.setMeta k v acc
act _ acc = acc
-- | Add meta to pandoc. Existing variables will be overwritten.
-- For specification, see module PandocSpec
addMeta :: P.Meta -> P.Pandoc -> P.Pandoc
addMeta m = appMeta (<> m) -- Data.Map says: (<>) == union and union should prefer the left operand, but somehow it does not!
--addMeta m p = meta <> p
-- where meta = P.Pandoc m mempty
-- | Pandoc conditionals only test if a variable is set or isn't set.
-- Variable "is-de" will be set to True if the "lang" variable starts with "de"
-- and will be unset otherwise
setIsDeFromLang :: P.Meta -> P.Meta
setIsDeFromLang m
| (Just (P.MetaString t)) <- P.lookupMeta "lang" m
, isDe t = P.setMeta isde True m
| otherwise = P.deleteMeta isde m
where
isde = "is-de"
defReaderOpts :: P.ReaderOptions
defReaderOpts = def { P.readerExtensions = P.pandocExtensions, P.readerStripComments = True }
defWriterOpts :: P.Template Text -> P.WriterOptions
defWriterOpts t = def { P.writerExtensions = P.pandocExtensions, P.writerTemplate = Just t }
-------------------------
-- Hardcoded Templates --
-------------------------
data LetterKind = Din5008 -- scrlttr2: Standard postal letter with address field, expects peprinted FraportLogo
| PinLetter -- Like Din5008, but for special paper with a protected pin field
| Plain -- scrartcl: Empty, expects empty paper with no preprints
| PlainLogo -- Like plain, but expects to be printed on paper with Logo
-- | Logo -- Like plain, but prints Fraport Logo in the upper right corner
deriving (Eq, Show)
templateLatex :: LetterKind -> Text
templateLatex =
let
tDin5008 = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/din5008.latex")
tPinLetter = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/din5008with_pin.latex")
tPlain = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/plain_article.latex")
in \case
PinLetter -> tPinLetter
Din5008 -> tDin5008
PlainLogo -> tPlain
Plain -> tPlain
paperKind :: LetterKind -> Text -- Muss genau 5 Zeichen haben!
paperKind PinLetter = "a4pin" -- Pin-Brief
paperKind Plain = "a4wht" -- Ohne Logo
paperKind Din5008 = "a4log" -- Mit Logo
paperKind PlainLogo = "a4log"
---------------
-- PrintJobs --
---------------
apcIdentSeparator :: Text
apcIdentSeparator = Text.take 3 "___" -- must always have length 3
data PrintJobIdentification = PrintJobIdentification
{ pjiName :: Text
, pjiApcAcknowledge :: Text
, pjiRecipient :: Maybe UserId
, pjiSender :: Maybe UserId
, pjiCourse :: Maybe CourseId
, pjiQualification :: Maybe QualificationId
, pjiLmsUser :: Maybe LmsIdent
}
deriving (Eq, Show)
-- | create an identifier for printing with apc; which must always be place with the same length; exept for the last part which may be of variable length
-- this is printed in white on white at the exact same position on the page
-- Note: that all letters to the same UUID within 24h are collated in one envelope
-- Example: 9ad8de3f-0a7e-ede5-bd8b-6d0ed85c1049-f___a4pin___230322-10___lms-stuvwxyz
mkApcIdent :: CryptoUUIDUser -> Char -> LetterKind -> Text -> Text -> Text
mkApcIdent uuid envelope lk tnow apcAck = Text.filter apcAcceptedChars $ Text.intercalate apcIdentSeparator
[ ensureLength 38 $ tshow (ciphertext uuid) <> Text.cons '-' (Text.singleton envelope)
, ensureLength 5 $ paperKind lk
, ensureLength 9 tnow
, apcAck -- length may be arbitrary, thus far was always 12
]
where
ensureLength :: Int -> Text -> Text
ensureLength n = Text.take n . Text.justifyLeft n 'x'
-- | Character allowed to be included in the APC identifier string printed in white in the header of all printed letters, must not contain ',' nor ';'
apcAcceptedChars :: Char -> Bool
apcAcceptedChars '-' = True
apcAcceptedChars '_' = True
apcAcceptedChars c = isAlphaNum c
------------------
-- Letter Class --
------------------
{- Probably not needed:}
data SomeUserTime where
SomeUserTime :: HasLocalTime t => SelDateTimeFormat -> t -> SomeUserTime
data ProtoMeta = IsMeta P.MetaValue
| IsTime SomeUserTime
convertProto :: DateTimeFormatter -> ProtoMeta -> P.MetaValue
convertProto _ (IsMeta v) = v
convertProto f (IsTime t) = P.toMetaValue $ f t
-}
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
getPJId :: l -> PrintJobIdentification
getLetterEnvelope :: l -> Char
getLetterKind :: Proxy l -> LetterKind
getTemplate :: Proxy l -> Text
encrypPDFfor :: Proxy l -> EncryptPDFfor
letterApcIdent :: (MDLetter l, MonadHandler m) => l -> CryptoUUIDUser -> UTCTime -> m Text
letterApcIdent l uuid now = do
-- now <- liftIO getCurrentTime
tnow <- formatTime' "%y%m%d-%H" now
return $ mkApcIdent uuid (getLetterEnvelope l) (getLetterKind $ pure l) tnow (pjiApcAcknowledge $ getPJId l)
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

86
src/Utils/Print/RenewQualification.hs Normal file
View File

@ -0,0 +1,86 @@
-- SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
module Utils.Print.RenewQualification where
import Import
import Text.Hamlet
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.Widgets (nameHtml) -- , nameHtml')
data LetterRenewQualificationF = LetterRenewQualificationF
{ lmsLogin :: LmsIdent
, lmsPin :: Text
, qualHolderID :: UserId
, qualHolderDN :: UserDisplayName
, qualHolderSN :: UserSurname
, qualExpiry :: Day
, qualId :: QualificationId
, qualName :: Text
, qualShort :: Text
, qualSchool :: SchoolId
, qualDuration :: Maybe Int
}
deriving (Eq, Show)
-- this datatype is specific to this letter only, and just to avoid code duplication for derived data or constants
data LetterRenewQualificationFData = LetterRenewQualificationFData { lmsUrl, lmsUrlLogin, lmsIdent :: Text }
deriving (Eq, Show)
letterRenewalQualificationFData :: LetterRenewQualificationF -> LetterRenewQualificationFData
letterRenewalQualificationFData LetterRenewQualificationF{lmsLogin} = LetterRenewQualificationFData{..}
where
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")
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}} =
let LetterRenewQualificationFData{..} = letterRenewalQualificationFData l
isSupervised = rcvrId /= qualHolderID
in mkMeta $
guardMonoid isSupervised
[ toMeta "supervisor" userDisplayName
, toMeta "de-opening" ("Sehr geehrte Damen und Herren,"::Text)
, toMeta "en-opening" ("Dear Sir or Madam,"::Text)
] <>
[ toMeta "login" lmsIdent
, toMeta "pin" lmsPin
, toMeta "examinee" qualHolderDN
, toMeta "expiry" (format SelFormatDate qualExpiry)
, mbMeta "validduration" (show <$> qualDuration)
, toMeta "url-text" lmsUrl
, toMeta "url" lmsUrlLogin
]
getPJId LetterRenewQualificationF{..} =
PrintJobIdentification
{ pjiName = "Renewal"
, pjiApcAcknowledge = "lms-" <> getLmsIdent lmsLogin
, pjiRecipient = Nothing -- to be filled later
, pjiSender = Nothing
, pjiCourse = Nothing
, pjiQualification = Just qualId
, pjiLmsUser = Just lmsLogin
}

2
start.sh
View File

@ -29,6 +29,8 @@ export RIBBON=${RIBBON:-${__HOST:-localhost}}
export APPROOT=${APPROOT:-http://localhost:$((${PORT_OFFSET:-0} + 3000))} export APPROOT=${APPROOT:-http://localhost:$((${PORT_OFFSET:-0} + 3000))}
export AVSPASS=${AVSPASS:-nopasswordset} export AVSPASS=${AVSPASS:-nopasswordset}
export PATH=${PATH:/home/jost/projects/fradrive} export PATH=${PATH:/home/jost/projects/fradrive}
export MAIL_REROUTE_TO_NAME='Steffen Jost'
export MAIL_REROUTE_TO_EMAIL=jost@tcs.ifi.lmu.de
unset HOST unset HOST
move-back() { move-back() {

9
templates/course.hamlet
View File

@ -78,6 +78,15 @@ $# #{summary}
<dd .deflist__dd> <dd .deflist__dd>
#{schoolName} #{schoolName}
$if length courseQualifications > 0
<dt .deflist__dt>_{MsgCourseQualifications (length courseQualifications)}
<dd .deflist__dd>
<ul .list--inline .list--comma-separated>
$forall Entity{entityVal=Qualification{qualificationName=qName,qualificationShorthand=qShort}} <- courseQualifications
<li>
<a href=@{QualificationR ssh qShort}>
#{qName}
$with numlecs <- length lecturers $with numlecs <- length lecturers
$if numlecs /= 0 $if numlecs /= 0
$if numlecs > 1 $if numlecs > 1

4
templates/i18n/admin-test/de-de-formal.hamlet
View File

@ -81,10 +81,10 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
<h2> <h2>
Erzeugtes PDF herunterladen: Erzeugtes PDF herunterladen:
<p> <p>
Hier ist ein Hier ist ein #
<a href=@{AdminTestPdfR}> <a href=@{AdminTestPdfR}>
Download-Link Download-Link
für eine PDF Vorschau. \ für eine PDF Vorschau.
<p> <p>
Zusätzlich wird dabei im Verzeichnis /tmp Zusätzlich wird dabei im Verzeichnis /tmp
das PDF mit und ohne Passwort gespeichert. das PDF mit und ohne Passwort gespeichert.

4
templates/i18n/admin-test/en-eu.hamlet
View File

@ -81,10 +81,10 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
<h2> <h2>
Download a generated PDF Download a generated PDF
<p> <p>
Here is a Here is a #
<a href=@{AdminTestPdfR}> <a href=@{AdminTestPdfR}>
Download-Link Download-Link
for a preview. \ for a preview.
<p> <p>
Following the link, the pdf will also be saved Following the link, the pdf will also be saved
to the /tmp directory, once without to the /tmp directory, once without

7
templates/i18n/avs-synchronisation/de-de-formal.hamlet
View File

@ -4,13 +4,6 @@ $# SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
$# $#
$# SPDX-License-Identifier: AGPL-3.0-or-later $# SPDX-License-Identifier: AGPL-3.0-or-later
<section>
<h1>
HINWEIS
<p>
Momentan werden aus Effizienzgründen alle Tabellen beschnitten und abgekürzt. #
Auch die Funktion zum Import unbekannter Führerscheininhaber ist derzeit auf ein paar Hundert beschränkt.
<section> <section>
<h2> <h2>
Personendaten aller AVS Fahrberechtigten Personendaten aller AVS Fahrberechtigten

7
templates/i18n/changelog/supervisors-may-revoke-licences.de-de-formal.hamlet Normal file
View File

@ -0,0 +1,7 @@
$newline never
$# SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
$#
$# SPDX-License-Identifier: AGPL-3.0-or-later
Ansprechpartner können nun Fahrerlizenzen zurückgeben oder als auslaufend markieren

7
templates/i18n/changelog/supervisors-may-revoke-licences.en-eu.hamlet Normal file
View File

@ -0,0 +1,7 @@
$newline never
$# SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
$#
$# SPDX-License-Identifier: AGPL-3.0-or-later
Supervisors may revoke driving licence qualifications or mark them to expire without renewal

30
templates/letter/din5008.latex
View File

@ -80,7 +80,7 @@ $endif$
%\usepackage[a4paper, bottom=8cm, top=3cm]{geometry} %%% THIS HAD NO EFFECT AT ALL %\usepackage[a4paper, bottom=8cm, top=3cm]{geometry} %%% THIS HAD NO EFFECT AT ALL
\usepackage{parskip} \usepackage{parskip}% might be useful for pandoc tightlist
\usepackage{graphics} \usepackage{graphics}
\usepackage{xcolor} \usepackage{xcolor}
@ -120,7 +120,11 @@ $endif$
} }
\setkomavar{fromphone}{$phone$} \setkomavar{fromphone}{$phone$}
\setkomavar{fromemail}{$email$} \setkomavar{fromemail}{$email$}
\setkomavar{signature}{$author$} %if there is a handwritten signature
%\setkomavar{signature}{$author$}
%if there is no handwritten signature
\setkomavar{signature}{}
\setplength{sigbeforevskip}{-\baselineskip}
\setkomavar{date}{$date$} \setkomavar{date}{$date$}
\setkomavar{place}{$place$} \setkomavar{place}{$place$}
@ -137,25 +141,17 @@ $endif$
$endfor$ $endfor$
} }
$if(apc-ident)$
\begin{textblock}{200}(5,5)%hpos,vpos
\textcolor{white!0}{$apc-ident$}%
\end{textblock}%
$endif$
$if(is-de)$ $if(is-de)$
\opening{$de-opening$} \opening{$de-opening$}
$else$ $else$
\opening{$en-opening$} \opening{$en-opening$}
$endif$ $endif$
\begin{textblock}{65}(84,232)%hpos,vpos
\textcolor{black!39}{
\begin{labeling}{Password:}
$if(is-de)$
\item[Benutzer:] \texttt{$login$}
\item[Passwort:] \texttt{$pin$}
$else$
\item[User:] \texttt{$login$}
\item[Password:] \texttt{$pin$}
$endif$
\end{labeling}
~}
\end{textblock}
$body$ $body$

185
templates/letter/din5008with_pin.latex Normal file
View File

@ -0,0 +1,185 @@
%Based upon https://github.com/benedictdudel/pandoc-letter-din5008
\documentclass[
paper=A4,
foldmarks=BTm, % show foldmarks top, middle, bottom
foldmarks=false, % don't print foldmarks
fromalign=left, % letter head on the right
fromphone=true, % show phone number
fromemail=true, % show email
fromlogo=false, % don't show logo in letter head
version=last, % latest version of KOMA letter
pagenumber=botright, % show pagenumbers on bottom right
firstfoot=false % first-page footer
]{scrlttr2}
\PassOptionsToPackage{hyphens}{url}
\PassOptionsToPackage{unicode$for(hyperrefoptions)$,$hyperrefoptions$$endfor$}{hyperref}
\IfFileExists{xurl.sty}{\usepackage{xurl}}{} % add URL line breaks if available
\IfFileExists{bookmark.sty}{\usepackage{bookmark}}{\usepackage{hyperref}}
\hypersetup{
$if(title-meta)$
pdftitle={$title-meta$},
$endif$
$if(author-meta)$
pdfauthor={$author-meta$},
$endif$
$if(lang)$
pdflang={$lang$},
$endif$
$if(subject)$
pdfsubject={$subject$},
$endif$
$if(keywords)$
pdfkeywords={$for(keywords)$$keywords$$sep$, $endfor$},
$endif$
}
\usepackage{url}
\usepackage{iftex}
%\usepackage[ngerman]{babel}
$if(lang)$
\ifLuaTeX
\usepackage[bidi=basic]{babel}
\else
\usepackage[bidi=default]{babel}
\fi
\babelprovide[main,import]{$babel-lang$}
$for(babel-otherlangs)$
\babelprovide[import]{$babel-otherlangs$}
$endfor$
% get rid of language-specific shorthands (see #6817):
\let\LanguageShortHands\languageshorthands
\def\languageshorthands#1{}
$endif$
\ifLuaTeX
\usepackage{selnolig} % disable illegal ligatures
\fi
\ifPDFTeX
\usepackage[$if(fontenc)$$fontenc$$else$T1$endif$]{fontenc}
\usepackage[utf8]{inputenc}
\usepackage{textcomp} % provide euro and other symbols
\usepackage{DejaVuSansMono} % better monofont
\else
% if luatex or xetex
\usepackage{fontspec}
\setmonofont{DejaVu Sans Mono}
\fi
$if(mathspec)$
\ifXeTeX
\usepackage{mathspec}
\else
\usepackage{unicode-math}
\fi
$else$
\usepackage{unicode-math}
$endif$
%\usepackage[a4paper, bottom=8cm, top=3cm]{geometry} %%% THIS HAD NO EFFECT AT ALL
\usepackage{parskip}% might be useful for pandoc tightlist
\usepackage{graphics}
\usepackage{xcolor}
\usepackage{booktabs}
\usepackage{longtable}
\usepackage[right]{eurosym}
\usepackage{enumitem}
\makeatletter
\setplength{firstheadvpos}{1.8cm}
\setplength{toaddrvpos}{5.5cm}
\setlength{\@tempskipa}{-1.2cm}%
\@addtoplength{toaddrheight}{\@tempskipa}
\makeatother
\setlength{\oddsidemargin}{\useplength{toaddrhpos}}
\addtolength{\oddsidemargin}{-1in}
\setlength{\textwidth}{\useplength{firstheadwidth}}
\usepackage[absolute,quiet,overlay]{textpos}%,showboxes
\setlength{\TPHorizModule}{1mm}
\setlength{\TPVertModule}{1mm}
\providecommand{\tightlist}{%
\setlength{\itemsep}{0pt}\setlength{\parskip}{0pt}}
\begin{document}%
\setkomavar{fromname}{$author$}%
\renewcommand*{\raggedsignature}{\raggedright}%
\setkomavar{fromaddress}{%
$for(return-address)$%
$return-address$$sep$\\
$endfor$
}
\setkomavar{fromphone}{$phone$}
\setkomavar{fromemail}{$email$}
%if there is a handwritten signature
%\setkomavar{signature}{$author$}
%if there is no handwritten signature
\setkomavar{signature}{}
\setplength{sigbeforevskip}{-\baselineskip}
\setkomavar{date}{$date$}
\setkomavar{place}{$place$}
$if(is-de)$
\setkomavar{subject}{$de-subject$}
$else$
\setkomavar{subject}{$en-subject$}
$endif$
\begin{letter}{%
$for(address)$
$address$$sep$\\
$endfor$
}
$if(apc-ident)$
\begin{textblock}{200}(5,5)%hpos,vpos
\textcolor{white!0}{$apc-ident$}%
\end{textblock}%
$endif$
$if(is-de)$
\opening{$de-opening$}
$else$
\opening{$en-opening$}
$endif$
\begin{textblock}{65}(84,232)%hpos,vpos
\textcolor{black!39}{
\begin{labeling}{Password:}%Achtung! Die Position des Logins muss sprachunabhängig immer an der gleichen Position sein, sonst kannn die Rückmeldung der Druckerei den Ident nicht mehr identifizieren!
$if(is-de)$
\item[Benutzer:] \texttt{$login$}
\item[Passwort:] \texttt{$pin$}
$else$
\item[User:] \texttt{$login$}
\item[Password:] \texttt{$pin$}
$endif$
\end{labeling}
~}
\end{textblock}
$body$
$if(is-de)$
\closing{$de-closing$}
$else$
\closing{$en-closing$}
$endif$
%\ps $postskriptum$
$if(encludes)$
\setkomavar*{enclseparator}{Anlage}
\encl{$encludes$}
$endif$
\end{letter}
\end{document}

15
templates/letter/fraport_qualification.md Normal file
View File

@ -0,0 +1,15 @@
---
### Metaddaten, welche hier eingestellt werden:
### Metadaten, welche automatisch ersetzt werden:
lang: de-de
is-de: true
date: 11.11.1111
...
$if(is-de)$
<!-- deutsche version -->
$else$
<!-- english version -->

23
templates/letter/fraport_renewal.md
View File

@ -12,10 +12,10 @@ return-address:
de-opening: Liebe Fahrberechtigungsinhaber, de-opening: Liebe Fahrberechtigungsinhaber,
en-opening: Dear driver, en-opening: Dear driver,
de-closing: | de-closing: |
Mit freundlichen Grüßen, Mit freundlichen Grüßen,
Ihre Fahrerausbildung Ihre Fahrerausbildung
en-closing: | en-closing: |
With kind regards, With kind regards,
Your Fraport Driver Training Your Fraport Driver Training
encludes: encludes:
hyperrefoptions: hidelinks hyperrefoptions: hidelinks
@ -29,11 +29,12 @@ lang: de-de
is-de: true is-de: true
login: 123456 login: 123456
pin: abcdef pin: abcdef
paper: pin
# Emfpänger # Emfpänger
examinee: E. M. Pfänger examinee: P. Rüfling
address: address:
- Musterfirma GmbH
- E. M. Pfänger - E. M. Pfänger
- Musterfirma GmbH
- Musterstraße 11 - Musterstraße 11
- 12345 Musterstadt - 12345 Musterstadt
... ...
@ -66,10 +67,10 @@ $if(validduration)$
$endif$ $endif$
verlängert werden. verlängert werden.
$if(supervisor)$ $if(supervisor)$
Ansprechpartner werden gebeten, die Login-Daten aus dem geschützen Sichtfenster weiter unten Ansprechpartner werden gebeten, die Anmeldedaten weiter unten
vertraulich an den Fahrberechtigungsinhaber weiterzuleiten. vertraulich an den Fahrberechtigungsinhaber weiterzuleiten.
$else$ $else$
Dazu bitte die Login-Daten aus dem geschützen Sichtfenster weiter unten verwenden. Dazu bitte die Anmeldedaten aus dem geschützen Sichtfenster weiter unten verwenden.
$endif$ $endif$
Fahrberechtigungsinhaber Fahrberechtigungsinhaber
@ -80,7 +81,7 @@ Ablaufdatum
: $expiry$ : $expiry$
URL Webseite der Prüfung
: [$url-text$]($url$) : [$url-text$]($url$)
@ -89,7 +90,7 @@ Sollte bis zum Ablaufdatum das E-Learning nicht erfolgreich abgeschlossen sein,
zur Wiedererlangung der Fahrberechtigung "F" erneut ein Grundkurs zur Wiedererlangung der Fahrberechtigung "F" erneut ein Grundkurs
bei der Fahrerausbildung absolviert werden. bei der Fahrerausbildung absolviert werden.
Bei Fragen können Sie sich gerne an das Team der Fahrerausbildung wenden. Bei Fragen können Sie sich gerne an das Team der Fahrerausbildung wenden.
(Please contact us if you prefer letters in English.!) (Please contact us if you prefer letters in English.)
$else$ $else$
@ -108,7 +109,7 @@ by successfully participating in
an e-learning. an e-learning.
$if(supervisor)$ $if(supervisor)$
Supervisors are kindly requested to forward the login data Supervisors are kindly requested to forward the login data
from the protected area below confidentially to the examinee. below confidentially to the examinee.
$else$ $else$
Please use the login data from the protected area below. Please use the login data from the protected area below.
$endif$ $endif$
@ -121,7 +122,7 @@ Expiry
: $expiry$ : $expiry$
URL Examination Website
: [$url-text$]($url$) : [$url-text$]($url$)
@ -137,6 +138,6 @@ $endif$
Please contact the Fraport driving school team, if you need any assistance. Please contact the Fraport driving school team, if you need any assistance.
(Kontaktieren Sie uns, wenn Sie zukünftige Briefe in deutscher Sprache bevorzugen.) (Kontaktieren Sie uns bitte, wenn Sie zukünftige Briefe in deutscher Sprache bevorzugen.)
$endif$ $endif$

107
templates/letter/plain_article.latex Normal file
View File

@ -0,0 +1,107 @@
%Based upon https://github.com/benedictdudel/pandoc-letter-din5008
\documentclass[
paper=A4,
firstfoot=false % first-page footer
]{scrlttr2}
\PassOptionsToPackage{hyphens}{url}
\PassOptionsToPackage{unicode$for(hyperrefoptions)$,$hyperrefoptions$$endfor$}{hyperref}
\IfFileExists{xurl.sty}{\usepackage{xurl}}{} % add URL line breaks if available
\IfFileExists{bookmark.sty}{\usepackage{bookmark}}{\usepackage{hyperref}}
\hypersetup{
$if(title-meta)$
pdftitle={$title-meta$},
$endif$
$if(author-meta)$
pdfauthor={$author-meta$},
$endif$
$if(lang)$
pdflang={$lang$},
$endif$
$if(subject)$
pdfsubject={$subject$},
$endif$
$if(keywords)$
pdfkeywords={$for(keywords)$$keywords$$sep$, $endfor$},
$endif$
}
\usepackage{url}
\usepackage{iftex}
%\usepackage[ngerman]{babel}
$if(lang)$
\ifLuaTeX
\usepackage[bidi=basic]{babel}
\else
\usepackage[bidi=default]{babel}
\fi
\babelprovide[main,import]{$babel-lang$}
$for(babel-otherlangs)$
\babelprovide[import]{$babel-otherlangs$}
$endfor$
% get rid of language-specific shorthands (see #6817):
\let\LanguageShortHands\languageshorthands
\def\languageshorthands#1{}
$endif$
\ifLuaTeX
\usepackage{selnolig} % disable illegal ligatures
\fi
\ifPDFTeX
\usepackage[$if(fontenc)$$fontenc$$else$T1$endif$]{fontenc}
\usepackage[utf8]{inputenc}
\usepackage{textcomp} % provide euro and other symbols
\usepackage{DejaVuSansMono} % better monofont
\else
% if luatex or xetex
\usepackage{fontspec}
\setmonofont{DejaVu Sans Mono}
\fi
$if(mathspec)$
\ifXeTeX
\usepackage{mathspec}
\else
\usepackage{unicode-math}
\fi
$else$
\usepackage{unicode-math}
$endif$
%\usepackage[a4paper, bottom=8cm, top=3cm]{geometry} %%% THIS HAD NO EFFECT AT ALL
\usepackage{parskip}% might be useful for pandoc tightlist
\usepackage{graphics}
\usepackage{xcolor}
\usepackage{booktabs}
\usepackage{longtable}
\usepackage[right]{eurosym}
\usepackage{enumitem}
\setlength{\oddsidemargin}{\useplength{toaddrhpos}}
\addtolength{\oddsidemargin}{-1in}
\setlength{\textwidth}{\useplength{firstheadwidth}}
\usepackage[absolute,quiet,overlay]{textpos}%,showboxes
\setlength{\TPHorizModule}{1mm}
\setlength{\TPVertModule}{1mm}
\providecommand{\tightlist}{%
\setlength{\itemsep}{0pt}\setlength{\parskip}{0pt}}
\begin{document}%
$if(apc-ident)$
\begin{textblock}{200}(5,5)%hpos,vpos
\textcolor{white!0}{$apc-ident$}%
\end{textblock}%
$endif$
$body$
\end{document}

7
templates/lms-user.hamlet
View File

@ -7,11 +7,11 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
$if null quals $if null quals
_{MsgQualificationUserNone} _{MsgQualificationUserNone}
$else $else
$forall (Entity _ quali, mbQualUsr, mbLmsUsr) <- quals $forall (Entity _ quali, mbQualUsr, mbLmsUsr, validity) <- quals
<section> <section>
<div .container> <div .container>
<h2> <h2>
#{qualificationShorthand quali} - #{qualificationName quali} - #{qualificationSchool quali} #{qualificationShorthand quali} - #{qualificationName quali} (#{qualificationSchool quali}) &nbsp; #{boolSymbol (E.unValue validity)}
<div .container> <div .container>
<dl .deflist> <dl .deflist>
$maybe (Entity _ qualUsr) <- mbQualUsr $maybe (Entity _ qualUsr) <- mbQualUsr
@ -41,7 +41,8 @@ $else
<dd .deflist__dd > <dd .deflist__dd >
<span .email> <span .email>
#{lmsUserPin lmsUsr} #{lmsUserPin lmsUsr}
\ ^{formatTimeW SelFormatDateTime (lmsUserDatePin lmsUsr)} <br>
^{formatTimeW SelFormatDateTime (lmsUserDatePin lmsUsr)}
$if lmsUserResetPin lmsUsr $if lmsUserResetPin lmsUsr
\ #{icon IconReset} \ #{icon IconReset}
$maybe ts <- lmsUserReceived lmsUsr $maybe ts <- lmsUserReceived lmsUsr

4
templates/mail/body/qualificationRenewal.hamlet
View File

@ -14,7 +14,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
<a href=@{QualificationR qualSchool (CI.mk qualShort)}> <a href=@{QualificationR qualSchool (CI.mk qualShort)}>
#{qualName} #{qualName}
<dt>_{SomeMessage MsgLmsUser} <dt>_{SomeMessage MsgLmsUser}
<dd>#{nameHtml qualHolder qualHolderSN} <dd>#{nameHtml qualHolderDN qualHolderSN}
<dt>_{SomeMessage MsgLmsQualificationValidUntil} <dt>_{SomeMessage MsgLmsQualificationValidUntil}
<dd>#{format SelFormatDate qualExpiry} <dd>#{format SelFormatDate qualExpiry}
@ -22,4 +22,4 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
_{SomeMessage MsgLmsRenewalInstructions} # _{SomeMessage MsgLmsRenewalInstructions} #
<a href=#{lmsUrlLogin}> <a href=#{lmsUrlLogin}>
_{SomeMessage MsgMppURL} #{lmsUrl} _{SomeMessage MsgLmsURL} #{lmsUrl}

4
templates/mail/genericMailLetter.hamlet
View File

@ -36,8 +36,8 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
<p> <p>
_{SomeMessage MsgMailSupervisedBody} _{SomeMessage MsgMailSupervisedBody}
<ul> <ul>
$forall svr <- receivers $forall csupr <- receivers
<li> <li>
#{nameHtml' svr} #{nameHtml' csupr}
^{ihamletSomeMessage editNotifications} ^{ihamletSomeMessage editNotifications}

8
templates/profileData.hamlet
View File

@ -56,12 +56,16 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
<dt .deflist__dt> <dt .deflist__dt>
_{MsgUserDisplayEmail} _{MsgUserDisplayEmail}
<dd .deflist__dd .email> <dd .deflist__dd .email>
#{userDisplayEmail} #{mailtoHtml userDisplayEmail}
$if not (validEmail' userDisplayEmail)
\ ^{messageTooltip tooltipInvalidEmail}
$if userEmail /= userDisplayEmail $if userEmail /= userDisplayEmail
<dt .deflist__dt> <dt .deflist__dt>
_{MsgUserSystemEmail} _{MsgUserSystemEmail}
<dd .deflist__dd> <dd .deflist__dd>
#{mailtoHtml userEmail} #{userEmail}
$if not (validEmail' userEmail)
\ ^{messageTooltip tooltipInvalidEmail}
<dt .deflist__dt> <dt .deflist__dt>
_{MsgAdminUserPinPassword} _{MsgAdminUserPinPassword}
<dd .deflist__dd> <dd .deflist__dd>

62
templates/qualification.hamlet
View File

@ -4,38 +4,40 @@ $# SPDX-FileCopyrightText: 2022 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen J
$# $#
$# SPDX-License-Identifier: AGPL-3.0-or-later $# SPDX-License-Identifier: AGPL-3.0-or-later
<dl .deflist> <section>
$maybe descr <- qualificationDescription quali <dl .deflist>
<dt .deflist__dt>_{MsgQualificationDescription} $maybe descr <- qualificationDescription quali
<dd .deflist__dd> <dt .deflist__dt>_{MsgQualificationDescription}
<div> <dd .deflist__dd>
#{descr} <div>
$maybe dvalid <- qualificationValidDuration quali #{descr}
<dt .deflist__dt>_{MsgQualificationValidDuration} $maybe dvalid <- qualificationValidDuration quali
<dd .deflist__dd>_{MsgMonths (fromIntegral dvalid)} <dt .deflist__dt>_{MsgQualificationValidDuration}
<dd .deflist__dd>_{MsgMonths (fromIntegral dvalid)}
$maybe daudit <- qualificationAuditDuration quali $maybe daudit <- qualificationAuditDuration quali
<dt .deflist__dt>_{MsgQualificationAuditDuration} <dt .deflist__dt>_{MsgQualificationAuditDuration}
<dd .deflist__dd>_{MsgMonths (fromIntegral daudit)} <dd .deflist__dd>_{MsgMonths (fromIntegral daudit)}
$maybe drefresh <- qualificationRefreshWithin quali $maybe drefresh <- qualificationRefreshWithin quali
<dt .deflist__dt>_{MsgQualificationRefreshWithin} ^{iconTooltip (msg2widget MsgQualificationRefreshWithinTooltip) Nothing True} <dt .deflist__dt>_{MsgQualificationRefreshWithin} ^{iconTooltip (msg2widget MsgQualificationRefreshWithinTooltip) Nothing True}
<dd .deflist__dd> <dd .deflist__dd>
$with drm <- cdMonths drefresh $with drm <- cdMonths drefresh
$with drd <- cdDays drefresh $with drd <- cdDays drefresh
$if drm > 0 $if drm > 0
_{MsgMonths (fromIntegral drm)} _{MsgMonths (fromIntegral drm)}
$if drd > 0
, #
$if drd > 0 $if drd > 0
, # _{MsgDays (fromIntegral drd)}
$if drd > 0
_{MsgDays (fromIntegral drd)}
<dt .deflist__dt>_{MsgQualificationElearningStart} <dt .deflist__dt>_{MsgQualificationElearningStart}
<dd .deflist__dd>#{boolSymbol (qualificationElearningStart quali)} <dd .deflist__dd>#{boolSymbol (qualificationElearningStart quali)}
$if (qualificationElearningStart quali) && isNothing (qualificationRefreshWithin quali) $if (qualificationElearningStart quali) && isNothing (qualificationRefreshWithin quali)
<p> <p>
#{icon IconNotificationError} #{icon IconNotificationError}
_{MsgLmsErrorNoRefreshElearning} _{MsgLmsErrorNoRefreshElearning}
^{qualificationTable} <section>
^{qualificationTable}

6
templates/system-message.hamlet
View File

@ -13,6 +13,6 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
$maybe (messageEditModal, translationAddModal, translationsEditModal) <- forms $maybe (messageEditModal, translationAddModal, translationsEditModal) <- forms
<section> <section>
^{messageEditModal} ^{messageEditModal} #
^{translationAddModal} ^{translationAddModal} #
^{translationsEditModal} ^{translationsEditModal} #

72
test/Database/Fill.hs
View File

@ -57,8 +57,8 @@ fillDb = do
addBDays = addBusinessDays Fraport -- holiday area to use addBDays = addBusinessDays Fraport -- holiday area to use
n_day n = addBDays n $ utctDay now n_day n = addBDays n $ utctDay now
n_day' n = now { utctDay = n_day n } n_day' n = now { utctDay = n_day n }
currentTerm = TermIdentifier . fst3 . toGregorian $ utctDay now (currentYear, _currentMonth, _currentDay) = toGregorian $ utctDay now
-- (currentYear, currentMonth, currentDay) = toGregorian $ getTermDay currentTerm currentTerm = TermIdentifier currentYear
nextTerm n = toEnum . (+n) $ fromEnum currentTerm nextTerm n = toEnum . (+n) $ fromEnum currentTerm
termTime :: TermIdentifier -- ^ Term termTime :: TermIdentifier -- ^ Term
@ -106,9 +106,9 @@ fillDb = do
, userCompanyPersonalNumber = Just "00000" , userCompanyPersonalNumber = Just "00000"
, userCompanyDepartment = Nothing , userCompanyDepartment = Nothing
, userPinPassword = Nothing , userPinPassword = Nothing
, userPostAddress = Nothing , userPostAddress = Just $ markdownToStoredMarkup ("Büro 127 \nMathematisches Institut der Ludwig-Maximilians-Universität München \nTheresienstr. 39 \nD-80333 München"::Text)
, userPostLastUpdate = Nothing , userPostLastUpdate = Nothing
, userPrefersPostal = False , userPrefersPostal = True
, userExamOfficeGetSynced = userDefaultExamOfficeGetSynced , userExamOfficeGetSynced = userDefaultExamOfficeGetSynced
, userExamOfficeGetLabels = userDefaultExamOfficeGetLabels , userExamOfficeGetLabels = userDefaultExamOfficeGetLabels
} }
@ -145,10 +145,10 @@ fillDb = do
, userTelephone = Nothing , userTelephone = Nothing
, userCompanyPersonalNumber = Nothing , userCompanyPersonalNumber = Nothing
, userCompanyDepartment = Nothing , userCompanyDepartment = Nothing
, userPinPassword = Nothing , userPinPassword = Just "tomatenmarmelade"
, userPostAddress = Nothing , userPostAddress = Just $ markdownToStoredMarkup ("Erdbeerweg 24 \n12345 Schlumpfhausen \nTraumland"::Text)
, userPostLastUpdate = Nothing , userPostLastUpdate = Nothing
, userPrefersPostal = False , userPrefersPostal = True
, userExamOfficeGetSynced = userDefaultExamOfficeGetSynced , userExamOfficeGetSynced = userDefaultExamOfficeGetSynced
, userExamOfficeGetLabels = userDefaultExamOfficeGetLabels , userExamOfficeGetLabels = userDefaultExamOfficeGetLabels
} }
@ -164,7 +164,7 @@ fillDb = do
, userLastAuthentication = Nothing , userLastAuthentication = Nothing
, userTokensIssuedAfter = Nothing , userTokensIssuedAfter = Nothing
, userMatrikelnummer = Nothing , userMatrikelnummer = Nothing
, userEmail = "jost@tcs.ifi.lmu.de" , userEmail = "e12345@fraport.de"
, userDisplayEmail = "jost@tcs.ifi.lmu.de" , userDisplayEmail = "jost@tcs.ifi.lmu.de"
, userDisplayName = "Steffen Jost" , userDisplayName = "Steffen Jost"
, userSurname = "Jost" , userSurname = "Jost"
@ -172,7 +172,7 @@ fillDb = do
, userTitle = Just "Dr." , userTitle = Just "Dr."
, userMaxFavourites = 14 , userMaxFavourites = 14
, userMaxFavouriteTerms = 4 , userMaxFavouriteTerms = 4
, userTheme = userDefaultTheme , userTheme = ThemeMossGreen
, userDateTimeFormat = userDefaultDateTimeFormat , userDateTimeFormat = userDefaultDateTimeFormat
, userDateFormat = userDefaultDateFormat , userDateFormat = userDefaultDateFormat
, userTimeFormat = userDefaultTimeFormat , userTimeFormat = userDefaultTimeFormat
@ -386,14 +386,14 @@ fillDb = do
= foldMap tshow cs : toMatrikel rest = foldMap tshow cs : toMatrikel rest
| otherwise | otherwise
= [] = []
manyUser (firstName, middleName, userSurname) (Just -> userMatrikelnummer) = User manyUser (firstName, middleName, userSurname) userMatrikelnummer' = User
{ userIdent { userIdent
, userAuthentication = AuthLDAP , userAuthentication = AuthLDAP
, userLastAuthentication = Nothing , userLastAuthentication = Nothing
, userTokensIssuedAfter = Nothing , userTokensIssuedAfter = Nothing
, userMatrikelnummer , userMatrikelnummer = Just userMatrikelnummer'
, userEmail = userIdent , userEmail = userEmail'
, userDisplayEmail = userIdent , userDisplayEmail = userDisplayEmail'
, userDisplayName = case middleName of , userDisplayName = case middleName of
Just middleName' -> [st|#{firstName} #{middleName'} #{userSurname}|] Just middleName' -> [st|#{firstName} #{middleName'} #{userSurname}|]
Nothing -> [st|#{firstName} #{userSurname}|] Nothing -> [st|#{firstName} #{userSurname}|]
@ -402,7 +402,7 @@ fillDb = do
, userTitle = Nothing , userTitle = Nothing
, userMaxFavourites = userDefaultMaxFavourites , userMaxFavourites = userDefaultMaxFavourites
, userMaxFavouriteTerms = userDefaultMaxFavourites , userMaxFavouriteTerms = userDefaultMaxFavourites
, userTheme = userDefaultTheme , userTheme = ThemeAberdeenReds
, userDateTimeFormat = userDefaultDateTimeFormat , userDateTimeFormat = userDefaultDateTimeFormat
, userDateFormat = userDefaultDateFormat , userDateFormat = userDefaultDateFormat
, userTimeFormat = userDefaultTimeFormat , userTimeFormat = userDefaultTimeFormat
@ -433,6 +433,18 @@ fillDb = do
userIdent = fromString $ case middleName of userIdent = fromString $ case middleName of
Just middleName' -> repack [st|#{firstName}.#{middleName'}.#{userSurname}@example.invalid|] Just middleName' -> repack [st|#{firstName}.#{middleName'}.#{userSurname}@example.invalid|]
Nothing -> repack [st|#{firstName}.#{userSurname}@example.invalid|] Nothing -> repack [st|#{firstName}.#{userSurname}@example.invalid|]
userEmail' :: CI Text
userEmail' = CI.mk $ case firstName of
"James" -> userIdent
"John" -> userIdent
--"Elizabeth" -> "AVSID:" <> userMatrikelnummer'
_ -> "E" <> userMatrikelnummer' <> "@fraport.de"
userDisplayEmail' :: CI Text
userDisplayEmail' = CI.mk $ case userSurname of
"Walker" -> "AVSNO:" <> userMatrikelnummer'
"Clark" -> "E" <> userMatrikelnummer' <> "@fraport.de"
_ -> userIdent
matrikel <- toMatrikel <$> getRandomRs (0 :: Int, 9 :: Int) matrikel <- toMatrikel <$> getRandomRs (0 :: Int, 9 :: Int)
manyUsers <- insertMany . getZipList $ manyUser <$> ZipList ((,,) <$> firstNames <*> middlenames <*> surnames) <*> ZipList matrikel manyUsers <- insertMany . getZipList $ manyUser <$> ZipList ((,,) <$> firstNames <*> middlenames <*> surnames) <*> ZipList matrikel
matUsers <- selectList [UserMatrikelnummer !=. Nothing] [] matUsers <- selectList [UserMatrikelnummer !=. Nothing] []
@ -562,7 +574,7 @@ fillDb = do
void . insert' $ QualificationUser maxMuster qid_f (n_day 0) (n_day $ -2) (n_day $ -8) Nothing False void . insert' $ QualificationUser maxMuster qid_f (n_day 0) (n_day $ -2) (n_day $ -8) Nothing False
void . insert' $ QualificationUser svaupel qid_f (n_day 1) (n_day $ -1) (n_day $ -2) Nothing True void . insert' $ QualificationUser svaupel qid_f (n_day 1) (n_day $ -1) (n_day $ -2) Nothing True
void . insert' $ QualificationUser sbarth qid_f (n_day 400) (n_day $ -40) (n_day $ -1200) Nothing True void . insert' $ QualificationUser sbarth qid_f (n_day 400) (n_day $ -40) (n_day $ -1200) Nothing True
void . insert' $ QualificationUser tinaTester qid_f (n_day 3) (n_day $ -60) (n_day $ -250) Nothing False void . insert' $ QualificationUser tinaTester qid_f (n_day 3) (n_day $ -60) (n_day $ -250) (Just $ QualificationBlocked (n_day $ -7) "Some long explanation for the block!") False
void . insert' $ QualificationUser tinaTester qid_r (n_day 3) (n_day $ -60) (n_day $ -250) Nothing False void . insert' $ QualificationUser tinaTester qid_r (n_day 3) (n_day $ -60) (n_day $ -250) Nothing False
void . insert' $ QualificationUser gkleen qid_r (n_day $ -7) (n_day $ -2) (n_day $ -9) Nothing True void . insert' $ QualificationUser gkleen qid_r (n_day $ -7) (n_day $ -2) (n_day $ -9) Nothing True
void . insert' $ QualificationUser maxMuster qid_r (n_day 1) (n_day $ -1) (n_day $ -2) Nothing False void . insert' $ QualificationUser maxMuster qid_r (n_day 1) (n_day $ -1) (n_day $ -2) Nothing False
@ -581,20 +593,20 @@ fillDb = do
void . insert' $ LmsUser qid_f jost (LmsIdent "ijk" ) "123" False now Nothing now Nothing (Just $ n_day' (-7)) (Just $ n_day' (-5)) void . insert' $ LmsUser qid_f jost (LmsIdent "ijk" ) "123" False now Nothing now Nothing (Just $ n_day' (-7)) (Just $ n_day' (-5))
void . insert' $ LmsUser qid_f svaupel (LmsIdent "abcdefg") "abc" False now (Just $ LmsSuccess $ n_day 1) (n_day' (-1)) (Just now) (Just $ n_day' 0) Nothing void . insert' $ LmsUser qid_f svaupel (LmsIdent "abcdefg") "abc" False now (Just $ LmsSuccess $ n_day 1) (n_day' (-1)) (Just now) (Just $ n_day' 0) Nothing
void . insert' $ LmsUser qid_f gkleen (LmsIdent "hijklmn") "@#!" True now (Just $ LmsBlocked $ utctDay now) (n_day' (-2)) (Just now) (Just $ n_day' (-4)) Nothing void . insert' $ LmsUser qid_f gkleen (LmsIdent "hijklmn") "@#!" True now (Just $ LmsBlocked $ utctDay now) (n_day' (-2)) (Just now) (Just $ n_day' (-4)) Nothing
void . insert' $ LmsUser qid_f tinaTester (LmsIdent "qwvu") "45678" True now (Just $ LmsSuccess $ n_day (-2)) (n_day' (-3)) (Just $ n_day' (-1)) (Just $ n_day' (-1)) Nothing void . insert' $ LmsUser qid_f tinaTester (LmsIdent "qwvu") "45678" True now (Just $ LmsSuccess $ n_day (-22)) (n_day' (-3)) (Just $ n_day' (-1)) (Just $ n_day' (-1)) Nothing
void . insert' $ LmsUser qid_f maxMuster (LmsIdent "xyz") "a1b2c3" False now (Just $ LmsBlocked $ n_day (-1)) (n_day' (-4)) (Just $ n_day' (-2)) (Just $ n_day' (-2)) Nothing void . insert' $ LmsUser qid_f maxMuster (LmsIdent "xyz") "a1b2c3" False now (Just $ LmsBlocked $ n_day (-11)) (n_day' (-4)) (Just $ n_day' (-2)) (Just $ n_day' (-2)) Nothing
void . insert' $ LmsUser qid_f fhamann (LmsIdent "123") "456" False now Nothing now Nothing Nothing Nothing void . insert' $ LmsUser qid_f fhamann (LmsIdent "123") "456" False now Nothing now Nothing Nothing Nothing
void . insert $ PrintJob "TestJob1" "job1" "No Text herein." (n_day' (-1)) Nothing Nothing (Just svaupel) Nothing (Just qid_f) Nothing void . insert $ PrintJob "TestJob1" "AckTestJob1" "job1" "No Text herein." (n_day' (-1)) Nothing Nothing (Just svaupel) Nothing (Just qid_f) Nothing
void . insert $ PrintJob "TestJob2" "job2" "No Text herein." (n_day' (-3)) (Just $ n_day' (-1)) (Just jost) (Just svaupel) Nothing (Just qid_f) (Just $ LmsIdent "ijk") void . insert $ PrintJob "TestJob2" "AckTestJob2" "job2" "No Text herein." (n_day' (-3)) (Just $ n_day' (-1)) (Just jost) (Just svaupel) Nothing (Just qid_f) (Just $ LmsIdent "ijk")
void . insert $ PrintJob "TestJob3" "job3" "No Text herein." (n_day' (-2)) Nothing Nothing Nothing Nothing Nothing Nothing void . insert $ PrintJob "TestJob3" "AckTestJob3" "job3" "No Text herein." (n_day' (-2)) Nothing Nothing Nothing Nothing Nothing Nothing
void . insert $ PrintJob "TestJob4" "job4" "No Text herein." (n_day' (-2)) Nothing (Just jost) Nothing Nothing Nothing (Just $ LmsIdent "qwvu") void . insert $ PrintJob "TestJob4" "AckTestJob4" "job4" "No Text herein." (n_day' (-2)) Nothing (Just jost) Nothing Nothing Nothing (Just $ LmsIdent "qwvu")
void . insert $ PrintJob "TestJob5" "job5" "No Text herein." (n_day' (-9)) Nothing (Just jost) (Just svaupel) Nothing (Just qid_r) (Just $ LmsIdent "qwvu") void . insert $ PrintJob "TestJob5" "AckTestJob5" "job5" "No Text herein." (n_day' (-9)) Nothing (Just jost) (Just svaupel) Nothing (Just qid_r) (Just $ LmsIdent "qwvu")
void . insert $ PrintJob "TestJob6" "job6" "No Text herein." (n_day' (-7)) Nothing (Just svaupel) Nothing Nothing (Just qid_r) Nothing void . insert $ PrintJob "TestJob6" "AckTestJob6" "job6" "No Text herein." (n_day' (-7)) Nothing (Just svaupel) Nothing Nothing (Just qid_r) Nothing
void . insert $ PrintJob "TestJob7" "job7" "No Text herein." (n_day' (-6)) (Just $ n_day' (-8)) (Just svaupel) Nothing Nothing Nothing (Just $ LmsIdent "abcdefg") void . insert $ PrintJob "TestJob7" "AckTestJob7" "job7" "No Text herein." (n_day' (-6)) (Just $ n_day' (-8)) (Just svaupel) Nothing Nothing Nothing (Just $ LmsIdent "abcdefg")
void . insert $ PrintJob "TestJob8" "job8" "No Text herein." (n_day' (-2)) (Just $ n_day' (-6)) (Just svaupel) Nothing Nothing Nothing (Just $ LmsIdent "abcdefg") void . insert $ PrintJob "TestJob8" "AckTestJob8" "job8" "No Text herein." (n_day' (-2)) (Just $ n_day' (-6)) (Just svaupel) Nothing Nothing Nothing (Just $ LmsIdent "abcdefg")
void . insert $ PrintJob "TestJob9" "job9" "No Text herein." (n_day' (-1)) Nothing (Just svaupel) Nothing Nothing Nothing (Just $ LmsIdent "abcdefg") void . insert $ PrintJob "TestJob9" "AckTestJob9" "job9" "No Text herein." (n_day' (-1)) Nothing (Just svaupel) Nothing Nothing Nothing (Just $ LmsIdent "abcdefg")
void . insert $ PrintJob "TestJob0" "job0" "No Text herein." (n_day' (-3)) Nothing Nothing Nothing Nothing Nothing (Just $ LmsIdent "hijklmn") void . insert $ PrintJob "TestJob0" "AckTestJob0" "job0" "No Text herein." (n_day' (-3)) Nothing Nothing Nothing Nothing Nothing (Just $ LmsIdent "hijklmn")
let let
@ -786,6 +798,7 @@ fillDb = do
jtt = (((Just .) .) .) . termTime tid jtt = (((Just .) .) .) . termTime tid
firstDay = utctDay $ termTime tid TermDayLectureStart 0 Nothing toMidnight firstDay = utctDay $ termTime tid TermDayLectureStart 0 Nothing toMidnight
secondDay = utctDay $ termTime tid TermDayLectureStart 1 Nothing toMidnight secondDay = utctDay $ termTime tid TermDayLectureStart 1 Nothing toMidnight
tyear = year tid
weekDay = dayOfWeek firstDay weekDay = dayOfWeek firstDay
-- thirdDay = utctDay $ termTime tid TermDayLectureStart 2 Nothing toMidnight -- thirdDay = utctDay $ termTime tid TermDayLectureStart 2 Nothing toMidnight
capacity = Just 8 capacity = Just 8
@ -816,8 +829,11 @@ fillDb = do
, courseDeregisterUntil = jtt TermDayLectureStart (-5) (Just Monday) toMidnight , courseDeregisterUntil = jtt TermDayLectureStart (-5) (Just Monday) toMidnight
, courseRegisterSecret = Nothing , courseRegisterSecret = Nothing
, courseMaterialFree = True , courseMaterialFree = True
} }
insert_ $ CourseEdit jost now c insert_ $ CourseEdit jost now c
when (tyear >= currentYear) $ insert_ $ CourseQualification c qid_f 2
when (tyear >= succ currentYear) $ insert_ $ CourseQualification c qid_r 3
when (tyear >= succ (succ currentYear)) $ insert_ $ CourseQualification c qid_l 1
insert_ Sheet insert_ Sheet
{ sheetCourse = c { sheetCourse = c
, sheetName = mkName "Sehtest" , sheetName = mkName "Sehtest"