Merge branch 'fradrive/localmaster'
This commit is contained in:
commit
eafaccfbde
@ -24,9 +24,9 @@ mail-from:
|
||||
email: "_env:MAILFROM_EMAIL:uniworx@localhost"
|
||||
mail-object-domain: "_env:MAILOBJECT_DOMAIN:localhost"
|
||||
mail-use-replyto-instead-sender: "_env:MAIL_USES_REPLYTO:true"
|
||||
#mail-reroute-to:
|
||||
# name: "_env:MAIL_REROUTE_TO_NAME:Steffen Jost"
|
||||
# email: "_env:MAIL_REROUTE_TO_EMAL:jost@tcs.ifi.lmu.de"
|
||||
mail-reroute-to:
|
||||
name: "_env:MAIL_REROUTE_TO_NAME:"
|
||||
email: "_env:MAIL_REROUTE_TO_EMAIL:"
|
||||
#mail-verp:
|
||||
# separator: "_env:VERP_SEPARATOR:+"
|
||||
# prefix: "_env:VERP_PREFIX:bounce"
|
||||
@ -150,6 +150,7 @@ lms-direct:
|
||||
download-header: "_env:LMSDOWNLOADHEADER:true"
|
||||
download-delimiter: "_env:LMSDOWNLOADDELIMITER:,"
|
||||
download-cr-lf: "_env:LMSDOWNLOADCRLF:true"
|
||||
deletion-days: "_env:LMSDELETIONDAYS:7"
|
||||
|
||||
avs:
|
||||
host: "_env:AVSHOST:skytest.fra.fraport.de"
|
||||
|
||||
@ -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
|
||||
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
|
||||
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
|
||||
RevokeUnknownLicencesFail: Nicht alle AVS Fahrberechtigungen unbekannter Fahrer konnten entzogen werden, siehe Log für Details
|
||||
AvsCommunicationError: AVS Schnittstelle lieferte einen unerwarteten Fehler.
|
||||
LicenceTableChangeAvs: Im AVS ändern
|
||||
LicenceTableGrantFDrive: In FRADrive erteilen
|
||||
LicenceTableRevokeFDrive: In FRADrive zum Vortag entziehen
|
||||
LicenceTableRevokeFDrive: In FRADrive entziehen
|
||||
@ -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
|
||||
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
|
||||
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
|
||||
RevokeUnknownLicencesFail: Not all AVS driving licences of unknown drivers could be revoked, see log for details
|
||||
AvsCommunicationError: AVS interface returned an unexpected error.
|
||||
LicenceTableChangeAvs: Change in AVS
|
||||
LicenceTableGrantFDrive: Grant in FRADrive
|
||||
LicenceTableRevokeFDrive: Revoke yesterday in FRADrive
|
||||
LicenceTableRevokeFDrive: Revoke in FRADrive
|
||||
|
||||
@ -242,3 +242,5 @@ CourseAdministrator: Kursadministrator:in
|
||||
CourseAvsRegisterTitle: Teilnehmer:innen anmelden
|
||||
CourseAvsRegisterParticipants: Teilnehmer:innen
|
||||
CourseAvsRegisterParticipantsTip: Mehrere Teilnehmer:innen mit Komma separieren
|
||||
|
||||
CourseQualifications n@Int: Assoziierte #{pluralDE n "Qualifikation" "Qualifikationen"}
|
||||
@ -241,3 +241,5 @@ CourseAdministrator: Course administrator
|
||||
CourseAvsRegisterTitle: Register participants
|
||||
CourseAvsRegisterParticipants: Participants
|
||||
CourseAvsRegisterParticipantsTip: Separate multiple participants with comma
|
||||
|
||||
CourseQualifications n: Associated #{pluralENs n "Qualification"}
|
||||
@ -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
|
||||
TutorialUserDeregister: Vom Tutorium Abmelden
|
||||
TutorialUserSendMail: Mitteilung verschicken
|
||||
TutorialUserPrintQualification: Zertifikat drucken
|
||||
TutorialUserGrantQualification: Qualifikation vergeben
|
||||
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
|
||||
|
||||
@ -45,6 +45,7 @@ TutorialUsersDeregistered count: Successfully deregistered #{show count} partici
|
||||
|
||||
TutorialUserDeregister: Deregister from tutorial
|
||||
TutorialUserSendMail: Send mail
|
||||
TutorialUserPrintQualification: Print certificate
|
||||
TutorialUserGrantQualification: Grant Qualification
|
||||
TutorialUserRenewQualification: Renew Qualification
|
||||
TutorialUserRenewedQualification n@Int: Successfully renewed qualification #{tshow n} tutorial #{pluralEN n "user" "users"}
|
||||
|
||||
@ -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.
|
||||
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.
|
||||
|
||||
ErrorUnknownFormAction: Unbekannte oder ungültige Formular Aktion wurde ignoriert.
|
||||
@ -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.
|
||||
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.
|
||||
|
||||
ErrorUnknownFormAction: Unknown or invalid form action was ignored.
|
||||
@ -7,6 +7,7 @@ PrintJobName: Bezeichnung
|
||||
PrintJobFilename: Dateiname
|
||||
PrintJobId !ident-ok: Id
|
||||
PrintJobCreated: Gesendet
|
||||
PrintJobApcAcknowledge: Bestätigungs ID
|
||||
PrintJobAcknowledged: Bestätigt
|
||||
PrintJobUnacknowledged: Noch nicht gedruckt
|
||||
PrintJobAcknowledge n@Int64: #{n} #{pluralDE n "Druckauftrag" "Druckaufräge"} als gedruckt und versendet bestätigt
|
||||
|
||||
@ -7,6 +7,7 @@ PrintJobName: Description
|
||||
PrintJobFilename: Filename
|
||||
PrintJobId: Id
|
||||
PrintJobCreated: Created
|
||||
PrintJobApcAcknowledge: Acknowledge ID
|
||||
PrintJobAcknowledged: Acknowledged
|
||||
PrintJobUnacknowledged: Not yet printed
|
||||
PrintJobAcknowledge n: #{n} #{pluralENs n "print-job"} marked as printed and mailed
|
||||
|
||||
@ -20,18 +20,20 @@ TableQualificationSapExportTooltip: Wird die Qualifikation an das SAP übermitte
|
||||
LmsQualificationValidUntil: Gültig bis
|
||||
TableQualificationLastRefresh: Zuletzt erneuert
|
||||
TableQualificationFirstHeld: Erstmalig
|
||||
TableQualificationBlockedDue: Suspendiert
|
||||
TableQualificationBlockedDue: Entzogen
|
||||
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?
|
||||
TableQualificationNoRenewal: Storniert
|
||||
TableQualificationNoRenewalTooltip: Es wird keine Benachrichtigung mehr versendet, wenn diese Qualifikation ablaufen sollte. Die Qualifikation kann noch gültig sein.
|
||||
TableQualificationNoRenewal: Auslaufend
|
||||
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
|
||||
QualificationUserNone: Für diese Person sind keine Qualifikationen registriert.
|
||||
QualificationBlockReason: Entzugsbegründung
|
||||
LmsUser: Inhaber
|
||||
TableLmsEmail: E-Mail
|
||||
LmsURL: Link E-Learning
|
||||
TableLmsEmail: E‑Mail
|
||||
TableLmsIdent: LMS Identifikation
|
||||
TableLmsElearning: E-Learning
|
||||
TableLmsPin: E-Learning Pin
|
||||
TableLmsElearning: E‑Learning
|
||||
TableLmsPin: E‑Learning Pin
|
||||
TableLmsResetPin: Pin zurücksetzen?
|
||||
TableLmsDatePin: Pin erstellt
|
||||
TableLmsDelete: Löschen?
|
||||
@ -41,7 +43,7 @@ TableLmsReceived: Letzte Rückmeldung
|
||||
TableLmsNotified: Versand Benachrichtigung
|
||||
TableLmsNotifiedTooltip: Benachrichtigungen werden erst versendet wenn das LMS bestätigt die Eröffnung des E-Learning für den Benutzer bestätigt hat, was ein paar Stunden dauern kann!
|
||||
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."}
|
||||
TableLmsStatusDay: Datum letzte Statusänderung E-Learning
|
||||
TableLmsSuccess: Bestanden
|
||||
@ -67,14 +69,19 @@ LmsErrorNoRefreshElearning: Fehler: E-Learning wird nicht automatisch gestartet,
|
||||
MailSubjectQualificationRenewal qname@Text: Qualifikation #{qname} muss demnächst erneuert werden
|
||||
MailSubjectQualificationExpiry qname@Text: Qualifikation #{qname} läuft demnächst ab
|
||||
MailSubjectQualificationExpired qname@Text: Qualifikation #{qname} ist ab sofort ungültig
|
||||
MailBodyQualificationRenewal 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!
|
||||
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
|
||||
QualificationActUnexpire: Benachrichtigung bei anstehender Erneuerung senden
|
||||
QualificationActExpire: Auslaufend markieren - keine Benachrichtigung zur Erneuerung senden
|
||||
QualificationActUnexpire: Auslaufend aufheben - kostenpflichtige Benachrichtigung bei anstehender Erneuerung senden
|
||||
QualificationSetExpire n@Int64: Benachrichtigung bei anstehender Erneuerung und E-Learning abgeschaltet für #{n} #{pluralDE n "Person" "Personen"}
|
||||
QualificationSetUnexpire n@Int64: Benachrichtigung bei anstehender Erneuerung und E-Learning aktiviert für #{n} #{pluralDE n "Person" "Personen"}
|
||||
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.
|
||||
LmsActNotify: Benachrichtigung E-Learning erneut per Post oder E-Mail versenden
|
||||
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"}.
|
||||
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
|
||||
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.
|
||||
LmsManualQueuing: Die folgenden Funktionen sollten einmal pro Tag ausgeführt werden.
|
||||
BtnLmsEnqueue: Nutzer mit ablaufenden Qualifikationen zum E-Learning anmelden und benachrichtigen
|
||||
|
||||
@ -20,18 +20,20 @@ TableQualificationSapExportTooltip: Is this qualification transmitted to SAP? On
|
||||
LmsQualificationValidUntil: Valid until
|
||||
TableQualificationLastRefresh: Last renewed
|
||||
TableQualificationFirstHeld: First held
|
||||
TableQualificationBlockedDue: Suspended
|
||||
TableQualificationBlockedDue: Revoked
|
||||
TableQualificationBlockedTooltip: Why and when was this qualification temporarily suspended?
|
||||
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.
|
||||
QualificationUserNoRenewal: Expires without further notification
|
||||
QualificationUserNone: No registered qualifications for this person.
|
||||
QualificationBlockReason: Reason for revoking
|
||||
LmsUser: Licensee
|
||||
LmsURL: Link E-learning
|
||||
TableLmsEmail: Email
|
||||
TableLmsIdent: LMS Identifier
|
||||
TableLmsPin: E-learning pin
|
||||
TableLmsElearning: E-learning
|
||||
TableLmsPin: E‑learning pin
|
||||
TableLmsElearning: E‑learning
|
||||
TableLmsResetPin: Reset pin?
|
||||
TableLmsDatePin: Pin created
|
||||
TableLmsDelete: Delete?
|
||||
@ -67,14 +69,19 @@ LmsErrorNoRefreshElearning: Error: E-learning will not be started automatically
|
||||
MailSubjectQualificationRenewal qname: Qualification #{qname} must be renewed shortly
|
||||
MailSubjectQualificationExpiry qname: Qualification #{qname} expires soon
|
||||
MailSubjectQualificationExpired qname: Qualification #{qname} is no longer valid
|
||||
MailBodyQualificationRenewal qname: 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!
|
||||
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
|
||||
QualificationActUnexpire: Notify upon due renewal
|
||||
QualificationActExpire: Discontinue - qualification expires silently
|
||||
QualificationActUnexpire: Continue - send a possibly fee-paying notification upon due renewal
|
||||
QualificationSetExpire n: Expiry notification and e-learning deactivated for #{n} #{pluralENs n "person"}
|
||||
QualificationSetUnexpire n: Expiry notification and e-learning activated for #{n} #{pluralENs n "person"}
|
||||
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.
|
||||
LmsActNotify: Resend e-learning notification by post or email
|
||||
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"}.
|
||||
LmsActionFailed n: No action for #{n} #{pluralENs n "person"}, since there was no ongoing examination.
|
||||
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.
|
||||
LmsManualQueuing: The following functions should be executed daily.
|
||||
BtnLmsEnqueue: Enqueue users with expiring qualifications for e-learning and notify them.
|
||||
|
||||
@ -38,7 +38,7 @@ BtnExamAutoOccurrenceCalculate: Verteilungstabelle berechnen
|
||||
BtnExamAutoOccurrenceAccept: Verteilung akzeptieren
|
||||
BtnExamAutoOccurrenceNudgeUp !ident-ok: +
|
||||
BtnExamAutoOccurrenceNudgeDown !ident-ok: -
|
||||
BtnSetDisplayEmail: E-Mail-Adresse setzen
|
||||
BtnSetDisplayEmail: E‑Mail-Adresse setzen
|
||||
BtnAuthLDAP: Auf Fraport AG Kennung (Büko) umstellen
|
||||
BtnAuthPWHash: Auf FRADrive interne Kennung umstellen
|
||||
BtnPasswordReset: Passwort zurücksetzen
|
||||
|
||||
@ -88,7 +88,7 @@ BreadcrumbVersion: Versionsgeschichte
|
||||
BreadcrumbHelp: Hilfe
|
||||
BreadcrumbHealth: Instanz-Zustand
|
||||
BreadcrumbInstance: Instanz-Identifikation
|
||||
BreadcrumbUserDisplayEmail: E-Mail-Adresse
|
||||
BreadcrumbUserDisplayEmail: E‑Mail-Adresse
|
||||
BreadcrumbProfileData: Persönliche Daten
|
||||
BreadcrumbAuthPreds: Authorisierungseinstellungen
|
||||
BreadcrumbTermShow: Semester
|
||||
@ -107,7 +107,7 @@ BreadcrumbSheetList: Übungsblätter
|
||||
BreadcrumbSheetNew: Neues Übungsblatt anlegen
|
||||
BreadcrumbSheetCurrent: Aktuelles Übungsblatt
|
||||
BreadcrumbSheetOldUnassigned: Abgaben ohne Korrektor:in
|
||||
BreadcrumbCourseCommunication: Kursmitteilung (E-Mail)
|
||||
BreadcrumbCourseCommunication: Kursmitteilung (E‑Mail)
|
||||
BreadcrumbTutorialList: Tutorien
|
||||
BreadcrumbTutorialNew: Neues Tutorium anlegen
|
||||
BreadcrumbCourseDelete: Kurs löschen
|
||||
|
||||
@ -31,7 +31,7 @@ MenuCourseList: Kurse
|
||||
MenuCourseMembers: Kursteilnehmer:innen
|
||||
MenuCourseAddMembers: Kursteilnehmer:innen hinzufügen
|
||||
MenuTutorialAddMembers: Tutorium Teilnehmer:innen hinzufügen
|
||||
MenuCourseCommunication: Kursmitteilung (E-Mail)
|
||||
MenuCourseCommunication: Kursmitteilung (E‑Mail)
|
||||
MenuCourseExamOffice: Prüfungsbeauftragte
|
||||
MenuTermShow: Semester
|
||||
MenuSubmissionDelete: Abgabe löschen
|
||||
@ -115,12 +115,12 @@ MenuCourseEventEdit: Kurstermin bearbeiten
|
||||
MenuLanguage: Sprache
|
||||
|
||||
MenuQualifications: Qualifikationen
|
||||
MenuLms !ident-ok: E-Learning
|
||||
MenuLmsEdit: Bearbeiten E-Learning
|
||||
MenuLms !ident-ok: E‑Learning
|
||||
MenuLmsEdit: Bearbeiten E‑Learning
|
||||
MenuLmsUser: Benutzer Qualifikationen
|
||||
MenuLmsUsers: Export E-Learning Benutzer
|
||||
MenuLmsUserlist: Melden E-Learning Benutzer
|
||||
MenuLmsResult: Melden Ergebnisse E-Learning
|
||||
MenuLmsUsers: Export E‑Learning Benutzer
|
||||
MenuLmsUserlist: Melden E‑Learning Benutzer
|
||||
MenuLmsResult: Melden Ergebnisse E‑Learning
|
||||
MenuLmsUpload: Hochladen
|
||||
MenuLmsDirectUpload: Direkter Upload
|
||||
MenuLmsDirectDownload: Direkter Download
|
||||
|
||||
@ -116,12 +116,12 @@ MenuCourseEventEdit: Edit course occurrence
|
||||
MenuLanguage: Language
|
||||
|
||||
MenuQualifications: Qualifications
|
||||
MenuLms: E-Learning
|
||||
MenuLmsEdit: Edit E-Learning
|
||||
MenuLms: E‑Learning
|
||||
MenuLmsEdit: Edit E‑Learning
|
||||
MenuLmsUser: User Qualifications
|
||||
MenuLmsUsers: Download E-Learning Users
|
||||
MenuLmsUserlist: Upload E-Learning Users
|
||||
MenuLmsResult: Upload E-Learning Results
|
||||
MenuLmsUsers: Download E‑Learning Users
|
||||
MenuLmsUserlist: Upload E‑Learning Users
|
||||
MenuLmsResult: Upload E‑Learning Results
|
||||
MenuLmsUpload: Upload
|
||||
MenuLmsDirectUpload: Direct Upload
|
||||
MenuLmsDirectDownload: Direct Download
|
||||
|
||||
@ -4,7 +4,7 @@
|
||||
|
||||
ExamOccurrenceStart: Prüfungsbeginn
|
||||
#general table-discriptions
|
||||
TableEmail: E-Mail
|
||||
TableEmail: E‑Mail
|
||||
TableStudyTerm: Studiengang
|
||||
TableStudyFeatureAge: Fachsemester
|
||||
TableStudyFeatureDegree: Abschluss
|
||||
|
||||
@ -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.
|
||||
MultiUserFieldInvitationExplanationAlways: Es wird an alle Adressen, die Sie hier angeben, eine Einladung per E-Mail versandt.
|
||||
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
|
||||
UtilExamResultPass: Bestanden/Nicht Bestanden
|
||||
UtilExamResultNoShow: Nicht erschienen
|
||||
|
||||
@ -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.
|
||||
MultiUserFieldInvitationExplanationAlways: An invitation will be sent via email to all addresses you enter here.
|
||||
AmbiguousEmail: Email address is ambiguous
|
||||
InvalidEmailAddress: Email address is invalid
|
||||
InvalidEmailAddressWith e: Email asdress #{show e} is invalid
|
||||
UtilExamResultGrade: Grade
|
||||
UtilExamResultPass: Passed/Failed
|
||||
UtilExamResultNoShow: Not present
|
||||
|
||||
@ -90,3 +90,10 @@ CourseUserExamOfficeOptOut
|
||||
school SchoolId
|
||||
UniqueCourseUserExamOfficeOptOut course user school
|
||||
deriving Generic
|
||||
|
||||
CourseQualification
|
||||
course CourseId
|
||||
qualification QualificationId
|
||||
sortOrder Int default=0
|
||||
UniqueCourseQualification course qualification
|
||||
deriving Generic
|
||||
@ -22,7 +22,7 @@ Qualification
|
||||
-- across all schools, only one qualification may be a driving licence:
|
||||
UniqueQualificationAvsLicence avsLicence !force
|
||||
-- NOTE: two NULL values are not equal for the purpose of Uniqueness constraints!
|
||||
deriving Generic
|
||||
deriving Eq Generic
|
||||
|
||||
-- TODOs:
|
||||
-- - Enstehen Kosten, wenn Teilnehmer für KnowHow eingereiht werden, aber nicht am Kurs teilnehmen?
|
||||
|
||||
@ -3,15 +3,17 @@
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
PrintJob
|
||||
name Text
|
||||
filename FilePath
|
||||
file ByteString -- stores plain pdf; otherwise use FileContentReference Maybe
|
||||
created UTCTime
|
||||
acknowledged UTCTime Maybe
|
||||
recipient UserId Maybe OnDeleteCascade OnUpdateCascade -- optional as some letters may contain just an address
|
||||
sender UserId Maybe OnDeleteSetNull OnUpdateCascade -- senders and associations are optional
|
||||
course CourseId Maybe OnDeleteCascade OnUpdateCascade
|
||||
qualification QualificationId Maybe OnDeleteCascade OnUpdateCascade
|
||||
lmsUser LmsIdent Maybe OnDeleteCascade OnUpdateCascade -- allows tracking if recipient has been notified; must be unique
|
||||
name Text
|
||||
apcIdent Text default='unknown'
|
||||
filename FilePath
|
||||
file ByteString -- stores plain pdf; otherwise use FileContentReference Maybe
|
||||
created UTCTime
|
||||
acknowledged UTCTime Maybe
|
||||
recipient UserId Maybe OnDeleteCascade OnUpdateCascade -- optional as some letters may contain just an address
|
||||
sender UserId Maybe OnDeleteSetNull OnUpdateCascade -- senders and associations are optional
|
||||
course CourseId Maybe OnDeleteCascade OnUpdateCascade
|
||||
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!
|
||||
-- UniquePrintJobApcIdent apcIdent -- TODO: not yet enforced, since LmsIdent is currently used
|
||||
deriving Generic
|
||||
@ -197,20 +197,24 @@ data Transaction
|
||||
, transactionNote :: Maybe Text
|
||||
, transactionReceived :: UTCTime -- when was the csv file received?
|
||||
}
|
||||
|
||||
| TransactionQualificationUserEdit
|
||||
{ transactionQualificationUser :: QualificationUserId
|
||||
, transactionQualification :: QualificationId
|
||||
, transactionUser :: UserId -- qualification holder that is updated
|
||||
| TransactionQualificationUserEdit -- Note that a renewal always entails unblocking as well!
|
||||
{ transactionUser :: UserId -- qualification holder that is updated
|
||||
, transactionQualificationUser :: QualificationUserId -- könnte entfernt werden
|
||||
, transactionQualification :: QualificationId
|
||||
, transactionQualificationValidUntil :: Day
|
||||
, transactionQualificationScheduleRenewal :: Maybe Bool -- Maybe, because some update may leave it unchanged (also avoids DB Migration)
|
||||
}
|
||||
| TransactionQualificationUserDelete
|
||||
{ transactionQualificationUser :: QualificationUserId
|
||||
, transactionQualification :: QualificationId
|
||||
, transactionUser :: UserId
|
||||
{ transactionUser :: UserId
|
||||
, transactionQualificationUser :: QualificationUserId
|
||||
, 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)
|
||||
|
||||
deriveJSON defaultOptions
|
||||
|
||||
@ -23,6 +23,7 @@ import qualified Database.Esqueleto.Utils as E
|
||||
import Handler.Utils.DateTime
|
||||
import Handler.Utils.Avs
|
||||
import Handler.Utils.Widgets
|
||||
import Handler.Utils.Users
|
||||
|
||||
import Handler.Admin.Test as Handler.Admin
|
||||
import Handler.Admin.ErrorMessage as Handler.Admin
|
||||
@ -83,7 +84,7 @@ getAdminProblemsR = do
|
||||
|
||||
getProblemUnreachableR :: Handler Html
|
||||
getProblemUnreachableR = do
|
||||
unreachables <- runDB $ E.select retrieveUnreachableUsers
|
||||
unreachables <- runDB retrieveUnreachableUsers'
|
||||
siteLayoutMsg MsgProblemsUnreachableHeading $ do
|
||||
setTitleI MsgProblemsUnreachableHeading
|
||||
[whamlet|
|
||||
@ -92,7 +93,7 @@ getProblemUnreachableR = do
|
||||
<ul>
|
||||
$forall usr <- unreachables
|
||||
<li>
|
||||
^{linkUserWidget ForProfileR usr}
|
||||
^{linkUserWidget ForProfileR usr} (#{usr ^. _userDisplayEmail} / #{usr ^. _userEmail})
|
||||
|]
|
||||
|
||||
getProblemFbutNoR :: Handler Html
|
||||
@ -147,9 +148,24 @@ retrieveUnreachableUsers = do
|
||||
user <- E.from $ E.table @User
|
||||
E.where_ $ E.isNothing (user E.^. UserPostAddress)
|
||||
E.&&. E.isNothing (user E.^. UserCompanyDepartment)
|
||||
E.&&. E.not_ ((user E.^. 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
|
||||
|
||||
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 = fmap isNothing . E.selectOne . retrieveDriversWithoutAvsId
|
||||
allDriversHaveAvsId = E.selectNotExists . retrieveDriversWithoutAvsId
|
||||
|
||||
@ -309,11 +309,15 @@ nullaryPathPiece ''LicenceTableAction $ camelToPathPiece' 2
|
||||
embedRenderMessage ''UniWorX ''LicenceTableAction id
|
||||
|
||||
data LicenceTableActionData = LicenceTableChangeAvsData
|
||||
| LicenceTableRevokeFDriveData --TODO: add { licenceTableChangeFDriveQId :: QualificationId to avoid lookup later
|
||||
| LicenceTableGrantFDriveData { licenceTableChangeFDriveQId :: QualificationId
|
||||
, licenceTableChangeFDriveEnd :: Day
|
||||
, licenceTableChangeFDriveRenew :: Maybe Bool
|
||||
}
|
||||
| LicenceTableRevokeFDriveData
|
||||
{ licenceTableChangeFDriveQId :: QualificationId
|
||||
, licenceTableChangeFDriveReason :: Text
|
||||
}
|
||||
| LicenceTableGrantFDriveData
|
||||
{ licenceTableChangeFDriveQId :: QualificationId
|
||||
, licenceTableChangeFDriveEnd :: Day
|
||||
, licenceTableChangeFDriveRenew :: Maybe Bool
|
||||
}
|
||||
deriving (Eq, Ord, Read, Show, Generic)
|
||||
|
||||
|
||||
@ -321,7 +325,7 @@ postProblemAvsSynchR, getProblemAvsSynchR :: Handler Html
|
||||
postProblemAvsSynchR = getProblemAvsSynchR
|
||||
getProblemAvsSynchR = do
|
||||
let catchAllAvs' r = flip catch (\err -> addMessageModal Error (i18n MsgAvsCommunicationError) (Right (text2widget $ tshow (err :: SomeException))) >> redirect r)
|
||||
catchAllAvs = catchAllAvs' ProblemAvsSynchR -- == current route; use only in conditions that are not repeated upon reload
|
||||
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
|
||||
|
||||
--
|
||||
@ -336,8 +340,8 @@ getProblemAvsSynchR = do
|
||||
numUnknownLicenceOwners = length unknownLicenceOwners
|
||||
|
||||
(btnImportUnknownWgt, btnImportUnknownRes) <- runButtonFormHash unknownLicenceOwners FIDBtnAvsImportUnknown
|
||||
ifMaybeM btnImportUnknownRes () $ \BtnAvsImportUnknown -> catchAllAvs $ do
|
||||
res <- forM (take 500 unknownLicenceOwners) $ try . upsertAvsUserById -- TODO: turn this into a background job
|
||||
ifMaybeM btnImportUnknownRes () $ \BtnAvsImportUnknown -> do
|
||||
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)
|
||||
--TODO: continue here!
|
||||
--procRes (Left (AvsUserAmbiguous api)) = (Sum 0, Set.singleton api, mempty, mempty)
|
||||
@ -367,10 +371,10 @@ getProblemAvsSynchR = do
|
||||
^{revokeUnknownExecWgt}
|
||||
|]
|
||||
|
||||
ifMaybeM btnRevokeUnknownRes () $ \BtnAvsRevokeUnknown -> catchAllAvs $ do
|
||||
ifMaybeM btnRevokeUnknownRes () $ \BtnAvsRevokeUnknown -> do
|
||||
let revokes = Set.map (AvsPersonLicence AvsNoLicence) $ Set.fromList unknownLicenceOwners
|
||||
no_revokes = Set.size revokes
|
||||
oks <- setLicencesAvs revokes
|
||||
oks <- catchAllAvs $ setLicencesAvs revokes
|
||||
if oks < no_revokes
|
||||
then addMessageI Error MsgRevokeUnknownLicencesFail
|
||||
else addMessageI Info MsgRevokeUnknownLicencesOk
|
||||
@ -386,26 +390,33 @@ getProblemAvsSynchR = do
|
||||
now <- liftIO getCurrentTime
|
||||
let nowaday = utctDay now
|
||||
procRes :: AvsLicence -> (LicenceTableActionData, Set AvsPersonId) -> Handler ()
|
||||
procRes aLic (LicenceTableChangeAvsData , apids) = catchAllAvs $ do
|
||||
oks <- setLicencesAvs $ Set.map (AvsPersonLicence aLic) apids
|
||||
procRes aLic (LicenceTableChangeAvsData , apids) = do
|
||||
oks <- catchAllAvs $ setLicencesAvs $ Set.map (AvsPersonLicence aLic) apids
|
||||
let no_req = Set.size apids
|
||||
mkind = if oks < no_req then Warning else Success
|
||||
addMessageI mkind $ MsgAvsSetLicences aLic oks no_req
|
||||
redirect ProblemAvsSynchR -- reload to update all tables
|
||||
|
||||
procRes alic (LicenceTableRevokeFDriveData, apids) = do
|
||||
nups <- runDB $ do
|
||||
procRes alic (LicenceTableRevokeFDriveData{..}, apids) = do
|
||||
oks <- runDB $ do
|
||||
qId <- getKeyBy404 $ UniqueQualificationAvsLicence $ Just alic
|
||||
selectedUsers <- view _userAvsUser <<$>> selectList [UserAvsPersonId <-. Set.toList apids] []
|
||||
forM_ selectedUsers $ upsertQualificationUser qId nowaday (pred nowaday) Nothing
|
||||
return $ length selectedUsers
|
||||
addMessageI Success $ MsgRevokeFraDriveLicences alic nups
|
||||
if qId /= licenceTableChangeFDriveQId
|
||||
then return (-1)
|
||||
else do
|
||||
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
|
||||
|
||||
procRes _alic (LicenceTableGrantFDriveData{..}, apids ) = do
|
||||
(n, Qualification{qualificationShorthand}) <- runDB $ do
|
||||
uas <- selectList [UserAvsPersonId <-. Set.toList apids] []
|
||||
let uids = view _userAvsUser <$> uas
|
||||
uids <- view _userAvsUser <<$>> selectList [UserAvsPersonId <-. Set.toList apids] []
|
||||
-- addMessage Info $ text2Html $ "UIDs: " <> tshow uids -- DEBUG
|
||||
forM_ uids $ upsertQualificationUser licenceTableChangeFDriveQId nowaday licenceTableChangeFDriveEnd licenceTableChangeFDriveRenew
|
||||
(length uids,) <$> get404 licenceTableChangeFDriveQId
|
||||
@ -547,7 +558,9 @@ mkLicenceTable dbtIdent aLic apids = do
|
||||
acts = mconcat
|
||||
[ singletonMap LicenceTableChangeAvs $ pure LicenceTableChangeAvsData
|
||||
, 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
|
||||
<$> apreq (selectField . fmap mkOptionList $ mapM qualOpt avsQualifications) (fslI MsgQualificationName) aLicQid
|
||||
<*> apreq dayField (fslI MsgLmsQualificationValidUntil) Nothing -- apreq?!
|
||||
@ -570,7 +583,7 @@ mkLicenceTable dbtIdent aLic apids = do
|
||||
dbtCsvDecode = Nothing
|
||||
dbtExtraReps = []
|
||||
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))
|
||||
-> FormResult ( LicenceTableActionData, Set AvsPersonId)
|
||||
postprocess inp = do
|
||||
|
||||
@ -22,10 +22,6 @@ import qualified Data.ByteString.Lazy as LBS
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import qualified Text.Pandoc as P
|
||||
import qualified Text.Pandoc.PDF as P
|
||||
import qualified Text.Pandoc.Builder as P
|
||||
|
||||
-- just to test i18nHamlet
|
||||
import Text.Hamlet
|
||||
-- import Handler.Utils.I18n
|
||||
@ -302,36 +298,33 @@ postAdminTestR = do
|
||||
|
||||
getAdminTestPdfR :: Handler TypedContent
|
||||
getAdminTestPdfR = do
|
||||
-- uUser <- maybeAuth -- to determine language for test
|
||||
templates <- liftIO $ do
|
||||
letter_tp <- P.compileTemplate "" templateRenewal
|
||||
din5008 <- P.compileTemplate "" templateDIN5008
|
||||
now <- getCurrentTime
|
||||
return (now, letter_tp, din5008)
|
||||
case templates of
|
||||
(_,Left err,_) -> sendResponseStatus internalServerError500 $ "Markdown template error: \n" <> err
|
||||
(_,_,Left err) -> sendResponseStatus internalServerError500 $ "LaTeX template error: \n" <> err
|
||||
(now, Right templ, Right latex) -> do
|
||||
content <- liftIO . P.runIO $ do
|
||||
let texopts = []
|
||||
readeropts = def { P.readerExtensions = P.pandocExtensions }
|
||||
writeropts1 = def { P.writerTemplate = Just templ }
|
||||
writeropts2 = def { P.writerTemplate = Just latex }
|
||||
-- https://github.com/jgm/pandoc/issues/1950
|
||||
-- using markdown as a template for itself for interpolation:
|
||||
doc1 <- P.readMarkdown readeropts templateRenewal
|
||||
doc2 <- P.writeMarkdown writeropts1 doc1
|
||||
doc3 <- P.readMarkdown readeropts doc2
|
||||
P.makePDF "lualatex" texopts P.writeLaTeX writeropts2 $
|
||||
P.setDate (P.text . tshow $ utctDay now) doc3
|
||||
case content of
|
||||
Right (Right bs) -> do
|
||||
liftIO $ LBS.writeFile "/tmp/generated.pdf" bs
|
||||
mbEncPdf <- encryptPDF "tomatenmarmelade" bs
|
||||
case mbEncPdf of
|
||||
Left err -> sendResponseStatus internalServerError500 $ "PDFtk error: \n" <> err
|
||||
Right encPdf -> do
|
||||
liftIO $ LBS.writeFile "/tmp/crypted.pdf" encPdf
|
||||
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
|
||||
usr <- requireAuth -- to determine language and recipient for test
|
||||
qual <- fromMaybeM
|
||||
(addMessage Error "Keine Qualifikation in der Datenbank zur Erzeugung eines Test-PDFs gefunden." >> redirect AdminTestR)
|
||||
(runDB $ selectFirst [] [Asc QualificationAvsLicence, Asc QualificationShorthand])
|
||||
encRecipient :: CryptoUUIDUser <- encrypt $ usr ^. _entityKey
|
||||
now <- liftIO getCurrentTime
|
||||
let nowaday = utctDay now
|
||||
letter = LetterRenewQualificationF
|
||||
{ lmsLogin = LmsIdent "abcdefgh"
|
||||
, lmsPin = "12345678"
|
||||
, qualHolderID = usr ^. _entityKey
|
||||
, qualHolderDN = usr ^. _userDisplayName
|
||||
, qualHolderSN = usr ^. _userSurname
|
||||
, qualExpiry = succ nowaday
|
||||
, qualId = qual ^. _entityKey
|
||||
, qualName = qual ^. _qualificationName . _CI
|
||||
, qualShort = qual ^. _qualificationShorthand . _CI
|
||||
, qualSchool = qual ^. _qualificationSchool
|
||||
, qualDuration = qual ^. _qualificationValidDuration
|
||||
}
|
||||
apcIdent <- letterApcIdent letter encRecipient now
|
||||
renderLetter usr letter apcIdent >>= \case
|
||||
Left err -> sendResponseStatus internalServerError500 $ "PDF generation failed: \n" <> err
|
||||
Right pdf -> do
|
||||
liftIO $ LBS.writeFile "/tmp/generated.pdf" pdf
|
||||
encryptPDF "tomatenmarmelade" pdf >>= \case
|
||||
Left err -> sendResponseStatus internalServerError500 $ "PDFtk error: \n" <> err
|
||||
Right encPdf -> do
|
||||
liftIO $ LBS.writeFile "/tmp/crypted.pdf" encPdf
|
||||
sendByteStringAsFile "demoPDF.pdf" (LBS.toStrict pdf) now
|
||||
|
||||
@ -31,7 +31,7 @@ getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
getCShowR tid ssh csh = do
|
||||
mbAid <- maybeAuthId
|
||||
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)]
|
||||
<- lift . E.select . E.from $
|
||||
\((school `E.InnerJoin` course) `E.LeftOuterJoin` participant) -> do
|
||||
@ -128,7 +128,9 @@ getCShowR tid ssh csh = do
|
||||
return $ material E.^. MaterialName
|
||||
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
|
||||
|
||||
|
||||
@ -395,7 +395,12 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
|
||||
, single ("lms-received" , SortColumnNullsInv $ queryLmsUser >>> (E.?. LmsUserReceived))
|
||||
, single ("lms-notified" , SortColumnNullsInv $ queryLmsUser >>> (E.?. LmsUserNotified)) -- cannot include printJob acknowledge date
|
||||
, 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
|
||||
[ 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"
|
||||
, colUserNameModalHdr MsgLmsUser AdminUserR
|
||||
, 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 "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> 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'
|
||||
getLmsUserR :: CryptoUUIDUser -> Handler Html
|
||||
getLmsUserR uuid = do
|
||||
getLmsUserR uuid = do
|
||||
uid <- decrypt uuid
|
||||
now <- liftIO getCurrentTime
|
||||
let nowaday = utctDay now
|
||||
(user@User{userDisplayName}, quals) <- runDB $ do
|
||||
usr <- get404 uid
|
||||
qs <- Ex.select $ do
|
||||
@ -625,7 +642,8 @@ getLmsUserR uuid = do
|
||||
)
|
||||
Ex.where_ $ E.isJust (qualUsr E.?. QualificationUserUser)
|
||||
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)
|
||||
|
||||
let heading = [whamlet|_{MsgMenuLmsUser} ^{userWidget user}|]
|
||||
|
||||
@ -34,13 +34,13 @@ data LmsUserTableCsv = LmsUserTableCsv -- for csv export only
|
||||
makeLenses_ ''LmsUserTableCsv
|
||||
|
||||
-- | Mundane conversion needed for direct download without dbTable onlu
|
||||
lmsUser2csv :: LmsUser -> LmsUserTableCsv
|
||||
lmsUser2csv lu@LmsUser{..} = LmsUserTableCsv
|
||||
lmsUser2csv :: Day -> LmsUser -> LmsUserTableCsv
|
||||
lmsUser2csv cutoff lu@LmsUser{..} = LmsUserTableCsv
|
||||
{ csvLUTident = lmsUserIdent
|
||||
, csvLUTpin = lmsUserPin
|
||||
, csvLUTresetPin = lmsUserResetPin & LmsBool
|
||||
, csvLUTdelete = lmsUserToDelete lu & LmsBool
|
||||
, csvLUTstaff = False & LmsBool
|
||||
, csvLUTresetPin = lmsUserResetPin & LmsBool
|
||||
, csvLUTdelete = lmsUserToDelete cutoff lu & LmsBool
|
||||
, csvLUTstaff = False & LmsBool
|
||||
}
|
||||
|
||||
-- csv without headers
|
||||
@ -84,7 +84,8 @@ instance CsvColumnsExplained LmsUserTableCsv where
|
||||
|
||||
mkUserTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget)
|
||||
mkUserTable _sid qsh qid = do
|
||||
dbtCsvName <- csvFilenameLmsUser qsh
|
||||
cutoff <- liftHandler lmsDeletionDate
|
||||
dbtCsvName <- csvFilenameLmsUser qsh
|
||||
let dbtCsvSheetName = dbtCsvName
|
||||
let
|
||||
userDBTable = DBTable{..}
|
||||
@ -100,14 +101,14 @@ mkUserTable _sid qsh qid = do
|
||||
, sortable (Just csvLmsPin) (i18nCell MsgTableLmsPin & cellAttrs <>~ [("uw-hide-column-default-hidden",mempty)]
|
||||
) $ \(view $ _dbrOutput . _entityVal . _lmsUserPin -> pin ) -> textCell pin
|
||||
, 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
|
||||
]
|
||||
dbtSorting = Map.fromList
|
||||
[ (csvLmsIdent , SortColumn (E.^. LmsUserIdent))
|
||||
, (csvLmsPin , SortColumn (E.^. LmsUserPin))
|
||||
, (csvLmsResetPin , SortColumn (E.^. LmsUserResetPin))
|
||||
, (csvLmsDelete , SortColumn lmsUserToDeleteExpr)
|
||||
, (csvLmsDelete , SortColumn (lmsUserToDeleteExpr cutoff))
|
||||
]
|
||||
dbtFilter = Map.fromList
|
||||
[ (csvLmsIdent , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsUserIdent ))
|
||||
@ -132,7 +133,7 @@ mkUserTable _sid qsh qid = do
|
||||
<$> view (_dbrOutput . _entityVal . _lmsUserIdent)
|
||||
<*> view (_dbrOutput . _entityVal . _lmsUserPin)
|
||||
<*> view (_dbrOutput . _entityVal . _lmsUserResetPin . _lmsBool)
|
||||
<*> view (_dbrOutput . _entityVal . _lmsUserToDelete . _lmsBool)
|
||||
<*> view (_dbrOutput . _entityVal . _lmsUserToDelete cutoff . _lmsBool)
|
||||
<*> const (LmsBool False)
|
||||
|
||||
dbtCsvDecode = Nothing
|
||||
@ -154,6 +155,7 @@ getLmsUsersR sid qsh = do
|
||||
getLmsUsersDirectR :: SchoolId -> QualificationShorthand -> Handler TypedContent
|
||||
getLmsUsersDirectR sid qsh = do
|
||||
$logInfoS "LMS" $ "Direct Download Users for " <> tshow qsh <> " at " <> tshow sid
|
||||
cutoff <- lmsDeletionDate
|
||||
lms_users <- runDB $ do
|
||||
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
|
||||
selectList [LmsUserQualification ==. qid, LmsUserEnded ==. Nothing] [Asc LmsUserStarted, Asc LmsUserIdent]
|
||||
@ -170,11 +172,11 @@ getLmsUsersDirectR sid qsh = do
|
||||
, csvLUTstaff = LmsBool False
|
||||
}
|
||||
-}
|
||||
LmsConf{..} <- getsYesod $ view _appLmsConf
|
||||
LmsConf{..} <- getsYesod $ view _appLmsConf
|
||||
let --csvRenderedData = toNamedRecord . lmsUser2csv . entityVal <$> lms_users
|
||||
--csvRenderedHeader = lmsUserTableCsvHeader
|
||||
--cvsRendered = CsvRendered {..}
|
||||
csvRendered = toCsvRendered lmsUserTableCsvHeader $ lmsUser2csv . entityVal <$> lms_users
|
||||
csvRendered = toCsvRendered lmsUserTableCsvHeader $ lmsUser2csv cutoff . entityVal <$> lms_users
|
||||
fmtOpts = def { csvIncludeHeader = lmsDownloadHeader
|
||||
, csvDelimiter = lmsDownloadDelimiter
|
||||
, csvUseCrLf = lmsDownloadCrLf
|
||||
|
||||
@ -18,110 +18,74 @@ import Import
|
||||
import qualified Data.Set as Set
|
||||
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 qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma
|
||||
import qualified Database.Esqueleto.Legacy as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
import Database.Esqueleto.Utils.TH
|
||||
|
||||
import qualified Control.Monad.State.Class as State
|
||||
import Utils.Print
|
||||
-- import Data.Aeson (encode)
|
||||
-- import qualified Data.Text as Text
|
||||
-- import qualified Data.Set as Set
|
||||
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Csv
|
||||
import qualified Data.Csv as Csv
|
||||
-- import Handler.Utils.Csv
|
||||
-- import qualified Data.Csv as Csv
|
||||
|
||||
-- avoids repetition of local definitions
|
||||
single :: (k,a) -> Map k a
|
||||
single = uncurry Map.singleton
|
||||
|
||||
data MetaPinRenewal = MetaPinRenewal
|
||||
{ mppExaminee :: Text
|
||||
, mppAddress :: StoredMarkup
|
||||
, mppLogin :: Text
|
||||
, mppPin :: Text
|
||||
, mppURL :: Maybe URI
|
||||
, mppDate :: Day
|
||||
, mppLang :: Lang
|
||||
, mppOpening :: Maybe Text
|
||||
, mppClosing :: Maybe Text
|
||||
, mppSupervisor:: Maybe Text
|
||||
}
|
||||
deriving (Eq, Ord, Show, Generic)
|
||||
data LRQF = LRQF
|
||||
{ lrqfUser :: Either UserEmail UserId
|
||||
, lrqfSuper :: Maybe (Either UserEmail UserId)
|
||||
, lrqfQuali :: Entity Qualification
|
||||
, lrqfIdent :: LmsIdent
|
||||
, lrqfPin :: Text
|
||||
, lrqfExpiry:: Day
|
||||
} deriving (Eq, Generic)
|
||||
|
||||
-- TODO: just for testing, remove in production
|
||||
instance Default MetaPinRenewal where
|
||||
def = MetaPinRenewal
|
||||
{ mppExaminee = "Papa Schlumpf"
|
||||
, mppAddress = plaintextToStoredMarkup ("Erdbeerweg 42\n98726 Schlumpfhausen"::Text)
|
||||
, mppLogin = "keiner123"
|
||||
, mppPin = "89998a"
|
||||
, mppURL = Nothing
|
||||
, mppDate = fromGregorian 2022 07 27
|
||||
, mppLang = "de-de"
|
||||
, mppOpening = Just "Lieber Schlumpfi,"
|
||||
, mppClosing = Nothing
|
||||
, mppSupervisor= Nothing
|
||||
makeRenewalForm :: Maybe LRQF -> Form LRQF
|
||||
makeRenewalForm tmpl = identifyForm FIDLmsLetter . validateForm validateLetterRenewQualificationF $ \html -> do
|
||||
-- now_day <- utctDay <$> liftIO getCurrentTime
|
||||
flip (renderAForm FormStandard) html $ LRQF
|
||||
<$> areq (userField False Nothing) (fslI MsgLmsUser) (lrqfUser <$> tmpl)
|
||||
<*> aopt (userField False Nothing) (fslI MsgTableSupervisor) (lrqfSuper <$> tmpl)
|
||||
<*> areq qualificationFieldEnt (fslI MsgQualificationName) (lrqfQuali <$> tmpl)
|
||||
<*> areq lmsField (fslI MsgTableLmsIdent) (lrqfIdent <$> tmpl)
|
||||
<*> areq textField (fslI MsgTableLmsPin) (lrqfPin <$> tmpl)
|
||||
<*> areq dayField (fslI MsgLmsQualificationValidUntil) (lrqfExpiry <$> tmpl)
|
||||
where
|
||||
lmsField = convertField LmsIdent getLmsIdent textField
|
||||
|
||||
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
|
||||
}
|
||||
|
||||
makeRenewalForm :: Maybe MetaPinRenewal -> Form MetaPinRenewal
|
||||
makeRenewalForm tmpl = identifyForm FIDLmsLetter . validateForm validateMetaPinRenewal $ \html -> do
|
||||
now_day <- utctDay <$> liftIO getCurrentTime
|
||||
flip (renderAForm FormStandard) html $ MetaPinRenewal
|
||||
<$> areq textField (fslI MsgMppRecipient) (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
|
||||
return (fromMaybe usr rcvr, letter)
|
||||
where
|
||||
getUser :: Either UserEmail UserId -> DB (Entity User)
|
||||
getUser (Right uid) = getEntity404 uid
|
||||
getUser (Left mail) = getBy404 $ UniqueEmail mail
|
||||
|
||||
|
||||
data PJTableAction = PJActAcknowledge
|
||||
@ -201,12 +165,13 @@ mkPJTable = do
|
||||
dbtProj = dbtProjFilteredPostId
|
||||
dbtColonnade = mconcat
|
||||
[ 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 "acknowledged") (i18nCell MsgPrintJobAcknowledged) $ \( view $ resultPrintJob . _entityVal . _printJobAcknowledged -> t) -> maybeDateTimeCell 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 "filename") (i18nCell MsgPrintPDF) $ \r -> let k = r ^. resultPrintJob . _entityKey
|
||||
t = r ^. resultPrintJob . _entityVal . _printJobFilename
|
||||
in anchorCellM (PrintDownloadR <$> encrypt k) (toWgt t)
|
||||
, sortable (Just "name") (i18nCell MsgPrintJobName) $ \( view $ resultPrintJob . _entityVal . _printJobName -> n) -> textCell n
|
||||
, sortable (Just "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 "sender") (i18nCell MsgPrintSender) $ \(preview resultSender -> u) -> maybeCell u $ cellHasUserLink AdminUserR
|
||||
, 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 ("created" , SortColumn $ queryPrintJob >>> (E.^. PrintJobCreated))
|
||||
, single ("acknowledged" , SortColumn $ queryPrintJob >>> (E.^. PrintJobAcknowledged))
|
||||
, single ("apcid" , SortColumn $ queryPrintJob >>> (E.^. PrintJobApcIdent))
|
||||
, single ("recipient" , sortUserNameBareM queryRecipient)
|
||||
, single ("sender" , sortUserNameBareM querySender )
|
||||
, single ("course" , SortColumn $ queryCourse >>> (E.?. CourseName))
|
||||
@ -226,7 +192,8 @@ mkPJTable = do
|
||||
]
|
||||
dbtFilter = mconcat
|
||||
[ 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.mkDayBetweenFilter $ views (to queryPrintJob) (E.^. PrintJobCreated))
|
||||
, 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 ("qualification", FilterColumn . E.mkContainsFilterWith Just $ views (to queryQualification) (E.?. QualificationName))
|
||||
, single ("lmsid" , FilterColumn . E.mkContainsFilterWith Just $ views (to queryPrintJob) (E.^. PrintJobLmsUser))
|
||||
|
||||
, single ("acknowledged" , FilterColumn . E.mkExactFilterLast $ views (to queryPrintJob) (E.isJust . (E.^. PrintJobAcknowledged)))
|
||||
]
|
||||
dbtFilterUI mPrev = mconcat
|
||||
@ -248,6 +216,7 @@ mkPJTable = do
|
||||
, prismAForm (singletonFilter "course" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintCourse)
|
||||
, prismAForm (singletonFilter "qualification". maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintQualification)
|
||||
, prismAForm (singletonFilter "lmsid" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintLmsUser)
|
||||
, prismAForm (singletonFilter "apcid" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintJobApcAcknowledge)
|
||||
, prismAForm (singletonFilter "acknowledged" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgPrintJobAcknowledged)
|
||||
]
|
||||
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout}
|
||||
@ -279,7 +248,7 @@ mkPJTable = do
|
||||
(First (Just act), jobMap) <- inp
|
||||
let jobSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) jobMap
|
||||
return (act, jobSet)
|
||||
psValidator = def & defaultSorting [SortAscBy "created"]
|
||||
psValidator = def & defaultSorting [SortDescBy "created"]
|
||||
-- & defaultFilter (singletonMap "acknowledged" [toPathPiece False]) -- TODO: sorting with Nothing restores this filter
|
||||
over _1 postprocess <$> dbTable psValidator DBTable{..}
|
||||
|
||||
@ -304,40 +273,34 @@ postPrintCenterR = do
|
||||
getPrintSendR, postPrintSendR :: Handler Html
|
||||
getPrintSendR = postPrintSendR
|
||||
postPrintSendR = do
|
||||
((sendResult, sendWidget), sendEnctype) <- runFormPost $ makeRenewalForm $ Just def
|
||||
let procFormSend mpr = do
|
||||
receivers <- runDB $ Ex.select $ do
|
||||
user <- Ex.from $ Ex.table @User
|
||||
Ex.where_ $ E.val (mppExaminee mpr) `E.isInfixOf` (user E.^. UserIdent)
|
||||
pure user
|
||||
letters <- case receivers of
|
||||
[] -> pure . (Nothing ,) <$> pdfRenewal (mprToMeta mpr)
|
||||
_ -> forM receivers $ \usr -> do
|
||||
meta <- mprToMetaUser usr mpr
|
||||
pdf <- pdfRenewal meta
|
||||
return (Just $ entityKey usr, pdf)
|
||||
oks <- forM letters $ \case
|
||||
(mbRecipient, Right bs) -> do
|
||||
-- liftIO $ LBS.writeFile "/tmp/generated.pdf" bs -- DEBUGGING ONLY
|
||||
-- addMessage Warning "PDF momentan nur gespeicher unter /tmp/generated.pdf"
|
||||
uID <- maybeAuthId
|
||||
runDB (sendLetter' "Test-Brief" bs (mbRecipient, uID) Nothing Nothing Nothing) >>= \case -- calls lpr
|
||||
Left err -> do
|
||||
let msg = "PDF printing failed with error: " <> err
|
||||
$logErrorS "LPR" 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
|
||||
usr <- requireAuth -- to determine language and recipient for test
|
||||
mbQual <- runDB $ selectFirst [] [Asc QualificationAvsLicence, Asc QualificationShorthand]
|
||||
now <- liftIO getCurrentTime
|
||||
let nowaday = utctDay now
|
||||
uid = usr ^. _entityKey
|
||||
mkLetter qual = LRQF
|
||||
{ lrqfUser = Right uid
|
||||
, lrqfSuper = Nothing
|
||||
, lrqfQuali = qual
|
||||
, lrqfIdent = LmsIdent "stuvwxyz"
|
||||
, lrqfPin = "76543210"
|
||||
, lrqfExpiry = succ nowaday
|
||||
}
|
||||
def_lrqf = mkLetter <$> mbQual
|
||||
|
||||
((sendResult, sendWidget), sendEnctype) <- runFormPost $ makeRenewalForm def_lrqf
|
||||
let procFormSend lrqf = do
|
||||
ok <- (runDB (lrqf2letter lrqf) >>= printLetter (Just uid)) >>= \case
|
||||
Left err -> do
|
||||
let msg = "PDF printing failed with error: " <> err
|
||||
$logErrorS "LPR" msg
|
||||
addMessage Error $ toHtml msg
|
||||
pure False
|
||||
(Just uid, Left err) -> do
|
||||
addMessage Error . toHtml $ "For uid " <> tshow uid <> ": " <> err
|
||||
pure False
|
||||
when (or oks) $ redirect PrintCenterR
|
||||
Right (ok, fpath) -> do
|
||||
let response = if null ok then mempty else " Response: " <> ok
|
||||
addMessage Success $ toHtml $ "Druckauftrag angelegt: " <> pack fpath <> response
|
||||
pure True
|
||||
when ok $ redirect PrintCenterR
|
||||
formResult sendResult procFormSend
|
||||
-- actionUrl <- fromMaybe AdminAvsR <$> getCurrentRoute
|
||||
siteLayoutMsg MsgPrintManualRenewal $ do
|
||||
@ -410,7 +373,11 @@ postPrintAckR ackDay numAck chksm = do
|
||||
ackForm
|
||||
|
||||
-- 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 = do
|
||||
@ -419,29 +386,37 @@ postPrintAckDirectR = do
|
||||
[(fhead,file)] -> do
|
||||
runDB $ do
|
||||
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
|
||||
case enr of
|
||||
Left (e :: SomeException) -> do -- catch all to avoid ok220 in case of any error
|
||||
$logWarnS "APC" $ "Result upload failed parsing: " <> tshow e
|
||||
return (badRequest400, "Error: " <> tshow e)
|
||||
Right lids -> do
|
||||
Right reqIds -> do
|
||||
let nrReq = length reqIds
|
||||
now <- liftIO getCurrentTime
|
||||
nr <- updateWhereCount
|
||||
[PrintJobAcknowledged ==. Nothing, PrintJobLmsUser <-. (Just <$> lids)]
|
||||
nrApcIds <- updateWhereCount
|
||||
[PrintJobAcknowledged ==. Nothing, PrintJobApcIdent <-. reqIds]
|
||||
[PrintJobAcknowledged =. Just now]
|
||||
let lenLids = length lids
|
||||
if | lenLids <= 0 -> do
|
||||
let msg = "Error: No print job was acknowledged as printed, but " <> tshow lenLids <> " were requested to be, for file " <> fhead
|
||||
nrOk <- if nrApcIds <= 0 && nrReq > 0
|
||||
then updateWhereCount -- for downwards compatibility only
|
||||
[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
|
||||
return (badRequest400, msg)
|
||||
| lenLids == fromIntegral nr -> do
|
||||
let msg = "Success: " <> tshow nr <> " print jobs were acknowledged as printed, for file " <> fhead
|
||||
| nrReq == fromIntegral nrOk -> do
|
||||
let msg = "Success: " <> tshow nrOk <> " print jobs were acknowledged as printed, for file " <> fhead
|
||||
$logInfoS "APC" msg
|
||||
return (ok200, msg)
|
||||
| otherwise -> do
|
||||
let msg = "Warning: Only " <> tshow nr <> " print jobs out of " <> tshow lenLids <> " were acknowledged as printed, for file " <> fhead
|
||||
$logWarnS "APC" msg
|
||||
forM_ reqIds $ \t -> $logInfoS "APC" $ "Received APC Identifier: \"" <> t <> "\""
|
||||
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)
|
||||
[] -> do
|
||||
let msg = "Error: No file received. A file of lms identifiers must be supplied for print job acknowledging."
|
||||
|
||||
@ -357,6 +357,10 @@ validateSettings User{..} = do
|
||||
userDisplayName == userDisplayName' || -- unchanged or valid (invalid displayNames delivered by LDAP are preserved)
|
||||
validDisplayName userTitle userFirstName userSurname userDisplayName'
|
||||
|
||||
userDisplayEmail' <- use _stgDisplayEmail
|
||||
guardValidation (MsgInvalidEmailAddressWith $ CI.original userDisplayEmail') $
|
||||
validEmail' userDisplayEmail'
|
||||
|
||||
userPostAddress' <- use _stgPostAddress
|
||||
let postalNotSet = isNothing userPostAddress'
|
||||
postalIsValid = validPostAddress userPostAddress'
|
||||
@ -445,7 +449,7 @@ serveProfileR (uid, user@User{..}) = do
|
||||
now <- liftIO getCurrentTime
|
||||
runDBJobs $ do
|
||||
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 ] ++
|
||||
[ UserDisplayName =. stgDisplayName
|
||||
, UserMaxFavourites =. stgMaxFavourites
|
||||
@ -617,6 +621,7 @@ makeProfileData (Entity uid User{..}) = do
|
||||
mCRoute <- getCurrentRoute
|
||||
showAdminInfo <- pure (mCRoute == Just (AdminUserR cID)) `or2M` hasReadAccessTo (AdminUserR cID)
|
||||
tooltipAvsPersNo <- messageI Info MsgAvsPersonNoNotId
|
||||
tooltipInvalidEmail <- messageI Error MsgInvalidEmailAddress
|
||||
|
||||
let profileRemarks = $(i18nWidgetFile "profile-remarks")
|
||||
return $(widgetFile "profileData")
|
||||
|
||||
@ -73,7 +73,7 @@ getSupervisees = do
|
||||
mkQualificationAllTable :: DB (Any, Widget)
|
||||
mkQualificationAllTable = do
|
||||
svs <- getSupervisees
|
||||
now <- liftIO getCurrentTime
|
||||
now <- liftIO getCurrentTime
|
||||
let
|
||||
resultDBTable = DBTable{..}
|
||||
where
|
||||
@ -236,7 +236,12 @@ instance HasEntity QualificationTableData User where
|
||||
instance HasUser QualificationTableData where
|
||||
hasUser = resultUser . _entityVal
|
||||
|
||||
data QualificationTableAction = QualificationActExpire | QualificationActUnexpire
|
||||
data QualificationTableAction
|
||||
= QualificationActExpire
|
||||
| QualificationActUnexpire
|
||||
| QualificationActBlockSupervisor
|
||||
| QualificationActBlock
|
||||
| QualificationActUnblock
|
||||
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
||||
|
||||
instance Universe QualificationTableAction
|
||||
@ -245,12 +250,24 @@ nullaryPathPiece ''QualificationTableAction $ camelToPathPiece' 2
|
||||
embedRenderMessage ''UniWorX ''QualificationTableAction id
|
||||
|
||||
-- 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)
|
||||
|
||||
isExpiryAct :: QualificationTableActionData -> Bool -- const true, but this may change in the future
|
||||
isExpiryAct :: QualificationTableActionData -> Bool
|
||||
isExpiryAct QualificationActExpireData = 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
|
||||
-> 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-plus",SortColumn $ \row -> E.coalesce [E.explicitUnsafeCoerceSqlExprValue "timestamp" $ (queryLmsUser row E.?. LmsUserStatus) E.#>>. "{day}"
|
||||
, 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
|
||||
[ 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
|
||||
E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday
|
||||
| otherwise -> E.true
|
||||
)
|
||||
)
|
||||
]
|
||||
dbtFilterUI mPrev = mconcat
|
||||
[ fltrUserNameEmailHdrUI MsgLmsUser mPrev
|
||||
@ -400,19 +424,36 @@ postQualificationR sid qsh = do
|
||||
((lmsRes, qualificationTable), Entity qid quali) <- runDB $ do
|
||||
qent@Entity{entityVal=Qualification{qualificationAuditDuration=auditMonths}} <- getBy404 $ SchoolQualificationShort sid qsh
|
||||
let acts :: Map QualificationTableAction (AForm Handler QualificationTableActionData)
|
||||
acts = mconcat
|
||||
acts = mconcat $
|
||||
[ singletonMap QualificationActExpire $ pure QualificationActExpireData
|
||||
, singletonMap QualificationActUnexpire $ pure QualificationActUnexpireData
|
||||
]
|
||||
linkLmsUser = toMaybe isAdmin LmsUserR
|
||||
] ++ bool
|
||||
[ 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
|
||||
[ dbSelect (applying _2) id (return . view (resultUser . _entityKey))
|
||||
, colUserNameModalHdr MsgLmsUser ForProfileR
|
||||
, colUserNameModalHdr MsgLmsUser linkUserName
|
||||
, 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 "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d
|
||||
, 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
|
||||
) $ \( view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification
|
||||
-- , sortable (Just "lms-started") (i18nCell MsgTableLmsElearning <> spacerCell <> i18nCell MsgTableLmsStarted)
|
||||
@ -425,18 +466,39 @@ postQualificationR sid qsh = do
|
||||
tbl <- mkQualificationTable isAdmin qent acts colChoices psValidator
|
||||
return (tbl, qent)
|
||||
|
||||
formResult lmsRes $ \case
|
||||
_ | not isAdmin -> addMessageI Error MsgUnauthorized -- only admins can use the form on this page for now
|
||||
(action, selectedUsers) | isExpiryAct action -> do
|
||||
formResult lmsRes $ \case
|
||||
(action, selectedUsers) | isExpiryAct action -> do
|
||||
let isUnexpire = action == QualificationActUnexpireData
|
||||
upd <- runDB $ updateWhereCount
|
||||
upd <- runDB $ updateWhereCount
|
||||
[QualificationUserQualification ==. qid, QualificationUserUser <-. Set.toList selectedUsers]
|
||||
[QualificationUserScheduleRenewal =. isUnexpire]
|
||||
let msgKind = if upd > 0 then Success else Warning
|
||||
msgVal = upd & if isUnexpire then MsgQualificationSetUnexpire else MsgQualificationSetExpire
|
||||
addMessageI msgKind msgVal
|
||||
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
|
||||
siteLayout heading $ do
|
||||
|
||||
@ -77,20 +77,18 @@ getTermShowR = do
|
||||
-> cell $ formatTime SelFormatDate termEnd >>= toWidget
|
||||
, sortable Nothing (i18nCell MsgTermHolidays) $ \(Entity _ Term{..},_, _)
|
||||
-> cell $ do
|
||||
let termHolidays' = groupHolidays termHolidays
|
||||
[whamlet|
|
||||
$newline never
|
||||
<ul .list--inline .list--comma-separated>
|
||||
$forall holiday <- termHolidays'
|
||||
$case holiday
|
||||
$of Left singleHoliday
|
||||
<li>^{formatTimeW SelFormatDate singleHoliday}
|
||||
$of Right (startD, endD)
|
||||
<li>
|
||||
^{formatTimeW SelFormatDate startD}
|
||||
–
|
||||
^{formatTimeW SelFormatDate endD}
|
||||
|]
|
||||
let termHolidays' = groupHolidays termHolidays
|
||||
[whamlet|
|
||||
$newline never
|
||||
<ul .list--inline .list--comma-separated>
|
||||
$forall holiday <- termHolidays'
|
||||
<li>
|
||||
$case holiday
|
||||
$of Left singleHoliday
|
||||
^{formatTimeW SelFormatDate singleHoliday}
|
||||
$of Right (startD, endD)
|
||||
^{formatTimeRangeW SelFormatDate startD (Just endD)}
|
||||
|]
|
||||
]
|
||||
dbtSorting = Map.fromList
|
||||
[ ( "start"
|
||||
|
||||
@ -2,6 +2,8 @@
|
||||
--
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
module Handler.Tutorial.Users
|
||||
( getTUsersR, postTUsersR
|
||||
) where
|
||||
@ -10,6 +12,7 @@ import Import
|
||||
|
||||
import Utils.Form
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Course
|
||||
import Handler.Utils.Tutorial
|
||||
import Database.Persist.Sql (deleteWhereCount)
|
||||
|
||||
@ -20,13 +23,15 @@ import qualified Data.Map as Map
|
||||
|
||||
-- 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
|
||||
|
||||
|
||||
data TutorialUserAction
|
||||
= TutorialUserRenewQualification
|
||||
= TutorialUserPrintQualification
|
||||
| TutorialUserRenewQualification
|
||||
| TutorialUserGrantQualification
|
||||
| TutorialUserSendMail
|
||||
| TutorialUserDeregister
|
||||
@ -38,12 +43,15 @@ nullaryPathPiece ''TutorialUserAction $ camelToPathPiece' 2
|
||||
embedRenderMessage ''UniWorX ''TutorialUserAction id
|
||||
|
||||
data TutorialUserActionData
|
||||
= TutorialUserRenewQualificationData
|
||||
= TutorialUserPrintQualificationData
|
||||
{ tuQualification :: QualificationId
|
||||
}
|
||||
| TutorialUserRenewQualificationData
|
||||
{ tuQualification :: QualificationId }
|
||||
| TutorialUserGrantQualificationData
|
||||
{ tuQualification :: QualificationId
|
||||
, tuValidUntil :: Day
|
||||
}
|
||||
}
|
||||
| TutorialUserSendMailData
|
||||
| TutorialUserDeregisterData{}
|
||||
deriving (Eq, Ord, Read, Show, Generic)
|
||||
@ -53,9 +61,10 @@ getTUsersR, postTUsersR :: TermId -> SchoolId -> CourseShorthand -> TutorialName
|
||||
getTUsersR = postTUsersR
|
||||
postTUsersR tid ssh csh tutn = do
|
||||
showSex <- getShowSex
|
||||
(Entity tutid Tutorial{..}, (participantRes, participantTable)) <- runDB $ do
|
||||
tut@(Entity tutid _) <- fetchTutorial tid ssh csh tutn
|
||||
qualifications <- selectList [QualificationSchool ==. ssh] [Asc QualificationShorthand]
|
||||
(Entity tutid Tutorial{..}, (participantRes, participantTable), qualifications) <- runDB $ do
|
||||
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
tut@(Entity tutid _) <- fetchTutorial tid ssh csh tutn
|
||||
qualifications <- getCourseQualifications cid
|
||||
now <- liftIO getCurrentTime
|
||||
let minDur :: Maybe Int = minimumMaybe $ catMaybes (view _qualificationValidDuration <$> qualifications) -- no instance Ord CalendarDiffDays
|
||||
dayExpiry = flip addGregorianDurationClip (utctDay now) . fromMonths <$> minDur
|
||||
@ -71,12 +80,12 @@ postTUsersR tid ssh csh tutn = do
|
||||
& defaultSortingByName
|
||||
& restrictSorting (\name _ -> none (== name) ["note", "registration", "tutorials", "exams", "submission-group", "state"]) -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information
|
||||
& restrictFilter (\name _ -> none (== name) ["tutorial", "exam", "submission-group", "active", "has-personalised-sheet-files"])
|
||||
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.&&. tutorialParticipant E.^. TutorialParticipantTutorial E.==. E.val tutid
|
||||
csvColChoices = flip elem ["name", "matriculation", "email", "qualifications"]
|
||||
|
||||
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
|
||||
let
|
||||
qualOpt :: Entity Qualification -> Handler (Option QualificationId)
|
||||
qualOpt (Entity qualId qual) = do
|
||||
@ -87,33 +96,47 @@ postTUsersR tid ssh csh tutn = do
|
||||
, optionExternalValue = tshow cQualId
|
||||
}
|
||||
acts :: Map TutorialUserAction (AForm Handler TutorialUserActionData)
|
||||
acts = Map.fromList
|
||||
[ ( TutorialUserRenewQualification
|
||||
, TutorialUserRenewQualificationData
|
||||
<$> apopt (selectField . fmap mkOptionList $ mapM qualOpt qualifications) (fslI MsgQualificationName) Nothing
|
||||
)
|
||||
, ( TutorialUserGrantQualification
|
||||
, TutorialUserGrantQualificationData
|
||||
<$> apopt (selectField . fmap mkOptionList $ mapM qualOpt qualifications) (fslI MsgQualificationName) Nothing
|
||||
<*> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry
|
||||
)
|
||||
, ( TutorialUserSendMail, pure TutorialUserSendMailData )
|
||||
acts = Map.fromList $
|
||||
(if null qualifications then mempty else
|
||||
[ ( TutorialUserPrintQualification
|
||||
, TutorialUserPrintQualificationData
|
||||
<$> apopt (selectField . fmap mkOptionList $ mapM qualOpt qualifications) (fslI MsgQualificationName) Nothing
|
||||
)
|
||||
, ( TutorialUserRenewQualification
|
||||
, TutorialUserRenewQualificationData
|
||||
<$> apopt (selectField . fmap mkOptionList $ mapM qualOpt qualifications) (fslI MsgQualificationName) Nothing
|
||||
)
|
||||
, ( TutorialUserGrantQualification
|
||||
, TutorialUserGrantQualificationData
|
||||
<$> apopt (selectField . fmap mkOptionList $ mapM qualOpt qualifications) (fslI MsgQualificationName) Nothing
|
||||
<*> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry
|
||||
)
|
||||
]
|
||||
) ++
|
||||
[ ( TutorialUserSendMail, pure TutorialUserSendMailData )
|
||||
, ( TutorialUserDeregister, pure TutorialUserDeregisterData )
|
||||
]
|
||||
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
|
||||
(TutorialUserGrantQualificationData{..}, selectedUsers) -> do
|
||||
-- today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime
|
||||
today <- utctDay <$> liftIO getCurrentTime
|
||||
runDB . forM_ selectedUsers $ upsertQualificationUser tuQualification today tuValidUntil Nothing
|
||||
addMessageI Success . MsgTutorialUserGrantedQualification $ Set.size selectedUsers
|
||||
redirect $ CTutorialR tid ssh csh tutn TUsersR
|
||||
(TutorialUserRenewQualificationData{..}, selectedUsers) -> 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
|
||||
(TutorialUserPrintQualificationData{..}, _selectedUsers)
|
||||
| tuQualification `Set.member` courseQids -> do
|
||||
-- TODO Continue here
|
||||
addMessageI Error MsgErrorUnknownFormAction
|
||||
(TutorialUserGrantQualificationData{..}, selectedUsers)
|
||||
| tuQualification `Set.member` courseQids -> do
|
||||
-- today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime
|
||||
today <- utctDay <$> liftIO getCurrentTime
|
||||
runDB . forM_ selectedUsers $ upsertQualificationUser tuQualification today tuValidUntil Nothing
|
||||
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
|
||||
cids <- traverse encrypt $ Set.toList selectedUsers :: Handler [CryptoUUIDUser]
|
||||
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
|
||||
redirect $ CTutorialR tid ssh csh tutn TUsersR
|
||||
_other ->
|
||||
addMessageI Error MsgErrorUnknownFormAction
|
||||
|
||||
tutors <- runDB $
|
||||
E.select $ E.from $ \(tutor `E.InnerJoin` user) -> do
|
||||
E.on $ tutor E.^. TutorUser E.==. user E.^. UserId
|
||||
E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid
|
||||
return user
|
||||
tutors <- runDB $ E.select $ do
|
||||
(tutor :& user) <- E.from $ E.table @Tutor `E.innerJoin` E.table @User
|
||||
`E.on` (\(tutor :& user) -> tutor E.^. TutorUser E.==. user E.^. UserId)
|
||||
E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid
|
||||
return user
|
||||
|
||||
let heading = prependCourseTitle tid ssh csh $ CI.original tutorialName
|
||||
siteLayoutMsg heading $ do
|
||||
|
||||
@ -188,10 +188,10 @@ postUsersR = do
|
||||
acts = mconcat
|
||||
[ singletonMap UserLdapSync $ pure UserLdapSyncData
|
||||
, 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)
|
||||
, 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)
|
||||
, singletonMap UserRemoveSupervisor $ pure UserRemoveSupervisorData
|
||||
]
|
||||
|
||||
@ -129,7 +129,7 @@ setLicenceAvs apid lic = do
|
||||
--setLicencesAvs :: Set AvsPersonLicence -> Handler Bool
|
||||
setLicencesAvs :: (MonadHandler m, MonadThrow m, HandlerSite m ~ UniWorX) =>
|
||||
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
|
||||
aux aqsl 0 persLics
|
||||
where
|
||||
|
||||
@ -2,6 +2,8 @@
|
||||
--
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
module Handler.Utils.Course where
|
||||
|
||||
import Import
|
||||
@ -10,6 +12,8 @@ import Handler.Utils.Memcached
|
||||
|
||||
import qualified Database.Esqueleto.Legacy 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
|
||||
|
||||
@ -103,3 +107,16 @@ showCourseEventRoom uid courseEvent = E.or
|
||||
E.where_ $ lecturer E.^. LecturerUser E.==. uid
|
||||
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
|
||||
@ -333,6 +333,7 @@ formatTimeRange' :: ( HasLocalTime t, HasLocalTime t'
|
||||
-> t -- ^ Start
|
||||
-> Maybe t' -- ^ End
|
||||
-> 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
|
||||
startT' <- cont proj startT
|
||||
let
|
||||
|
||||
@ -594,6 +594,9 @@ degreeField = selectField $ optionsPersistKey [] [Asc StudyDegreeName, Asc Study
|
||||
degreeFieldEnt :: Field Handler (Entity StudyDegree)
|
||||
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)
|
||||
studyFeaturesPrimaryFieldFor :: Bool -- ^ Allow user to select `Nothing` (only applies if set of options is nonempty)?
|
||||
|
||||
@ -17,6 +17,7 @@ module Handler.Utils.LMS
|
||||
, csvFilenameLmsUser
|
||||
, csvFilenameLmsUserlist
|
||||
, csvFilenameLmsResult
|
||||
, lmsDeletionDate
|
||||
, lmsUserToDelete, _lmsUserToDelete
|
||||
, lmsUserToDeleteExpr
|
||||
, lmsUserStatusWidget
|
||||
@ -33,6 +34,7 @@ import Data.Csv (HasHeader(..), FromRecord)
|
||||
|
||||
import qualified Data.Set as Set (notMember)
|
||||
import qualified Database.Esqueleto.Legacy as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
|
||||
import Control.Monad.Random.Class (uniform)
|
||||
import Control.Monad.Trans.Random (evalRandTIO)
|
||||
@ -101,15 +103,25 @@ makeLmsFilename ftag (citext2lower -> qsh) = do
|
||||
getYMTH :: MonadHandler m => m Text
|
||||
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
|
||||
lmsUserToDeleteExpr :: 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 :: Day -> E.SqlExpr (Entity LmsUser) -> E.SqlExpr (E.Value Bool)
|
||||
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 LmsUser{lmsUserEnded, lmsUserStatus} = isNothing lmsUserEnded && isJust lmsUserStatus
|
||||
|
||||
_lmsUserToDelete :: Getter LmsUser Bool
|
||||
_lmsUserToDelete = to lmsUserToDelete
|
||||
_lmsUserToDelete :: Day -> Getter LmsUser Bool
|
||||
_lmsUserToDelete cutoff = to $ lmsUserToDelete cutoff
|
||||
|
||||
-- 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 }
|
||||
|
||||
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 banList = untilJustMaxM maxLmsUserIdentRetries getIdentOk
|
||||
@ -147,8 +159,8 @@ randomLMSIdentBut banList = untilJustMaxM maxLmsUserIdentRetries getIdentOk
|
||||
l <- randomLMSIdent
|
||||
return $ toMaybe (Set.notMember l banList) l
|
||||
|
||||
randomLMSpw :: MonadIO m => m Text
|
||||
randomLMSpw = randomText extra lengthPassword
|
||||
randomLMSpw :: MonadIO m => m Text -- may contain all kinds of symbols, but our users had trouble with some, like ',' '.' ':' '_'
|
||||
randomLMSpw = randomText extra lengthPassword
|
||||
where
|
||||
extra = "+=!?" -- you cannot distinguish ;: and ., in printed letters
|
||||
|
||||
|
||||
@ -16,7 +16,7 @@ import Handler.Utils.Pandoc
|
||||
import Handler.Utils.Files
|
||||
import Handler.Utils.Widgets (nameHtml') -- TODO: how to use name widget here?
|
||||
import Handler.Utils.Users (getReceivers)
|
||||
import Handler.Utils.Profile (pickValidEmail)
|
||||
import Handler.Utils.Profile
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
@ -42,13 +42,13 @@ addRecipientsDB uFilter = runConduit $ transPipe (liftHandler . runDB) (selectSo
|
||||
userAddressFrom :: User -> Address
|
||||
-- ^ 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
|
||||
|
||||
userAddress :: User -> Address
|
||||
-- ^ 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}
|
||||
= Address (Just userDisplayName) $ CI.original $ pickValidEmail userDisplayEmail userEmail
|
||||
|
||||
@ -98,15 +98,21 @@ userMailT uid mAct = do
|
||||
$else
|
||||
_{MsgMailSupervisorNoCopy}
|
||||
|]
|
||||
mailT ctx $ do
|
||||
_mailTo .= pure (userAddress supervisor)
|
||||
mAct
|
||||
if uid==svr
|
||||
then when (2 <= length receivers) $ addHtmlMarkdownAlternatives' "InfoSupervised" infoSupervised -- notify about supervisors
|
||||
else do
|
||||
mapSubject ("[SUPERVISOR] " <>)
|
||||
addHtmlMarkdownAlternatives' "InfoSupervisor" infoSupervisor -- adding explanation why the supervisor received this email
|
||||
|
||||
mailtoAddr = userAddress supervisor
|
||||
if validEmail $ addressEmail mailtoAddr
|
||||
then
|
||||
mailT ctx $ do
|
||||
-- TODO: ensure that the Email is VALID HERE!
|
||||
_mailTo .= pure mailtoAddr
|
||||
mAct
|
||||
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
|
||||
userMailTdirect :: ( MonadHandler m
|
||||
@ -131,9 +137,22 @@ userMailTdirect uid mAct = do
|
||||
SelFormatTime -> userTimeFormat
|
||||
, mcCsvOptions = userCsvOptions
|
||||
}
|
||||
mailtoAddr = userAddress user
|
||||
mailT ctx $ do
|
||||
_mailTo .= pure (userAddress user)
|
||||
mAct
|
||||
failedSubject <- lookupMailHeader "Subject"
|
||||
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
|
||||
|
||||
@ -9,7 +9,8 @@ module Handler.Utils.Profile
|
||||
, validDisplayName
|
||||
, fixDisplayName
|
||||
, validPostAddress
|
||||
, validEmail, validEmail', pickValidEmail
|
||||
, validEmail, validEmail'
|
||||
, pickValidEmail, pickValidEmail'
|
||||
) where
|
||||
|
||||
import Import.NoFoundation
|
||||
@ -79,14 +80,27 @@ validPostAddress (Just StoredMarkup {markupInput = addr})
|
||||
= True
|
||||
validPostAddress _ = False
|
||||
|
||||
-- also see `Handler.Utils.Users.getEmailAddress` for Tests accepting User Type
|
||||
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' = 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
|
||||
pickValidEmail :: UserEmail -> UserEmail -> UserEmail
|
||||
pickValidEmail x y
|
||||
| validEmail' x = x
|
||||
| otherwise = y
|
||||
pickValidEmail x y
|
||||
| validEmail' x = x
|
||||
| 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
|
||||
@ -10,6 +10,7 @@ module Handler.Utils.Qualification
|
||||
import Import
|
||||
|
||||
-- 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.Utils as E
|
||||
|
||||
@ -100,4 +101,40 @@ renewValidQualificationUsers qid uids =
|
||||
, transactionQualificationScheduleRenewal = Nothing
|
||||
}
|
||||
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
|
||||
@ -370,7 +370,7 @@ qualificationBlockedCellNoReason (Just QualificationBlocked{qualificationBlocked
|
||||
qualificationBlockedCell :: IsDBTable m a => Maybe QualificationBlocked -> DBCell m a
|
||||
qualificationBlockedCell Nothing = mempty
|
||||
qualificationBlockedCell (Just QualificationBlocked{..})
|
||||
| 12 >= length qualificationBlockedReason = mkCellWith textCell
|
||||
| 32 >= length qualificationBlockedReason = mkCellWith textCell
|
||||
| otherwise = mkCellWith modalCell
|
||||
where
|
||||
mkCellWith c = c qualificationBlockedReason <> spacerCell <> iconCell IconBlocked <> spacerCell <> dayCell qualificationBlockedDay
|
||||
|
||||
@ -14,6 +14,7 @@ module Handler.Utils.Users
|
||||
, UserAssimilateException(..), UserAssimilateExceptionReason(..)
|
||||
, assimilateUser
|
||||
, userPrefersEmail, userPrefersLetter
|
||||
, getEmailAddress
|
||||
, getPostalAddress, getPostalPreferenceAndAddress
|
||||
, abbrvName
|
||||
, getReceivers
|
||||
@ -71,13 +72,16 @@ userPrefersEmail = not . userPrefersLetter
|
||||
|
||||
-- | result (True, Nothing) indicates that neither userEmail nor userPostAddress is known
|
||||
getPostalPreferenceAndAddress :: User -> (Bool, Maybe [Text])
|
||||
getPostalPreferenceAndAddress usr@User{..} =
|
||||
getPostalPreferenceAndAddress usr@User{userPrefersPostal} =
|
||||
((userPrefersPostal && postPossible) || not emailPossible, pa)
|
||||
-- (((userPrefersPostal || isNothing userPinPassword) && postPossible) || not emailPossible, pa) -- ignore email/post preference if no pinPassword is set
|
||||
where
|
||||
emailPossible = validEmail' userEmail
|
||||
postPossible = isJust pa
|
||||
where
|
||||
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{..}
|
||||
@ -89,7 +93,7 @@ getPostalAddress User{..}
|
||||
| otherwise
|
||||
= 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
|
||||
-- a boolean indicating if the user is own supervisor with rerouteNotifications
|
||||
getReceivers :: UserId -> DB (Entity User, [Entity User], Bool)
|
||||
|
||||
@ -28,13 +28,11 @@ import qualified Data.Set as Set
|
||||
import qualified Data.Time.Zones as TZ
|
||||
import Handler.Utils.DateTime
|
||||
import Handler.Utils.LMS (randomLMSIdentBut, randomLMSpw, maxLmsUserIdentRetries)
|
||||
import Handler.Utils.Qualification
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
|
||||
blockedByElearning :: Text
|
||||
blockedByElearning = "E-Learning durchgefallen"
|
||||
|
||||
dispatchJobLmsQualificationsEnqueue :: JobHandler UniWorX
|
||||
dispatchJobLmsQualificationsEnqueue = JobHandlerAtomic $ fetchRefreshQualifications JobLmsEnqueue
|
||||
|
||||
@ -182,10 +180,6 @@ dispatchJobLmsResults qid = JobHandlerAtomic act
|
||||
where
|
||||
-- act :: YesodJobDB UniWorX ()
|
||||
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
|
||||
(quser :& luser :& lresult) <- E.from $
|
||||
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)
|
||||
now <- liftIO getCurrentTime
|
||||
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.
|
||||
let lmsUserStartedDay = localDay $ TZ.utcToLocalTimeTZ appTZ lmsUserStarted
|
||||
saneDate = lmsResultSuccess `inBetween` (lmsUserStartedDay, min qualificationUserValidUntil locDay)
|
||||
&& qualificationUserLastRefresh <= utctDay lmsUserStarted
|
||||
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
|
||||
then do
|
||||
-- TODO: refactor using functions from Handler.Utils.Qualification to ensure nothing is forgotten!
|
||||
qUsr <- updateGet quid
|
||||
[ QualificationUserValidUntil =. newValidTo
|
||||
, QualificationUserLastRefresh =. lmsResultSuccess
|
||||
]
|
||||
-- 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) $
|
||||
update quid [ QualificationUserBlockedDue =. Nothing ]
|
||||
update luid [ LmsUserStatus =. Just newStatus
|
||||
, LmsUserReceived =. Just lmsResultTimestamp
|
||||
]
|
||||
audit TransactionQualificationUserEdit
|
||||
{ transactionQualificationUser = quid
|
||||
, transactionQualification = qualificationUserQualification
|
||||
, transactionUser = qualificationUserUser
|
||||
, transactionQualificationValidUntil = newValidTo
|
||||
, transactionQualificationScheduleRenewal = Nothing
|
||||
}
|
||||
_ok <- renewValidQualificationUsers qid [qualificationUserUser] -- blocked is unaffected
|
||||
-- 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
|
||||
update luid
|
||||
[ LmsUserStatus =. Just newStatus
|
||||
, LmsUserReceived =. Just lmsResultTimestamp
|
||||
]
|
||||
-- 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
|
||||
-- when (Just (qualificationBlockedReasonText QualificationBlockFailedELearning) == qUsr ^? _qualificationUserBlockedDue . _Just . _qualificationBlockedReason) $
|
||||
-- update quid [ QualificationUserBlockedDue =. Nothing ]
|
||||
return Nothing
|
||||
else do
|
||||
let errmsg = [st|LMS success with insane date #{tshow lmsResultSuccess} received for #{tshow lmsUserIdent}|]
|
||||
@ -295,9 +280,7 @@ dispatchJobLmsUserlist qid = JobHandlerAtomic act
|
||||
, transactionReceived = lReceived
|
||||
}
|
||||
update luid [LmsUserStatus =. (oldStatus <> Just newStatus)]
|
||||
updateBy (UniqueQualificationUser qid (lmsUserUser luser))
|
||||
[QualificationUserBlockedDue =. Just (QualificationBlocked { qualificationBlockedDay = blockedDay
|
||||
, qualificationBlockedReason = blockedByElearning } )]
|
||||
void $ qualificationUserBlocking qid [lmsUserUser luser] $ Just $ mkQualificationBlocked QualificationBlockFailedELearning blockedDay
|
||||
queueDBJob JobSendNotification
|
||||
{ jRecipient = lmsUserUser luser
|
||||
, jNotification = NotificationQualificationExpired { nQualification = qid, nExpiry = blockedDay }
|
||||
|
||||
@ -15,7 +15,7 @@ import Jobs.Queue
|
||||
|
||||
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.ExternalExam
|
||||
|
||||
@ -26,8 +26,8 @@ dispatchJobQueueNotification :: Notification -> JobHandler UniWorX
|
||||
dispatchJobQueueNotification jNotification = JobHandlerAtomic $
|
||||
runConduit $ yield jNotification
|
||||
.| transPipe (hoist lift) determineNotificationCandidates
|
||||
.| C.filterM (\(notification', override, Entity _ User{userNotificationSettings,userEmail}) ->
|
||||
and2M (return $ validEmail' userEmail) $
|
||||
.| C.filterM (\(notification', override, Entity _ User{userNotificationSettings,userDisplayEmail,userEmail}) ->
|
||||
and2M (return $ isJust $ pickValidEmail' userDisplayEmail userEmail) $
|
||||
or2M (return override) $ notificationAllowed userNotificationSettings <$> hoist lift (classifyNotification notification'))
|
||||
.| C.map (\(notification', _, Entity uid _) -> JobSendNotification uid notification')
|
||||
.| sinkDBJobs
|
||||
|
||||
@ -78,7 +78,8 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do
|
||||
let letter = LetterRenewQualificationF
|
||||
{ lmsLogin = lmsUserIdent
|
||||
, lmsPin = lmsUserPin
|
||||
, qualHolder = userDisplayName
|
||||
, qualHolderID = jRecipient
|
||||
, qualHolderDN = userDisplayName
|
||||
, qualHolderSN = userSurname
|
||||
, qualExpiry = qualificationUserValidUntil
|
||||
, qualId = nQualification
|
||||
|
||||
@ -53,6 +53,7 @@ classifyChangelogItem = \case
|
||||
changelogItemDays :: Map ChangelogItem Day
|
||||
changelogItemDays = Map.fromListWithKey (\k d1 d2 -> bool (error $ "Duplicate changelog days for " <> show k) d1 $ d1 /= d2)
|
||||
[ (ChangelogFradriveInitialRelease, [day|2022-12-12|])
|
||||
, (ChangelogSupervisorsMayRevokeLicences, [day|2023-03-27|])
|
||||
]
|
||||
|
||||
{- FOR REFERENCE, PREVIOUS CHANGELOG (delete in the future, along with all translation files):
|
||||
|
||||
@ -11,6 +11,8 @@ module Model.Types.Lms
|
||||
) where
|
||||
|
||||
import Import.NoModel
|
||||
import qualified Data.Map as Map
|
||||
import Data.Map ((!))
|
||||
import Database.Persist.Sql
|
||||
import qualified Database.Esqueleto.Experimental as E
|
||||
import qualified Data.Csv as Csv
|
||||
@ -46,7 +48,7 @@ instance Ord LmsStatus where
|
||||
|
||||
isLmsSuccess :: LmsStatus -> Bool
|
||||
isLmsSuccess LmsSuccess{} = True
|
||||
isLmsSuccess _other = False
|
||||
isLmsSuccess _other = False
|
||||
|
||||
makeLenses_ ''LmsStatus
|
||||
|
||||
@ -87,6 +89,25 @@ instance Csv.ToField QualificationBlocked where
|
||||
-- instance ToMessage QualificationBlocked where -- no longer used
|
||||
-- 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
|
||||
newtype LmsBool = LmsBool { lms2bool :: Bool }
|
||||
deriving (Eq, Ord, Read, Show, Generic)
|
||||
@ -113,10 +134,10 @@ _lmsDay = iso LmsDay lms2day
|
||||
|
||||
-- | Format for day for LMS interface
|
||||
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
|
||||
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
|
||||
-- parseField = fmap LmsDay . parseLmsDay <=< Csv.parseField
|
||||
|
||||
@ -317,6 +317,7 @@ data LmsConf = LmsConf
|
||||
, lmsDownloadHeader :: Bool
|
||||
, lmsDownloadDelimiter :: Char
|
||||
, lmsDownloadCrLf :: Bool
|
||||
, lmsDeletionDays :: Int
|
||||
} deriving (Show)
|
||||
|
||||
data AvsConf = AvsConf
|
||||
@ -516,6 +517,7 @@ instance FromJSON LmsConf where
|
||||
lmsDownloadHeader <- o .: "download-header"
|
||||
lmsDownloadDelimiter <- o .: "download-delimiter"
|
||||
lmsDownloadCrLf <- o .: "download-cr-lf"
|
||||
lmsDeletionDays <- o .: "deletion-days"
|
||||
return LmsConf{..}
|
||||
|
||||
makeLenses_ ''LmsConf
|
||||
@ -657,7 +659,7 @@ instance FromJSON AppSettings where
|
||||
appMailVerp <- fromMaybe VerpNone . join <$> (o .:? "mail-verp" <|> pure Nothing)
|
||||
appMailRetainSent <- o .: "mail-retain-sent"
|
||||
appMailSupport <- o .: "mail-support"
|
||||
appMailRerouteTo <- o .:? "mail-reroute-to"
|
||||
appMailRerouteTo <- join <$> (o .:? "mail-reroute-to" <|> pure Nothing)
|
||||
|
||||
appJobWorkers <- o .: "job-workers"
|
||||
appJobFlushInterval <- o .:? "job-flush-interval"
|
||||
|
||||
@ -275,6 +275,9 @@ addAttrsClass cl attrs = ("class", cl') : noClAttrs
|
||||
-- tickmark :: IsString a => a
|
||||
-- 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
|
||||
textElem :: Char -> Text -> Bool
|
||||
textElem c = Text.any (c ==)
|
||||
@ -284,6 +287,12 @@ textElem c = Text.any (c ==)
|
||||
stripAll :: Text -> Text
|
||||
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
|
||||
cropText :: Text -> Text
|
||||
cropText (Text.take 255 -> t) = headDef t $ Text.lines t
|
||||
|
||||
@ -5,13 +5,12 @@
|
||||
{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
|
||||
|
||||
module Utils.Print
|
||||
( pdfRenewal
|
||||
, sendLetter, sendLetter'
|
||||
, sendEmailOrLetter
|
||||
( renderLetter -- used for generating letter pdfs
|
||||
, sendEmailOrLetter -- directly print or sends by email
|
||||
, printLetter -- always send a letter
|
||||
, letterApcIdent -- create acknowledge string for APC
|
||||
, encryptPDF
|
||||
, sanitizeCmdArg, validCmdArgument
|
||||
, templateDIN5008
|
||||
, templateRenewal
|
||||
-- , compileTemplate, makePDF
|
||||
, _Meta, addMeta
|
||||
, toMeta, mbMeta -- single values
|
||||
@ -23,16 +22,16 @@ module Utils.Print
|
||||
import Data.Char (isSeparator)
|
||||
import qualified Data.Text as T
|
||||
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 Control.Monad.Except
|
||||
import Import hiding (embedFile)
|
||||
import Data.FileEmbed (embedFile)
|
||||
-- import Data.FileEmbed (embedFile)
|
||||
|
||||
import qualified Text.Pandoc as P
|
||||
import qualified Text.Pandoc.PDF as P
|
||||
import qualified Text.Pandoc.Builder as P
|
||||
-- import qualified Text.Pandoc.PDF as P
|
||||
-- import qualified Text.Pandoc.Builder as P
|
||||
|
||||
import Text.Hamlet
|
||||
|
||||
@ -42,10 +41,14 @@ 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.Widgets (nameHtml')
|
||||
import Handler.Utils.Avs (updateReceivers)
|
||||
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?
|
||||
|
||||
{- 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 --
|
||||
-------------------------
|
||||
@ -158,40 +67,42 @@ defWriterOpts t = def { P.writerExtensions = P.pandocExtensions, P.writerTemplat
|
||||
-- This is a hack to allow variable interpolation within a document.
|
||||
-- Pandoc currently only allows interpolation within 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 meta StoredMarkup{..} = do
|
||||
tmpl <- compileTemplate strictMarkupInput
|
||||
doc <- areader readerOpts strictMarkupInput
|
||||
let writerOpts = def { P.writerExtensions = P.pandocExtensions
|
||||
, P.writerTemplate = Just tmpl }
|
||||
P.writeMarkdown writerOpts
|
||||
$ appMeta setIsDeFromLang
|
||||
$ addMeta meta doc
|
||||
where
|
||||
strictMarkupInput = toStrict markupInput
|
||||
readerOpts = def { P.readerExtensions = P.pandocExtensions
|
||||
, P.readerStripComments = True
|
||||
}
|
||||
-- reader :: (P.PandocMonad m, P.ToSources a) => P.ReaderOptions -> a -> m P.Pandoc
|
||||
areader = case markupInputFormat of
|
||||
MarkupHtml -> P.readHtml
|
||||
MarkupMarkdown -> P.readMarkdown
|
||||
MarkupPlaintext -> P.readMarkdown
|
||||
-- reTemplateLetter :: P.PandocMonad m => P.Meta -> StoredMarkup -> m Text
|
||||
-- reTemplateLetter meta StoredMarkup{..} = do
|
||||
-- tmpl <- compileTemplate strictMarkupInput
|
||||
-- doc <- areader readerOpts strictMarkupInput
|
||||
-- let writerOpts = def { P.writerExtensions = P.pandocExtensions
|
||||
-- , P.writerTemplate = Just tmpl }
|
||||
-- P.writeMarkdown writerOpts
|
||||
-- $ appMeta setIsDeFromLang
|
||||
-- $ addMeta meta doc
|
||||
-- where
|
||||
-- strictMarkupInput = toStrict markupInput
|
||||
-- readerOpts = def { P.readerExtensions = P.pandocExtensions
|
||||
-- , P.readerStripComments = True
|
||||
-- }
|
||||
-- -- reader :: (P.PandocMonad m, P.ToSources a) => P.ReaderOptions -> a -> m P.Pandoc
|
||||
-- areader = case markupInputFormat of
|
||||
-- MarkupHtml -> P.readHtml
|
||||
-- MarkupMarkdown -> P.readMarkdown
|
||||
-- MarkupPlaintext -> P.readMarkdown
|
||||
|
||||
reTemplateLetter' :: P.PandocMonad m => P.Meta -> Text -> m Text
|
||||
reTemplateLetter' meta md = do
|
||||
tmpl <- compileTemplate md
|
||||
doc <- P.readMarkdown readerOpts md
|
||||
let writerOpts = def { P.writerExtensions = P.pandocExtensions
|
||||
, P.writerTemplate = Just tmpl }
|
||||
P.writeMarkdown writerOpts
|
||||
$ appMeta setIsDeFromLang
|
||||
$ addMeta meta doc
|
||||
where
|
||||
readerOpts = def { P.readerExtensions = P.pandocExtensions
|
||||
, P.readerStripComments = True
|
||||
}
|
||||
-- reTemplateLetter' :: P.PandocMonad m => P.Meta -> Text -> m Text
|
||||
-- reTemplateLetter' meta md = do
|
||||
-- tmpl <- compileTemplate md
|
||||
-- doc <- P.readMarkdown readerOpts md
|
||||
-- let writerOpts = def { P.writerExtensions = P.pandocExtensions
|
||||
-- , P.writerTemplate = Just tmpl }
|
||||
-- P.writeMarkdown writerOpts
|
||||
-- $ appMeta setIsDeFromLang
|
||||
-- $ addMeta meta doc
|
||||
-- where
|
||||
-- readerOpts = def { P.readerExtensions = P.pandocExtensions
|
||||
-- , 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 template meta = runExceptT $ do
|
||||
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
|
||||
$ addMeta meta doc
|
||||
|
||||
--pdfDIN5008 :: P.PandocMonad m => Text -> m LBS.ByteString -- for pandoc > 2.18
|
||||
pdfDIN5008' :: P.Meta -> Text -> P.PandocIO LBS.ByteString
|
||||
pdfDIN5008' meta md = do
|
||||
tmpl <- compileTemplate templateDIN5008
|
||||
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)
|
||||
-- | creates a PDF using a LaTeX template
|
||||
pdfLaTeX :: LetterKind -> P.Meta -> Text -> HandlerFor UniWorX (Either P.PandocError LBS.ByteString)
|
||||
pdfLaTeX lk meta md = do
|
||||
e_tmpl <- $cachedHereBinary ("LetterKind:" <> tshow lk) (liftIO . P.runIO $ compileTemplate $ templateLatex lk)
|
||||
actRight e_tmpl $ \tmpl -> liftIO . P.runIO $ do
|
||||
let readerOpts = def { P.readerExtensions = P.pandocExtensions }
|
||||
writerOpts = def { P.writerExtensions = P.pandocExtensions
|
||||
@ -231,95 +130,60 @@ pdfDIN5008 meta md = do
|
||||
$ addMeta meta doc
|
||||
|
||||
|
||||
|
||||
-------------------------
|
||||
-- Specialized Letters --
|
||||
-------------------------
|
||||
|
||||
-- | like 'reTemplateLetter' but uses 'templateRenewal' and caches the result
|
||||
mdRenewal' :: P.Meta -> HandlerFor UniWorX (Either P.PandocError Text)
|
||||
mdRenewal' meta = do
|
||||
let readerOpts = def { P.readerExtensions = P.pandocExtensions
|
||||
, P.readerStripComments = True
|
||||
}
|
||||
e_doc <- $cachedHereBinary ("renewal-pandoc"::Text) (liftIO . P.runIO $ P.readMarkdown readerOpts templateRenewal)
|
||||
e_tmpl <- $cachedHereBinary ("renewal-template"::Text) (liftIO . P.runIO $ compileTemplate templateRenewal)
|
||||
case (e_doc, e_tmpl) of
|
||||
(Left err, _) -> pure $ Left err
|
||||
(_, Left err) -> pure $ Left err
|
||||
(Right md_doc, Right md_tmpl) -> do
|
||||
let writerOpts = def { P.writerExtensions = P.pandocExtensions
|
||||
, 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
|
||||
renderLetter :: (MDLetter l) => Entity User -> l -> Text -> Handler (Either Text LBS.ByteString)
|
||||
renderLetter rcvrEnt@Entity{entityVal=rcvr} mdl apcIdent = do
|
||||
now <- liftIO getCurrentTime
|
||||
formatter@DateTimeFormatter{ format } <- getDateTimeFormatterUser' rcvr
|
||||
let lang = selectDeEn $ rcvr & userLanguages -- select either German or English only, default de; see Utils.Lang
|
||||
kind = getLetterKind $ pure mdl
|
||||
tmpl = getTemplate $ pure mdl
|
||||
meta = addApcIdent apcIdent
|
||||
<> letterMeta mdl formatter lang rcvrEnt
|
||||
<> mkMeta
|
||||
[ toMeta "lang" lang
|
||||
, toMeta "date" $ format SelFormatDate now
|
||||
, toMeta "rcvr-name" $ rcvr & userDisplayName
|
||||
, toMeta "address" $ fromMaybe [rcvr & userDisplayName] $ getPostalAddress rcvr
|
||||
--, toMeta "rcvr-email" $ rcvr & userDisplayEmail -- note that some templates use "email" already otherwise
|
||||
]
|
||||
e_md <- mdTemplating tmpl meta
|
||||
result <- actRight e_md $ pdfLaTeX kind meta
|
||||
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 --
|
||||
---------------
|
||||
|
||||
data PrintJobIdentification = PrintJobIdentification
|
||||
{ pjiName :: Text
|
||||
, pjiRecipient :: Maybe UserId
|
||||
, pjiSender :: Maybe UserId
|
||||
, pjiCourse :: Maybe CourseId
|
||||
, pjiQualification :: Maybe QualificationId
|
||||
, pjiLmsUser :: Maybe LmsIdent
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
-- Only used in print-test-handler for PrintSendR
|
||||
printLetter :: (MDLetter l) => Maybe UserId -> (Entity User, l) -> Handler (Either Text (Text, FilePath))
|
||||
printLetter senderId (rcvr, letter) = do
|
||||
let rcvrId = rcvr ^. _entityKey
|
||||
encRecipient :: CryptoUUIDUser <- encrypt rcvrId
|
||||
now <- liftIO getCurrentTime
|
||||
apcIdent <- letterApcIdent letter encRecipient now
|
||||
pdf <- renderLetter rcvr letter apcIdent
|
||||
let protoPji = getPJId letter
|
||||
pji = protoPji
|
||||
{ pjiRecipient = Just rcvrId
|
||||
, pjiSender = senderId
|
||||
, pjiName = "TEST_" <> pjiName protoPji
|
||||
, pjiApcAcknowledge = apcIdent
|
||||
}
|
||||
actRight pdf $ runDB . printLetter' pji
|
||||
|
||||
-- DEPRECATED
|
||||
sendLetter' :: Text -> LBS.ByteString -> (Maybe UserId, Maybe UserId) -> Maybe CourseId -> Maybe QualificationId -> Maybe LmsIdent -> DB (Either Text (Text, FilePath))
|
||||
sendLetter' printJobName pdf (printJobRecipient, printJobSender) printJobCourse printJobQualification printJobLmsUser =
|
||||
sendLetter pdf PrintJobIdentification
|
||||
{ pjiName = printJobName
|
||||
, pjiRecipient = printJobRecipient
|
||||
, pjiSender = printJobSender
|
||||
, pjiCourse = printJobCourse
|
||||
, pjiQualification = printJobQualification
|
||||
, pjiLmsUser = printJobLmsUser
|
||||
}
|
||||
|
||||
sendLetter :: LBS.ByteString -> PrintJobIdentification -> DB (Either Text (Text, FilePath))
|
||||
sendLetter pdf PrintJobIdentification{pjiName = printJobName, pjiRecipient = printJobRecipient, pjiSender = printJobSender, pjiCourse = printJobCourse, pjiQualification = printJobQualification, pjiLmsUser = printJobLmsUser} = do
|
||||
printLetter' :: PrintJobIdentification -> LBS.ByteString -> DB (Either Text (Text, FilePath))
|
||||
printLetter' pji pdf = do
|
||||
let PrintJobIdentification
|
||||
{ pjiName = printJobName
|
||||
, pjiApcAcknowledge = printJobApcIdent
|
||||
, pjiRecipient = printJobRecipient
|
||||
, pjiSender = printJobSender
|
||||
, pjiCourse = printJobCourse
|
||||
, pjiQualification = printJobQualification
|
||||
, pjiLmsUser = printJobLmsUser
|
||||
} = pji
|
||||
recipient <- join <$> mapM get printJobRecipient
|
||||
sender <- join <$> mapM get printJobSender
|
||||
course <- join <$> mapM get printJobCourse
|
||||
@ -344,8 +208,8 @@ sendLetter pdf PrintJobIdentification{pjiName = printJobName, pjiRecipient = pri
|
||||
return $ Right (ok, printJobFilename)
|
||||
|
||||
{-
|
||||
sendLetter'' :: _ -> DB PureFile
|
||||
sendLetter'' _ = do
|
||||
printLetter'' :: _ -> DB PureFile
|
||||
printLetter'' _ = do
|
||||
...
|
||||
return $ File { fileTitle = printJobFilename
|
||||
, 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 recipient letter = do
|
||||
sendEmailOrLetter recipient letter = do
|
||||
(underling, receivers, undercopy) <- updateReceivers recipient -- TODO: check to avoid this almost circular dependency
|
||||
let tmpl = getTemplate $ pure letter
|
||||
pjid = getPJId letter
|
||||
-- Below are only needed if sent by email
|
||||
mailSubject = getMailSubject letter
|
||||
now <- liftIO getCurrentTime
|
||||
let pjid = getPJId letter
|
||||
mailSubject = getMailSubject letter -- these are only needed if sent by email, but we're lazy anyway
|
||||
undername = underling ^. _userDisplayName -- nameHtml' underling
|
||||
undermail = CI.original $ underling ^. _userEmail
|
||||
now <- liftIO getCurrentTime
|
||||
oks <- forM receivers $ \Entity{ entityKey = svr, entityVal = rcvrUsr } -> do
|
||||
formatter@DateTimeFormatter{ format } <- getDateTimeFormatterUser' rcvrUsr
|
||||
let (preferPost, postal) = getPostalPreferenceAndAddress rcvrUsr
|
||||
isSupervised = recipient /= svr
|
||||
lang = selectDeEn $ rcvrUsr & userLanguages -- select either German or English only, default de; see Utils.Lang
|
||||
mailBody = getMailBody letter formatter
|
||||
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
|
||||
oks <- forM receivers $ \rcvrEnt@Entity{ entityKey = svr, entityVal = rcvrUsr } -> do
|
||||
encRecipient :: CryptoUUIDUser <- encrypt svr
|
||||
apcIdent <- letterApcIdent letter encRecipient now
|
||||
let (preferPost, postal) = getPostalPreferenceAndAddress rcvrUsr
|
||||
-- mailBody = getMailBody letter formatter
|
||||
renderLetter rcvrEnt letter apcIdent >>= \case
|
||||
_ | preferPost, isNothing postal -> do -- neither email nor postal is known
|
||||
let msg = "Notification failed for " <> tshow encRecipient <> ", who has neither a known email nor postal address. Notification: " <> tshow pjid
|
||||
$logErrorS "LETTER" msg
|
||||
return False
|
||||
Left err -> do -- pdf generation failed
|
||||
encRecipient :: CryptoUUIDUser <- encrypt svr
|
||||
Left err -> do -- pdf generation failed
|
||||
let msg = "Notification failed for " <> tshow encRecipient <> ". PDF generation failed: "<> cropText err <> "For Notification: " <> tshow pjid
|
||||
$logErrorS "LETTER" msg
|
||||
return False
|
||||
Right pdf | preferPost -> -- send printed letter
|
||||
runDB (sendLetter pdf pjid{ pjiRecipient = Just svr}) >>= \case
|
||||
Left err -> do
|
||||
encRecipient :: CryptoUUIDUser <- encrypt svr
|
||||
runDB (printLetter' pjid{pjiRecipient = Just svr, pjiApcAcknowledge = apcIdent} pdf) >>= \case
|
||||
Left err -> do
|
||||
let msg = "Notification failed for " <> tshow encRecipient <> ". PDF printing failed. The print job could not be sent: " <> cropText err
|
||||
$logErrorS "LETTER" msg
|
||||
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
|
||||
return True
|
||||
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
|
||||
Just passwd -> encryptPDF passwd pdf >>= \case
|
||||
Right encPdf -> return encPdf
|
||||
Left err -> do
|
||||
encRecipient :: CryptoUUIDUser <- encrypt svr
|
||||
Left err -> do
|
||||
let msg = "Notification for " <> tshow encRecipient <> " has unencrypted attachment. Encrypting PDF failed: " <> cropText err
|
||||
$logWarnS "LETTER" msg
|
||||
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
|
||||
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
|
||||
setSubjectI mailSubject
|
||||
editNotifications <- mkEditNotifications svr
|
||||
let supername = rcvrUsr ^. _userDisplayName -- nameHtml' rcvrUsr
|
||||
addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/genericMailLetter.hamlet")
|
||||
addPart (File { fileTitle = T.unpack $ pjiName pjid <> ".pdf"
|
||||
, 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:
|
||||
-- > 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 jb bs = do
|
||||
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."
|
||||
Just lprServerArg -> do
|
||||
Just lprServerArg -> do
|
||||
let pc = setStdin (byteStringInput bs) $
|
||||
proc "lpr" $
|
||||
jobname ++ -- -J jobname -- a name for job identification at printing site
|
||||
@ -590,10 +364,10 @@ lprPDF jb bs = do
|
||||
exit2either <$> readProcess' pc
|
||||
where
|
||||
getLprServerArg = do
|
||||
rerouteMail <- getsYesod $ view _appMailRerouteTo
|
||||
case rerouteMail of
|
||||
rerouteMail <- getsYesod $ view _appMailRerouteTo
|
||||
case rerouteMail of
|
||||
Just _ -> return Nothing
|
||||
Nothing -> do
|
||||
Nothing -> do
|
||||
LprConf{..} <- getsYesod $ view _appLprConf
|
||||
return . Just $ "-P " <> lprQueue <> "@" <> lprHost <> ":" <> show lprPort
|
||||
|
||||
|
||||
241
src/Utils/Print/Letters.hs
Normal file
241
src/Utils/Print/Letters.hs
Normal 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
86
src/Utils/Print/RenewQualification.hs
Normal 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
2
start.sh
@ -29,6 +29,8 @@ export RIBBON=${RIBBON:-${__HOST:-localhost}}
|
||||
export APPROOT=${APPROOT:-http://localhost:$((${PORT_OFFSET:-0} + 3000))}
|
||||
export AVSPASS=${AVSPASS:-nopasswordset}
|
||||
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
|
||||
|
||||
move-back() {
|
||||
|
||||
@ -78,6 +78,15 @@ $# #{summary}
|
||||
<dd .deflist__dd>
|
||||
#{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
|
||||
$if numlecs /= 0
|
||||
$if numlecs > 1
|
||||
|
||||
@ -81,10 +81,10 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
<h2>
|
||||
Erzeugtes PDF herunterladen:
|
||||
<p>
|
||||
Hier ist ein
|
||||
Hier ist ein #
|
||||
<a href=@{AdminTestPdfR}>
|
||||
Download-Link
|
||||
für eine PDF Vorschau.
|
||||
\ für eine PDF Vorschau.
|
||||
<p>
|
||||
Zusätzlich wird dabei im Verzeichnis /tmp
|
||||
das PDF mit und ohne Passwort gespeichert.
|
||||
@ -81,10 +81,10 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
<h2>
|
||||
Download a generated PDF
|
||||
<p>
|
||||
Here is a
|
||||
Here is a #
|
||||
<a href=@{AdminTestPdfR}>
|
||||
Download-Link
|
||||
for a preview.
|
||||
\ for a preview.
|
||||
<p>
|
||||
Following the link, the pdf will also be saved
|
||||
to the /tmp directory, once without
|
||||
|
||||
@ -4,13 +4,6 @@ $# SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
|
||||
$#
|
||||
$# 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>
|
||||
<h2>
|
||||
Personendaten aller AVS Fahrberechtigten
|
||||
|
||||
@ -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
|
||||
@ -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
|
||||
@ -80,7 +80,7 @@ $endif$
|
||||
|
||||
%\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{xcolor}
|
||||
@ -120,7 +120,11 @@ $endif$
|
||||
}
|
||||
\setkomavar{fromphone}{$phone$}
|
||||
\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{place}{$place$}
|
||||
@ -137,25 +141,17 @@ $endif$
|
||||
$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:}
|
||||
$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}
|
||||
$endif$
|
||||
|
||||
$body$
|
||||
|
||||
|
||||
185
templates/letter/din5008with_pin.latex
Normal file
185
templates/letter/din5008with_pin.latex
Normal 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
15
templates/letter/fraport_qualification.md
Normal 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 -->
|
||||
@ -12,10 +12,10 @@ return-address:
|
||||
de-opening: Liebe Fahrberechtigungsinhaber,
|
||||
en-opening: Dear driver,
|
||||
de-closing: |
|
||||
Mit freundlichen Grüßen,
|
||||
Mit freundlichen Grüßen,
|
||||
Ihre Fahrerausbildung
|
||||
en-closing: |
|
||||
With kind regards,
|
||||
With kind regards,
|
||||
Your Fraport Driver Training
|
||||
encludes:
|
||||
hyperrefoptions: hidelinks
|
||||
@ -29,11 +29,12 @@ lang: de-de
|
||||
is-de: true
|
||||
login: 123456
|
||||
pin: abcdef
|
||||
paper: pin
|
||||
# Emfpänger
|
||||
examinee: E. M. Pfänger
|
||||
examinee: P. Rüfling
|
||||
address:
|
||||
- Musterfirma GmbH
|
||||
- E. M. Pfänger
|
||||
- Musterfirma GmbH
|
||||
- Musterstraße 11
|
||||
- 12345 Musterstadt
|
||||
...
|
||||
@ -66,10 +67,10 @@ $if(validduration)$
|
||||
$endif$
|
||||
verlängert werden.
|
||||
$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.
|
||||
$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$
|
||||
|
||||
Fahrberechtigungsinhaber
|
||||
@ -80,7 +81,7 @@ Ablaufdatum
|
||||
|
||||
: $expiry$
|
||||
|
||||
URL
|
||||
Webseite der Prüfung
|
||||
|
||||
: [$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
|
||||
bei der Fahrerausbildung absolviert werden.
|
||||
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$
|
||||
|
||||
@ -108,7 +109,7 @@ by successfully participating in
|
||||
an e-learning.
|
||||
$if(supervisor)$
|
||||
Supervisors are kindly requested to forward the login data
|
||||
from the protected area below confidentially to the examinee.
|
||||
below confidentially to the examinee.
|
||||
$else$
|
||||
Please use the login data from the protected area below.
|
||||
$endif$
|
||||
@ -121,7 +122,7 @@ Expiry
|
||||
|
||||
: $expiry$
|
||||
|
||||
URL
|
||||
Examination Website
|
||||
|
||||
: [$url-text$]($url$)
|
||||
|
||||
@ -137,6 +138,6 @@ $endif$
|
||||
|
||||
|
||||
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$
|
||||
|
||||
107
templates/letter/plain_article.latex
Normal file
107
templates/letter/plain_article.latex
Normal 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,11 +7,11 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
$if null quals
|
||||
_{MsgQualificationUserNone}
|
||||
$else
|
||||
$forall (Entity _ quali, mbQualUsr, mbLmsUsr) <- quals
|
||||
$forall (Entity _ quali, mbQualUsr, mbLmsUsr, validity) <- quals
|
||||
<section>
|
||||
<div .container>
|
||||
<h2>
|
||||
#{qualificationShorthand quali} - #{qualificationName quali} - #{qualificationSchool quali}
|
||||
#{qualificationShorthand quali} - #{qualificationName quali} (#{qualificationSchool quali}) #{boolSymbol (E.unValue validity)}
|
||||
<div .container>
|
||||
<dl .deflist>
|
||||
$maybe (Entity _ qualUsr) <- mbQualUsr
|
||||
@ -41,7 +41,8 @@ $else
|
||||
<dd .deflist__dd >
|
||||
<span .email>
|
||||
#{lmsUserPin lmsUsr}
|
||||
\ ^{formatTimeW SelFormatDateTime (lmsUserDatePin lmsUsr)}
|
||||
<br>
|
||||
^{formatTimeW SelFormatDateTime (lmsUserDatePin lmsUsr)}
|
||||
$if lmsUserResetPin lmsUsr
|
||||
\ #{icon IconReset}
|
||||
$maybe ts <- lmsUserReceived lmsUsr
|
||||
|
||||
@ -14,7 +14,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
<a href=@{QualificationR qualSchool (CI.mk qualShort)}>
|
||||
#{qualName}
|
||||
<dt>_{SomeMessage MsgLmsUser}
|
||||
<dd>#{nameHtml qualHolder qualHolderSN}
|
||||
<dd>#{nameHtml qualHolderDN qualHolderSN}
|
||||
<dt>_{SomeMessage MsgLmsQualificationValidUntil}
|
||||
<dd>#{format SelFormatDate qualExpiry}
|
||||
|
||||
@ -22,4 +22,4 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
_{SomeMessage MsgLmsRenewalInstructions} #
|
||||
|
||||
<a href=#{lmsUrlLogin}>
|
||||
_{SomeMessage MsgMppURL} #{lmsUrl}
|
||||
_{SomeMessage MsgLmsURL} #{lmsUrl}
|
||||
|
||||
@ -36,8 +36,8 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
<p>
|
||||
_{SomeMessage MsgMailSupervisedBody}
|
||||
<ul>
|
||||
$forall svr <- receivers
|
||||
$forall csupr <- receivers
|
||||
<li>
|
||||
#{nameHtml' svr}
|
||||
#{nameHtml' csupr}
|
||||
|
||||
^{ihamletSomeMessage editNotifications}
|
||||
|
||||
@ -56,12 +56,16 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
<dt .deflist__dt>
|
||||
_{MsgUserDisplayEmail}
|
||||
<dd .deflist__dd .email>
|
||||
#{userDisplayEmail}
|
||||
#{mailtoHtml userDisplayEmail}
|
||||
$if not (validEmail' userDisplayEmail)
|
||||
\ ^{messageTooltip tooltipInvalidEmail}
|
||||
$if userEmail /= userDisplayEmail
|
||||
<dt .deflist__dt>
|
||||
_{MsgUserSystemEmail}
|
||||
<dd .deflist__dd>
|
||||
#{mailtoHtml userEmail}
|
||||
#{userEmail}
|
||||
$if not (validEmail' userEmail)
|
||||
\ ^{messageTooltip tooltipInvalidEmail}
|
||||
<dt .deflist__dt>
|
||||
_{MsgAdminUserPinPassword}
|
||||
<dd .deflist__dd>
|
||||
|
||||
@ -4,38 +4,40 @@ $# SPDX-FileCopyrightText: 2022 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen J
|
||||
$#
|
||||
$# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
<dl .deflist>
|
||||
$maybe descr <- qualificationDescription quali
|
||||
<dt .deflist__dt>_{MsgQualificationDescription}
|
||||
<dd .deflist__dd>
|
||||
<div>
|
||||
#{descr}
|
||||
$maybe dvalid <- qualificationValidDuration quali
|
||||
<dt .deflist__dt>_{MsgQualificationValidDuration}
|
||||
<dd .deflist__dd>_{MsgMonths (fromIntegral dvalid)}
|
||||
<section>
|
||||
<dl .deflist>
|
||||
$maybe descr <- qualificationDescription quali
|
||||
<dt .deflist__dt>_{MsgQualificationDescription}
|
||||
<dd .deflist__dd>
|
||||
<div>
|
||||
#{descr}
|
||||
$maybe dvalid <- qualificationValidDuration quali
|
||||
<dt .deflist__dt>_{MsgQualificationValidDuration}
|
||||
<dd .deflist__dd>_{MsgMonths (fromIntegral dvalid)}
|
||||
|
||||
$maybe daudit <- qualificationAuditDuration quali
|
||||
<dt .deflist__dt>_{MsgQualificationAuditDuration}
|
||||
<dd .deflist__dd>_{MsgMonths (fromIntegral daudit)}
|
||||
$maybe daudit <- qualificationAuditDuration quali
|
||||
<dt .deflist__dt>_{MsgQualificationAuditDuration}
|
||||
<dd .deflist__dd>_{MsgMonths (fromIntegral daudit)}
|
||||
|
||||
$maybe drefresh <- qualificationRefreshWithin quali
|
||||
<dt .deflist__dt>_{MsgQualificationRefreshWithin} ^{iconTooltip (msg2widget MsgQualificationRefreshWithinTooltip) Nothing True}
|
||||
<dd .deflist__dd>
|
||||
$with drm <- cdMonths drefresh
|
||||
$with drd <- cdDays drefresh
|
||||
$if drm > 0
|
||||
_{MsgMonths (fromIntegral drm)}
|
||||
$maybe drefresh <- qualificationRefreshWithin quali
|
||||
<dt .deflist__dt>_{MsgQualificationRefreshWithin} ^{iconTooltip (msg2widget MsgQualificationRefreshWithinTooltip) Nothing True}
|
||||
<dd .deflist__dd>
|
||||
$with drm <- cdMonths drefresh
|
||||
$with drd <- cdDays drefresh
|
||||
$if drm > 0
|
||||
_{MsgMonths (fromIntegral drm)}
|
||||
$if drd > 0
|
||||
, #
|
||||
$if drd > 0
|
||||
, #
|
||||
$if drd > 0
|
||||
_{MsgDays (fromIntegral drd)}
|
||||
_{MsgDays (fromIntegral drd)}
|
||||
|
||||
<dt .deflist__dt>_{MsgQualificationElearningStart}
|
||||
<dd .deflist__dd>#{boolSymbol (qualificationElearningStart quali)}
|
||||
$if (qualificationElearningStart quali) && isNothing (qualificationRefreshWithin quali)
|
||||
<p>
|
||||
#{icon IconNotificationError}
|
||||
_{MsgLmsErrorNoRefreshElearning}
|
||||
|
||||
^{qualificationTable}
|
||||
<dt .deflist__dt>_{MsgQualificationElearningStart}
|
||||
<dd .deflist__dd>#{boolSymbol (qualificationElearningStart quali)}
|
||||
$if (qualificationElearningStart quali) && isNothing (qualificationRefreshWithin quali)
|
||||
<p>
|
||||
#{icon IconNotificationError}
|
||||
_{MsgLmsErrorNoRefreshElearning}
|
||||
|
||||
<section>
|
||||
^{qualificationTable}
|
||||
|
||||
|
||||
@ -13,6 +13,6 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
$maybe (messageEditModal, translationAddModal, translationsEditModal) <- forms
|
||||
<section>
|
||||
^{messageEditModal}
|
||||
^{translationAddModal}
|
||||
^{translationsEditModal}
|
||||
^{messageEditModal} #
|
||||
^{translationAddModal} #
|
||||
^{translationsEditModal} #
|
||||
|
||||
@ -57,8 +57,8 @@ fillDb = do
|
||||
addBDays = addBusinessDays Fraport -- holiday area to use
|
||||
n_day n = addBDays n $ utctDay now
|
||||
n_day' n = now { utctDay = n_day n }
|
||||
currentTerm = TermIdentifier . fst3 . toGregorian $ utctDay now
|
||||
-- (currentYear, currentMonth, currentDay) = toGregorian $ getTermDay currentTerm
|
||||
(currentYear, _currentMonth, _currentDay) = toGregorian $ utctDay now
|
||||
currentTerm = TermIdentifier currentYear
|
||||
nextTerm n = toEnum . (+n) $ fromEnum currentTerm
|
||||
|
||||
termTime :: TermIdentifier -- ^ Term
|
||||
@ -106,9 +106,9 @@ fillDb = do
|
||||
, userCompanyPersonalNumber = Just "00000"
|
||||
, userCompanyDepartment = 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
|
||||
, userPrefersPostal = False
|
||||
, userPrefersPostal = True
|
||||
, userExamOfficeGetSynced = userDefaultExamOfficeGetSynced
|
||||
, userExamOfficeGetLabels = userDefaultExamOfficeGetLabels
|
||||
}
|
||||
@ -145,10 +145,10 @@ fillDb = do
|
||||
, userTelephone = Nothing
|
||||
, userCompanyPersonalNumber = Nothing
|
||||
, userCompanyDepartment = Nothing
|
||||
, userPinPassword = Nothing
|
||||
, userPostAddress = Nothing
|
||||
, userPinPassword = Just "tomatenmarmelade"
|
||||
, userPostAddress = Just $ markdownToStoredMarkup ("Erdbeerweg 24 \n12345 Schlumpfhausen \nTraumland"::Text)
|
||||
, userPostLastUpdate = Nothing
|
||||
, userPrefersPostal = False
|
||||
, userPrefersPostal = True
|
||||
, userExamOfficeGetSynced = userDefaultExamOfficeGetSynced
|
||||
, userExamOfficeGetLabels = userDefaultExamOfficeGetLabels
|
||||
}
|
||||
@ -164,7 +164,7 @@ fillDb = do
|
||||
, userLastAuthentication = Nothing
|
||||
, userTokensIssuedAfter = Nothing
|
||||
, userMatrikelnummer = Nothing
|
||||
, userEmail = "jost@tcs.ifi.lmu.de"
|
||||
, userEmail = "e12345@fraport.de"
|
||||
, userDisplayEmail = "jost@tcs.ifi.lmu.de"
|
||||
, userDisplayName = "Steffen Jost"
|
||||
, userSurname = "Jost"
|
||||
@ -172,7 +172,7 @@ fillDb = do
|
||||
, userTitle = Just "Dr."
|
||||
, userMaxFavourites = 14
|
||||
, userMaxFavouriteTerms = 4
|
||||
, userTheme = userDefaultTheme
|
||||
, userTheme = ThemeMossGreen
|
||||
, userDateTimeFormat = userDefaultDateTimeFormat
|
||||
, userDateFormat = userDefaultDateFormat
|
||||
, userTimeFormat = userDefaultTimeFormat
|
||||
@ -386,14 +386,14 @@ fillDb = do
|
||||
= foldMap tshow cs : toMatrikel rest
|
||||
| otherwise
|
||||
= []
|
||||
manyUser (firstName, middleName, userSurname) (Just -> userMatrikelnummer) = User
|
||||
manyUser (firstName, middleName, userSurname) userMatrikelnummer' = User
|
||||
{ userIdent
|
||||
, userAuthentication = AuthLDAP
|
||||
, userLastAuthentication = Nothing
|
||||
, userTokensIssuedAfter = Nothing
|
||||
, userMatrikelnummer
|
||||
, userEmail = userIdent
|
||||
, userDisplayEmail = userIdent
|
||||
, userMatrikelnummer = Just userMatrikelnummer'
|
||||
, userEmail = userEmail'
|
||||
, userDisplayEmail = userDisplayEmail'
|
||||
, userDisplayName = case middleName of
|
||||
Just middleName' -> [st|#{firstName} #{middleName'} #{userSurname}|]
|
||||
Nothing -> [st|#{firstName} #{userSurname}|]
|
||||
@ -402,7 +402,7 @@ fillDb = do
|
||||
, userTitle = Nothing
|
||||
, userMaxFavourites = userDefaultMaxFavourites
|
||||
, userMaxFavouriteTerms = userDefaultMaxFavourites
|
||||
, userTheme = userDefaultTheme
|
||||
, userTheme = ThemeAberdeenReds
|
||||
, userDateTimeFormat = userDefaultDateTimeFormat
|
||||
, userDateFormat = userDefaultDateFormat
|
||||
, userTimeFormat = userDefaultTimeFormat
|
||||
@ -433,6 +433,18 @@ fillDb = do
|
||||
userIdent = fromString $ case middleName of
|
||||
Just middleName' -> repack [st|#{firstName}.#{middleName'}.#{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)
|
||||
manyUsers <- insertMany . getZipList $ manyUser <$> ZipList ((,,) <$> firstNames <*> middlenames <*> surnames) <*> ZipList matrikel
|
||||
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 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 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 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
|
||||
@ -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 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 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 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 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 (-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 $ PrintJob "TestJob1" "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 "TestJob3" "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 "TestJob5" "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 "TestJob7" "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 "TestJob9" "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 "TestJob1" "AckTestJob1" "job1" "No Text herein." (n_day' (-1)) Nothing Nothing (Just svaupel) Nothing (Just qid_f) Nothing
|
||||
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" "AckTestJob3" "job3" "No Text herein." (n_day' (-2)) Nothing Nothing Nothing Nothing Nothing Nothing
|
||||
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" "AckTestJob5" "job5" "No Text herein." (n_day' (-9)) Nothing (Just jost) (Just svaupel) Nothing (Just qid_r) (Just $ LmsIdent "qwvu")
|
||||
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" "AckTestJob7" "job7" "No Text herein." (n_day' (-6)) (Just $ n_day' (-8)) (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" "AckTestJob9" "job9" "No Text herein." (n_day' (-1)) Nothing (Just svaupel) Nothing Nothing Nothing (Just $ LmsIdent "abcdefg")
|
||||
void . insert $ PrintJob "TestJob0" "AckTestJob0" "job0" "No Text herein." (n_day' (-3)) Nothing Nothing Nothing Nothing Nothing (Just $ LmsIdent "hijklmn")
|
||||
|
||||
|
||||
let
|
||||
@ -786,6 +798,7 @@ fillDb = do
|
||||
jtt = (((Just .) .) .) . termTime tid
|
||||
firstDay = utctDay $ termTime tid TermDayLectureStart 0 Nothing toMidnight
|
||||
secondDay = utctDay $ termTime tid TermDayLectureStart 1 Nothing toMidnight
|
||||
tyear = year tid
|
||||
weekDay = dayOfWeek firstDay
|
||||
-- thirdDay = utctDay $ termTime tid TermDayLectureStart 2 Nothing toMidnight
|
||||
capacity = Just 8
|
||||
@ -816,8 +829,11 @@ fillDb = do
|
||||
, courseDeregisterUntil = jtt TermDayLectureStart (-5) (Just Monday) toMidnight
|
||||
, courseRegisterSecret = Nothing
|
||||
, courseMaterialFree = True
|
||||
}
|
||||
}
|
||||
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
|
||||
{ sheetCourse = c
|
||||
, sheetName = mkName "Sehtest"
|
||||
|
||||
Loading…
Reference in New Issue
Block a user