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

Merge branch 'master' into fradrive/api-avs

Browse Source
This commit is contained in:
Steffen Jost 2022-09-21 15:02:03 +02:00
commit a2f22b389a
65 changed files with 1219 additions and 761 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
CHANGELOG.md
View File

@ -2,6 +2,40 @@
All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines. All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines.
## [26.5.4](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v26.5.3...v26.5.4) (2022-09-21)
### Bug Fixes
* **notifications:** qualification renewals are more robust and not sent multiple times at once ([1cdd52e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/1cdd52e96c727139d6cd630da5117fd3b4aa5a7f))
## [26.5.3](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v26.5.2...v26.5.3) (2022-09-16)
## [26.5.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v26.5.1...v26.5.2) (2022-09-14)
### Bug Fixes
* **lms:** trigger userlist job after upload ([cceb600](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/cceb60074fbb26d7ed2d10a1c37297fa6e52292a))
## [26.5.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v26.5.0...v26.5.1) (2022-09-14)
## [26.5.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v26.4.0...v26.5.0) (2022-09-09)
### Features
* **lpr:** print center allows filtering by day now ([cac4870](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/cac4870c95f5367536ee48644fea8a526a0da5a3))
## [26.4.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v26.3.1...v26.4.0) (2022-09-08)
### Features
* **avs:** add SetRampDrivingLicence and InfoRampDrivingLicence to AVS interface ([a1272e3](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/a1272e38b72d146b881492341a86e1fc544ab0ff))
* **lms:** configurable csv settings for lms direct import and export routes ([6159403](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/6159403b27dab30178645dc37c99d41b4aaf610c))
* **users:** allow users to set postal address and email encryption password ([655fcf7](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/655fcf756471a2dfc6380e4b63236ca8d5229e11))
## [26.3.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v26.3.0...v26.3.1) (2022-09-03) ## [26.3.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v26.3.0...v26.3.1) (2022-09-03)

7
config/settings.yml
View File

@ -125,6 +125,13 @@ ldap:
ldap-re-test-failover: 60 ldap-re-test-failover: 60
lms-direct:
upload-header: "_env:LMSUPLOADHEADER:true"
upload-delimiter: "_env:LMSUPLOADDELIMITER:"
download-header: "_env:LMSDOWNLOADHEADER:true"
download-delimiter: "_env:LMSDOWNLOADDELIMITER:,"
download-cr-lf: "_env:LMSDOWNLOADCRLF:true"
avs: avs:
host: "_env:AVSHOST:skytest.fra.fraport.de" host: "_env:AVSHOST:skytest.fra.fraport.de"
port: "_env:AVSPORT:443" port: "_env:AVSPORT:443"

5
lpr Executable file
View File

@ -0,0 +1,5 @@
#!/usr/bin/env bash
printf "lpr dummy called, arguments ignored.\n"
printf "Nothing is printed."
exit 0

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

@ -106,7 +106,7 @@ PWHashLoginTitle: FRADrive Login
PWHashLoginNote: Verwenden Sie dieses Formular für zugesandte FRADrive Logindaten. Angestellte der Fraport AG sollten stattdessen den Büko-Login verwenden! PWHashLoginNote: Verwenden Sie dieses Formular für zugesandte FRADrive Logindaten. Angestellte der Fraport AG sollten stattdessen den Büko-Login verwenden!
DummyLoginTitle: Development-Login DummyLoginTitle: Development-Login
InternalLdapError: Interner Fehler beim Fraport Büko-Login InternalLdapError: Interner Fehler beim Fraport Büko-Login
CampusUserInvalidIdent: Konnte anhand des Fraport Büko-Logins keine eindeutige Identifikation CampusUserInvalidIdent: Konnte anhand des Fraport Büko-Logins keine eindeutige Identifikation ermitteln
CampusUserInvalidEmail: Konnte anhand des Fraport Büko-Logins keine E-Mail-Addresse ermitteln CampusUserInvalidEmail: Konnte anhand des Fraport Büko-Logins keine E-Mail-Addresse ermitteln
CampusUserInvalidDisplayName: Konnte anhand des Fraport Büko-Logins keinen vollen Namen ermitteln CampusUserInvalidDisplayName: Konnte anhand des Fraport Büko-Logins keinen vollen Namen ermitteln
CampusUserInvalidGivenName: Konnte anhand des Fraport Büko-Logins keinen Vornamen ermitteln CampusUserInvalidGivenName: Konnte anhand des Fraport Büko-Logins keinen Vornamen ermitteln

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

@ -17,4 +17,4 @@ InvitationAcceptDecline: Einladung annehmen/ablehnen
InvitationFromTip displayName@Text: Sie erhalten diese Einladung, weil #{displayName} ihren Versand in FRADrive ausgelöst hat. InvitationFromTip displayName@Text: Sie erhalten diese Einladung, weil #{displayName} ihren Versand in FRADrive ausgelöst hat.
InvitationFromTipAnonymous: Sie erhalten diese Einladung, weil ein nicht eingeloggter Benutzer/eine nichteingeloggte Benutzerin ihren Versand in FRADrive ausgelöst hat. InvitationFromTipAnonymous: Sie erhalten diese Einladung, weil ein nicht eingeloggter Benutzer/eine nichteingeloggte Benutzerin ihren Versand in FRADrive ausgelöst hat.
InvitationUniWorXTip: FRADrive ist ein webbasiertes Schulungsverwaltungssystem der Fraport AG. InvitationUniWorXTip: FRADrive ist ein webbasiertes Schulungsverwaltungssystem der Fraport AG.
LinkActiveUntil time@Text: Der Link ist nur bis #{time} aktiv! LinkActiveUntil time@Text: Dieser Link ist nur bis #{time} aktiv!

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

@ -17,4 +17,4 @@ InvitationAcceptDecline: Accept/Decline invitation
InvitationFromTip displayName: You are receiving this invitation because #{displayName} has caused it to be sent from within FRADrive. InvitationFromTip displayName: You are receiving this invitation because #{displayName} has caused it to be sent from within FRADrive.
InvitationFromTipAnonymous: You are receiving this invitiation because an user who didn't log in has caused it to be send from within FRADrive. InvitationFromTipAnonymous: You are receiving this invitiation because an user who didn't log in has caused it to be send from within FRADrive.
InvitationUniWorXTip: FRADrive is a web based training management system at Fraport AG. InvitationUniWorXTip: FRADrive is a web based training management system at Fraport AG.
LinkActiveUntil time@Text: The link is only active until #{time}! LinkActiveUntil time@Text: This link is only active until #{time}!

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

@ -12,6 +12,7 @@ TableQualificationCountTotal: Gesamt
LmsQualificationValidUntil: Gültig bis LmsQualificationValidUntil: Gültig bis
TableQualificationLastRefresh: Zuletzt erneuert TableQualificationLastRefresh: Zuletzt erneuert
TableQualificationFirstHeld: Erstmalig TableQualificationFirstHeld: Erstmalig
TableQualificationBlockedDue: Suspendiert
LmsUser: Inhaber LmsUser: Inhaber
TableLmsEmail: E-Mail TableLmsEmail: E-Mail
TableLmsIdent: Identifikation TableLmsIdent: Identifikation
@ -23,12 +24,14 @@ TableLmsDelete: Löschen?
TableLmsStaff: Interner Mitarbeiter? TableLmsStaff: Interner Mitarbeiter?
TableLmsStarted: Begonnen TableLmsStarted: Begonnen
TableLmsReceived: Letzte Rückmeldung TableLmsReceived: Letzte Rückmeldung
TableLmsNotified: Versand Benachrichtigung
TableLmsEnded: Beended TableLmsEnded: Beended
TableLmsStatus: Status E-Lernen TableLmsStatus: Status E-Lernen
TableLmsSuccess: Bestanden TableLmsSuccess: Bestanden
TableLmsFailed: Gesperrt TableLmsFailed: Gesperrt
FilterLmsValid: Aktuell gültig FilterLmsValid: Aktuell gültig
FilterLmsRenewal: Erneuerung anstehend FilterLmsRenewal: Erneuerung anstehend
FilterLmsNotified: Benachrichtigt
CsvColumnLmsIdent: E-Lernen Identifikator, einzigartig pro Qualifikation und Teilnehmer CsvColumnLmsIdent: E-Lernen Identifikator, einzigartig pro Qualifikation und Teilnehmer
CsvColumnLmsPin: PIN des E-Lernen Zugangs CsvColumnLmsPin: PIN des E-Lernen Zugangs
CsvColumnLmsResetPin: Wird die PIN bei der nächsten Synchronisation zurückgesetzt? CsvColumnLmsResetPin: Wird die PIN bei der nächsten Synchronisation zurückgesetzt?
@ -48,7 +51,7 @@ MailSubjectQualificationRenewal qname@Text: Qualifikation #{qname} muss demnäch
MailSubjectQualificationExpiry qname@Text: Qualifikation #{qname} läuft demnächst ab MailSubjectQualificationExpiry qname@Text: Qualifikation #{qname} läuft demnächst ab
MailBodyQualificationRenewal: Sie müssen diese Qualifikaton demnächst durch einen E-Lernen Kurs erneuern. MailBodyQualificationRenewal: Sie müssen diese Qualifikaton demnächst durch einen E-Lernen Kurs erneuern.
MailBodyQualificationExpiry: Diese Qualifikaton läuft bald ab. Tätigkeiten, welche diese Qualifikation voraussetzen dürfen dann nicht länger ausgeübt werden! MailBodyQualificationExpiry: Diese Qualifikaton läuft bald ab. Tätigkeiten, welche diese Qualifikation voraussetzen dürfen dann nicht länger ausgeübt werden!
LmsRenewalInstructions: Anweisungen zur Verlängerung finden Sie im angehängten PDF. Um Missbrauch zu verhindern wurde das PDF dem von Ihnen in FRADrive hinterlegten PIN-Passwort verschlüsselt. Falls kein PIN-Passwort hinterlegt wurde, ist das Passwort ihre Fraport Ausweisnummer, inklusive Punkt und der Ziffer danach. LmsRenewalInstructions: Anweisungen zur Verlängerung finden Sie im angehängten PDF. Um Missbrauch zu verhindern wurde das PDF dem von Ihnen in FRADrive hinterlegten PDF-Passwort verschlüsselt. Falls kein PDF-Passwort hinterlegt wurde, ist das PDF-Passwort Ihre Fraport Ausweisnummer, inklusive Punkt und der Ziffer danach.
LmsNoRenewal: Leider kann diese Qualifikation nicht alleine durch E-Lernen verlängert werden. LmsNoRenewal: Leider kann diese Qualifikation nicht alleine durch E-Lernen verlängert werden.
LmsActNotify: Benachrichtigung E-Lernen erneut per Post oder E-Mail versenden LmsActNotify: Benachrichtigung E-Lernen erneut per Post oder E-Mail versenden
LmsActRenewPin: Neue zufällige E-Lernen PIN zuweisen LmsActRenewPin: Neue zufällige E-Lernen PIN zuweisen
@ -59,7 +62,7 @@ LmsActionFailed n@Int: Aktion nicht durchgeführt für #{n} #{pluralDE n "Person
MppOpening: Anrede MppOpening: Anrede
MppClosing: Grußformel MppClosing: Grußformel
MppDate: Datum MppDate: Datum
MppURL: Link Prüfung MppURL: Link E-Lernen
MppLogin !ident-ok: Login MppLogin !ident-ok: Login
MppPin !ident-ok: Pin MppPin !ident-ok: Pin
MppRecipient: Empfänger MppRecipient: Empfänger

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

@ -12,6 +12,7 @@ TableQualificationCountTotal: Total
LmsQualificationValidUntil: Valid until LmsQualificationValidUntil: Valid until
TableQualificationLastRefresh: Last renewed TableQualificationLastRefresh: Last renewed
TableQualificationFirstHeld: First held TableQualificationFirstHeld: First held
TableQualificationBlockedDue: Suspended
LmsUser: Licensee LmsUser: Licensee
TableLmsEmail: Email TableLmsEmail: Email
TableLmsIdent: Identifier TableLmsIdent: Identifier
@ -23,12 +24,14 @@ TableLmsDelete: Delete?
TableLmsStaff: Staff? TableLmsStaff: Staff?
TableLmsStarted: Started TableLmsStarted: Started
TableLmsReceived: Last update TableLmsReceived: Last update
TableLmsNotified: Notification sent
TableLmsEnded: Ended TableLmsEnded: Ended
TableLmsStatus: Status e-learning TableLmsStatus: Status e-learning
TableLmsSuccess: Completed TableLmsSuccess: Completed
TableLmsFailed: Blocked TableLmsFailed: Blocked
FilterLmsValid: Currently valid FilterLmsValid: Currently valid
FilterLmsRenewal: Renewal due FilterLmsRenewal: Renewal due
FilterLmsNotified: Notified
CsvColumnLmsIdent: E-learning identifier, unique for each qualification and user CsvColumnLmsIdent: E-learning identifier, unique for each qualification and user
CsvColumnLmsPin: PIN for e-learning access CsvColumnLmsPin: PIN for e-learning access
CsvColumnLmsResetPin: Will the e-learning PIN be reset upon next synchronisation? CsvColumnLmsResetPin: Will the e-learning PIN be reset upon next synchronisation?
@ -48,7 +51,7 @@ MailSubjectQualificationRenewal qname@Text: Qualification #{qname} must be renew
MailSubjectQualificationExpiry qname@Text: Qualification #{qname} expires soon MailSubjectQualificationExpiry qname@Text: Qualification #{qname} expires soon
MailBodyQualificationRenewal: You will soon need to renew this qualficiation by completing an e-learning course. MailBodyQualificationRenewal: You will soon need to renew this qualficiation by completing an e-learning course.
MailBodyQualificationExpiry: This qualificaton expires soon. You may then no longer execute any duties that require this qualification as a precondition! MailBodyQualificationExpiry: This qualificaton expires soon. You may then no longer execute any duties that require this qualification as a precondition!
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 PIN-Password. If you have not yet chosen a PIN-Password yet, then the password is your Fraport id card number, inkluding the punctuation mark and the Digit thereafter. 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.
LmsNoRenewal: Unfortunately, this particular qualification cannot be renewed through E-learning only. LmsNoRenewal: Unfortunately, this particular qualification cannot be renewed through E-learning only.
LmsActNotify: Resend e-learning notification by post or email LmsActNotify: Resend e-learning notification by post or email
LmsActRenewPin: Randomly replace e-learning PIN LmsActRenewPin: Randomly replace e-learning PIN
@ -59,7 +62,7 @@ LmsActionFailed n@Int: No action for #{n} #{pluralENs n "person"}, since there w
MppOpening: Opening MppOpening: Opening
MppClosing: Closing MppClosing: Closing
MppDate: Date MppDate: Date
MppURL: Link Examination MppURL: Link e-learning
MppLogin: Login MppLogin: Login
MppPin: Pin MppPin: Pin
MppRecipient: Recipient MppRecipient: Recipient

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

@ -130,6 +130,8 @@ UserAuthModePWHashChangedToLDAP: Sie können sich nun mit Ihrer Fraport AG Kennu
UserAuthModeLDAPChangedToPWHash: Sie können sich nun mit einer FRADrive-internen Kennung einloggen UserAuthModeLDAPChangedToPWHash: Sie können sich nun mit einer FRADrive-internen Kennung einloggen
AuthPWHashTip: Sie müssen nun das mit "FRADrive-Login" beschriftete Login-Formular verwenden. Stellen Sie bitte sicher, dass Sie ein Passwort gesetzt haben, bevor Sie versuchen sich anzumelden. AuthPWHashTip: Sie müssen nun das mit "FRADrive-Login" beschriftete Login-Formular verwenden. Stellen Sie bitte sicher, dass Sie ein Passwort gesetzt haben, bevor Sie versuchen sich anzumelden.
PasswordResetEmailIncoming: Einen Link um ihr Passwort zu setzen bzw. zu ändern bekommen Sie, aus Sicherheitsgründen, in einer separaten E-Mail. PasswordResetEmailIncoming: Einen Link um ihr Passwort zu setzen bzw. zu ändern bekommen Sie, aus Sicherheitsgründen, in einer separaten E-Mail.
MailFradrive !ident-ok: FRADrive
MailBodyFradrive: ist die Führerscheinverwaltungsapp der Fraport AG.
#userRightsUpdate.hs + templates #userRightsUpdate.hs + templates
MailSubjectUserRightsUpdate name@Text: Berechtigungen für #{name} aktualisiert MailSubjectUserRightsUpdate name@Text: Berechtigungen für #{name} aktualisiert

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

@ -130,6 +130,8 @@ UserAuthModePWHashChangedToLDAP: You can now log in to FRADrive using your Frapo
UserAuthModeLDAPChangedToPWHash: You can now log in using your FRADrive-internal account UserAuthModeLDAPChangedToPWHash: You can now log in using your FRADrive-internal account
AuthPWHashTip: You now need to use the login form labeled "FRADrive login". Please ensure that you have already set a password when you try to log in. AuthPWHashTip: You now need to use the login form labeled "FRADrive login". Please ensure that you have already set a password when you try to log in.
PasswordResetEmailIncoming: For security reasons you will receive a link to the page on which you can set and later change your password in a separate email. PasswordResetEmailIncoming: For security reasons you will receive a link to the page on which you can set and later change your password in a separate email.
MailFradrive: FRADrive
MailBodyFradrive: is the apron driving licence management app of Fraport AG.
#userRightsUpdate.hs + templates #userRightsUpdate.hs + templates
MailSubjectUserRightsUpdate name: Permissions for #{name} changed MailSubjectUserRightsUpdate name: Permissions for #{name} changed

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

@ -27,9 +27,10 @@ WarningDaysTip: Wie viele Tage im Voraus sollen Fristen von Prüfungen etc. auf
ShowSex: Geschlechter anderer Nutzer:innen anzeigen ShowSex: Geschlechter anderer Nutzer:innen anzeigen
ShowSexTip: Sollen in Kursteilnehmer:innen-Tabellen u.Ä. die Geschlechter der Nutzer:innen angezeigt werden? ShowSexTip: Sollen in Kursteilnehmer:innen-Tabellen u.Ä. die Geschlechter der Nutzer:innen angezeigt werden?
PDFPassword: Passwort zur Verschlüsselung von PDF Anhängen an Email Benachrichtigungen PDFPassword: Passwort zur Verschlüsselung von PDF Anhängen an Email Benachrichtigungens
PDFPasswordTip: Achtung, dieses Passwort ist für FRADrive Administratoren einsehbar und wird unverschlüsselt gespeichert! PDFPasswordTip: Achtung, dieses Passwort ist für FRADrive Administratoren einsehbar und wird unverschlüsselt gespeichert!
PDFPasswordInvalid: Bitte ein nicht-triviales Passwort ohne Leerzeichen für PDF Email Anhänge eintragen! PDFPasswordInvalid c@Char: Bitte ein nicht-triviales Passwort für PDF Email Anhänge eintragen! Ungültiges Zeichen: #{char2Text c}
PDFPasswordTooShort n@Int: Bitte ein PDF Passwort mit mindestens #{show n} Zeichen wählen.
PrefersPostal: Sollen Benachrichtigung möglichst per Post versendet werden anstatt per Email? PrefersPostal: Sollen Benachrichtigung möglichst per Post versendet werden anstatt per Email?
PostalTip: Postversand kann in Rechnung gestellt werden und ist derzeit nur für Benachrichtigungen über Erneuerung und Ablauf von Qualifikation, wie z.B. Führerscheine, verfügbar. PostalTip: Postversand kann in Rechnung gestellt werden und ist derzeit nur für Benachrichtigungen über Erneuerung und Ablauf von Qualifikation, wie z.B. Führerscheine, verfügbar.
PostAddress: Postalische Adresse PostAddress: Postalische Adresse

3
messages/uniworx/categories/settings/en-eu.msg
View File

@ -29,7 +29,8 @@ ShowSexTip: Should users' sex be displayed in (among others) lists of course par
PDFPassword: Password to lock PDF email attachments PDFPassword: Password to lock PDF email attachments
PDFPasswordTip: Please note that this password is displayed to FRADrive admins and is saved unencrypted PDFPasswordTip: Please note that this password is displayed to FRADrive admins and is saved unencrypted
PDFPasswordInvalid: Please supply a sensible password for encrypting PDF email attachments! PDFPasswordInvalid c: Please supply a sensible password for encrypting PDF email attachments! Invalid character #{char2Text c}
PDFPasswordTooShort n: Please provide a password with at least #{show n} characters.
PrefersPostal: Should notifications preferably send by post instead of email? PrefersPostal: Should notifications preferably send by post instead of email?
PostalTip: Mailing may incur a fee and is currently only avaulable for qualification expiry notifications, such as driving lincence renewal. PostalTip: Mailing may incur a fee and is currently only avaulable for qualification expiry notifications, such as driving lincence renewal.
PostAddress: Postal address PostAddress: Postal address

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

@ -130,10 +130,12 @@ MenuLmsUsers: Export E-Lernen Benutzer
MenuLmsUserlist: Melden E-Lernen Benutzer MenuLmsUserlist: Melden E-Lernen Benutzer
MenuLmsResult: Melden Ergebnisse E-Lernen MenuLmsResult: Melden Ergebnisse E-Lernen
MenuLmsUpload: Hochladen MenuLmsUpload: Hochladen
MenuLmsDirect: Direkter Upload MenuLmsDirectUpload: Direkter Upload
MenuLmsDirectDownload: Direkter Download
MenuLmsFake: Testnutzer generieren MenuLmsFake: Testnutzer generieren
MenuAvs: Schnittstelle AVS MenuAvs: Schnittstelle AVS
MenuLdap: Schnittstelle LDAP
MenuApc: Druckerei MenuApc: Druckerei
MenuPrintSend: Manueller Briefversand MenuPrintSend: Manueller Briefversand
MenuPrintDownload: Brief herunterladen MenuPrintDownload: Brief herunterladen

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

@ -131,10 +131,12 @@ MenuLmsUsers: Download E-Learning Users
MenuLmsUserlist: Upload E-Learning Users MenuLmsUserlist: Upload E-Learning Users
MenuLmsResult: Upload E-Learning Results MenuLmsResult: Upload E-Learning Results
MenuLmsUpload: Upload MenuLmsUpload: Upload
MenuLmsDirect: Direct Upload MenuLmsDirectUpload: Direct Upload
MenuLmsDirectDownload: Direct Download
MenuLmsFake: Generate test users MenuLmsFake: Generate test users
MenuAvs: AVS Interface MenuAvs: AVS Interface
MenuLdap: LDAP Interface
MenuApc: Printing MenuApc: Printing
MenuPrintSend: Send Letter MenuPrintSend: Send Letter
MenuPrintDownload: Download Letter MenuPrintDownload: Download Letter

79
models/lms.model
View File

@ -1,11 +1,11 @@
Qualification Qualification
-- INVARIANT: 2*refreshWithin < validDuration -- INVARIANT: 2*refreshWithin < validDuration
school SchoolId --TODO: Ansprechpartner der Schule in Briefe erwähnen school SchoolId --TODO: Ansprechpartner der Schule in Briefe erwähnen
shorthand (CI Text) shorthand (CI Text)
name (CI Text) name (CI Text)
description StoredMarkup Maybe -- user-defined large Html, ought to contain full description description StoredMarkup Maybe -- user-defined large Html, ought to contain full description
validDuration Word Maybe -- qualification is valid indefinitely or for a specified number of months validDuration Word Maybe -- qualification is valid indefinitely or for a specified number of months, use with addMonthsDay
auditDuration Word Maybe -- number of month to keep audit log; or indefinitely auditDuration Word Maybe -- number of months to keep audit log and LmsUserIdents; or indefinitely (dangerous, since LmsIdents may run out)
refreshWithin CalendarDiffDays Maybe -- notify users about renewal within this number of month/days before expiry; to be used with addGregorianDurationClip refreshWithin CalendarDiffDays Maybe -- notify users about renewal within this number of month/days before expiry; to be used with addGregorianDurationClip
elearningStart Bool -- automatically schedule e-refresher elearningStart Bool -- automatically schedule e-refresher
-- elearningOnly Bool -- successful E-learing automatically increases validity. NO! -- elearningOnly Bool -- successful E-learing automatically increases validity. NO!
@ -18,9 +18,9 @@ Qualification
-- TODOs: -- TODOs:
-- - Enstehen Kosten, wenn Teilnehmer für KnowHow eingereiht werden, aber nicht am Kurs teilnehmen? -- - Enstehen Kosten, wenn Teilnehmer für KnowHow eingereiht werden, aber nicht am Kurs teilnehmen?
-- Falls ja, so sollte bei automatischem refresher vorher der Kunde durch FRADrive befragt werden?! -- Falls ja, so sollte bei automatischem refresher vorher der Kunde durch FRADrive befragt werden?!
-- A: Der Inhaber per Email informieren! -- A: Der Inhaber per Email informieren!
-- A: Es kann gleich eine LMS Pin generiert und verschickt werden! -- A: Es kann gleich eine LMS Pin generiert und verschickt werden!
-- - Aufteilung Qualification "R" in zwei Teile: "R e-learning" und "R praxis" okay? -- - Aufteilung Qualification "R" in zwei Teile: "R e-learning" und "R praxis" okay?
-- Besonderheiten: -- Besonderheiten:
-- - LmsIdent muss für alle Qualificationen einzigartig sein! -- - LmsIdent muss für alle Qualificationen einzigartig sein!
@ -33,7 +33,7 @@ Qualification
QualificationPrecondition QualificationPrecondition
qualification QualificationId OnDeleteCascade OnUpdateCascade -- AND: not unique, ie. qualification can have multiple required preconditions qualification QualificationId OnDeleteCascade OnUpdateCascade -- AND: not unique, ie. qualification can have multiple required preconditions
required [QualificationId] -- OR : alternatives, any one will suffice required [QualificationId] -- OR : alternatives, any one will suffice
continuous Bool -- expiring precondition removes qualification continuous Bool -- expiring precondition removes qualification
deriving Generic deriving Generic
@ -49,20 +49,21 @@ QualificationUser
user UserId OnDeleteCascade OnUpdateCascade user UserId OnDeleteCascade OnUpdateCascade
qualification QualificationId OnDeleteCascade OnUpdateCascade qualification QualificationId OnDeleteCascade OnUpdateCascade
validUntil Day validUntil Day
lastRefresh Day -- lastRefresh > validUntil possible, if Qualification^elearningOnly == False lastRefresh Day -- lastRefresh > validUntil possible, if Qualification^elearningOnly == False
firstHeld Day -- first time the qualification was earned, should never change firstHeld Day -- first time the qualification was earned, should never change
blockedDue QualificationBlocked Maybe -- isJust means that the qualification is currently revoked
-- temporärer Entzug vorsehen -- temporärer Entzug vorsehen
-- Begründungsfeld vorsehen -- Begründungsfeld vorsehen
UniqueQualificationUser qualification user UniqueQualificationUser qualification user
deriving Generic deriving Generic
-- LMS Interface Tables, need regular processing by background jobs, per QualificationId: -- LMS Interface Tables, need regular processing by background jobs, per QualificationId:
-- --
-- 1. Daily Job: Add to LmsUser daily all qualification holders with -- 1. Daily Job: Add to LmsUser daily all qualification holders with
-- QualificationUserValidUntil >= now -- QualificationUserValidUntil >= now
-- /\ QualificationUserValudUntil <= now + QualificationRefreshWithin (time to schedule refresher) -- /\ QualificationUserValudUntil <= now + QualificationRefreshWithin (time to schedule refresher)
-- /\ not already enlisted -- /\ not already enlisted
-- --
-- 2. REST GET User.csv: -- 2. REST GET User.csv:
-- - where LmsUserReceived == Nothing \/ (LmsUserResetPin /\ LmsUserEnded == Nothing) -- - where LmsUserReceived == Nothing \/ (LmsUserResetPin /\ LmsUserEnded == Nothing)
-- - delete-flag: isJust LmsUserStatus -- - delete-flag: isJust LmsUserStatus
@ -76,59 +77,61 @@ QualificationUser
-- - For all LmsUser: -- - For all LmsUser:
-- + if contained: -- + if contained:
-- set LmsUserReceived to Just now() -- set LmsUserReceived to Just now()
-- if LmsUserlistFailed: set LmsUserStatus to Just Day -- if LmsUserlistFailed: set LmsUserStatus to Just LmsBlocked now
-- + not contained, by LmsUserReceived is set: set LmsUserEnded to Just now() -- + not contained, by LmsUserReceived is set: set LmsUserEnded to Just now()
-- - move row to LmsAudit -- - move row to LmsAudit
-- --
-- 6. When received: Daily Job LmsResult: -- 6. When received: Daily Job LmsResult:
-- - set LmsUserReceived to Just now() -- - set LmsUserReceived to Just now() -- always
-- - set LmsUserStatus to Just Day -- always -- - set LmsUserStatus to Just LmsSuccess now -- conditional
-- - and renew QualificationValidTo
-- - move row to LmsAudit -- - move row to LmsAudit
-- --
-- 7. Daily Job: dequeue LMS Users -- 7. Daily Job: dequeue LMS Users
-- - renew qualification, if passed
-- - remove from LmsUser after audit Period has passed -- - remove from LmsUser after audit Period has passed
LmsUser LmsUser
qualification QualificationId OnDeleteCascade OnUpdateCascade qualification QualificationId OnDeleteCascade OnUpdateCascade
user UserId OnDeleteCascade OnUpdateCascade user UserId OnDeleteCascade OnUpdateCascade
ident LmsIdent -- must be unique accross all LMS courses! ident LmsIdent -- must be unique accross all LMS courses!
pin Text pin Text
resetPin Bool default=false -- should pin be reset? resetPin Bool default=false -- should pin be reset?
datePin UTCTime default=now() -- time pin was created datePin UTCTime default=now() -- time pin was created
status LmsStatus Maybe -- open, success or failure; isJust indicates user will be deleted from LMS status LmsStatus Maybe -- open, success or failure; status should never change unless isNothing; isJust indicates lms is finished and user shall be deleted from LMS
--toDelete encoded by Handler.Utils.LMS.lmsUserToDelete --toDelete encoded by Handler.Utils.LMS.lmsUserToDelete
started UTCTime default=now() started UTCTime default=now()
received UTCTime Maybe -- last acknowledgement by LMS received UTCTime Maybe -- last acknowledgement by LMS
ended UTCTime Maybe -- ident was deleted from LMS notified UTCTime Maybe -- last notified by FRADrive
ended UTCTime Maybe -- ident was deleted from LMS
-- Primary ident -- newtype Key LmsUserId = LmsUserKey { unLmsUser :: Text } -- change LmsIdent -> Text. Do we want this? -- Primary ident -- newtype Key LmsUserId = LmsUserKey { unLmsUser :: Text } -- change LmsIdent -> Text. Do we want this?
UniqueLmsIdent ident -- idents must be unique accross all qualifications, since idents are global within LMS! UniqueLmsIdent ident -- idents must be unique accross all qualifications, since idents are global within LMS!
UniqueLmsQualificationUser qualification user -- each user may be enrolled at most once per course UniqueLmsQualificationUser qualification user -- each user may be enrolled at most once per course
deriving Generic deriving Generic
-- LmsUserlist stores LMS upload for later processing only -- LmsUserlist stores LMS upload for later processing only
LmsUserlist LmsUserlist
qualification QualificationId OnDeleteCascade OnUpdateCascade qualification QualificationId OnDeleteCascade OnUpdateCascade
ident LmsIdent ident LmsIdent
failed Bool failed Bool
timestamp UTCTime default=now() timestamp UTCTime default=now()
UniqueLmsUserlist qualification ident UniqueLmsUserlist qualification ident
deriving Generic deriving Generic
-- LmsResult stores LMS upload for later processing only -- LmsResult stores LMS upload for later processing only
LmsResult LmsResult
qualification QualificationId OnDeleteCascade OnUpdateCascade qualification QualificationId OnDeleteCascade OnUpdateCascade
ident LmsIdent ident LmsIdent
success Day success Day
timestamp UTCTime default=now() timestamp UTCTime default=now()
UniqueLmsResult qualification ident -- required by DBTable UniqueLmsResult qualification ident -- required by DBTable
deriving Generic deriving Generic
-- Logs all processed rows from LmsUserlist and LmsResult -- Logs all processed rows from LmsUserlist and LmsResult
LmsAudit LmsAudit
qualification QualificationId OnDeleteCascade OnUpdateCascade qualification QualificationId OnDeleteCascade OnUpdateCascade
ident LmsIdent ident LmsIdent
notificationType LmsStatus -- LmsBlocked Day | LmsSuccess Day notificationType LmsStatus -- LmsBlocked Day | LmsSuccess Day
note Text Maybe
received UTCTime -- timestamp from LmsUserlist/LmsResult received UTCTime -- timestamp from LmsUserlist/LmsResult
processed UTCTime default=now() processed UTCTime default=now()
deriving Generic deriving Generic

2
models/mail.model
View File

@ -3,7 +3,7 @@ SentMail
sentBy InstanceId sentBy InstanceId
objectId MailObjectId Maybe objectId MailObjectId Maybe
bounceSecret BounceSecret Maybe bounceSecret BounceSecret Maybe
recipient UserId Maybe recipient UserId Maybe OnDeleteCascade
headers MailHeaders headers MailHeaders
contentRef SentMailContentId contentRef SentMailContentId
deriving Generic deriving Generic

1
nix/docker/default.nix
View File

@ -38,6 +38,7 @@ let
# just for manual testing within the pod, may be removef for production? # just for manual testing within the pod, may be removef for production?
curl wget netcat openldap curl wget netcat openldap
unixtools.netstat htop gnugrep unixtools.netstat htop gnugrep
locale
] ++ optionals isDemo [ postgresql_12 memcached uniworx.uniworx.components.exes.uniworxdb ]; ] ++ optionals isDemo [ postgresql_12 memcached uniworx.uniworx.components.exes.uniworxdb ];
runAsRoot = '' runAsRoot = ''

2
nix/docker/demo-version.json
View File

@ -1,3 +1,3 @@
{ {
"version": "26.3.1" "version": "26.5.4"
} }

2
nix/docker/version.json
View File

@ -1,3 +1,3 @@
{ {
"version": "26.3.1" "version": "26.5.4"
} }

2
package-lock.json generated
View File

@ -1,6 +1,6 @@
{ {
"name": "uni2work", "name": "uni2work",
"version": "26.3.1", "version": "26.5.4",
"lockfileVersion": 1, "lockfileVersion": 1,
"requires": true, "requires": true,
"dependencies": { "dependencies": {

2
package.json
View File

@ -1,6 +1,6 @@
{ {
"name": "uni2work", "name": "uni2work",
"version": "26.3.1", "version": "26.5.4",
"description": "", "description": "",
"keywords": [], "keywords": [],
"author": "", "author": "",

2
package.yaml
View File

@ -1,5 +1,5 @@
name: uniworx name: uniworx
version: 26.3.1 version: 26.5.4
dependencies: dependencies:
- base - base
- yesod - yesod

1
routes
View File

@ -62,6 +62,7 @@
/admin/tokens AdminTokensR GET POST /admin/tokens AdminTokensR GET POST
/admin/crontab AdminCrontabR GET /admin/crontab AdminCrontabR GET
/admin/avs AdminAvsR GET POST /admin/avs AdminAvsR GET POST
/admin/ldap AdminLdapR GET POST
/print PrintCenterR GET POST !system-printer /print PrintCenterR GET POST !system-printer
/print/send PrintSendR GET POST /print/send PrintSendR GET POST

7
src/Auth/LDAP.hs
View File

@ -5,7 +5,7 @@ module Auth.LDAP
, ADError(..), ADInvalidCredentials(..) , ADError(..), ADInvalidCredentials(..)
, campusLogin , campusLogin
, CampusUserException(..) , CampusUserException(..)
, campusUser, campusUser' , campusUser, campusUser', campusUser''
, campusUserReTest, campusUserReTest' , campusUserReTest, campusUserReTest'
, campusUserMatr, campusUserMatr' , campusUserMatr, campusUserMatr'
, CampusMessage(..) , CampusMessage(..)
@ -145,8 +145,11 @@ campusUser pool mode creds = throwLeft =<< campusUserWith withLdapFailover pool
campusUser' :: (MonadMask m, MonadUnliftIO m, MonadLogger m) => Failover (LdapConf, LdapPool) -> FailoverMode -> User -> m (Maybe (Ldap.AttrList [])) campusUser' :: (MonadMask m, MonadUnliftIO m, MonadLogger m) => Failover (LdapConf, LdapPool) -> FailoverMode -> User -> m (Maybe (Ldap.AttrList []))
campusUser' pool mode User{userIdent} campusUser' pool mode User{userIdent}
= runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ campusUser pool mode (Creds apLdap (CI.original userIdent) []) = campusUser'' pool mode $ CI.original userIdent
campusUser'' :: (MonadMask m, MonadUnliftIO m, MonadLogger m) => Failover (LdapConf, LdapPool) -> FailoverMode -> Text -> m (Maybe (Ldap.AttrList []))
campusUser'' pool mode ident
= runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ campusUser pool mode (Creds apLdap ident [])
campusUserMatr :: (MonadUnliftIO m, MonadMask m, MonadLogger m) => Failover (LdapConf, LdapPool) -> FailoverMode -> UserMatriculation -> m (Ldap.AttrList []) campusUserMatr :: (MonadUnliftIO m, MonadMask m, MonadLogger m) => Failover (LdapConf, LdapPool) -> FailoverMode -> UserMatriculation -> m (Ldap.AttrList [])
campusUserMatr pool mode userMatr = either (throwM . CampusUserLdapError) return <=< withLdapFailover _2 pool mode $ \(conf@LdapConf{..}, ldap) -> liftIO $ do campusUserMatr pool mode userMatr = either (throwM . CampusUserLdapError) return <=< withLdapFailover _2 pool mode $ \(conf@LdapConf{..}, ldap) -> liftIO $ do

32
src/Database/Esqueleto/Utils.hs
View File

@ -14,6 +14,7 @@ module Database.Esqueleto.Utils
, mkExactFilter, mkExactFilterWith , mkExactFilter, mkExactFilterWith
, mkExactFilterLast, mkExactFilterLastWith , mkExactFilterLast, mkExactFilterLastWith
, mkContainsFilter, mkContainsFilterWith , mkContainsFilter, mkContainsFilterWith
, mkDayFilter, mkDayFilterFrom, mkDayFilterTo
, mkExistsFilter , mkExistsFilter
, anyFilter, allFilter , anyFilter, allFilter
, orderByList , orderByList
@ -222,7 +223,7 @@ mkExactFilterWith cast lenslike row criterias
mkExactFilterLast :: (PersistField a) mkExactFilterLast :: (PersistField a)
=> (t -> E.SqlExpr (E.Value a)) -- ^ getter from query to searched element => (t -> E.SqlExpr (E.Value a)) -- ^ getter from query to searched element
-> t -- ^ query row -> t -- ^ query row
-> Last a -- ^ needle collection -> Last a -- ^ needle
-> E.SqlExpr (E.Value Bool) -> E.SqlExpr (E.Value Bool)
mkExactFilterLast = mkExactFilterLastWith id mkExactFilterLast = mkExactFilterLastWith id
@ -231,7 +232,7 @@ mkExactFilterLastWith :: (PersistField b)
=> (a -> b) -- ^ type conversion => (a -> b) -- ^ type conversion
-> (t -> E.SqlExpr (E.Value b)) -- ^ getter from query to searched element -> (t -> E.SqlExpr (E.Value b)) -- ^ getter from query to searched element
-> t -- ^ query row -> t -- ^ query row
-> Last a -- ^ needle collection -> Last a -- ^ needle
-> E.SqlExpr (E.Value Bool) -> E.SqlExpr (E.Value Bool)
mkExactFilterLastWith cast lenslike row criterias mkExactFilterLastWith cast lenslike row criterias
| Last (Just crit) <- criterias = lenslike row E.==. E.val (cast crit) | Last (Just crit) <- criterias = lenslike row E.==. E.val (cast crit)
@ -258,6 +259,33 @@ mkContainsFilterWith cast lenslike row criterias
| Set.null criterias = true | Set.null criterias = true
| otherwise = any (hasInfix $ lenslike row) (E.val . cast <$> Set.toList criterias) | otherwise = any (hasInfix $ lenslike row) (E.val . cast <$> Set.toList criterias)
mkDayFilter :: (t -> E.SqlExpr (E.Value UTCTime)) -- ^ getter from query to searched element
-> t -- ^ query row
-> Last Day -- ^ a day to filter for
-> E.SqlExpr (E.Value Bool)
mkDayFilter lenslike row criterias
| Last (Just crit) <- criterias = day (lenslike row) E.==. E.val crit
| otherwise = true
mkDayFilterFrom :: (t -> E.SqlExpr (E.Value UTCTime)) -- ^ getter from query to searched element
-> t -- ^ query row
-> Last Day -- ^ a day range to filter for
-> E.SqlExpr (E.Value Bool)
mkDayFilterFrom lenslike row criterias
| Last (Just crit) <- criterias = day (lenslike row) E.>=. E.val crit
| otherwise = true
mkDayFilterTo :: (t -> E.SqlExpr (E.Value UTCTime)) -- ^ getter from query to searched element
-> t -- ^ query row
-> Last Day -- ^ a day range to filter for
-> E.SqlExpr (E.Value Bool)
mkDayFilterTo lenslike row criterias
| Last (Just crit) <- criterias = day (lenslike row) E.<=. E.val crit
| otherwise = true
mkExistsFilter :: PathPiece a mkExistsFilter :: PathPiece a
=> (t -> a -> E.SqlQuery ()) => (t -> a -> E.SqlQuery ())
-> t -> t

19
src/Foundation/Navigation.hs
View File

@ -105,6 +105,7 @@ breadcrumb AdminErrMsgR = i18nCrumb MsgMenuAdminErrMsg $ Just AdminR
breadcrumb AdminTokensR = i18nCrumb MsgMenuAdminTokens $ Just AdminR breadcrumb AdminTokensR = i18nCrumb MsgMenuAdminTokens $ Just AdminR
breadcrumb AdminCrontabR = i18nCrumb MsgBreadcrumbAdminCrontab $ Just AdminR breadcrumb AdminCrontabR = i18nCrumb MsgBreadcrumbAdminCrontab $ Just AdminR
breadcrumb AdminAvsR = i18nCrumb MsgMenuAvs $ Just AdminR breadcrumb AdminAvsR = i18nCrumb MsgMenuAvs $ Just AdminR
breadcrumb AdminLdapR = i18nCrumb MsgMenuLdap $ Just AdminR
breadcrumb PrintCenterR = i18nCrumb MsgMenuApc Nothing breadcrumb PrintCenterR = i18nCrumb MsgMenuApc Nothing
breadcrumb PrintSendR = i18nCrumb MsgMenuPrintSend $ Just PrintCenterR breadcrumb PrintSendR = i18nCrumb MsgMenuPrintSend $ Just PrintCenterR
@ -819,6 +820,14 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the
, navQuick' = mempty , navQuick' = mempty
, navForceActive = False , navForceActive = False
} }
, NavLink
{ navLabel = MsgMenuLdap
, navRoute = AdminLdapR
, navAccess' = NavAccessTrue
, navType = NavTypeLink { navModal = False }
, navQuick' = mempty
, navForceActive = False
}
] ]
} }
, return NavHeaderContainer , return NavHeaderContainer
@ -2464,21 +2473,21 @@ pageActions (LmsR sid qsh) = return
[ NavPageActionPrimary [ NavPageActionPrimary
{ navLink = defNavLink MsgMenuLmsUsers $ LmsUsersR sid qsh { navLink = defNavLink MsgMenuLmsUsers $ LmsUsersR sid qsh
, navChildren = , navChildren =
[ defNavLink MsgMenuLmsDirect $ LmsUsersDirectR sid qsh [ defNavLink MsgMenuLmsDirectDownload $ LmsUsersDirectR sid qsh
] ]
} }
, NavPageActionPrimary , NavPageActionPrimary
{ navLink = defNavLink MsgMenuLmsUserlist $ LmsUserlistR sid qsh { navLink = defNavLink MsgMenuLmsUserlist $ LmsUserlistR sid qsh
, navChildren = , navChildren =
[ defNavLink MsgMenuLmsUpload $ LmsUserlistUploadR sid qsh [ defNavLink MsgMenuLmsUpload $ LmsUserlistUploadR sid qsh
, defNavLink MsgMenuLmsDirect $ LmsUserlistDirectR sid qsh , defNavLink MsgMenuLmsDirectUpload $ LmsUserlistDirectR sid qsh
] ]
} }
, NavPageActionPrimary , NavPageActionPrimary
{ navLink = defNavLink MsgMenuLmsResult $ LmsResultR sid qsh { navLink = defNavLink MsgMenuLmsResult $ LmsResultR sid qsh
, navChildren = , navChildren =
[ defNavLink MsgMenuLmsUpload $ LmsResultUploadR sid qsh [ defNavLink MsgMenuLmsUpload $ LmsResultUploadR sid qsh
, defNavLink MsgMenuLmsDirect $ LmsResultDirectR sid qsh , defNavLink MsgMenuLmsDirectUpload $ LmsResultDirectR sid qsh
] ]
} }
, NavPageActionSecondary { , NavPageActionSecondary {

260
src/Foundation/Yesod/Auth.hs
View File

@ -1,6 +1,7 @@
module Foundation.Yesod.Auth module Foundation.Yesod.Auth
( authenticate ( authenticate
, upsertCampusUser , upsertCampusUser
, decodeUserTest
, CampusUserConversionException(..) , CampusUserConversionException(..)
, campusUserFailoverMode, updateUserLanguage , campusUserFailoverMode, updateUserLanguage
) where ) where
@ -154,124 +155,20 @@ upsertCampusUser :: forall m.
=> UpsertCampusUserMode -> Ldap.AttrList [] -> SqlPersistT m (Entity User) => UpsertCampusUserMode -> Ldap.AttrList [] -> SqlPersistT m (Entity User)
upsertCampusUser upsertMode ldapData = do upsertCampusUser upsertMode ldapData = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
UserDefaultConf{..} <- getsYesod $ view _appUserDefaults userDefaultConf <- getsYesod $ view _appUserDefaults
let (newUser,userUpdate) <- decodeUser now userDefaultConf upsertMode ldapData
ldapMap :: Map.Map Ldap.Attr [Ldap.AttrValue] -- Recall: Ldap.AttrValue == ByteString
ldapMap = Map.fromListWith (++) $ ldapData <&> second (filter (not . ByteString.null)) oldUsers <- for (userLdapPrimaryKey newUser) $ \pKey -> selectKeysList [ UserLdapPrimaryKey ==. Just pKey ] []
-- only accept a single result, throw error otherwise
-- decodeLdap1 :: (MonadThrow m, Exception e) => Ldap.Attr -> e -> m Text
decodeLdap1 attr err
| [bs] <- ldapMap !!! attr
, Right t <- Text.decodeUtf8' bs
= return t
| otherwise = throwM err
-- accept any successful decoding or empty; only throw an error if all decodings fail
-- decodeLdap' :: (Exception e) => Ldap.Attr -> e -> m Text
decodeLdap' attr err
| [] <- vs = return Nothing
| (h:_) <- rights vs = return $ Just h
| otherwise = throwM err
where
vs = Text.decodeUtf8' <$> ldapMap !!! attr
-- just returns Nothing on error, pure
decodeLdap :: Ldap.Attr -> Maybe Text
decodeLdap attr = listToMaybe . rights $ Text.decodeUtf8' <$> ldapMap !!! attr
userTelephone = decodeLdap ldapUserTelephone
userMobile = decodeLdap ldapUserMobile
userCompanyPersonalNumber = decodeLdap ldapUserFraportPersonalnummer
userCompanyDepartment = decodeLdap ldapUserFraportAbteilung
userAuthentication
| is _UpsertCampusUserLoginOther upsertMode
= error "Non-LDAP logins should only work for users that are already known"
| otherwise = AuthLDAP
userLastAuthentication = guardOn isLogin now
isLogin = has (_UpsertCampusUserLoginLdap <> _UpsertCampusUserLoginOther . united) upsertMode
userIdent <- if
| [bs] <- ldapMap !!! ldapUserPrincipalName
, Right userIdent' <- CI.mk <$> Text.decodeUtf8' bs
, hasn't _upsertCampusUserIdent upsertMode || has (_upsertCampusUserIdent . only userIdent') upsertMode
-> return userIdent'
| Just userIdent' <- upsertMode ^? _upsertCampusUserIdent
-> return userIdent'
| otherwise
-> throwM CampusUserInvalidIdent
userEmail <- if
| userEmail : _ <- mapMaybe (assertM (elem '@') . either (const Nothing) Just . Text.decodeUtf8') (lookupSome ldapMap $ toList ldapUserEmail)
-> return $ CI.mk userEmail
| otherwise
-> throwM CampusUserInvalidEmail
userFirstName <- decodeLdap1 ldapUserFirstName CampusUserInvalidGivenName
userSurname <- decodeLdap1 ldapUserSurname CampusUserInvalidSurname
userTitle <- decodeLdap' ldapUserTitle CampusUserInvalidTitle
userDisplayName' <- decodeLdap1 ldapUserDisplayName CampusUserInvalidDisplayName >>=
(maybeThrow CampusUserInvalidDisplayName . checkDisplayName userTitle userFirstName userSurname)
userLdapPrimaryKey <- if
| [bs] <- ldapMap !!! ldapPrimaryKey
, Right userLdapPrimaryKey'' <- Text.decodeUtf8' bs
, Just userLdapPrimaryKey''' <- assertM' (not . Text.null) $ Text.strip userLdapPrimaryKey''
-> return $ Just userLdapPrimaryKey'''
| otherwise
-> return Nothing
let
newUser = User
{ userMaxFavourites = userDefaultMaxFavourites
, userMaxFavouriteTerms = userDefaultMaxFavouriteTerms
, userTheme = userDefaultTheme
, userDateTimeFormat = userDefaultDateTimeFormat
, userDateFormat = userDefaultDateFormat
, userTimeFormat = userDefaultTimeFormat
, userDownloadFiles = userDefaultDownloadFiles
, userWarningDays = userDefaultWarningDays
, userShowSex = userDefaultShowSex
, userSex = Nothing
, userExamOfficeGetSynced = userDefaultExamOfficeGetSynced
, userExamOfficeGetLabels = userDefaultExamOfficeGetLabels
, userNotificationSettings = def
, userLanguages = Nothing
, userCsvOptions = def
, userTokensIssuedAfter = Nothing
, userCreated = now
, userLastLdapSynchronisation = Just now
, userDisplayName = userDisplayName'
, userDisplayEmail = userEmail
, userMatrikelnummer = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO
, userPostAddress = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO
, userPinPassword = Nothing -- must be derived via AVS
, userPrefersPostal = False
, ..
}
userUpdate = [
-- UserDisplayName =. userDisplayName -- not updated here, since users are allowed to change their DisplayName; see line 272
UserFirstName =. userFirstName
, UserSurname =. userSurname
, UserEmail =. userEmail
, UserLastLdapSynchronisation =. Just now
, UserLdapPrimaryKey =. userLdapPrimaryKey
, UserMobile =. userMobile
, UserTelephone =. userTelephone
, UserCompanyPersonalNumber =. userCompanyPersonalNumber
, UserCompanyDepartment =. userCompanyDepartment
] ++
[ UserLastAuthentication =. Just now | isLogin ]
oldUsers <- for userLdapPrimaryKey $ \pKey -> selectKeysList [ UserLdapPrimaryKey ==. Just pKey ] []
user@(Entity userId userRec) <- case oldUsers of user@(Entity userId userRec) <- case oldUsers of
Just [oldUserId] -> updateGetEntity oldUserId userUpdate Just [oldUserId] -> updateGetEntity oldUserId userUpdate
_other -> upsertBy (UniqueAuthentication userIdent) newUser userUpdate _other -> upsertBy (UniqueAuthentication (newUser ^. _userIdent)) newUser userUpdate
unless (validDisplayName userTitle userFirstName userSurname $ userDisplayName userRec) $ unless (validDisplayName (newUser ^. _userTitle)
update userId [ UserDisplayName =. userDisplayName' ] (newUser ^. _userFirstName)
(newUser ^. _userSurname)
(userRec ^. _userDisplayName)) $
update userId [ UserDisplayName =. (newUser ^. _userDisplayName) ]
let let
userSystemFunctions = determineSystemFunctions . Set.fromList $ map CI.mk userSystemFunctions' userSystemFunctions = determineSystemFunctions . Set.fromList $ map CI.mk userSystemFunctions'
@ -289,6 +186,141 @@ upsertCampusUser upsertMode ldapData = do
return user return user
decodeUserTest :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m)
=> Maybe UserIdent -> Ldap.AttrList [] -> m (Either CampusUserConversionException (User, [Update User]))
decodeUserTest mbIdent ldapData = do
now <- liftIO getCurrentTime
userDefaultConf <- getsYesod $ view _appUserDefaults
let mode = maybe UpsertCampusUserLoginLdap UpsertCampusUserLoginDummy mbIdent
try $ decodeUser now userDefaultConf mode ldapData
decodeUser :: (MonadThrow m) => UTCTime -> UserDefaultConf -> UpsertCampusUserMode -> Ldap.AttrList [] -> m (User,_)
decodeUser now UserDefaultConf{..} upsertMode ldapData = do
let
userTelephone = decodeLdap ldapUserTelephone
userMobile = decodeLdap ldapUserMobile
userCompanyPersonalNumber = decodeLdap ldapUserFraportPersonalnummer
userCompanyDepartment = decodeLdap ldapUserFraportAbteilung
userAuthentication
| is _UpsertCampusUserLoginOther upsertMode
= AuthPWHash (error "Non-LDAP logins should only work for users that are already known")
| otherwise = AuthLDAP
userLastAuthentication = guardOn isLogin now
isLogin = has (_UpsertCampusUserLoginLdap <> _UpsertCampusUserLoginOther . united) upsertMode
userTitle = decodeLdap ldapUserTitle -- CampusUserInvalidTitle
userFirstName = decodeLdap' ldapUserFirstName -- CampusUserInvalidGivenName
userSurname = decodeLdap' ldapUserSurname -- CampusUserInvalidSurname
userDisplayName <- decodeLdap1 ldapUserDisplayName CampusUserInvalidDisplayName <&> fixDisplayName -- do not check LDAP-given userDisplayName
--userDisplayName <- decodeLdap1 ldapUserDisplayName CampusUserInvalidDisplayName >>=
-- (maybeThrow CampusUserInvalidDisplayName . checkDisplayName userTitle userFirstName userSurname)
userIdent <- if
| [bs] <- ldapMap !!! ldapUserPrincipalName
, Right userIdent' <- CI.mk <$> Text.decodeUtf8' bs
, hasn't _upsertCampusUserIdent upsertMode || has (_upsertCampusUserIdent . only userIdent') upsertMode
-> return userIdent'
| Just userIdent' <- upsertMode ^? _upsertCampusUserIdent
-> return userIdent'
| otherwise
-> throwM CampusUserInvalidIdent
userEmail <- if
| userEmail : _ <- mapMaybe (assertM (elem '@') . either (const Nothing) Just . Text.decodeUtf8') (lookupSome ldapMap $ toList ldapUserEmail)
-> return $ CI.mk userEmail
| otherwise
-> throwM CampusUserInvalidEmail
userLdapPrimaryKey <- if
| [bs] <- ldapMap !!! ldapPrimaryKey
, Right userLdapPrimaryKey'' <- Text.decodeUtf8' bs
, Just userLdapPrimaryKey''' <- assertM' (not . Text.null) $ Text.strip userLdapPrimaryKey''
-> return $ Just userLdapPrimaryKey'''
| otherwise
-> return Nothing
let
newUser = User
{ userMaxFavourites = userDefaultMaxFavourites
, userMaxFavouriteTerms = userDefaultMaxFavouriteTerms
, userTheme = userDefaultTheme
, userDateTimeFormat = userDefaultDateTimeFormat
, userDateFormat = userDefaultDateFormat
, userTimeFormat = userDefaultTimeFormat
, userDownloadFiles = userDefaultDownloadFiles
, userWarningDays = userDefaultWarningDays
, userShowSex = userDefaultShowSex
, userSex = Nothing
, userExamOfficeGetSynced = userDefaultExamOfficeGetSynced
, userExamOfficeGetLabels = userDefaultExamOfficeGetLabels
, userNotificationSettings = def
, userLanguages = Nothing
, userCsvOptions = def
, userTokensIssuedAfter = Nothing
, userCreated = now
, userLastLdapSynchronisation = Just now
, userDisplayName = userDisplayName
, userDisplayEmail = userEmail
, userMatrikelnummer = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO
, userPostAddress = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO
, userPinPassword = Nothing -- must be derived via AVS
, userPrefersPostal = False
, ..
}
userUpdate = [
-- UserDisplayName =. userDisplayName -- not updated here, since users are allowed to change their DisplayName; see line 272
UserFirstName =. userFirstName
, UserSurname =. userSurname
, UserEmail =. userEmail
, UserLastLdapSynchronisation =. Just now
, UserLdapPrimaryKey =. userLdapPrimaryKey
, UserMobile =. userMobile
, UserTelephone =. userTelephone
, UserCompanyPersonalNumber =. userCompanyPersonalNumber
, UserCompanyDepartment =. userCompanyDepartment
] ++
[ UserLastAuthentication =. Just now | isLogin ]
return (newUser, userUpdate)
where
ldapMap :: Map.Map Ldap.Attr [Ldap.AttrValue] -- Recall: Ldap.AttrValue == ByteString
ldapMap = Map.fromListWith (++) $ ldapData <&> second (filter (not . ByteString.null))
-- just returns Nothing on error, pure
decodeLdap :: Ldap.Attr -> Maybe Text
decodeLdap attr = listToMaybe . rights $ Text.decodeUtf8' <$> ldapMap !!! attr
decodeLdap' :: Ldap.Attr -> Text
decodeLdap' = fromMaybe "" . decodeLdap
-- accept the first successful decoding or empty; only throw an error if all decodings fail
-- decodeLdap' :: (Exception e) => Ldap.Attr -> e -> m (Maybe Text)
-- decodeLdap' attr err
-- | [] <- vs = return Nothing
-- | (h:_) <- rights vs = return $ Just h
-- | otherwise = throwM err
-- where
-- vs = Text.decodeUtf8' <$> (ldapMap !!! attr)
-- only accepts the first successful decoding, ignoring all others, but failing if there is none
-- decodeLdap1 :: (MonadThrow m, Exception e) => Ldap.Attr -> e -> m Text
decodeLdap1 attr err
| (h:_) <- rights vs = return h
| otherwise = throwM err
where
vs = Text.decodeUtf8' <$> (ldapMap !!! attr)
-- accept and merge one or more successful decodings, ignoring all others
-- decodeLdapN attr err
-- | t@(_:_) <- rights vs
-- = return $ Text.unwords t
-- | otherwise = throwM err
-- where
-- vs = Text.decodeUtf8' <$> (ldapMap !!! attr)
associateUserSchoolsByTerms :: MonadIO m => UserId -> SqlPersistT m () associateUserSchoolsByTerms :: MonadIO m => UserId -> SqlPersistT m ()
associateUserSchoolsByTerms uid = do associateUserSchoolsByTerms uid = do
sfs <- selectList [StudyFeaturesUser ==. uid] [] sfs <- selectList [StudyFeaturesUser ==. uid] []

1
src/Handler/Admin.hs
View File

@ -9,6 +9,7 @@ import Handler.Admin.ErrorMessage as Handler.Admin
import Handler.Admin.Tokens as Handler.Admin import Handler.Admin.Tokens as Handler.Admin
import Handler.Admin.Crontab as Handler.Admin import Handler.Admin.Crontab as Handler.Admin
import Handler.Admin.Avs as Handler.Admin import Handler.Admin.Avs as Handler.Admin
import Handler.Admin.Ldap as Handler.Admin
getAdminR :: Handler Html getAdminR :: Handler Html
getAdminR = getAdminR =

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

@ -51,7 +51,7 @@ validateAvsQueryStatus = do
AvsQueryStatus ids <- State.get AvsQueryStatus ids <- State.get
guardValidation (MsgAvsQueryStatusInvalid $ tshow ids) $ not (null ids) guardValidation (MsgAvsQueryStatusInvalid $ tshow ids) $ not (null ids)
getAdminAvsR, postAdminAvsR :: Handler Html getAdminAvsR, postAdminAvsR :: Handler Html
getAdminAvsR = postAdminAvsR getAdminAvsR = postAdminAvsR
postAdminAvsR = do postAdminAvsR = do
mAvsQuery <- getsYesod $ view _appAvsQuery mAvsQuery <- getsYesod $ view _appAvsQuery

81
src/Handler/Admin/Ldap.hs Normal file
View File

@ -0,0 +1,81 @@
module Handler.Admin.Ldap
( getAdminLdapR
, postAdminLdapR
) where
import Import
-- import qualified Control.Monad.State.Class as State
-- import Data.Aeson (encode)
import qualified Data.CaseInsensitive as CI
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
-- import qualified Data.Set as Set
import Foundation.Yesod.Auth (decodeUserTest)
import Handler.Utils
import qualified Ldap.Client as Ldap
import Auth.LDAP
newtype LdapQueryPerson = LdapQueryPerson
{ ldapQueryIdent :: Text
-- , ldapQueryName :: Maybe Text
-- , ldapQueryPNum :: Maybe Text
}
deriving (Eq, Ord, Read, Show, Generic, Typeable)
makeLdapPersonForm :: Maybe LdapQueryPerson -> Form LdapQueryPerson
makeLdapPersonForm tmpl = validateForm validateLdapQueryPerson $ \html ->
flip (renderAForm FormStandard) html $ LdapQueryPerson
<$> areq textField (fslI MsgAdminUserIdent) (ldapQueryIdent <$> tmpl)
-- <*> aopt textField (fslI MsgAdminUserSurname) (ldapQueryName <$> tmpl)
-- <*> aopt textField (fslI MsgAdminUserFPersonalNumber) (ldapQueryPNum <$> tmpl)
validateLdapQueryPerson :: FormValidator LdapQueryPerson Handler ()
validateLdapQueryPerson = return () -- currently no tests needed
--LdapQueryPerson{..} <- State.get
--guardValidation MsgAvsQueryEmpty
--is _Just ldapQueryIdent ||
--is _Just ldapQueryName ||
--is _Just ldapQueryPNum
getAdminLdapR, postAdminLdapR :: Handler Html
getAdminLdapR = postAdminLdapR
postAdminLdapR = do
((presult, pwidget), penctype) <- runFormPost $ makeLdapPersonForm Nothing
let procFormPerson :: LdapQueryPerson -> Handler (Maybe (Ldap.AttrList []))
procFormPerson LdapQueryPerson{..} = do
ldapPool' <- getsYesod $ view _appLdapPool
if isNothing ldapPool'
then addMessage Warning $ text2Html "LDAP Configuration missing."
else addMessage Info $ text2Html "Input for LDAP test received."
fmap join . for ldapPool' $ \ldapPool -> do
ldapData <- campusUser'' ldapPool FailoverUnlimited ldapQueryIdent
decodedErr <- decodeUserTest (Just $ CI.mk ldapQueryIdent) $ concat ldapData
whenIsLeft decodedErr $ addMessageI Error
return ldapData
mbLdapData <- formResultMaybe presult procFormPerson
actionUrl <- fromMaybe AdminLdapR <$> getCurrentRoute
siteLayoutMsg MsgMenuLdap $ do
setTitleI MsgMenuLdap
let personForm = wrapForm pwidget def
{ formAction = Just $ SomeRoute actionUrl
, formEncoding = penctype
}
presentUtf8 lv = Text.intercalate ", " (either tshow id . Text.decodeUtf8' <$> lv)
presentLatin1 lv = Text.intercalate ", " ( Text.decodeLatin1 <$> lv)
-- TODO: use i18nWidgetFile instead if this is to become permanent
$(widgetFile "ldap")

38
src/Handler/LMS.hs
View File

@ -178,11 +178,13 @@ data LmsTableCsv = LmsTableCsv -- L..T..C.. -> ltc..
, ltcValidUntil :: Day , ltcValidUntil :: Day
, ltcLastRefresh :: Day , ltcLastRefresh :: Day
, ltcFirstHeld :: Day , ltcFirstHeld :: Day
, ltcBlockedDue :: Maybe QualificationBlocked
, ltcLmsIdent :: Maybe LmsIdent , ltcLmsIdent :: Maybe LmsIdent
, ltcLmsStatus :: Maybe LmsStatus , ltcLmsStatus :: Maybe LmsStatus
, ltcLmsStarted :: Maybe UTCTime , ltcLmsStarted :: Maybe UTCTime
, ltcLmsDatePin :: Maybe UTCTime , ltcLmsDatePin :: Maybe UTCTime
, ltcLmsReceived :: Maybe UTCTime , ltcLmsReceived :: Maybe UTCTime
, ltcLmsNotified :: Maybe UTCTime
, ltcLmsEnded :: Maybe UTCTime , ltcLmsEnded :: Maybe UTCTime
} }
deriving Generic deriving Generic
@ -192,19 +194,23 @@ ltcExample :: LmsTableCsv
ltcExample = LmsTableCsv ltcExample = LmsTableCsv
{ ltcDisplayName = "Max Mustermann" { ltcDisplayName = "Max Mustermann"
, ltcEmail = "m.mustermann@does.not.exist" , ltcEmail = "m.mustermann@does.not.exist"
, ltcValidUntil = compday , ltcValidUntil = compDay
, ltcLastRefresh = compday , ltcLastRefresh = compDay
, ltcFirstHeld = compday , ltcFirstHeld = compDay
, ltcBlockedDue = Nothing
, ltcLmsIdent = Nothing , ltcLmsIdent = Nothing
, ltcLmsStatus = Nothing , ltcLmsStatus = Nothing
, ltcLmsStarted = Nothing , ltcLmsStarted = Just compTime
, ltcLmsDatePin = Nothing , ltcLmsDatePin = Nothing
, ltcLmsReceived = Nothing , ltcLmsReceived = Nothing
, ltcLmsNotified = Nothing
, ltcLmsEnded = Nothing , ltcLmsEnded = Nothing
} }
where where
compday :: Day compTime :: UTCTime
compday = utctDay $compileTime compTime = $compileTime
compDay :: Day
compDay = utctDay compTime
ltcOptions :: Csv.Options ltcOptions :: Csv.Options
ltcOptions = Csv.defaultOptions { Csv.fieldLabelModifier = renameLtc } ltcOptions = Csv.defaultOptions { Csv.fieldLabelModifier = renameLtc }
@ -338,11 +344,13 @@ mkLmsTable (Entity qid quali) acts restrict cols psValidator = do
, single ("valid-until" , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil)) , single ("valid-until" , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil))
, single ("last-refresh", SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh)) , single ("last-refresh", SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh))
, single ("first-held" , SortColumn $ queryQualUser >>> (E.^. QualificationUserFirstHeld)) , single ("first-held" , SortColumn $ queryQualUser >>> (E.^. QualificationUserFirstHeld))
, single ("blocked-due" , SortColumn $ queryQualUser >>> (E.^. QualificationUserBlockedDue))
, single ("lms-ident" , SortColumn $ queryLmsUser >>> (E.?. LmsUserIdent)) , single ("lms-ident" , SortColumn $ queryLmsUser >>> (E.?. LmsUserIdent))
, single ("lms-status" , SortColumn $ views (to queryLmsUser) (E.?. LmsUserStatus)) , single ("lms-status" , SortColumn $ views (to queryLmsUser) (E.?. LmsUserStatus))
, single ("lms-started" , SortColumn $ queryLmsUser >>> (E.?. LmsUserStarted)) , single ("lms-started" , SortColumn $ queryLmsUser >>> (E.?. LmsUserStarted))
, single ("lms-datepin" , SortColumn $ queryLmsUser >>> (E.?. LmsUserDatePin)) , single ("lms-datepin" , SortColumn $ queryLmsUser >>> (E.?. LmsUserDatePin))
, single ("lms-received", SortColumn $ queryLmsUser >>> (E.?. LmsUserReceived)) , single ("lms-received", SortColumn $ queryLmsUser >>> (E.?. LmsUserReceived))
, single ("lms-notified", SortColumn $ queryLmsUser >>> (E.?. LmsUserNotified))
, single ("lms-ended" , SortColumn $ queryLmsUser >>> (E.?. LmsUserEnded)) , single ("lms-ended" , SortColumn $ queryLmsUser >>> (E.?. LmsUserEnded))
] ]
dbtFilter = mconcat dbtFilter = mconcat
@ -356,12 +364,20 @@ mkLmsTable (Entity qid quali) acts restrict cols psValidator = do
E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday
| otherwise -> E.true | otherwise -> E.true
) )
, single ("lms-notified", FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) (E.isJust . (E.?. LmsUserNotified)))
--, single ("lms-notified", FilterColumn $ \(view (to queryLmsUser) -> luser) criterion ->
-- case getLast criterion of
-- Just True -> E.isJust $ luser E.?. LmsUserNotified
-- Just False -> E.isNothing $ luser E.?. LmsUserNotified
-- Nothing -> E.true
-- )
] ]
dbtFilterUI mPrev = mconcat dbtFilterUI mPrev = mconcat
[ fltrUserNameEmailHdrUI MsgLmsUser mPrev [ fltrUserNameEmailHdrUI MsgLmsUser mPrev
, prismAForm (singletonFilter "lms-ident" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent) , prismAForm (singletonFilter "lms-ident" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent)
-- , prismAForm (singletonFilter "lms-status" . maybePrism _PathPiece) mPrev $ aopt (selectField' (Just $ SomeMessage MsgTableNoFilter) $ return (optionsPairs [(MsgTableLmsSuccess,"success"::Text),(MsgTableLmsFailed,"blocked")])) (fslI MsgTableLmsStatus) -- , prismAForm (singletonFilter "lms-status" . maybePrism _PathPiece) mPrev $ aopt (selectField' (Just $ SomeMessage MsgTableNoFilter) $ return (optionsPairs [(MsgTableLmsSuccess,"success"::Text),(MsgTableLmsFailed,"blocked")])) (fslI MsgTableLmsStatus)
, prismAForm (singletonFilter "validity" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid) , prismAForm (singletonFilter "validity" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid)
, prismAForm (singletonFilter "lms-notified" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsNotified)
, if isNothing mbRenewal then mempty , if isNothing mbRenewal then mempty
else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal) else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal)
] ]
@ -383,11 +399,13 @@ mkLmsTable (Entity qid quali) acts restrict cols psValidator = do
<*> view (resultQualUser . _entityVal . _qualificationUserValidUntil) <*> view (resultQualUser . _entityVal . _qualificationUserValidUntil)
<*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh) <*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh)
<*> view (resultQualUser . _entityVal . _qualificationUserFirstHeld) <*> view (resultQualUser . _entityVal . _qualificationUserFirstHeld)
<*> view (resultQualUser . _entityVal . _qualificationUserBlockedDue)
<*> preview (resultLmsUser . _entityVal . _lmsUserIdent) <*> preview (resultLmsUser . _entityVal . _lmsUserIdent)
<*> (join . preview (resultLmsUser . _entityVal . _lmsUserStatus)) <*> (join . preview (resultLmsUser . _entityVal . _lmsUserStatus))
<*> preview (resultLmsUser . _entityVal . _lmsUserStarted) <*> preview (resultLmsUser . _entityVal . _lmsUserStarted)
<*> preview (resultLmsUser . _entityVal . _lmsUserDatePin) <*> preview (resultLmsUser . _entityVal . _lmsUserDatePin)
<*> (join . preview (resultLmsUser . _entityVal . _lmsUserReceived)) <*> (join . preview (resultLmsUser . _entityVal . _lmsUserReceived))
<*> (join . preview (resultLmsUser . _entityVal . _lmsUserNotified))
<*> (join . preview (resultLmsUser . _entityVal . _lmsUserEnded)) <*> (join . preview (resultLmsUser . _entityVal . _lmsUserEnded))
dbtCsvDecode = Nothing dbtCsvDecode = Nothing
dbtExtraReps = [] dbtExtraReps = []
@ -438,14 +456,16 @@ postLmsR sid qsh = do
[ dbSelectIf (applying _2) id (return . view (resultUser . _entityKey)) (\r -> isJust $ r ^? resultLmsUser) -- TODO: refactor using function "is" [ dbSelectIf (applying _2) id (return . view (resultUser . _entityKey)) (\r -> isJust $ r ^? resultLmsUser) -- TODO: refactor using function "is"
, colUserNameLinkHdr MsgLmsUser AdminUserR , colUserNameLinkHdr MsgLmsUser AdminUserR
, colUserEmail , colUserEmail
, sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \( view $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> dayCell d , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \( view $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> dayCell d
, sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d
, sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d , sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d
, sortable (Just "blocked-due") (i18nCell MsgTableQualificationBlockedDue) $ \( view $ resultQualUser . _entityVal . _qualificationUserBlockedDue -> b) -> qualificationBlockedCell b
, sortable (Just "lms-ident") (i18nLms MsgTableLmsIdent) $ \(preview $ resultLmsUser . _entityVal . _lmsUserIdent . _getLmsIdent -> lid) -> foldMap textCell lid , sortable (Just "lms-ident") (i18nLms MsgTableLmsIdent) $ \(preview $ resultLmsUser . _entityVal . _lmsUserIdent . _getLmsIdent -> lid) -> foldMap textCell lid
, sortable (Just "lms-status") (i18nLms MsgTableLmsStatus) $ \(preview $ resultLmsUser . _entityVal . _lmsUserStatus -> status) -> foldMap lmsStatusCell $ join status , sortable (Just "lms-status") (i18nLms MsgTableLmsStatus) $ \(preview $ resultLmsUser . _entityVal . _lmsUserStatus -> status) -> foldMap lmsStatusCell $ join status
, sortable (Just "lms-started") (i18nLms MsgTableLmsStarted) $ \(preview $ resultLmsUser . _entityVal . _lmsUserStarted -> d) -> foldMap dateTimeCell d , sortable (Just "lms-started") (i18nLms MsgTableLmsStarted) $ \(preview $ resultLmsUser . _entityVal . _lmsUserStarted -> d) -> foldMap dateTimeCell d
, sortable (Just "lms-datepin") (i18nLms MsgTableLmsDatePin) $ \(preview $ resultLmsUser . _entityVal . _lmsUserDatePin -> d) -> foldMap dateTimeCell d , sortable (Just "lms-datepin") (i18nLms MsgTableLmsDatePin) $ \(preview $ resultLmsUser . _entityVal . _lmsUserDatePin -> d) -> foldMap dateTimeCell d
, sortable (Just "lms-received") (i18nLms MsgTableLmsReceived) $ \(preview $ resultLmsUser . _entityVal . _lmsUserReceived -> d) -> foldMap dateTimeCell $ join d , sortable (Just "lms-received") (i18nLms MsgTableLmsReceived) $ \(preview $ resultLmsUser . _entityVal . _lmsUserReceived -> d) -> foldMap dateTimeCell $ join d
, sortable (Just "lms-notified") (i18nLms MsgTableLmsNotified) $ \(preview $ resultLmsUser . _entityVal . _lmsUserNotified -> d) -> foldMap dateTimeCell $ join d
, sortable (Just "lms-ended") (i18nLms MsgTableLmsEnded) $ \(preview $ resultLmsUser . _entityVal . _lmsUserEnded -> d) -> foldMap dateTimeCell $ join d , sortable (Just "lms-ended") (i18nLms MsgTableLmsEnded) $ \(preview $ resultLmsUser . _entityVal . _lmsUserEnded -> d) -> foldMap dateTimeCell $ join d
] ]
where where

1
src/Handler/LMS/Fake.hs
View File

@ -113,6 +113,7 @@ fakeQualificationUsers (Entity qid Qualification{qualificationRefreshWithin}) (u
qualificationUserValidUntil = addDays expOffset expiryNotifyDay qualificationUserValidUntil = addDays expOffset expiryNotifyDay
qualificationUserFirstHeld = addGregorianMonthsClip (-24) qualificationUserValidUntil qualificationUserFirstHeld = addGregorianMonthsClip (-24) qualificationUserValidUntil
qualificationUserLastRefresh = qualificationUserFirstHeld qualificationUserLastRefresh = qualificationUserFirstHeld
qualificationUserBlockedDue = Nothing
_ <- upsert QualificationUser{..} _ <- upsert QualificationUser{..}
[ QualificationUserValidUntil =. qualificationUserValidUntil [ QualificationUserValidUntil =. qualificationUserValidUntil
, QualificationUserLastRefresh =. qualificationUserLastRefresh , QualificationUserLastRefresh =. qualificationUserLastRefresh

131
src/Handler/LMS/Result.hs
View File

@ -1,8 +1,8 @@
{-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances {-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances
module Handler.LMS.Result module Handler.LMS.Result
( getLmsResultR, postLmsResultR ( getLmsResultR, postLmsResultR
, getLmsResultUploadR, postLmsResultUploadR , getLmsResultUploadR, postLmsResultUploadR
, postLmsResultDirectR , postLmsResultDirectR
) )
where where
@ -29,11 +29,11 @@ data LmsResultTableCsv = LmsResultTableCsv
deriving Generic deriving Generic
makeLenses_ ''LmsResultTableCsv makeLenses_ ''LmsResultTableCsv
-- csv without headers -- TODO not yet supported -- csv without headers
--instance Csv.ToRecord LmsResultTableCsv -- default suffices instance Csv.ToRecord LmsResultTableCsv -- default suffices
--instance Csv.FromRecord LmsResultTableCsv -- default suffices instance Csv.FromRecord LmsResultTableCsv -- default suffices
-- csv with headers -- csv with headers
lmsResultTableCsvHeader :: Csv.Header lmsResultTableCsvHeader :: Csv.Header
lmsResultTableCsvHeader = Csv.header [ csvLmsIdent, csvLmsSuccess ] lmsResultTableCsvHeader = Csv.header [ csvLmsIdent, csvLmsSuccess ]
@ -73,15 +73,15 @@ deriveJSON defaultOptions
, sumEncoding = TaggedObject "action" "data" , sumEncoding = TaggedObject "action" "data"
} ''LmsResultCsvAction } ''LmsResultCsvAction
data LmsResultCsvException data LmsResultCsvException
= LmsResultCsvExceptionDuplicatedKey -- TODO: this is not used anywhere?! = LmsResultCsvExceptionDuplicatedKey -- TODO: this is not used anywhere?!
deriving (Show, Generic, Typeable) deriving (Show, Generic, Typeable)
instance Exception LmsResultCsvException instance Exception LmsResultCsvException
embedRenderMessage ''UniWorX ''LmsResultCsvException id embedRenderMessage ''UniWorX ''LmsResultCsvException id
mkResultTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget) mkResultTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget)
mkResultTable sid qsh qid = do mkResultTable sid qsh qid = do
now_day <- utctDay <$> liftIO getCurrentTime now_day <- utctDay <$> liftIO getCurrentTime
dbtCsvName <- csvFilenameLmsResult qsh dbtCsvName <- csvFilenameLmsResult qsh
let dbtCsvSheetName = dbtCsvName let dbtCsvSheetName = dbtCsvName
@ -97,7 +97,7 @@ mkResultTable sid qsh qid = do
[ sortable (Just csvLmsIdent) (i18nCell MsgTableLmsIdent) $ \(view $ _dbrOutput . _entityVal . _lmsResultIdent . _getLmsIdent -> ident) -> textCell ident [ sortable (Just csvLmsIdent) (i18nCell MsgTableLmsIdent) $ \(view $ _dbrOutput . _entityVal . _lmsResultIdent . _getLmsIdent -> ident) -> textCell ident
, sortable (Just csvLmsSuccess) (i18nCell MsgTableLmsSuccess) $ \(view $ _dbrOutput . _entityVal . _lmsResultSuccess -> success) -> dayCell success , sortable (Just csvLmsSuccess) (i18nCell MsgTableLmsSuccess) $ \(view $ _dbrOutput . _entityVal . _lmsResultSuccess -> success) -> dayCell success
, sortable (Just csvLmsTimestamp) (i18nCell MsgTableLmsReceived) $ \(view $ _dbrOutput . _entityVal . _lmsResultTimestamp -> timestamp) -> dateTimeCell timestamp , sortable (Just csvLmsTimestamp) (i18nCell MsgTableLmsReceived) $ \(view $ _dbrOutput . _entityVal . _lmsResultTimestamp -> timestamp) -> dateTimeCell timestamp
] ]
dbtSorting = Map.fromList dbtSorting = Map.fromList
[ (csvLmsIdent , SortColumn (E.^. LmsResultIdent)) [ (csvLmsIdent , SortColumn (E.^. LmsResultIdent))
, (csvLmsSuccess , SortColumn (E.^. LmsResultSuccess)) , (csvLmsSuccess , SortColumn (E.^. LmsResultSuccess))
@ -107,72 +107,72 @@ mkResultTable sid qsh qid = do
[ (csvLmsIdent , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsResultIdent)) [ (csvLmsIdent , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsResultIdent))
, (csvLmsSuccess, FilterColumn $ E.mkExactFilter (E.^. LmsResultSuccess)) , (csvLmsSuccess, FilterColumn $ E.mkExactFilter (E.^. LmsResultSuccess))
] ]
dbtFilterUI = \mPrev -> mconcat dbtFilterUI = \mPrev -> mconcat
[ prismAForm (singletonFilter csvLmsIdent . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent) [ prismAForm (singletonFilter csvLmsIdent . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent)
, prismAForm (singletonFilter csvLmsSuccess . maybePrism _PathPiece) mPrev $ aopt (hoistField lift dayField) (fslI MsgTableLmsSuccess) , prismAForm (singletonFilter csvLmsSuccess . maybePrism _PathPiece) mPrev $ aopt (hoistField lift dayField) (fslI MsgTableLmsSuccess)
] ]
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
dbtParams = def dbtParams = def
dbtIdent :: Text dbtIdent :: Text
dbtIdent = "lms-result" dbtIdent = "lms-result"
dbtCsvEncode = Just DBTCsvEncode dbtCsvEncode = Just DBTCsvEncode
{ dbtCsvExportForm = pure () { dbtCsvExportForm = pure ()
, dbtCsvDoEncode = \() -> C.map (doEncode' . view _2) , dbtCsvDoEncode = \() -> C.map (doEncode' . view _2)
, dbtCsvName , dbtCsvName
, dbtCsvSheetName , dbtCsvSheetName
, dbtCsvNoExportData = Just id , dbtCsvNoExportData = Just id
, dbtCsvHeader = const $ return lmsResultTableCsvHeader , dbtCsvHeader = const $ return lmsResultTableCsvHeader
, dbtCsvExampleData = Just , dbtCsvExampleData = Just
[ LmsResultTableCsv{csvLRTident = LmsIdent lid, csvLRTsuccess = LmsDay $ addDays (-dos) now_day } [ LmsResultTableCsv{csvLRTident = LmsIdent lid, csvLRTsuccess = LmsDay $ addDays (-dos) now_day }
| (lid,dos) <- zip ["abcdefgh", "12345678", "ident8ch"] [1..] | (lid,dos) <- zip ["abcdefgh", "12345678", "ident8ch"] [1..]
] ]
} }
where where
doEncode' = LmsResultTableCsv doEncode' = LmsResultTableCsv
<$> view (_dbrOutput . _entityVal . _lmsResultIdent) <$> view (_dbrOutput . _entityVal . _lmsResultIdent)
<*> view (_dbrOutput . _entityVal . _lmsResultSuccess . _lmsDay) <*> view (_dbrOutput . _entityVal . _lmsResultSuccess . _lmsDay)
dbtCsvDecode = Just DBTCsvDecode -- Just save to DB; Job will process data later dbtCsvDecode = Just DBTCsvDecode -- Just save to DB; Job will process data later
{ dbtCsvRowKey = \LmsResultTableCsv{..} -> { dbtCsvRowKey = \LmsResultTableCsv{..} ->
fmap E.Value . MaybeT . getKeyBy $ UniqueLmsResult qid csvLRTident fmap E.Value . MaybeT . getKeyBy $ UniqueLmsResult qid csvLRTident
, dbtCsvComputeActions = \case -- purpose is to show a diff to the user first , dbtCsvComputeActions = \case -- purpose is to show a diff to the user first
DBCsvDiffNew{dbCsvNewKey = Nothing, dbCsvNew} -> do DBCsvDiffNew{dbCsvNewKey = Nothing, dbCsvNew} -> do
yield $ LmsResultInsertData yield $ LmsResultInsertData
{ lmsResultInsertIdent = csvLRTident dbCsvNew { lmsResultInsertIdent = csvLRTident dbCsvNew
, lmsResultInsertSuccess = csvLRTsuccess dbCsvNew & lms2day , lmsResultInsertSuccess = csvLRTsuccess dbCsvNew & lms2day
} }
DBCsvDiffNew{dbCsvNewKey = Just _, dbCsvNew = _} -> error "UniqueLmsResult was found, but the key no longer exists." -- TODO: how can this ever happen? Check Pagination-Code DBCsvDiffNew{dbCsvNewKey = Just _, dbCsvNew = _} -> error "UniqueLmsResult was found, but the key no longer exists." -- TODO: how can this ever happen? Check Pagination-Code
DBCsvDiffExisting{dbCsvNew = LmsResultTableCsv{..}, dbCsvOld} -> do DBCsvDiffExisting{dbCsvNew = LmsResultTableCsv{..}, dbCsvOld} -> do
let successDay = lms2day csvLRTsuccess let successDay = lms2day csvLRTsuccess
when (successDay /= dbCsvOld ^. _dbrOutput . _entityVal . _lmsResultSuccess) $ when (successDay /= dbCsvOld ^. _dbrOutput . _entityVal . _lmsResultSuccess) $
yield $ LmsResultUpdateData yield $ LmsResultUpdateData
{ lmsResultInsertIdent = csvLRTident { lmsResultInsertIdent = csvLRTident
, lmsResultInsertSuccess = successDay , lmsResultInsertSuccess = successDay
} }
DBCsvDiffMissing{} -> return () -- no deletion DBCsvDiffMissing{} -> return () -- no deletion
, dbtCsvClassifyAction = \case , dbtCsvClassifyAction = \case
LmsResultInsertData{} -> LmsResultInsert LmsResultInsertData{} -> LmsResultInsert
LmsResultUpdateData{} -> LmsResultUpdate LmsResultUpdateData{} -> LmsResultUpdate
, dbtCsvCoarsenActionClass = \case , dbtCsvCoarsenActionClass = \case
LmsResultInsert -> DBCsvActionNew LmsResultInsert -> DBCsvActionNew
LmsResultUpdate -> DBCsvActionExisting LmsResultUpdate -> DBCsvActionExisting
, dbtCsvValidateActions = return () -- no validation, since this is an automatic upload, i.e. no user to review error , dbtCsvValidateActions = return () -- no validation, since this is an automatic upload, i.e. no user to review error
, dbtCsvExecuteActions = do , dbtCsvExecuteActions = do
C.mapM_ $ \actionData -> do C.mapM_ $ \actionData -> do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
void $ upsert void $ upsert
LmsResult LmsResult
{ lmsResultQualification = qid { lmsResultQualification = qid
, lmsResultIdent = lmsResultInsertIdent actionData , lmsResultIdent = lmsResultInsertIdent actionData
, lmsResultSuccess = lmsResultInsertSuccess actionData , lmsResultSuccess = lmsResultInsertSuccess actionData
, lmsResultTimestamp = now -- lmsResultInsertTimestamp -- does it matter which one to choose? , lmsResultTimestamp = now -- lmsResultInsertTimestamp -- does it matter which one to choose?
} }
[ LmsResultSuccess =. lmsResultInsertSuccess actionData [ LmsResultSuccess =. lmsResultInsertSuccess actionData
, LmsResultTimestamp =. now , LmsResultTimestamp =. now
] ]
-- audit $ Transaction.. (add to Audit.Types) -- audit $ Transaction.. (add to Audit.Types)
lift . queueDBJob $ JobLmsResults qid lift . queueDBJob $ JobLmsResults qid
return $ LmsResultR sid qsh return $ LmsResultR sid qsh
, dbtCsvRenderKey = const $ \case , dbtCsvRenderKey = const $ \case
LmsResultInsertData{..} -> do -- TODO: i18n LmsResultInsertData{..} -> do -- TODO: i18n
[whamlet| [whamlet|
$newline never $newline never
@ -187,7 +187,7 @@ mkResultTable sid qsh qid = do
|] |]
, dbtCsvRenderActionClass = toWidget <=< ap getMessageRender . pure , dbtCsvRenderActionClass = toWidget <=< ap getMessageRender . pure
, dbtCsvRenderException = ap getMessageRender . pure :: LmsResultCsvException -> DB Text , dbtCsvRenderException = ap getMessageRender . pure :: LmsResultCsvException -> DB Text
} }
dbtExtraReps = [] dbtExtraReps = []
resultDBTableValidator = def resultDBTableValidator = def
@ -198,9 +198,9 @@ getLmsResultR, postLmsResultR :: SchoolId -> QualificationShorthand -> Handler
getLmsResultR = postLmsResultR getLmsResultR = postLmsResultR
postLmsResultR sid qsh = do postLmsResultR sid qsh = do
let directUploadLink = LmsResultUploadR sid qsh let directUploadLink = LmsResultUploadR sid qsh
lmsTable <- runDB $ do lmsTable <- runDB $ do
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
view _2 <$> mkResultTable sid qsh qid view _2 <$> mkResultTable sid qsh qid
siteLayoutMsg MsgMenuLmsResult $ do siteLayoutMsg MsgMenuLmsResult $ do
setTitleI MsgMenuLmsResult setTitleI MsgMenuLmsResult
$(widgetFile "lms-result") $(widgetFile "lms-result")
@ -211,17 +211,17 @@ postLmsResultR sid qsh = do
saveResultCsv :: QualificationId -> Int -> LmsResultTableCsv -> JobDB Int saveResultCsv :: QualificationId -> Int -> LmsResultTableCsv -> JobDB Int
saveResultCsv qid i LmsResultTableCsv{..} = do saveResultCsv qid i LmsResultTableCsv{..} = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
void $ upsert void $ upsert
LmsResult LmsResult
{ lmsResultQualification = qid { lmsResultQualification = qid
, lmsResultIdent = csvLRTident , lmsResultIdent = csvLRTident
, lmsResultSuccess = csvLRTsuccess & lms2day , lmsResultSuccess = csvLRTsuccess & lms2day
, lmsResultTimestamp = now , lmsResultTimestamp = now
} }
[ LmsResultSuccess =. (csvLRTsuccess & lms2day) [ LmsResultSuccess =. (csvLRTsuccess & lms2day)
, LmsResultTimestamp =. now , LmsResultTimestamp =. now
] ]
return $ succ i return $ succ i
makeResultUploadForm :: Form FileInfo makeResultUploadForm :: Form FileInfo
makeResultUploadForm = renderAForm FormStandard $ fileAFormReq "Result CSV" makeResultUploadForm = renderAForm FormStandard $ fileAFormReq "Result CSV"
@ -230,23 +230,23 @@ getLmsResultUploadR, postLmsResultUploadR :: SchoolId -> QualificationShorthand
getLmsResultUploadR = postLmsResultUploadR getLmsResultUploadR = postLmsResultUploadR
postLmsResultUploadR sid qsh = do postLmsResultUploadR sid qsh = do
((result,widget), enctype) <- runFormPost makeResultUploadForm ((result,widget), enctype) <- runFormPost makeResultUploadForm
case result of case result of
FormSuccess file -> do FormSuccess file -> do
-- content <- fileSourceByteString file -- content <- fileSourceByteString file
-- return $ Just (fileName file, content) -- return $ Just (fileName file, content)
nr <- runDBJobs $ do nr <- runDBJobs $ do
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
nr <- runConduit $ fileSource file nr <- runConduit $ fileSource file
.| decodeCsv .| decodeCsv
.| foldMC (saveResultCsv qid) 0 .| foldMC (saveResultCsv qid) 0
queueDBJob $ JobLmsResults qid queueDBJob $ JobLmsResults qid
return nr return nr
addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file <> pack (" mit " <> show nr <> " Zeilen") addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file <> pack (" mit " <> show nr <> " Zeilen")
redirect $ LmsResultR sid qsh redirect $ LmsResultR sid qsh
FormFailure errs -> do FormFailure errs -> do
forM_ errs $ addMessage Error . toHtml forM_ errs $ addMessage Error . toHtml
redirect $ LmsResultUploadR sid qsh redirect $ LmsResultUploadR sid qsh
FormMissing -> FormMissing ->
siteLayoutMsg MsgMenuLmsResult $ do siteLayoutMsg MsgMenuLmsResult $ do
setTitleI MsgMenuLmsUpload setTitleI MsgMenuLmsUpload
[whamlet|$newline never [whamlet|$newline never
@ -258,31 +258,32 @@ postLmsResultUploadR sid qsh = do
postLmsResultDirectR :: SchoolId -> QualificationShorthand -> Handler Html postLmsResultDirectR :: SchoolId -> QualificationShorthand -> Handler Html
postLmsResultDirectR sid qsh = do postLmsResultDirectR sid qsh = do
(_params, files) <- runRequestBody (_params, files) <- runRequestBody
(status, msg) <- case files of (status, msg) <- case files of
[(fhead,file)] -> do [(fhead,file)] -> do
runDBJobs $ do lmsDecoder <- getLmsCsvDecoder
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh runDBJobs $ do
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
enr <- try $ runConduit $ fileSource file enr <- try $ runConduit $ fileSource file
.| decodeCsv .| lmsDecoder
.| foldMC (saveResultCsv qid) 0 .| foldMC (saveResultCsv qid) 0
case enr of case enr of
Left (e :: SomeException) -> do -- catch all to avoid ok220 in case of any error Left (e :: SomeException) -> do -- catch all to avoid ok220 in case of any error
$logWarnS "LMS" $ "Result upload failed parsing: " <> tshow e $logWarnS "LMS" $ "Result upload failed parsing: " <> tshow e
return (badRequest400, "Exception: " <> tshow e) return (badRequest400, "Exception: " <> tshow e)
Right nr -> do Right nr -> do
let msg = "Success. LMS Result upload file " <> fileName file <> " containing " <> tshow nr <> " rows for header " <> fhead let msg = "Success. LMS Result upload file " <> fileName file <> " containing " <> tshow nr <> " rows for header " <> fhead
$logWarnS "LMS" msg -- TODO: change to Info Level in the future $logInfoS "LMS" msg
queueDBJob $ JobLmsResults qid when (nr > 0) $ queueDBJob $ JobLmsResults qid
return (ok200, msg) return (ok200, msg)
[] -> do [] -> do
let msg = "Result upload file missing." let msg = "Result upload file missing."
$logWarnS "LMS" msg $logWarnS "LMS" msg
return (badRequest400, msg) return (badRequest400, msg)
_other -> do _other -> do
let msg = "Result upload received multiple files; all ignored." let msg = "Result upload received multiple files; all ignored."
$logWarnS "LMS" msg $logWarnS "LMS" msg
return (badRequest400, msg) return (badRequest400, msg)
sendResponseStatus status msg sendResponseStatus status msg

110
src/Handler/LMS/Userlist.hs
View File

@ -1,8 +1,8 @@
{-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances {-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances
module Handler.LMS.Userlist module Handler.LMS.Userlist
( getLmsUserlistR, postLmsUserlistR ( getLmsUserlistR, postLmsUserlistR
, getLmsUserlistUploadR, postLmsUserlistUploadR , getLmsUserlistUploadR, postLmsUserlistUploadR
, postLmsUserlistDirectR , postLmsUserlistDirectR
) )
where where
@ -23,20 +23,20 @@ import Jobs.Queue
data LmsUserlistTableCsv = LmsUserlistTableCsv data LmsUserlistTableCsv = LmsUserlistTableCsv
{ csvLULident :: LmsIdent { csvLULident :: LmsIdent
, csvLULfailed :: LmsBool , csvLULfailed :: LmsBool
} }
deriving Generic deriving Generic
makeLenses_ ''LmsUserlistTableCsv makeLenses_ ''LmsUserlistTableCsv
-- csv without headers -- TODO not yet supported -- csv without headers
--instance Csv.ToRecord LmsUserlistTableCsv instance Csv.ToRecord LmsUserlistTableCsv
--instance Csv.FromRecord LmsUserlistTableCsv instance Csv.FromRecord LmsUserlistTableCsv
-- csv with headers -- csv with headers
instance DefaultOrdered LmsUserlistTableCsv where instance DefaultOrdered LmsUserlistTableCsv where
headerOrder = const $ Csv.header [ csvLmsIdent, csvLmsBlocked ] headerOrder = const $ Csv.header [ csvLmsIdent, csvLmsBlocked ]
instance ToNamedRecord LmsUserlistTableCsv where instance ToNamedRecord LmsUserlistTableCsv where
toNamedRecord LmsUserlistTableCsv{..} = Csv.namedRecord toNamedRecord LmsUserlistTableCsv{..} = Csv.namedRecord
[ csvLmsIdent Csv..= csvLULident [ csvLmsIdent Csv..= csvLULident
, csvLmsBlocked Csv..= csvLULfailed , csvLmsBlocked Csv..= csvLULfailed
@ -57,7 +57,7 @@ instance CsvColumnsExplained LmsUserlistTableCsv where
single k v = singletonMap k [whamlet|_{v}|] single k v = singletonMap k [whamlet|_{v}|]
data LmsUserlistCsvActionClass = LmsUserlistInsert | LmsUserlistUpdate data LmsUserlistCsvActionClass = LmsUserlistInsert | LmsUserlistUpdate
deriving (Eq, Ord, Read, Show, Generic, Typeable, Enum, Bounded) deriving (Eq, Ord, Read, Show, Generic, Typeable, Enum, Bounded)
embedRenderMessage ''UniWorX ''LmsUserlistCsvActionClass id embedRenderMessage ''UniWorX ''LmsUserlistCsvActionClass id
@ -72,12 +72,12 @@ deriveJSON defaultOptions
} ''LmsUserlistCsvAction } ''LmsUserlistCsvAction
data LmsUserlistCsvException data LmsUserlistCsvException
= LmsUserlistCsvExceptionDuplicatedKey -- TODO: this is not used anywhere?! = LmsUserlistCsvExceptionDuplicatedKey -- TODO: this is not used anywhere?!
deriving (Show, Generic, Typeable) deriving (Show, Generic, Typeable)
instance Exception LmsUserlistCsvException instance Exception LmsUserlistCsvException
embedRenderMessage ''UniWorX ''LmsUserlistCsvException id embedRenderMessage ''UniWorX ''LmsUserlistCsvException id
mkUserlistTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget) mkUserlistTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget)
mkUserlistTable sid qsh qid = do mkUserlistTable sid qsh qid = do
@ -105,7 +105,7 @@ mkUserlistTable sid qsh qid = do
[ (csvLmsIdent , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsUserlistIdent )) [ (csvLmsIdent , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsUserlistIdent ))
, (csvLmsBlocked, FilterColumn $ E.mkExactFilter (E.^. LmsUserlistFailed)) , (csvLmsBlocked, FilterColumn $ E.mkExactFilter (E.^. LmsUserlistFailed))
] ]
dbtFilterUI = \mPrev -> mconcat dbtFilterUI = \mPrev -> mconcat
[ prismAForm (singletonFilter csvLmsIdent . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent) [ prismAForm (singletonFilter csvLmsIdent . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent)
, prismAForm (singletonFilter csvLmsBlocked . maybePrism _PathPiece) mPrev $ aopt (hoistField lift checkBoxField) (fslI MsgTableLmsFailed) , prismAForm (singletonFilter csvLmsBlocked . maybePrism _PathPiece) mPrev $ aopt (hoistField lift checkBoxField) (fslI MsgTableLmsFailed)
] ]
@ -114,9 +114,9 @@ mkUserlistTable sid qsh qid = do
dbtIdent :: Text dbtIdent :: Text
dbtIdent = "lms-userlist" dbtIdent = "lms-userlist"
dbtCsvEncode = simpleCsvEncode dbtCsvName dbtCsvSheetName doEncode' <&> addExample dbtCsvEncode = simpleCsvEncode dbtCsvName dbtCsvSheetName doEncode' <&> addExample
where where
addExample dce = dce{ dbtCsvExampleData = csvExample } addExample dce = dce{ dbtCsvExampleData = csvExample }
csvExample = Just csvExample = Just
[ LmsUserlistTableCsv{csvLULident = LmsIdent lid, csvLULfailed = LmsBool ufl} [ LmsUserlistTableCsv{csvLULident = LmsIdent lid, csvLULfailed = LmsBool ufl}
| (lid,ufl) <- zip ["abcdefgh", "12345678", "ident8ch"] [False,True,False] | (lid,ufl) <- zip ["abcdefgh", "12345678", "ident8ch"] [False,True,False]
] ]
@ -125,47 +125,47 @@ mkUserlistTable sid qsh qid = do
<*> view (_dbrOutput . _entityVal . _lmsUserlistFailed . _lmsBool) <*> view (_dbrOutput . _entityVal . _lmsUserlistFailed . _lmsBool)
dbtCsvDecode = Just DBTCsvDecode {..} dbtCsvDecode = Just DBTCsvDecode {..}
where where
dbtCsvRowKey = \LmsUserlistTableCsv{csvLULident} -> dbtCsvRowKey = \LmsUserlistTableCsv{csvLULident} ->
fmap E.Value . MaybeT . getKeyBy $ UniqueLmsUserlist qid csvLULident fmap E.Value . MaybeT . getKeyBy $ UniqueLmsUserlist qid csvLULident
dbtCsvComputeActions = \case -- shows a diff first dbtCsvComputeActions = \case -- shows a diff first
DBCsvDiffNew{dbCsvNew} -> do DBCsvDiffNew{dbCsvNew} -> do
yield $ LmsUserlistInsertData yield $ LmsUserlistInsertData
{ lmsUserlistInsertIdent = csvLULident dbCsvNew { lmsUserlistInsertIdent = csvLULident dbCsvNew
, lmsUserlistInsertFailed = lms2bool $ csvLULfailed dbCsvNew , lmsUserlistInsertFailed = lms2bool $ csvLULfailed dbCsvNew
} }
DBCsvDiffExisting{dbCsvNew = LmsUserlistTableCsv{..}, dbCsvOld} -> do DBCsvDiffExisting{dbCsvNew = LmsUserlistTableCsv{..}, dbCsvOld} -> do
let failedBool = lms2bool csvLULfailed let failedBool = lms2bool csvLULfailed
when (failedBool /= dbCsvOld ^. _dbrOutput . _entityVal . _lmsUserlistFailed) $ when (failedBool /= dbCsvOld ^. _dbrOutput . _entityVal . _lmsUserlistFailed) $
yield $ LmsUserlistUpdateData yield $ LmsUserlistUpdateData
{ lmsUserlistInsertIdent = csvLULident { lmsUserlistInsertIdent = csvLULident
, lmsUserlistInsertFailed = csvLULfailed & lms2bool , lmsUserlistInsertFailed = csvLULfailed & lms2bool
} }
DBCsvDiffMissing{} -> return () -- no deletion DBCsvDiffMissing{} -> return () -- no deletion
dbtCsvClassifyAction = \case dbtCsvClassifyAction = \case
LmsUserlistInsertData{} -> LmsUserlistInsert LmsUserlistInsertData{} -> LmsUserlistInsert
LmsUserlistUpdateData{} -> LmsUserlistUpdate LmsUserlistUpdateData{} -> LmsUserlistUpdate
dbtCsvCoarsenActionClass = \case dbtCsvCoarsenActionClass = \case
LmsUserlistInsert -> DBCsvActionNew LmsUserlistInsert -> DBCsvActionNew
LmsUserlistUpdate -> DBCsvActionExisting LmsUserlistUpdate -> DBCsvActionExisting
dbtCsvValidateActions = return () -- no validation, since this is an automatic upload, i.e. no user to review error dbtCsvValidateActions = return () -- no validation, since this is an automatic upload, i.e. no user to review error
dbtCsvExecuteActions = do dbtCsvExecuteActions = do
C.mapM_ $ \actionData -> do C.mapM_ $ \actionData -> do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
void $ upsert LmsUserlist void $ upsert LmsUserlist
{ {
lmsUserlistQualification = qid lmsUserlistQualification = qid
, lmsUserlistIdent = lmsUserlistInsertIdent actionData , lmsUserlistIdent = lmsUserlistInsertIdent actionData
, lmsUserlistFailed = lmsUserlistInsertFailed actionData , lmsUserlistFailed = lmsUserlistInsertFailed actionData
, lmsUserlistTimestamp = now , lmsUserlistTimestamp = now
} }
[ [
LmsUserlistFailed =. lmsUserlistInsertFailed actionData -- TODO: should we allow a reset from failed: True to False? LmsUserlistFailed =. lmsUserlistInsertFailed actionData -- TODO: should we allow a reset from failed: True to False?
, LmsUserlistTimestamp =. now , LmsUserlistTimestamp =. now
] ]
-- audit -- audit
lift . queueDBJob $ JobLmsUserlist qid lift . queueDBJob $ JobLmsUserlist qid
return $ LmsUserlistR sid qsh return $ LmsUserlistR sid qsh
dbtCsvRenderKey = const $ \case dbtCsvRenderKey = const $ \case
LmsUserlistInsertData{..} -> do -- TODO: i18n LmsUserlistInsertData{..} -> do -- TODO: i18n
[whamlet| [whamlet|
$newline never $newline never
@ -195,7 +195,7 @@ mkUserlistTable sid qsh qid = do
getLmsUserlistR, postLmsUserlistR :: SchoolId -> QualificationShorthand -> Handler Html getLmsUserlistR, postLmsUserlistR :: SchoolId -> QualificationShorthand -> Handler Html
getLmsUserlistR = postLmsUserlistR getLmsUserlistR = postLmsUserlistR
postLmsUserlistR sid qsh = do postLmsUserlistR sid qsh = do
lmsTable <- runDB $ do lmsTable <- runDB $ do
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
@ -211,17 +211,17 @@ postLmsUserlistR sid qsh = do
saveUserlistCsv :: QualificationId -> Int -> LmsUserlistTableCsv -> JobDB Int saveUserlistCsv :: QualificationId -> Int -> LmsUserlistTableCsv -> JobDB Int
saveUserlistCsv qid i LmsUserlistTableCsv{..} = do saveUserlistCsv qid i LmsUserlistTableCsv{..} = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
void $ upsert void $ upsert
LmsUserlist LmsUserlist
{ lmsUserlistQualification = qid { lmsUserlistQualification = qid
, lmsUserlistIdent = csvLULident , lmsUserlistIdent = csvLULident
, lmsUserlistFailed = csvLULfailed & lms2bool , lmsUserlistFailed = csvLULfailed & lms2bool
, lmsUserlistTimestamp = now , lmsUserlistTimestamp = now
} }
[ LmsUserlistFailed =. (csvLULfailed & lms2bool) [ LmsUserlistFailed =. (csvLULfailed & lms2bool)
, LmsUserlistTimestamp =. now , LmsUserlistTimestamp =. now
] ]
return $ succ i return $ succ i
makeUserlistUploadForm :: Form FileInfo makeUserlistUploadForm :: Form FileInfo
makeUserlistUploadForm = renderAForm FormStandard $ fileAFormReq "Userlist CSV" makeUserlistUploadForm = renderAForm FormStandard $ fileAFormReq "Userlist CSV"
@ -230,19 +230,19 @@ getLmsUserlistUploadR, postLmsUserlistUploadR :: SchoolId -> QualificationShorth
getLmsUserlistUploadR = postLmsUserlistUploadR getLmsUserlistUploadR = postLmsUserlistUploadR
postLmsUserlistUploadR sid qsh = do postLmsUserlistUploadR sid qsh = do
((result,widget), enctype) <- runFormPost makeUserlistUploadForm ((result,widget), enctype) <- runFormPost makeUserlistUploadForm
case result of case result of
FormSuccess file -> do FormSuccess file -> do
nr <- runDBJobs $ do nr <- runDBJobs $ do
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
nr <- runConduit $ fileSource file .| decodeCsv .| foldMC (saveUserlistCsv qid) 0 nr <- runConduit $ fileSource file .| decodeCsv .| foldMC (saveUserlistCsv qid) 0
queueDBJob $ JobLmsUserlist qid queueDBJob $ JobLmsUserlist qid
return nr return nr
addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file <> pack (" mit " <> show nr <> " Zeilen") addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file <> pack (" mit " <> show nr <> " Zeilen")
redirect $ LmsUserlistR sid qsh redirect $ LmsUserlistR sid qsh
FormFailure errs -> do FormFailure errs -> do
forM_ errs $ addMessage Error . toHtml forM_ errs $ addMessage Error . toHtml
redirect $ LmsUserlistUploadR sid qsh redirect $ LmsUserlistUploadR sid qsh
FormMissing -> FormMissing ->
siteLayoutMsg MsgMenuLmsUserlist $ do siteLayoutMsg MsgMenuLmsUserlist $ do
setTitleI MsgMenuLmsUpload setTitleI MsgMenuLmsUpload
[whamlet|$newline never [whamlet|$newline never
@ -255,30 +255,30 @@ postLmsUserlistUploadR sid qsh = do
postLmsUserlistDirectR :: SchoolId -> QualificationShorthand -> Handler Html postLmsUserlistDirectR :: SchoolId -> QualificationShorthand -> Handler Html
postLmsUserlistDirectR sid qsh = do postLmsUserlistDirectR sid qsh = do
(_params, files) <- runRequestBody (_params, files) <- runRequestBody
(status, msg) <- case files of (status, msg) <- case files of
[(fhead,file)] -> do [(fhead,file)] -> do
runDBJobs $ do lmsDecoder <- getLmsCsvDecoder
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh runDBJobs $ do
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
enr <- try $ runConduit $ fileSource file enr <- try $ runConduit $ fileSource file
.| decodeCsv .| lmsDecoder
.| foldMC (saveUserlistCsv qid) 0 .| foldMC (saveUserlistCsv qid) 0
case enr of case enr of
Left (e :: SomeException) -> do Left (e :: SomeException) -> do
$logWarnS "LMS" $ "Userlist upload failed parsing: " <> tshow e $logWarnS "LMS" $ "Userlist upload failed parsing: " <> tshow e
return (badRequest400, "Exception: " <> tshow e) return (badRequest400, "Exception: " <> tshow e)
Right nr -> do Right nr -> do
let msg = "Success. LMS Userlist upload file " <> fileName file <> " containing " <> tshow nr <> " rows for header " <> fhead let msg = "Success. LMS Userlist upload file " <> fileName file <> " containing " <> tshow nr <> " rows for header " <> fhead
$logWarnS "LMS" msg -- TODO: change to Info Level in the future $logInfoS "LMS" msg
queueDBJob $ JobLmsResults qid when (nr > 0) $ queueDBJob $ JobLmsUserlist qid
return (ok200, msg) return (ok200, msg)
[] -> do [] -> do
let msg = "Userlist upload file missing." let msg = "Userlist upload file missing."
$logWarnS "LMS" msg $logWarnS "LMS" msg
return (badRequest400, msg) return (badRequest400, msg)
_other -> do _other -> do
let msg = "Userlist upload received multiple files; all ignored." let msg = "Userlist upload received multiple files; all ignored."
$logWarnS "LMS" msg $logWarnS "LMS" msg
return (badRequest400, msg) return (badRequest400, msg)
sendResponseStatus status msg sendResponseStatus status msg

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

@ -27,30 +27,30 @@ data LmsUserTableCsv = LmsUserTableCsv -- for csv export only
, csvLUTresetPin, csvLUTdelete, csvLUTstaff :: LmsBool , csvLUTresetPin, csvLUTdelete, csvLUTstaff :: LmsBool
} }
deriving Generic deriving Generic
makeLenses_ ''LmsUserTableCsv makeLenses_ ''LmsUserTableCsv
-- | Mundane conversion needed for direct download without dbTable onlu -- | Mundane conversion needed for direct download without dbTable onlu
lmsUser2csv :: LmsUser -> LmsUserTableCsv lmsUser2csv :: LmsUser -> LmsUserTableCsv
lmsUser2csv lu@LmsUser{..} = LmsUserTableCsv lmsUser2csv lu@LmsUser{..} = LmsUserTableCsv
{ csvLUTident = lmsUserIdent { csvLUTident = lmsUserIdent
, csvLUTpin = lmsUserPin , csvLUTpin = lmsUserPin
, csvLUTresetPin = lmsUserResetPin & LmsBool , csvLUTresetPin = lmsUserResetPin & LmsBool
, csvLUTdelete = lmsUserToDelete lu & LmsBool , csvLUTdelete = lmsUserToDelete lu & LmsBool
, csvLUTstaff = False & LmsBool , csvLUTstaff = False & LmsBool
} }
-- csv without headers -- TODO not yet supported -- csv without headers
-- instance Csv.ToRecord LmsUserTableCsv instance Csv.ToRecord LmsUserTableCsv
-- instance Csv.FromRecord LmsUserTableCsv instance Csv.FromRecord LmsUserTableCsv
-- csv with headers -- csv with headers
lmsUserTableCsvHeader :: Csv.Header lmsUserTableCsvHeader :: Csv.Header
lmsUserTableCsvHeader = Csv.header [ csvLmsIdent, csvLmsPin, csvLmsResetPin, csvLmsDelete, csvLmsStaff ] lmsUserTableCsvHeader = Csv.header [ csvLmsIdent, csvLmsPin, csvLmsResetPin, csvLmsDelete, csvLmsStaff ]
instance ToNamedRecord LmsUserTableCsv where instance ToNamedRecord LmsUserTableCsv where
toNamedRecord LmsUserTableCsv{..} = Csv.namedRecord toNamedRecord LmsUserTableCsv{..} = Csv.namedRecord
[ csvLmsIdent Csv..= csvLUTident [ csvLmsIdent Csv..= csvLUTident
, csvLmsPin Csv..= csvLUTpin , csvLmsPin Csv..= csvLUTpin
, csvLmsResetPin Csv..= csvLUTresetPin , csvLmsResetPin Csv..= csvLUTresetPin
, csvLmsDelete Csv..= csvLUTdelete , csvLmsDelete Csv..= csvLUTdelete
, csvLmsStaff Csv..= csvLUTstaff , csvLmsStaff Csv..= csvLUTstaff
@ -79,14 +79,14 @@ instance CsvColumnsExplained LmsUserTableCsv where
mkUserTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget) mkUserTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget)
mkUserTable _sid qsh qid = do mkUserTable _sid qsh qid = do
dbtCsvName <- csvFilenameLmsUser qsh dbtCsvName <- csvFilenameLmsUser qsh
let dbtCsvSheetName = dbtCsvName let dbtCsvSheetName = dbtCsvName
let let
userDBTable = DBTable{..} userDBTable = DBTable{..}
where where
dbtSQLQuery lmsuser = do dbtSQLQuery lmsuser = do
E.where_ $ lmsuser E.^. LmsUserQualification E.==. E.val qid E.where_ $ lmsuser E.^. LmsUserQualification E.==. E.val qid
E.&&. E.isNothing (lmsuser E.^. LmsUserEnded) E.&&. E.isNothing (lmsuser E.^. LmsUserEnded)
return lmsuser return lmsuser
dbtRowKey = (E.^. LmsUserId) dbtRowKey = (E.^. LmsUserId)
@ -94,7 +94,7 @@ mkUserTable _sid qsh qid = do
dbtColonnade = dbColonnade $ mconcat dbtColonnade = dbColonnade $ mconcat
[ sortable (Just csvLmsIdent) (i18nCell MsgTableLmsIdent) $ \(view $ _dbrOutput . _entityVal . _lmsUserIdent . _getLmsIdent -> ident) -> textCell ident [ sortable (Just csvLmsIdent) (i18nCell MsgTableLmsIdent) $ \(view $ _dbrOutput . _entityVal . _lmsUserIdent . _getLmsIdent -> ident) -> textCell ident
, sortable (Just csvLmsPin) (i18nCell MsgTableLmsPin & cellAttrs <>~ [("uw-hide-column-default-hidden",mempty)] , sortable (Just csvLmsPin) (i18nCell MsgTableLmsPin & cellAttrs <>~ [("uw-hide-column-default-hidden",mempty)]
) $ \(view $ _dbrOutput . _entityVal . _lmsUserPin -> pin ) -> textCell pin ) $ \(view $ _dbrOutput . _entityVal . _lmsUserPin -> pin ) -> textCell pin
, sortable (Just csvLmsResetPin) (i18nCell MsgTableLmsResetPin) $ \(view $ _dbrOutput . _entityVal . _lmsUserResetPin -> reset) -> ifIconCell reset IconReset , sortable (Just csvLmsResetPin) (i18nCell MsgTableLmsResetPin) $ \(view $ _dbrOutput . _entityVal . _lmsUserResetPin -> reset) -> ifIconCell reset IconReset
, sortable (Just csvLmsDelete) (i18nCell MsgTableLmsDelete) $ \(view $ _dbrOutput . _entityVal . _lmsUserToDelete -> del ) -> ifIconCell del IconRemoveUser , sortable (Just csvLmsDelete) (i18nCell MsgTableLmsDelete) $ \(view $ _dbrOutput . _entityVal . _lmsUserToDelete -> del ) -> ifIconCell del IconRemoveUser
, sortable Nothing (i18nCell MsgTableLmsStaff) $ const mempty , sortable Nothing (i18nCell MsgTableLmsStaff) $ const mempty
@ -109,16 +109,16 @@ mkUserTable _sid qsh qid = do
[ (csvLmsIdent , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsUserIdent )) [ (csvLmsIdent , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsUserIdent ))
, (csvLmsResetPin , FilterColumn $ E.mkExactFilter (E.^. LmsUserResetPin)) , (csvLmsResetPin , FilterColumn $ E.mkExactFilter (E.^. LmsUserResetPin))
] ]
dbtFilterUI = \mPrev -> mconcat dbtFilterUI = \mPrev -> mconcat
[ prismAForm (singletonFilter csvLmsIdent . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent) [ prismAForm (singletonFilter csvLmsIdent . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent)
, prismAForm (singletonFilter csvLmsResetPin . maybePrism _PathPiece) mPrev $ aopt (hoistField lift checkBoxField) (fslI MsgTableLmsResetPin) , prismAForm (singletonFilter csvLmsResetPin . maybePrism _PathPiece) mPrev $ aopt (hoistField lift checkBoxField) (fslI MsgTableLmsResetPin)
] ]
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
dbtParams = def dbtParams = def
dbtIdent :: Text dbtIdent :: Text
dbtIdent = "lms-user" dbtIdent = "lms-user"
dbtCsvEncode = Just DBTCsvEncode {..} dbtCsvEncode = Just DBTCsvEncode {..}
where where
dbtCsvExportForm = pure () dbtCsvExportForm = pure ()
dbtCsvNoExportData = Just id dbtCsvNoExportData = Just id
dbtCsvExampleData = Nothing dbtCsvExampleData = Nothing
@ -129,7 +129,7 @@ mkUserTable _sid qsh qid = do
<*> view (_dbrOutput . _entityVal . _lmsUserPin) <*> view (_dbrOutput . _entityVal . _lmsUserPin)
<*> view (_dbrOutput . _entityVal . _lmsUserResetPin . _lmsBool) <*> view (_dbrOutput . _entityVal . _lmsUserResetPin . _lmsBool)
<*> view (_dbrOutput . _entityVal . _lmsUserToDelete . _lmsBool) <*> view (_dbrOutput . _entityVal . _lmsUserToDelete . _lmsBool)
<*> const (LmsBool False) <*> const (LmsBool False)
dbtCsvDecode = Nothing dbtCsvDecode = Nothing
dbtExtraReps = [] dbtExtraReps = []
@ -140,9 +140,9 @@ mkUserTable _sid qsh qid = do
getLmsUsersR :: SchoolId -> QualificationShorthand -> Handler Html getLmsUsersR :: SchoolId -> QualificationShorthand -> Handler Html
getLmsUsersR sid qsh = do getLmsUsersR sid qsh = do
lmsTable <- runDB $ do lmsTable <- runDB $ do
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
view _2 <$> mkUserTable sid qsh qid view _2 <$> mkUserTable sid qsh qid
siteLayoutMsg MsgMenuLmsUsers $ do siteLayoutMsg MsgMenuLmsUsers $ do
setTitleI MsgMenuLmsUsers setTitleI MsgMenuLmsUsers
$(widgetFile "lms-user") $(widgetFile "lms-user")
@ -150,26 +150,34 @@ getLmsUsersR sid qsh = do
getLmsUsersDirectR :: SchoolId -> QualificationShorthand -> Handler TypedContent getLmsUsersDirectR :: SchoolId -> QualificationShorthand -> Handler TypedContent
getLmsUsersDirectR sid qsh = do getLmsUsersDirectR sid qsh = do
lms_users <- runDB $ do lms_users <- runDB $ do
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
selectList [LmsUserQualification ==. qid, LmsUserEnded ==. Nothing] [Asc LmsUserStarted, Asc LmsUserIdent] selectList [LmsUserQualification ==. qid, LmsUserEnded ==. Nothing] [Asc LmsUserStarted, Asc LmsUserIdent]
{- To avoid exporting unneeded columns, we would need an SqlSelect instance for LmsUserTableCsv; probably not worth it {- To avoid exporting unneeded columns, we would need an SqlSelect instance for LmsUserTableCsv; probably not worth it
Ex.select $ do Ex.select $ do
lmsuser <- Ex.from $ Ex.table @LmsUser lmsuser <- Ex.from $ Ex.table @LmsUser
Ex.where_ $ lmsuser Ex.^. LmsUserQualification Ex.==. Ex.val qid Ex.where_ $ lmsuser Ex.^. LmsUserQualification Ex.==. Ex.val qid
Ex.&&. Ex.isNothing (lmsuser Ex.^. LmsUserEnded) Ex.&&. Ex.isNothing (lmsuser Ex.^. LmsUserEnded)
pure $ LmsUserTableCsv pure $ LmsUserTableCsv
{ csvLUTident = lmsuser Ex.^. LmsUserIdent { csvLUTident = lmsuser Ex.^. LmsUserIdent
, csvLUTpin = lmsuser Ex.^. LmsUserPin , csvLUTpin = lmsuser Ex.^. LmsUserPin
, csvLUTresetPin = LmsBool . Ex.unValue $ lmsuser Ex.^. LmsUserResetPin , csvLUTresetPin = LmsBool . Ex.unValue $ lmsuser Ex.^. LmsUserResetPin
, csvLUTdelete = LmsBool . Ex.unValue $ Ex.isNothing (lmsuser Ex.^. LmsUserEnded) Ex.&&. Ex.not_ (Ex.isNothing $ lmsuser Ex.^. LmsUserStatus) , csvLUTdelete = LmsBool . Ex.unValue $ Ex.isNothing (lmsuser Ex.^. LmsUserEnded) Ex.&&. Ex.not_ (Ex.isNothing $ lmsuser Ex.^. LmsUserStatus)
, csvLUTstaff = LmsBool False , csvLUTstaff = LmsBool False
} }
-} -}
let csvRenderedData = toNamedRecord . lmsUser2csv . entityVal <$> lms_users LmsConf{..} <- getsYesod $ view _appLmsConf
csvRenderedHeader = lmsUserTableCsvHeader let --csvRenderedData = toNamedRecord . lmsUser2csv . entityVal <$> lms_users
csvSheetName <- csvFilenameLmsUser qsh --csvRenderedHeader = lmsUserTableCsvHeader
--cvsRendered = CsvRendered {..}
csvRendered = toCsvRendered lmsUserTableCsvHeader $ lmsUser2csv . entityVal <$> lms_users
fmtOpts = def { csvIncludeHeader = lmsDownloadHeader
, csvDelimiter = lmsDownloadDelimiter
, csvUseCrLf = lmsDownloadCrLf
}
csvOpts = def { csvFormat = fmtOpts }
csvSheetName <- csvFilenameLmsUser qsh
addHeader "Content-Disposition" $ "attachment; filename=\"" <> csvSheetName <> "\"" addHeader "Content-Disposition" $ "attachment; filename=\"" <> csvSheetName <> "\""
csvRenderedToTypedContent csvSheetName CsvRendered{..} csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered
-- direct Download see: -- direct Download see:
-- https://ersocon.net/blog/2017/2/22/creating-csv-files-in-yesod -- https://ersocon.net/blog/2017/2/22/creating-csv-files-in-yesod

38
src/Handler/PrintCenter.hs
View File

@ -3,7 +3,7 @@
module Handler.PrintCenter module Handler.PrintCenter
( getPrintCenterR, postPrintCenterR ( getPrintCenterR, postPrintCenterR
, getPrintSendR , postPrintSendR , getPrintSendR , postPrintSendR
, getPrintDownloadR , getPrintDownloadR
) where ) where
import Import import Import
@ -98,10 +98,10 @@ mprToMeta MetaPinRenewal{..} = mkMeta
where where
deOrEn = if isDe mppLang then "de" else "en" deOrEn = if isDe mppLang then "de" else "en"
keyOpening = deOrEn <> "-opening" keyOpening = deOrEn <> "-opening"
keyClosing = deOrEn <> "-closing" keyClosing = deOrEn <> "-closing"
mprToMetaUser :: (MonadHandler m, HandlerSite m ~ UniWorX) => Entity User -> MetaPinRenewal -> m P.Meta mprToMetaUser :: (MonadHandler m, HandlerSite m ~ UniWorX) => Entity User -> MetaPinRenewal -> m P.Meta
mprToMetaUser entUser@Entity{entityVal = u} mpr = do mprToMetaUser entUser@Entity{entityVal = u} mpr = do
let userLang = userLanguages u >>= (listToMaybe . view _Wrapped) -- auch möglich `op Languages` statt `view _Wrapped` let userLang = userLanguages u >>= (listToMaybe . view _Wrapped) -- auch möglich `op Languages` statt `view _Wrapped`
meta = mprToMeta mpr{ mppRecipient = userDisplayName u meta = mprToMeta mpr{ mppRecipient = userDisplayName u
-- , mppAddress = userDisplayName u : html2textlines userAddress --TODO once we have User addresses within the DB -- , mppAddress = userDisplayName u : html2textlines userAddress --TODO once we have User addresses within the DB
@ -183,12 +183,6 @@ mkPJTable :: DB (FormResult (PJTableActionData, Set PrintJobId), Widget)
mkPJTable = do mkPJTable = do
currentRoute <- fromMaybe (error "mkPJTable called from 404-handler") <$> liftHandler getCurrentRoute -- albeit we do know the route here currentRoute <- fromMaybe (error "mkPJTable called from 404-handler") <$> liftHandler getCurrentRoute -- albeit we do know the route here
let let
showId :: PrintJobId -> Widget
showId k = do
c <- encrypt k
let f :: CryptoUUIDPrintJob -> Text
f x = toPathPiece x
[whamlet|#{f c}|]
dbtSQLQuery = pjTableQuery dbtSQLQuery = pjTableQuery
dbtRowKey = queryPrintJob >>> (E.^. PrintJobId) dbtRowKey = queryPrintJob >>> (E.^. PrintJobId)
dbtProj = dbtProjFilteredPostId dbtProj = dbtProjFilteredPostId
@ -196,11 +190,10 @@ mkPJTable = do
[ dbSelectIf (applying _2) id (return . view (resultPrintJob . _entityKey)) (\r -> isNothing $ r ^. resultPrintJob . _entityVal . _printJobAcknowledged) [ dbSelectIf (applying _2) id (return . view (resultPrintJob . _entityKey)) (\r -> isNothing $ r ^. resultPrintJob . _entityVal . _printJobAcknowledged)
, sortable (Just "pj-created") (i18nCell MsgPrintJobCreated) $ \( view $ resultPrintJob . _entityVal . _printJobCreated -> t) -> dateTimeCell t , sortable (Just "pj-created") (i18nCell MsgPrintJobCreated) $ \( view $ resultPrintJob . _entityVal . _printJobCreated -> t) -> dateTimeCell t
, sortable (Just "pj-acknowledged") (i18nCell MsgPrintJobAcknowledged) $ \( view $ resultPrintJob . _entityVal . _printJobAcknowledged -> t) -> maybeDateTimeCell t , sortable (Just "pj-acknowledged") (i18nCell MsgPrintJobAcknowledged) $ \( view $ resultPrintJob . _entityVal . _printJobAcknowledged -> t) -> maybeDateTimeCell t
, sortable (Just "pj-filename") (i18nCell MsgPrintJobFilename) $ \( view $ resultPrintJob . _entityVal . _printJobFilename -> t) -> textCell t , sortable (Just "pj-filename") (i18nCell MsgPrintPDF) $ \r -> let k = r ^. resultPrintJob . _entityKey
, sortable (toNothingS "pdf") (i18nCell MsgPrintPDF) $ \( view $ resultPrintJob . _entityKey -> k) -> anchorCellM (PrintDownloadR <$> encrypt k) (showId k) t = r ^. resultPrintJob . _entityVal . _printJobFilename
-- , sortable (Just "pj-id") (i18nCell MsgPrintJobId) $ \( view $ resultPrintJob . _entityKey -> k) -> textCell (tshow . E.unSqlBackendKey $ unPrintJobKey k) in anchorCellM (PrintDownloadR <$> encrypt k) (toWgt t)
-- , sortable (Just "pj-id") (i18nCell MsgPrintJobId) $ \( view $ resultPrintJob . _entityKey -> k) -> cell (showId k) , sortable (Just "pj-name") (i18nCell MsgPrintJobName) $ \( view $ resultPrintJob . _entityVal . _printJobName -> n) -> textCell n
, sortable (Just "pj-name") (i18nCell MsgPrintJobName) $ \( view $ resultPrintJob . _entityVal . _printJobName -> n) -> textCell n
, sortable (Just "pj-recipient") (i18nCell MsgPrintRecipient) $ \(preview resultRecipient -> u) -> maybeCell u $ cellHasUserLink AdminUserR , sortable (Just "pj-recipient") (i18nCell MsgPrintRecipient) $ \(preview resultRecipient -> u) -> maybeCell u $ cellHasUserLink AdminUserR
, sortable (Just "pj-sender") (i18nCell MsgPrintSender) $ \(preview resultSender -> u) -> maybeCell u $ cellHasUserLink AdminUserR , sortable (Just "pj-sender") (i18nCell MsgPrintSender) $ \(preview resultSender -> u) -> maybeCell u $ cellHasUserLink AdminUserR
, sortable (Just "pj-course") (i18nCell MsgPrintCourse) $ \(preview $ resultCourse . _entityVal -> c) -> maybeCell c courseCell , sortable (Just "pj-course") (i18nCell MsgPrintCourse) $ \(preview $ resultCourse . _entityVal -> c) -> maybeCell c courseCell
@ -209,7 +202,6 @@ mkPJTable = do
dbtSorting = mconcat dbtSorting = mconcat
[ single ("pj-name" , SortColumn $ queryPrintJob >>> (E.^. PrintJobName)) [ single ("pj-name" , SortColumn $ queryPrintJob >>> (E.^. PrintJobName))
, single ("pj-filename" , SortColumn $ queryPrintJob >>> (E.^. PrintJobFilename)) , single ("pj-filename" , SortColumn $ queryPrintJob >>> (E.^. PrintJobFilename))
-- , single ("pj-id" , SortColumn $ queryPrintJob >>> (E.^. PrintJobId))
, single ("pj-created" , SortColumn $ queryPrintJob >>> (E.^. PrintJobCreated)) , single ("pj-created" , SortColumn $ queryPrintJob >>> (E.^. PrintJobCreated))
, single ("pj-acknowledged" , SortColumn $ queryPrintJob >>> (E.^. PrintJobAcknowledged)) , single ("pj-acknowledged" , SortColumn $ queryPrintJob >>> (E.^. PrintJobAcknowledged))
, single ("pj-recipient" , sortUserNameBareM queryRecipient) , single ("pj-recipient" , sortUserNameBareM queryRecipient)
@ -220,6 +212,8 @@ mkPJTable = do
dbtFilter = mconcat dbtFilter = mconcat
[ single ("pj-name" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobName)) [ single ("pj-name" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobName))
, single ("pj-filename" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobFilename)) , single ("pj-filename" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobFilename))
, single ("pj-created" , FilterColumn . E.mkDayFilter $ views (to queryPrintJob) (E.^. PrintJobCreated))
--, single ("pj-created" , FilterColumn . E.mkDayBetweenFilter $ views (to queryPrintJob) (E.^. PrintJobCreated))
, single ("pj-recipient" , FilterColumn . E.mkContainsFilterWith Just $ views (to queryRecipient) (E.?. UserDisplayName)) , single ("pj-recipient" , FilterColumn . E.mkContainsFilterWith Just $ views (to queryRecipient) (E.?. UserDisplayName))
, single ("pj-sender" , FilterColumn . E.mkContainsFilterWith Just $ views (to querySender) (E.?. UserDisplayName)) , single ("pj-sender" , FilterColumn . E.mkContainsFilterWith Just $ views (to querySender) (E.?. UserDisplayName))
, single ("pj-course" , FilterColumn . E.mkContainsFilterWith Just $ views (to queryCourse) (E.?. CourseName)) , single ("pj-course" , FilterColumn . E.mkContainsFilterWith Just $ views (to queryCourse) (E.?. CourseName))
@ -227,8 +221,12 @@ mkPJTable = do
, single ("acknowledged" , FilterColumn . E.mkExactFilterLast $ views (to queryPrintJob) (E.isJust . (E.^. PrintJobAcknowledged))) , single ("acknowledged" , FilterColumn . E.mkExactFilterLast $ views (to queryPrintJob) (E.isJust . (E.^. PrintJobAcknowledged)))
] ]
dbtFilterUI mPrev = mconcat dbtFilterUI mPrev = mconcat
[ prismAForm (singletonFilter "pj-filename" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintJobFilename) [ prismAForm (singletonFilter "pj-name" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintJobName)
, prismAForm (singletonFilter "pj-name" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintJobName) , prismAForm (singletonFilter "pj-filename" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintJobFilename)
, prismAForm (singletonFilter "pj-created" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift dayField) (fslI MsgPrintJobCreated)
--, prismAForm (singletonFilter "pj-created" . maybePrism _PathPiece) mPrev ((,) <$> aopt (hoistField lift dayField) (fslI MsgPrintJobCreated)
-- <*> aopt (hoistField lift dayField) (fslI MsgPrintJobCreated)
-- )
, prismAForm (singletonFilter "pj-recipient" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintRecipient) , prismAForm (singletonFilter "pj-recipient" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintRecipient)
, prismAForm (singletonFilter "pj-sender" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintSender) , prismAForm (singletonFilter "pj-sender" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintSender)
, prismAForm (singletonFilter "pj-course" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintCourse) , prismAForm (singletonFilter "pj-course" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintCourse)
@ -307,13 +305,13 @@ postPrintSendR = do
-- liftIO $ LBS.writeFile "/tmp/generated.pdf" bs -- DEBUGGING ONLY -- liftIO $ LBS.writeFile "/tmp/generated.pdf" bs -- DEBUGGING ONLY
-- addMessage Warning "PDF momentan nur gespeicher unter /tmp/generated.pdf" -- addMessage Warning "PDF momentan nur gespeicher unter /tmp/generated.pdf"
uID <- maybeAuthId uID <- maybeAuthId
runDB (sendLetter "Test-Brief" bs mbRecipient uID Nothing Nothing) >>= \case -- calls lpr runDB (sendLetter "Test-Brief" bs (mbRecipient, uID) Nothing Nothing) >>= \case -- calls lpr
Left err -> do Left err -> do
let msg = "PDF printing failed with error: " <> err let msg = "PDF printing failed with error: " <> err
$logErrorS "LPR" msg $logErrorS "LPR" msg
addMessage Error $ toHtml msg addMessage Error $ toHtml msg
pure False pure False
Right (ok, fpath) -> do Right (ok, fpath) -> do
let response = if null ok then mempty else " Response: " <> ok let response = if null ok then mempty else " Response: " <> ok
addMessage Success $ toHtml $ "Druckauftrag angelegt: " <> pack fpath <> response addMessage Success $ toHtml $ "Druckauftrag angelegt: " <> pack fpath <> response
pure True pure True
@ -325,7 +323,7 @@ postPrintSendR = do
pure False pure False
when (or oks) $ redirect PrintCenterR when (or oks) $ redirect PrintCenterR
formResult sendResult procFormSend formResult sendResult procFormSend
-- actionUrl <- fromMaybe AdminAvsR <$> getCurrentRoute -- actionUrl <- fromMaybe AdminAvsR <$> getCurrentRoute
siteLayoutMsg MsgPrintManualRenewal $ do siteLayoutMsg MsgPrintManualRenewal $ do
setTitleI MsgMenuPrintSend setTitleI MsgMenuPrintSend
let sendForm = wrapForm sendWidget def let sendForm = wrapForm sendWidget def

9
src/Handler/Profile.hs
View File

@ -439,11 +439,14 @@ validateSettings :: User -> FormValidator SettingsForm Handler ()
validateSettings User{..} = do validateSettings User{..} = do
userDisplayName' <- use _stgDisplayName userDisplayName' <- use _stgDisplayName
guardValidation MsgUserDisplayNameInvalid $ guardValidation MsgUserDisplayNameInvalid $
validDisplayName userTitle userFirstName userSurname userDisplayName' userDisplayName == userDisplayName' || -- unchanged or valid (invalid displayNames delivered by LDAP are preserved)
validDisplayName userTitle userFirstName userSurname userDisplayName'
userPinPassword' <- use _stgPinPassword userPinPassword' <- use _stgPinPassword
guardValidation MsgPDFPasswordInvalid $ let pinBad = validCmdArgument userPinPassword'
validCmdArgument userPinPassword' -- used as CMD argument for pdftk pinMinChar = 5
whenIsJust pinBad (tellValidationError . MsgPDFPasswordInvalid) -- used as CMD argument for pdftk
guardValidation (MsgPDFPasswordTooShort pinMinChar) $ pinMinChar <= length userPinPassword'
userPostAddress' <- use _stgPostAddress userPostAddress' <- use _stgPostAddress
let postalNotSet = isNothing userPostAddress' let postalNotSet = isNothing userPostAddress'

11
src/Handler/Utils/Csv.hs
View File

@ -1,7 +1,7 @@
{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-orphans #-}
module Handler.Utils.Csv module Handler.Utils.Csv
( decodeCsv, decodeCsvPositional ( decodeCsv, decodeCsvPositional, decodeCsvWith
, encodeCsv, encodeCsvWith, encodeCsvRendered, encodeCsvRenderedWith , encodeCsv, encodeCsvWith, encodeCsvRendered, encodeCsvRenderedWith
, csvRenderedToTypedContent, csvRenderedToTypedContentWith , csvRenderedToTypedContent, csvRenderedToTypedContentWith
, expectedCsvFormat, expectedCsvContentType , expectedCsvFormat, expectedCsvContentType
@ -87,6 +87,15 @@ decodeCsv = decodeCsv' $ \opts -> fromNamedCsvStreamError opts (review _haltingC
decodeCsvPositional :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m, FromRecord csv) => HasHeader -> ConduitT ByteString csv m () decodeCsvPositional :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m, FromRecord csv) => HasHeader -> ConduitT ByteString csv m ()
decodeCsvPositional hdr = decodeCsv' $ \opts -> fromCsvStreamError opts hdr (review _haltingCsvParseError) .| throwIncrementalErrors decodeCsvPositional hdr = decodeCsv' $ \opts -> fromCsvStreamError opts hdr (review _haltingCsvParseError) .| throwIncrementalErrors
decodeCsvWith :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m, FromNamedRecord csv, FromRecord csv) => CsvOptions -> ConduitT ByteString csv m ()
decodeCsvWith opts
| csvIncludeHeader fmtOpts
= decodeCsv' $ \_ -> fromNamedCsvStreamError decOpts (review _haltingCsvParseError) .| throwIncrementalErrors
| otherwise
= decodeCsv' $ \_ -> fromCsvStreamError decOpts NoHeader (review _haltingCsvParseError) .| throwIncrementalErrors
where
fmtOpts = csvFormat opts
decOpts = DecodeOptions { decDelimiter = fromIntegral $ Char.ord $ csvDelimiter fmtOpts }
decodeCsv' :: forall csv m. decodeCsv' :: forall csv m.
( MonadHandler m, HandlerSite m ~ UniWorX ( MonadHandler m, HandlerSite m ~ UniWorX

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

@ -4,7 +4,7 @@ module Handler.Utils.DateTime
( utcToLocalTime, utcToZonedTime ( utcToLocalTime, utcToZonedTime
, localTimeToUTC, TZ.LocalToUTCResult(..), localTimeToUTCSimple , localTimeToUTC, TZ.LocalToUTCResult(..), localTimeToUTCSimple
, toTimeOfDay , toTimeOfDay
, toMidnight, beforeMidnight, toMidday, toMorning , toMidnight, beforeMidnight, toMidday, toMorning, addHours
, formatDiffDays, formatCalendarDiffDays , formatDiffDays, formatCalendarDiffDays
, formatTime' , formatTime'
, formatTime, formatTimeUser, formatTimeW, formatTimeMail , formatTime, formatTimeUser, formatTimeW, formatTimeMail
@ -12,9 +12,10 @@ module Handler.Utils.DateTime
, getTimeLocale, getDateTimeFormat , getTimeLocale, getDateTimeFormat
, getDateTimeFormatter , getDateTimeFormatter
, validDateTimeFormats, dateTimeFormatOptions , validDateTimeFormats, dateTimeFormatOptions
, addLocalDays, addDiffDays, addMonths , addLocalDays
, addDiffDaysClip, addDiffDaysRollOver
, addOneWeek, addWeeks , addOneWeek, addWeeks
, fromMonths , fromDays, fromMonths
, weeksToAdd , weeksToAdd
, setYear, getYear , setYear, getYear
, firstDayOfWeekOnAfter , firstDayOfWeekOnAfter
@ -73,6 +74,9 @@ toMorning = toTimeOfDay 6 0 0
toTimeOfDay :: Int -> Int -> Pico -> Day -> UTCTime toTimeOfDay :: Int -> Int -> Pico -> Day -> UTCTime
toTimeOfDay todHour todMin todSec d = localTimeToUTCTZ appTZ $ LocalTime d TimeOfDay{..} toTimeOfDay todHour todMin todSec d = localTimeToUTCTZ appTZ $ LocalTime d TimeOfDay{..}
addHours :: Integer -> UTCTime -> UTCTime
addHours = addUTCTime . secondsToNominalDiffTime . fromInteger . (* 3600)
instance HasLocalTime UTCTime where instance HasLocalTime UTCTime where
toLocalTime = utcToLocalTime toLocalTime = utcToLocalTime
@ -261,15 +265,17 @@ addLocalDays n utct = localTimeToUTCTZ appTZ newLocal
-- CalendarDiffDays -- -- CalendarDiffDays --
---------------------- ----------------------
fromMonths :: Word -> CalendarDiffDays fromMonths :: Integral a => a -> CalendarDiffDays
fromMonths m = scaleCalendarDiffDays (toInteger m) calendarMonth fromMonths (toInteger -> m) = CalendarDiffDays { cdMonths = m, cdDays = 0 } -- above is equivalent
-- fromMonths m = CalendarDiffDays { cdMonths = m, cdDays = 0 } -- above is equivalent
addDiffDays :: CalendarDiffDays -> UTCTime -> UTCTime fromDays :: Integral a => a -> CalendarDiffDays
addDiffDays = over _utctDay . addGregorianDurationClip fromDays (toInteger -> d) = CalendarDiffDays { cdMonths = 0, cdDays = d }
addMonths :: Word -> UTCTime -> UTCTime addDiffDaysClip :: CalendarDiffDays -> UTCTime -> UTCTime
addMonths = addDiffDays . fromMonths addDiffDaysClip = over _utctDay . addGregorianDurationClip
addDiffDaysRollOver :: CalendarDiffDays -> UTCTime -> UTCTime
addDiffDaysRollOver = over _utctDay . addGregorianDurationRollOver
weeksToAdd :: UTCTime -> UTCTime -> Integer weeksToAdd :: UTCTime -> UTCTime -> Integer
-- ^ Number of weeks needed to add so that first -- ^ Number of weeks needed to add so that first

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

@ -2067,6 +2067,7 @@ csvFormatOptionsForm fs mPrev = hoistAForm liftHandler . multiActionA csvActs fs
<*> apreq (selectField lineEndOpts) (fslI MsgCsvUseCrLf) (preview _csvUseCrLf =<< mPrev) <*> apreq (selectField lineEndOpts) (fslI MsgCsvUseCrLf) (preview _csvUseCrLf =<< mPrev)
<*> apreq (selectField quoteOpts) (fslI MsgCsvQuoting & setTooltip MsgCsvQuotingTip) (preview _csvQuoting =<< mPrev) <*> apreq (selectField quoteOpts) (fslI MsgCsvQuoting & setTooltip MsgCsvQuotingTip) (preview _csvQuoting =<< mPrev)
<*> apreq (selectField encodingOpts) (fslI MsgCsvEncoding & setTooltip MsgCsvEncodingTip) (preview _csvEncoding =<< mPrev) <*> apreq (selectField encodingOpts) (fslI MsgCsvEncoding & setTooltip MsgCsvEncodingTip) (preview _csvEncoding =<< mPrev)
<*> pure True
FormatXlsx -> pure CsvXlsxFormatOptions FormatXlsx -> pure CsvXlsxFormatOptions
delimiterOpts :: Handler (OptionList Char) delimiterOpts :: Handler (OptionList Char)

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

@ -1,17 +1,18 @@
{-# OPTIONS -Wno-redundant-constraints #-} -- needed for Getter {-# OPTIONS -Wno-redundant-constraints #-} -- needed for Getter
module Handler.Utils.LMS module Handler.Utils.LMS
( csvLmsIdent ( getLmsCsvDecoder
, csvLmsIdent
, csvLmsTimestamp , csvLmsTimestamp
, csvLmsBlocked , csvLmsBlocked
, csvLmsSuccess , csvLmsSuccess
, csvLmsPin , csvLmsPin
, csvLmsResetPin , csvLmsResetPin
, csvLmsDelete , csvLmsDelete
, csvLmsStaff , csvLmsStaff
, csvFilenameLmsUser , csvFilenameLmsUser
, csvFilenameLmsUserlist , csvFilenameLmsUserlist
, csvFilenameLmsResult , csvFilenameLmsResult
, lmsUserToDelete, _lmsUserToDelete , lmsUserToDelete, _lmsUserToDelete
, lmsUserToDeleteExpr , lmsUserToDeleteExpr
, randomLMSIdent, randomLMSpw, maxLmsUserIdentRetries , randomLMSIdent, randomLMSpw, maxLmsUserIdentRetries
@ -19,14 +20,30 @@ module Handler.Utils.LMS
-- general utils for LMS Interface Handlers -- general utils for LMS Interface Handlers
import Import import Import
import Handler.Utils import Handler.Utils
import Handler.Utils.Csv
import Data.Csv (HasHeader(..), FromRecord)
import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Legacy as E
import Control.Monad.Random.Class (uniform) import Control.Monad.Random.Class (uniform)
import Control.Monad.Trans.Random (evalRandTIO) import Control.Monad.Trans.Random (evalRandTIO)
-- generic Column names
getLmsCsvDecoder :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m, FromNamedRecord csv, FromRecord csv) => Handler (ConduitT ByteString csv m ())
getLmsCsvDecoder = do
LmsConf{..} <- getsYesod $ view _appLmsConf
if | Just upDelim <- lmsUploadDelimiter -> do
let fmtOpts = def { csvDelimiter = upDelim
, csvIncludeHeader = lmsUploadHeader
}
csvOpts = def { csvFormat = fmtOpts }
return $ decodeCsvWith csvOpts
| lmsUploadHeader -> return decodeCsv
| otherwise -> return $ decodeCsvPositional NoHeader
-- generic Column names
csvLmsIdent :: IsString a => a csvLmsIdent :: IsString a => a
csvLmsIdent = fromString "user" -- "Benutzerkennung" csvLmsIdent = fromString "user" -- "Benutzerkennung"
@ -81,44 +98,43 @@ getYMTH = formatTime' "%Y%m%d%H" =<< liftIO getCurrentTime
lmsUserToDeleteExpr :: E.SqlExpr (Entity LmsUser) -> E.SqlExpr (E.Value Bool) 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 lmslist = E.isNothing (lmslist E.^. LmsUserEnded) E.&&. E.not_ (E.isNothing $ lmslist E.^. LmsUserStatus)
lmsUserToDelete :: LmsUser -> Bool lmsUserToDelete :: LmsUser -> Bool
lmsUserToDelete LmsUser{lmsUserEnded, lmsUserStatus} = isNothing lmsUserEnded && isJust lmsUserStatus lmsUserToDelete LmsUser{lmsUserEnded, lmsUserStatus} = isNothing lmsUserEnded && isJust lmsUserStatus
_lmsUserToDelete :: Getter LmsUser Bool _lmsUserToDelete :: Getter LmsUser Bool
_lmsUserToDelete = to lmsUserToDelete _lmsUserToDelete = to lmsUserToDelete
-- random generation of LmsIdentifiers, maybe this should be in Model.Types.Lms since length specifications are type-y? -- random generation of LmsIdentifiers, maybe this should be in Model.Types.Lms since length specifications are type-y?
lengthIdent :: Int lengthIdent :: Int
lengthIdent = 8 lengthIdent = 8
lengthPassword :: Int lengthPassword :: Int
lengthPassword = 8 lengthPassword = 8
-- | Maximal number of times, randomLMSIdent should be called in a row to find an unused LmsIdent -- | Maximal number of times, randomLMSIdent should be called in a row to find an unused LmsIdent
maxLmsUserIdentRetries :: Int maxLmsUserIdentRetries :: Int
maxLmsUserIdentRetries = 27 maxLmsUserIdentRetries = 27
-- | Generate Random Text of specified length using numbers and lower case letters plus supplied extra characters -- | Generate Random Text of specified length using numbers and lower case letters plus supplied extra characters
randomText :: MonadIO m => String -> Int -> m Text randomText :: MonadIO m => String -> Int -> m Text
randomText extra n = fmap pack . evalRandTIO . replicateM n $ uniform range randomText extra n = fmap pack . evalRandTIO . replicateM n $ uniform range
where where
num_letters = ['0'..'9'] ++ ['a'..'z'] num_letters = ['0'..'9'] ++ ['a'..'z']
range = extra ++ num_letters range = extra ++ num_letters
--TODO: consider using package elocrypt for user-friendly passwords here, licence requires mentioning of author, etc. though --TODO: consider using package elocrypt for user-friendly passwords here, licence requires mentioning of author, etc. though
-- import qualified Data.Elocrypt as Elo -- import qualified Data.Elocrypt as Elo
-- randomLMSIdent :: MonadRandom m => m LmsIdent -- randomLMSIdent :: MonadRandom m => m LmsIdent
-- randomLMSIdent = LmsIdent . T.pack <$> Elo.mkPassword lengthIdent eopt -- randomLMSIdent = LmsIdent . T.pack <$> Elo.mkPassword lengthIdent eopt
-- where -- where
-- eopt = Elo.genOptions -- { genCapitals = False, genSpecials = False, genDigitis = True } -- eopt = Elo.genOptions -- { genCapitals = False, genSpecials = False, genDigitis = True }
randomLMSIdent :: MonadIO m => m LmsIdent randomLMSIdent :: MonadIO m => m LmsIdent
randomLMSIdent = LmsIdent <$> randomText [] lengthIdent randomLMSIdent = LmsIdent <$> randomText [] lengthIdent
randomLMSpw :: MonadIO m => m Text randomLMSpw :: MonadIO m => m Text
randomLMSpw = randomText extra lengthPassword randomLMSpw = randomText extra lengthPassword
where where
extra = "_-+*.:;=!?#" extra = "-+*.:;=!?#$"

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

@ -14,12 +14,16 @@ import qualified Data.Text.Lazy as LT
import qualified Data.MultiSet as MultiSet import qualified Data.MultiSet as MultiSet
import qualified Data.Set as Set import qualified Data.Set as Set
-- | Instead of CI.mk, this still allows use of Text.isInfixOf, etc.
stripFold :: Text -> Text
stripFold = Text.toCaseFold . Text.strip
-- | remove last comma and swap order of the two parts, ie. transforming "surname, givennames" into "givennames surname". -- | remove last comma and swap order of the two parts, ie. transforming "surname, givennames" into "givennames surname".
-- Input "givennames surname" is left unchanged, except for removing excess whitespace -- Input "givennames surname" is left unchanged, except for removing excess whitespace
fixDisplayName :: UserDisplayName -> UserDisplayName fixDisplayName :: UserDisplayName -> UserDisplayName
fixDisplayName udn = fixDisplayName udn =
let (Text.strip . Text.dropEnd 1 -> surname, Text.strip -> firstnames) = Text.breakOnEnd "," udn let (Text.strip . Text.dropEnd 1 -> surname, Text.strip -> firstnames) = Text.breakOnEnd "," udn
in Text.strip $ firstnames <> Text.cons ' ' surname in Text.toTitle $ Text.strip $ firstnames <> Text.cons ' ' surname
-- | Like `validDisplayName` but may return an automatically corrected name -- | Like `validDisplayName` but may return an automatically corrected name
checkDisplayName :: Maybe UserTitle -> UserFirstName -> UserSurname -> UserDisplayName -> Maybe UserDisplayName checkDisplayName :: Maybe UserTitle -> UserFirstName -> UserSurname -> UserDisplayName -> Maybe UserDisplayName
@ -32,7 +36,7 @@ validDisplayName :: Maybe UserTitle
-> UserSurname -> UserSurname
-> UserDisplayName -> UserDisplayName
-> Bool -> Bool
validDisplayName (fmap Text.strip -> mTitle) (Text.strip -> fName) (Text.strip -> sName) (Text.strip -> dName) validDisplayName (fmap stripFold -> mTitle) (stripFold -> fName) (stripFold -> sName) (stripFold -> dName)
= and [ dNameFrags `MultiSet.isSubsetOf` MultiSet.unions [titleFrags, fNameFrags, sNameFrags] = and [ dNameFrags `MultiSet.isSubsetOf` MultiSet.unions [titleFrags, fNameFrags, sNameFrags]
, sName `Text.isInfixOf` dName , sName `Text.isInfixOf` dName
, all ((<= 1) . Text.length) . filter (Text.any isAdd) $ Text.group dName , all ((<= 1) . Text.length) . filter (Text.any isAdd) $ Text.group dName
@ -53,6 +57,7 @@ validDisplayName (fmap Text.strip -> mTitle) (Text.strip -> fName) (Text.strip -
isAdd = (`Set.member` addLetters) isAdd = (`Set.member` addLetters)
splitAdd = Text.split isAdd splitAdd = Text.split isAdd
makeMultiSet = MultiSet.fromList . filter (not . Text.null) . splitAdd makeMultiSet = MultiSet.fromList . filter (not . Text.null) . splitAdd
-- | Primitive postal address requires at least one alphabetic character, one digit and a line break -- | Primitive postal address requires at least one alphabetic character, one digit and a line break
validPostAddress :: Maybe StoredMarkup -> Bool validPostAddress :: Maybe StoredMarkup -> Bool

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

@ -315,4 +315,8 @@ lmsStatusCell :: IsDBTable m a => LmsStatus -> DBCell m a
lmsStatusCell ls = iconCell ic <> spacerCell <> dayCell (lmsStatusDay ls) lmsStatusCell ls = iconCell ic <> spacerCell <> dayCell (lmsStatusDay ls)
where where
ic | isLmsSuccess ls = IconOK ic | isLmsSuccess ls = IconOK
| otherwise = IconNotOK | otherwise = IconNotOK
qualificationBlockedCell :: IsDBTable m a => Maybe QualificationBlocked -> DBCell m a
qualificationBlockedCell Nothing = mempty
qualificationBlockedCell (Just qb) = iconCell IconBlocked <> msgCell qb <> dayCell (qualificationBlockedDay qb)

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

@ -1,15 +1,15 @@
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
module Jobs.Handler.LMS module Jobs.Handler.LMS
( dispatchJobLmsQualificationsEnqueue ( dispatchJobLmsQualificationsEnqueue
, dispatchJobLmsQualificationsDequeue , dispatchJobLmsQualificationsDequeue
, dispatchJobLmsEnqueue, dispatchJobLmsEnqueueUser , dispatchJobLmsEnqueue, dispatchJobLmsEnqueueUser
, dispatchJobLmsDequeue , dispatchJobLmsDequeue
, dispatchJobLmsResults , dispatchJobLmsResults
, dispatchJobLmsUserlist , dispatchJobLmsUserlist
) where ) where
import Import import Import
import Jobs.Queue import Jobs.Queue
-- import Jobs.Handler.Intervals.Utils -- import Jobs.Handler.Intervals.Utils
@ -18,210 +18,223 @@ import qualified Database.Esqueleto.Experimental as E
-- import qualified Database.Esqueleto.PostgreSQL as E -- for insertSelect variant -- import qualified Database.Esqueleto.PostgreSQL as E -- for insertSelect variant
import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Utils as E
import Handler.Utils.DateTime (fromMonths, addMonths) import Handler.Utils.DateTime
import Handler.Utils.LMS (randomLMSIdent, randomLMSpw, maxLmsUserIdentRetries) import Handler.Utils.LMS (randomLMSIdent, randomLMSpw, maxLmsUserIdentRetries)
import qualified Data.CaseInsensitive as CI
dispatchJobLmsQualificationsEnqueue :: JobHandler UniWorX dispatchJobLmsQualificationsEnqueue :: JobHandler UniWorX
dispatchJobLmsQualificationsEnqueue = JobHandlerAtomic act dispatchJobLmsQualificationsEnqueue = JobHandlerAtomic $ fetchRefreshQualifications JobLmsEnqueue
where
act :: YesodJobDB UniWorX () dispatchJobLmsQualificationsDequeue :: JobHandler UniWorX
act = do dispatchJobLmsQualificationsDequeue = JobHandlerAtomic $ fetchRefreshQualifications JobLmsDequeue
qids <- E.select $ do
q <- E.from $ E.table @Qualification -- execute given job for all qualifications that allow refreshs
E.where_ $ E.isJust (q E.^. QualificationRefreshWithin) fetchRefreshQualifications :: (QualificationId -> Job) -> YesodJobDB UniWorX ()
-- E.&&. q E.^. QualificationElearningStart -- checked later, since we need to send out notifications regardless fetchRefreshQualifications qidJob = do
pure $ q E.^. QualificationId qids <- E.select $ do
forM_ qids $ \(E.unValue -> qid) -> q <- E.from $ E.table @Qualification
queueDBJob $ JobLmsEnqueue qid E.where_ $ E.isJust (q E.^. QualificationRefreshWithin)
pure $ q E.^. QualificationId
forM_ qids $ \(E.unValue -> qid) ->
queueDBJob $ qidJob qid
-- | enlist expiring qualification holders to e-learning -- | enlist expiring qualification holders to e-learning
-- NOTE: getting rid of QualificationId parameter and using a DB-join fails, since addGregorianDurationClip cannot be performed within DB -- NOTE: getting rid of QualificationId parameter and using a DB-join fails, since addGregorianDurationClip cannot be performed within DB
dispatchJobLmsEnqueue :: QualificationId -> JobHandler UniWorX dispatchJobLmsEnqueue :: QualificationId -> JobHandler UniWorX
dispatchJobLmsEnqueue qid = JobHandlerAtomic act dispatchJobLmsEnqueue qid = JobHandlerAtomic act
where where
-- act :: YesodJobDB UniWorX () -- act :: YesodJobDB UniWorX ()
act = do act = do
$logInfoS "lms" $ "Start e-learning users for qualification " <> tshow qid <> "."
quali <- getJust qid -- may throw an error, aborting the job quali <- getJust qid -- may throw an error, aborting the job
now <- liftIO getCurrentTime let qshort = CI.original $ qualificationShorthand quali
case qualificationRefreshWithin quali of $logInfoS "lms" $ "Notifying about exipiring qualification " <> qshort
Nothing -> return () -- no automatic scheduling for this qid now <- liftIO getCurrentTime
case qualificationRefreshWithin quali of
Nothing -> return () -- no automatic scheduling for this qid
(Just renewalPeriod) -> do (Just renewalPeriod) -> do
let now_day = utctDay now let now_day = utctDay now
renewalDate = addGregorianDurationClip renewalPeriod now_day renewalDate = addGregorianDurationClip renewalPeriod now_day
renewalUsers <- E.select $ do renewalUsers <- E.select $ do
quser <- E.from $ E.table @QualificationUser quser <- E.from $ E.table @QualificationUser
E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid
E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val now_day E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val now_day
E.&&. quser E.^. QualificationUserValidUntil E.<=. E.val renewalDate E.&&. quser E.^. QualificationUserValidUntil E.<=. E.val renewalDate
E.&&. E.notExists (do E.&&. E.notExists (do
luser <- E.from $ E.table @LmsUser luser <- E.from $ E.table @LmsUser
E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid
E.&&. luser E.^. LmsUserUser E.==. quser E.^. QualificationUserUser E.&&. luser E.^. LmsUserUser E.==. quser E.^. QualificationUserUser
) )
pure quser pure quser
let usr_job :: Entity QualificationUser -> Job let usr_job :: Entity QualificationUser -> Job
usr_job quser = usr_job quser =
let uid = quser ^. _entityVal . _qualificationUserUser let uid = quser ^. _entityVal . _qualificationUserUser
uex = quser ^. _entityVal . _qualificationUserValidUntil uex = quser ^. _entityVal . _qualificationUserValidUntil
in if qualificationElearningStart quali in if qualificationElearningStart quali
then JobLmsEnqueueUser { jQualification = qid, jUser = uid } then JobLmsEnqueueUser { jQualification = qid, jUser = uid }
else JobSendNotification { jRecipient = uid, jNotification = else JobSendNotification { jRecipient = uid, jNotification =
NotificationQualificationExpiry { nQualification = qid, nExpiry = uex } NotificationQualificationExpiry { nQualification = qid, nExpiry = uex }
} }
forM_ renewalUsers (queueDBJob . usr_job) forM_ renewalUsers (queueDBJob . usr_job)
case qualificationAuditDuration quali of
Nothing -> return () -- no automatic removal
(Just auditDuration) ->
let deleteDate = addMonths auditDuration now
in deleteWhere [LmsUserQualification ==. qid, LmsUserEnded !=. Nothing, LmsUserEnded >. Just deleteDate]
dispatchJobLmsEnqueueUser :: QualificationId -> UserId -> JobHandler UniWorX dispatchJobLmsEnqueueUser :: QualificationId -> UserId -> JobHandler UniWorX
dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act
where where
act :: YesodJobDB UniWorX () act :: YesodJobDB UniWorX ()
act = do act = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
let mkLmsUser lid lpin = LmsUser let mkLmsUser lid lpin = LmsUser
{ lmsUserQualification = qid { lmsUserQualification = qid
, lmsUserUser = uid , lmsUserUser = uid
, lmsUserIdent = lid , lmsUserIdent = lid
, lmsUserPin = lpin , lmsUserPin = lpin
, lmsUserResetPin = False , lmsUserResetPin = False
, lmsUserDatePin = now , lmsUserDatePin = now
, lmsUserStatus = Nothing , lmsUserStatus = Nothing
, lmsUserStarted = now , lmsUserStarted = now
, lmsUserReceived = Nothing , lmsUserReceived = Nothing
, lmsUserEnded = Nothing , lmsUserNotified = Nothing
, lmsUserEnded = Nothing
} }
-- startLmsUser :: YesodJobDB UniWorX (Maybe (Entity LmsUser)) -- startLmsUser :: YesodJobDB UniWorX (Maybe (Entity LmsUser))
startLmsUser = E.insertUniqueEntity =<< (mkLmsUser <$> randomLMSIdent <*> randomLMSpw) startLmsUser = E.insertUniqueEntity =<< (mkLmsUser <$> randomLMSIdent <*> randomLMSpw)
inserted <- untilJustMaxM maxLmsUserIdentRetries startLmsUser inserted <- untilJustMaxM maxLmsUserIdentRetries startLmsUser
case inserted of case inserted of
Nothing -> $logErrorS "LMS" $ "Generating and inserting fresh LmsIdent failed for uid " <> tshow uid <> " and qid " <> tshow qid <> "!" Nothing -> do
(Just _) -> queueDBJob JobSendNotification { jRecipient = uid, jNotification = uuid :: CryptoUUIDUser <- encrypt uid
NotificationQualificationRenewal { nQualification = qid } $logErrorS "LMS" $ "Generating and inserting fresh LmsIdent failed for uuid " <> tshow uuid <> " and qid " <> tshow qid <> "!"
} (Just _) -> return () -- lmsUser started, but not yet notified
dispatchJobLmsQualificationsDequeue :: JobHandler UniWorX -- purge LmsIdent adter QualificationAuditDuration expired
dispatchJobLmsQualificationsDequeue = JobHandlerAtomic act dispatchJobLmsDequeue :: QualificationId -> JobHandler UniWorX
dispatchJobLmsDequeue qid = JobHandlerAtomic act
where
act = do
quali <- getJust qid -- may throw an error, aborting the job
let qshort = CI.original $ qualificationShorthand quali
$logInfoS "lms" $ "Processing e-learning results for qualification " <> qshort
now <- liftIO getCurrentTime
-- purge LmsUsers
case qualificationAuditDuration quali of
Nothing -> return () -- no automatic removal
(Just auditDuration) -> do
let auditCutoff = addDiffDaysRollOver (fromMonths $ negate auditDuration) now
delusersVals <- E.select $ do
luser <- E.from $ E.table @LmsUser
E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid
E.&&. luser E.^. LmsUserEnded E.<. E.just (E.val auditCutoff)
E.&&. E.isJust (luser E.^. LmsUserEnded)
E.&&. E.notExists (do
laudit <- E.from $ E.table @LmsAudit
E.where_ $ laudit E.^. LmsAuditQualification E.==. E.val qid
E.&&. laudit E.^. LmsAuditIdent E.==. luser E.^. LmsUserIdent
E.&&. laudit E.^. LmsAuditProcessed E.>=. E.val auditCutoff
)
pure (luser E.^. LmsUserIdent)
let numdel = length delusers
delusers = E.unValue <$> delusersVals
deleteWhere [LmsUserQualification ==. qid, LmsUserIdent <-. delusers]
deleteWhere [LmsUserlistQualification ==. qid, LmsUserlistIdent <-. delusers]
deleteWhere [LmsResultQualification ==. qid, LmsResultIdent <-. delusers]
deleteWhere [LmsAuditQualification ==. qid, LmsAuditIdent <-. delusers]
when (numdel > 0) $ $logInfoS "lms" $ "Deleting " <> tshow numdel <> " LmsIdents due to audit duration expiry for qualification " <> qshort
-- processes received results and lengthen qualifications, if applicable
dispatchJobLmsResults :: QualificationId -> JobHandler UniWorX
dispatchJobLmsResults qid = JobHandlerAtomic act
where
-- act :: YesodJobDB UniWorX ()
act = hoist lift $ do
quali <- getJust qid
now <- liftIO getCurrentTime
let nowadayP1 = succ $ utctDay now -- add one day to account for time synch problems
renewalMonths :: Word = fromMaybe (error ("Cannot renew qualification " <> citext2string (qualificationShorthand quali) <> " without specified validDuration!"))
(qualificationValidDuration quali)
-- result :: [(Entity QualificationUser, Entity LmsUser, Entity LmsResult)]
results <- E.select $ do
(quser E.:& luser E.:& lresult) <- E.from $
E.table @QualificationUser -- table not needed if renewal from lms completion day is used TODO: decide!
`E.innerJoin` E.table @LmsUser
`E.on` (\(quser E.:& luser) ->
luser E.^. LmsUserUser E.==. quser E.^. QualificationUserUser
E.&&. luser E.^. LmsUserQualification E.==. quser E.^. QualificationUserQualification)
`E.innerJoin` E.table @LmsResult
`E.on` (\(_ E.:& luser E.:& lresult) ->
luser E.^. LmsUserIdent E.==. lresult E.^. LmsResultIdent
E.&&. luser E.^. LmsUserQualification E.==. lresult E.^. LmsResultQualification)
E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid
E.&&. luser E.^. LmsUserQualification E.==. E.val qid
E.&&. E.isNothing (luser E.^. LmsUserStatus) -- do not process learners already having a result
E.&&. E.isNothing (luser E.^. LmsUserEnded) -- do not process closed learners
return (quser, luser, lresult)
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 = utctDay lmsUserStarted
saneDate = lmsResultSuccess `inBetween` (lmsUserStartedDay, min qualificationUserValidUntil nowadayP1)
&& qualificationUserLastRefresh <= lmsUserStartedDay
newStatus = LmsSuccess lmsResultSuccess
newValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) qualificationUserValidUntil -- renew from old validUntil onwards
note <- if saneDate && isLmsSuccess newStatus
then do
update quid [ QualificationUserValidUntil =. newValidTo
, QualificationUserLastRefresh =. lmsResultSuccess
]
update luid [ LmsUserStatus =. Just newStatus
, LmsUserReceived =. Just lmsResultTimestamp
]
return Nothing
else do
let errmsg = [st|LMS success with insane date #{tshow lmsResultSuccess} received for #{tshow lmsUserIdent}|]
$logErrorS "LmsResult" errmsg
return $ Just errmsg
insert_ $ LmsAudit qid lmsUserIdent newStatus note lmsResultTimestamp now -- always log success, since this is only transmitted once
delete lrid
$logInfoS "LmsResult" [st|Processed #{tshow (length results)} LMS results|]
-- processes received input and block qualifications, if applicable
dispatchJobLmsUserlist :: QualificationId -> JobHandler UniWorX
dispatchJobLmsUserlist qid = JobHandlerAtomic act
where where
act :: YesodJobDB UniWorX () act :: YesodJobDB UniWorX ()
act = do
qids <- E.select $ do
q <- E.from $ E.table @Qualification
E.where_ $ E.isJust (q E.^. QualificationRefreshWithin)
-- E.&&. q E.^. QualificationElearningStart -- checked later, since we need to send out notifications regardless
pure $ q E.^. QualificationId
forM_ qids $ \(E.unValue -> qid) ->
queueDBJob $ JobLmsEnqueue qid
dispatchJobLmsDequeue :: QualificationId -> JobHandler UniWorX
dispatchJobLmsDequeue qid = JobHandlerAtomic act
-- wenn bestanden: qualification verlängern
-- wenn Aufbewahrungszeit abgelaufen: LmsIdent löschen (verhindert verfrühten neustart)
where
act = do act = do
$logInfoS "lms" $ "Process e-learning results for qualification " <> tshow qid <> "." now <- liftIO getCurrentTime
quali <- getJust qid -- may throw an error, aborting the job
case qualificationRefreshWithin quali of
Nothing -> return () -- no automatic scheduling for this qid
(Just renewalPeriod) -> do
now_day <- utctDay <$> liftIO getCurrentTime
let renewalDate = addGregorianDurationClip renewalPeriod now_day
-- CONTINUE HERE:
-- select users that need renewal due to success
-- delete users after audit period has expired
renewalUsers <- E.select $ do
(quser E.:& luser) <- E.from $ E.table @QualificationUser `E.innerJoin` E.table @LmsUser
`E.on` (\(quser E.:& luser) -> quser E.^. QualificationUserUser E.==. luser E.^. LmsUserUser
E.&&. quser E.^. QualificationUserQualification E.==. luser E.^. LmsUserQualification
)
E.where_ $ E.val qid E.==. quser E.^. QualificationUserQualification
E.&&. E.val qid E.==. luser E.^. LmsUserQualification
E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val now_day -- still valid
E.&&. quser E.^. QualificationUserValidUntil E.<=. E.val renewalDate -- due to renewal
E.&&. E.isJust (luser E.^. LmsUserStatus) -- TODO: should check for success -- result already known
pure (quser, luser)
let usr_job (quser, luser) =
let vold = quser ^. _entityVal . _qualificationUserValidUntil
pmonth = fromMonths $ fromMaybe 0 $ qualificationValidDuration quali -- TODO: decide how to deal with qualification that have infinite validity?!
vnew = addGregorianDurationClip pmonth vold
lmsstatus = luser ^. _entityVal . _lmsUserStatus
in case lmsstatus of
Just (LmsSuccess refreshDay) -> update (quser ^. _entityKey) [QualificationUserValidUntil =. vnew, QualificationUserLastRefresh =. refreshDay]
_ -> return ()
forM_ renewalUsers usr_job
dispatchJobLmsResults :: QualificationId -> JobHandler UniWorX
dispatchJobLmsResults qid = JobHandlerAtomic act
where
-- act :: YesodJobDB UniWorX ()
act = hoist lift $ do
now <- liftIO getCurrentTime
-- result :: [(Entity LmsUser, Entity LmsResult)]
results <- E.select $ do
(luser E.:& lresult) <- E.from $
E.table @LmsUser `E.innerJoin` E.table @LmsResult
`E.on` (\(luser E.:& lresult) -> luser E.^. LmsUserIdent E.==. lresult E.^. LmsResultIdent
E.&&. luser E.^. LmsUserQualification E.==. lresult E.^. LmsResultQualification)
E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid
E.&&. E.isNothing (luser E.^. LmsUserEnded) -- do not process closed learners
return (luser, lresult)
forM_ results $ \(Entity luid luser, Entity lrid lresult) -> do
-- three separate DB operations per result is not so nice. All within one transaction though.
let lreceived = lmsResultTimestamp lresult
newStatus = lmsResultSuccess lresult & LmsSuccess
oldStatus = lmsUserStatus luser
saneDate = lmsResultSuccess lresult `inBetween` (utctDay $ lmsUserStarted luser, utctDay now)
-- always log success, since this is only transmitted once
if saneDate
then
update luid [ LmsUserStatus =. (oldStatus <> Just newStatus)
, LmsUserReceived =. Just lreceived
]
else
$logErrorS "LmsResult" [st|LMS success with insane date #{tshow (lmsResultSuccess lresult)} received|]
insert_ $ LmsAudit qid (lmsUserIdent luser) newStatus lreceived now
delete lrid
$logInfoS "LmsResult" [st|Processed #{tshow (length results)} LMS results|]
dispatchJobLmsUserlist :: QualificationId -> JobHandler UniWorX
dispatchJobLmsUserlist qid = JobHandlerAtomic act
where
-- act :: YesodJobDB UniWorX ()
act = hoist lift $ do
now <- liftIO getCurrentTime
-- result :: [(Entity LmsUser, Entity LmsUserlist)] -- result :: [(Entity LmsUser, Entity LmsUserlist)]
results <- E.select $ do results <- E.select $ do
(luser E.:& lulist) <- E.from $ (luser E.:& lulist) <- E.from $
E.table @LmsUser `E.leftJoin` E.table @LmsUserlist E.table @LmsUser `E.leftJoin` E.table @LmsUserlist
`E.on` (\(luser E.:& lulist) -> luser E.^. LmsUserIdent E.=?. lulist E.?. LmsUserlistIdent `E.on` (\(luser E.:& lulist) -> luser E.^. LmsUserIdent E.=?. lulist E.?. LmsUserlistIdent
E.&&. luser E.^. LmsUserQualification E.=?. lulist E.?. LmsUserlistQualification) E.&&. luser E.^. LmsUserQualification E.=?. lulist E.?. LmsUserlistQualification)
E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid
E.&&. E.isNothing (luser E.^. LmsUserEnded) -- do not process closed learners E.&&. E.isNothing (luser E.^. LmsUserEnded) -- do not process closed learners
return (luser, lulist) return (luser, lulist)
forM_ results $ \case forM_ results $ \case
(Entity luid luser, Nothing) (Entity luid luser, Nothing)
| isJust $ lmsUserReceived luser | isJust $ lmsUserReceived luser -- mark all previuosly reported, but now unreported users as ended (LMS deleted them as expected)
, isNothing $ lmsUserEnded luser -> , isNothing $ lmsUserEnded luser ->
update luid [LmsUserEnded =. Just now] update luid [LmsUserEnded =. Just now]
| otherwise -> return () -- likely not yet started | otherwise -> return () -- users likely not yet started
(Entity luid luser, Just (Entity lulid lulist)) -> do (Entity luid luser, Just (Entity lulid lulist)) -> do
when (isNothing $ lmsUserNotified luser) $ do -- notify users that lms is available
queueDBJob JobSendNotification
{ jRecipient = lmsUserUser luser
, jNotification = NotificationQualificationRenewal { nQualification = qid }
}
-- update luid [ LmsUserNotified =. Just now ] -- wird erst beim tatsächlichen senden gesetzt!
let lReceived = lmsUserlistTimestamp lulist let lReceived = lmsUserlistTimestamp lulist
isBlocked = lmsUserlistFailed lulist isBlocked = lmsUserlistFailed lulist
newStatus = LmsBlocked $ utctDay lReceived update luid [LmsUserReceived =. Just lReceived]
oldStatus = lmsUserStatus luser when isBlocked $ do
update luid [ LmsUserStatus =. (oldStatus <> toMaybe isBlocked newStatus) let newStatus = LmsBlocked $ utctDay lReceived
, LmsUserReceived =. Just lReceived ] oldStatus = lmsUserStatus luser
when isBlocked . insert_ $ LmsAudit qid (lmsUserIdent luser) newStatus lReceived now -- always log blocked insert_ $ LmsAudit qid (lmsUserIdent luser) newStatus (Just $ "Old Status was " <> tshow oldStatus) lReceived now
delete lulid update luid [LmsUserStatus =. (oldStatus <> Just newStatus)]
updateBy (UniqueQualificationUser qid (lmsUserUser luser)) [QualificationUserBlockedDue =. Just (QualificationBlockedLms (utctDay lReceived))]
delete lulid
$logInfoS "LmsUserlist" [st|Processed LMS Userlist with ${tshow (length results)} entries|] $logInfoS "LmsUserlist" [st|Processed LMS Userlist with ${tshow (length results)} entries|]

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

@ -49,7 +49,7 @@ dispatchNotificationQualificationExpiry nQualification _nExpiry jRecipient = use
-- NOTE: qualificationRenewal expects that LmsUser already exists for recipient -- NOTE: qualificationRenewal expects that LmsUser already exists for recipient
dispatchNotificationQualificationRenewal :: QualificationId -> UserId -> Handler () dispatchNotificationQualificationRenewal :: QualificationId -> UserId -> Handler ()
dispatchNotificationQualificationRenewal nQualification jRecipient = do dispatchNotificationQualificationRenewal nQualification jRecipient = do
(recipient@User{..}, Qualification{..}, Entity _ QualificationUser{..}, Entity _ LmsUser{..}) <- runDB $ (,,,) (recipient@User{..}, Qualification{..}, Entity _ QualificationUser{..}, Entity luid LmsUser{..}) <- runDB $ (,,,)
<$> getJust jRecipient <$> getJust jRecipient
<*> getJust nQualification <*> getJust nQualification
<*> getJustBy (UniqueQualificationUser nQualification jRecipient) <*> getJustBy (UniqueQualificationUser nQualification jRecipient)
@ -59,62 +59,74 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do
let entRecipient = Entity jRecipient recipient let entRecipient = Entity jRecipient recipient
qname = CI.original qualificationName qname = CI.original qualificationName
$logDebugS "LMS" $ "Notify " <> tshow encRecipient <> " for renewal of qualification " <> qname $logInfoS "LMS" $ "Notify " <> tshow encRecipient <> " for renewal of qualification " <> qname
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
letterDate <- formatTimeUser SelFormatDate now $ Just entRecipient letterDate <- formatTimeUser SelFormatDate now $ Just entRecipient
expiryDate <- formatTimeUser SelFormatDate qualificationUserValidUntil $ Just entRecipient expiryDate <- formatTimeUser SelFormatDate qualificationUserValidUntil $ Just entRecipient
let printJobName = "RenewalPin" let printJobName = "RenewalPin"
prepAddress upa = userDisplayName : (upa & html2textlines) -- TODO: use supervisor's address fileName = printJobName <> "_" <> abbrvName recipient <> ".pdf"
pdfMeta = mkMeta lmsIdent = lmsUserIdent & getLmsIdent
lmsUrl = "https://drive.fraport.de"
lmsLogin = lmsUrl <> "/?login=" <> lmsIdent
prepAddress upa = userDisplayName : (upa & html2textlines) -- TODO: use supervisor's address
pdfMeta = mkMeta
[ toMeta "date" letterDate [ toMeta "date" letterDate
, toMeta "lang" (selectDeEn userLanguages) -- select either German or English only, see Utils.Lang , toMeta "lang" (selectDeEn userLanguages) -- select either German or English only, see Utils.Lang
, toMeta "login" (lmsUserIdent & getLmsIdent) , toMeta "login" lmsIdent
, toMeta "pin" lmsUserPin , toMeta "pin" lmsUserPin
, toMeta "recipient" userDisplayName , toMeta "recipient" userDisplayName
, mbMeta "address" (prepAddress <$> userPostAddress) , mbMeta "address" (prepAddress <$> userPostAddress)
, toMeta "expiry" expiryDate , toMeta "expiry" expiryDate
, mbMeta "validduration" (show <$> qualificationValidDuration) , mbMeta "validduration" (show <$> qualificationValidDuration)
, toMeta "url-text" lmsUrl
, toMeta "url" lmsLogin
] ]
pdfRenewal pdfMeta >>= \case emailRenewal attachment = do
Left err -> do when (Text.null (CI.original userEmail)) $ do
let msg = "Notify " <> tshow encRecipient <> " PDF generation failed with error: " <> err let msg = "Notify " <> tshow encRecipient <> " failed: no email nor address for user known!"
$logErrorS "LMS" msg $logErrorS "LMS" msg
error $ unpack msg error $ unpack msg -- if neither email nor postal address is known, we must abort!
userMailT jRecipient $ do
Right pdf | userPrefersLetter recipient -> do replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
let printSender = Nothing setSubjectI $ MsgMailSubjectQualificationRenewal qname
runDB (sendLetter printJobName pdf printSender (Just jRecipient) Nothing (Just nQualification)) >>= \case whenIsJust attachment $ \afile ->
Left err -> do
let msg = "Notify " <> tshow encRecipient <> " PDF printing to send letter failed with error: " <> err
$logErrorS "LMS" msg
error $ unpack msg
Right (msg,_)
| null msg -> return ()
| otherwise -> $logWarnS "LMS" $ "PDF printing to send letter with lpr returned ExitSucces and the following message: " <> msg
Right pdf -> userMailT jRecipient $ do
-- userPrefersLetter is false if both userEmail and userPostAddress are null
when (Text.null (CI.original userEmail)) $ $logErrorS "LMS" ("Notify " <> tshow encRecipient <> " failed: no email nor address for user known!")
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
setSubjectI $ MsgMailSubjectQualificationRenewal qname
let fileName = printJobName <> "_" <> abbrvName recipient <> ".pdf"
encryptPDF (fromMaybe "tomatenmarmelade" userPinPassword) pdf >>= \case -- TODO
Left err -> do
let msg = "Notify " <> tshow encRecipient <> " PDF encryption failed with error: " <> err
$logErrorS "LMS" msg
Right pdffile -> do
addPart (File { fileTitle = Text.unpack fileName addPart (File { fileTitle = Text.unpack fileName
, fileModified = now , fileModified = now
, fileContent = Just $ yield $ LBS.toStrict pdffile , fileContent = Just $ yield $ LBS.toStrict afile
} :: PureFile) } :: PureFile)
editNotifications <- mkEditNotifications jRecipient
addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/qualificationRenewal.hamlet")
editNotifications <- mkEditNotifications jRecipient pdfRenewal pdfMeta >>= \case
addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/qualificationRenewal.hamlet") Right pdf | userPrefersLetter recipient -> -- userPrefersLetter is false if both userEmail and userPostAddress are null
let printSender = Nothing
in runDB (sendLetter printJobName pdf (Just jRecipient, printSender) Nothing (Just nQualification)) >>= \case
Left err -> do
let msg = "Notify " <> tshow encRecipient <> ": PDF printing to send letter failed with error " <> cropText err
$logErrorS "LMS" msg
error $ unpack msg
Right (msg,_)
| null msg -> return ()
| otherwise -> $logWarnS "LMS" $ "PDF printing to send letter with lpr returned ExitSucces and the following message: " <> msg
Right pdf -> do
attch <- case userPinPassword of
Nothing -> return $ Just pdf -- attach unencrypted, since there is no password set
Just passwd -> encryptPDF passwd pdf >>= \case
Right encPdf -> return $ Just encPdf -- attach encrypted
Left err -> do -- send email without attachment, so that the user is at least notified about the expiry
let msg = "Notify " <> tshow encRecipient <> " PDF encryption failed with error: " <> cropText err
$logErrorS "LMS" msg
return Nothing
emailRenewal attch
Left err -> do
let msg = "Notify " <> tshow encRecipient <> " PDF generation failed with error: " <> cropText err
$logErrorS "LMS" msg
emailRenewal Nothing
-- if we reach the end, mark the user as notified. TODO: Maybe defer this until the print job is marked as sent?
runDB $ update luid [ LmsUserNotified =. Just now]

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

@ -9,6 +9,7 @@ import Import
import Auth.PWHash (PWHashMessage(..)) import Auth.PWHash (PWHashMessage(..))
import Handler.Utils.Mail import Handler.Utils.Mail
-- import Handler.Utils.Widgets (simpleLink, simpleLinkI)
import Jobs.Handler.SendNotification.Utils import Jobs.Handler.SendNotification.Utils
import Text.Hamlet import Text.Hamlet
@ -21,6 +22,6 @@ dispatchNotificationUserAuthModeUpdate nUser _nOriginalAuthMode jRecipient = us
setSubjectI MsgMailSubjectUserAuthModeUpdate setSubjectI MsgMailSubjectUserAuthModeUpdate
editNotifications <- ihamletSomeMessage <$> mkEditNotifications jRecipient editNotifications <- ihamletSomeMessage <$> mkEditNotifications jRecipient
-- let linkRoot :: Widget = simpleLink (text2widget "FRADrive") NewsR -- TODO: use MsgMailFradrive instead
addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/userAuthModeUpdate.hamlet") :: HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX)) addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/userAuthModeUpdate.hamlet") :: HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX))

37
src/Jobs/Types.hs
View File

@ -322,19 +322,32 @@ data JobNoQueueSame = JobNoQueueSame | JobNoQueueSameTag
jobNoQueueSame :: Job -> Maybe JobNoQueueSame jobNoQueueSame :: Job -> Maybe JobNoQueueSame
jobNoQueueSame = \case jobNoQueueSame = \case
JobSendPasswordReset{} -> Just JobNoQueueSame JobSendNotification{jNotification} -> notifyNoQueueSame jNotification
JobTruncateTransactionLog{} -> Just JobNoQueueSame JobSendPasswordReset{} -> Just JobNoQueueSame
JobPruneInvitations{} -> Just JobNoQueueSame JobTruncateTransactionLog{} -> Just JobNoQueueSame
JobDeleteTransactionLogIPs{} -> Just JobNoQueueSame JobPruneInvitations{} -> Just JobNoQueueSame
JobSynchroniseLdapUser{} -> Just JobNoQueueSame JobDeleteTransactionLogIPs{} -> Just JobNoQueueSame
JobChangeUserDisplayEmail{} -> Just JobNoQueueSame JobSynchroniseLdapUser{} -> Just JobNoQueueSame
JobPruneSessionFiles{} -> Just JobNoQueueSameTag JobChangeUserDisplayEmail{} -> Just JobNoQueueSame
JobPruneUnreferencedFiles{} -> Just JobNoQueueSameTag JobPruneSessionFiles{} -> Just JobNoQueueSameTag
JobInjectFiles{} -> Just JobNoQueueSameTag JobPruneUnreferencedFiles{} -> Just JobNoQueueSameTag
JobInjectFiles{} -> Just JobNoQueueSameTag
JobPruneFallbackPersonalisedSheetFilesKeys{} -> Just JobNoQueueSameTag JobPruneFallbackPersonalisedSheetFilesKeys{} -> Just JobNoQueueSameTag
JobRechunkFiles{} -> Just JobNoQueueSameTag JobRechunkFiles{} -> Just JobNoQueueSameTag
JobDetectMissingFiles{} -> Just JobNoQueueSameTag JobDetectMissingFiles{} -> Just JobNoQueueSameTag
_ -> Nothing JobLmsQualificationsEnqueue -> Just JobNoQueueSame
JobLmsEnqueue {} -> Just JobNoQueueSame
JobLmsEnqueueUser {} -> Just JobNoQueueSame
JobLmsQualificationsDequeue -> Just JobNoQueueSame
JobLmsDequeue {} -> Just JobNoQueueSame
JobLmsUserlist {} -> Just JobNoQueueSame
JobLmsResults {} -> Just JobNoQueueSame
_ -> Nothing
notifyNoQueueSame :: Notification -> Maybe JobNoQueueSame
notifyNoQueueSame = \case
NotificationQualificationRenewal{} -> Just JobNoQueueSame -- send one at once; safe, since the job is rescheduled if sending was not acknowledged
_ -> Nothing
jobMovable :: JobCtl -> Bool jobMovable :: JobCtl -> Bool
jobMovable = isn't _JobCtlTest jobMovable = isn't _JobCtlTest

6
src/Model/Migration/Definitions.hs
View File

@ -432,7 +432,7 @@ customMigrations = mapF $ \case
whenM ((&&) <$> tableExists "allocation_course_file" <*> (not <$> tableExists "course_app_instruction_file")) $ do whenM ((&&) <$> tableExists "allocation_course_file" <*> (not <$> tableExists "course_app_instruction_file")) $ do
[executeQQ| [executeQQ|
CREATe TABLE "course_app_instruction_file"("id" SERIAL8 PRIMARY KEY UNIQUE,"course" INT8 NOT NULL,"file" INT8 NOT NULL); CREATE TABLE "course_app_instruction_file"("id" SERIAL8 PRIMARY KEY UNIQUE,"course" INT8 NOT NULL,"file" INT8 NOT NULL);
ALTER TABLE "course_app_instruction_file" ADD CONSTRAINT "unique_course_app_instruction_file" UNIQUE("course","file"); ALTER TABLE "course_app_instruction_file" ADD CONSTRAINT "unique_course_app_instruction_file" UNIQUE("course","file");
ALTER TABLE "course_app_instruction_file" ADD CONSTRAINT "course_app_instruction_file_course_fkey" FOREIGN KEY("course") REFERENCES "course"("id"); ALTER TABLE "course_app_instruction_file" ADD CONSTRAINT "course_app_instruction_file_course_fkey" FOREIGN KEY("course") REFERENCES "course"("id");
ALTER TABLE "course_app_instruction_file" ADD CONSTRAINT "course_app_instruction_file_file_fkey" FOREIGN KEY("file") REFERENCES "file"("id"); ALTER TABLE "course_app_instruction_file" ADD CONSTRAINT "course_app_instruction_file_file_fkey" FOREIGN KEY("file") REFERENCES "file"("id");
@ -463,7 +463,7 @@ customMigrations = mapF $ \case
Migration20190828UserFunction -> do Migration20190828UserFunction -> do
[executeQQ| [executeQQ|
CREATe TABLE IF NOT EXISTS "user_function" ( "id" serial8 primary key, "user" bigint, "school" citext, "function" text ); CREATE TABLE IF NOT EXISTS "user_function" ( "id" serial8 primary key, "user" bigint, "school" citext, "function" text );
|] |]
whenM (tableExists "user_admin") $ do whenM (tableExists "user_admin") $ do
@ -1002,7 +1002,7 @@ customMigrations = mapF $ \case
whenM (and2M (tableExists "term") (not <$> tableExists "term_active")) $ do whenM (and2M (tableExists "term") (not <$> tableExists "term_active")) $ do
[executeQQ| [executeQQ|
CREATe TABLE "term_active" ("id" SERIAL8 PRIMARY KEY UNIQUE, "term" numeric(5,1) NOT NULL, "from" timestamp with time zone NOT NULL) CREATE TABLE "term_active" ("id" SERIAL8 PRIMARY KEY UNIQUE, "term" numeric(5,1) NOT NULL, "from" timestamp with time zone NOT NULL)
|] |]
let getTerms = [queryQQ|SELECT "name", "active" FROM "term"|] let getTerms = [queryQQ|SELECT "name", "active" FROM "term"|]

14
src/Model/Types/Avs.hs
View File

@ -79,7 +79,7 @@ licence2char AvsLicenceVorfeld = 'F'
licence2char AvsLicenceRollfeld = 'R' licence2char AvsLicenceRollfeld = 'R'
data AvsDataCardColor = AvsCardColorGrün | AvsCardColorBlau | AvsCardColorRot | AvsCardColorGelb | AvsCardColorMisc Text data AvsDataCardColor = AvsCardColorMisc Text | AvsCardColorGrün | AvsCardColorBlau | AvsCardColorRot | AvsCardColorGelb
deriving (Eq, Ord, Read, Show, Generic, Typeable) deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriving anyclass (NFData) deriving anyclass (NFData)
@ -104,12 +104,12 @@ data AvsDataPersonCard = AvsDataPersonCard
{ avsDataValid :: Bool -- card currently valid? Note that AVS encodes booleans as JSON String "true" and "false" and not as JSON booleans { avsDataValid :: Bool -- card currently valid? Note that AVS encodes booleans as JSON String "true" and "false" and not as JSON booleans
, avsDataValidTo :: Maybe Day -- always Nothing if returned with AvsResponseStatus , avsDataValidTo :: Maybe Day -- always Nothing if returned with AvsResponseStatus
, avsDataIssueDate :: Maybe Day -- always Nothing if returned with AvsResponseStatus , avsDataIssueDate :: Maybe Day -- always Nothing if returned with AvsResponseStatus
, avsDataCardColor :: AvsDataCardColor
, avsDataCardAreas :: Set Char -- logically a set of upper-case letters , avsDataCardAreas :: Set Char -- logically a set of upper-case letters
, avsDataStreet :: Maybe Text -- always Nothing if returned with AvsResponseStatus , avsDataStreet :: Maybe Text -- always Nothing if returned with AvsResponseStatus
, avsDataPostalCode:: Maybe Text -- always Nothing if returned with AvsResponseStatus , avsDataPostalCode:: Maybe Text -- always Nothing if returned with AvsResponseStatus
, avsDataCity :: Maybe Text -- always Nothing if returned with AvsResponseStatus , avsDataCity :: Maybe Text -- always Nothing if returned with AvsResponseStatus
, avsDataFirm :: Maybe Text -- always Nothing if returned with AvsResponseStatus , avsDataFirm :: Maybe Text -- always Nothing if returned with AvsResponseStatus
, avsDataCardColor :: AvsDataCardColor
, avsDataCardNo :: Text -- always 8 digits , avsDataCardNo :: Text -- always 8 digits
, avsDataVersionNo :: Text , avsDataVersionNo :: Text
} }
@ -134,12 +134,12 @@ instance FromJSON AvsDataPersonCard where
<$> ((v .: "Valid") <&> sloppyBool) <$> ((v .: "Valid") <&> sloppyBool)
<*> v .:? "ValidTo" <*> v .:? "ValidTo"
<*> v .:? "IssueDate" <*> v .:? "IssueDate"
<*> v .: "CardColor"
<*> ((v .: "CardAreas") <&> charSet) <*> ((v .: "CardAreas") <&> charSet)
<*> v .:? "Street" <*> v .:? "Street"
<*> v .:? "PostalCode" <*> v .:? "PostalCode"
<*> v .:? "City" <*> v .:? "City"
<*> v .:? "Firm" <*> v .:? "Firm"
<*> v .: "CardColor"
<*> v .: "CardNo" <*> v .: "CardNo"
<*> v .: "VersionNo" <*> v .: "VersionNo"
@ -230,6 +230,8 @@ deriveJSON defaultOptions
, rejectUnknownFields = False , rejectUnknownFields = False
} ''AvsResponsePerson } ''AvsResponsePerson
------------- -------------
-- Queries -- -- Queries --
------------- -------------
@ -296,6 +298,8 @@ pickLicenceAddress a b
| Just r <- pickBetter' avsDataValid = r -- prefer valid cards | Just r <- pickBetter' avsDataValid = r -- prefer valid cards
| Just r <- pickBetter' (Set.member licenceRollfeld . avsDataCardAreas) = r -- prefer 'R' cards | Just r <- pickBetter' (Set.member licenceRollfeld . avsDataCardAreas) = r -- prefer 'R' cards
| Just r <- pickBetter' (Set.member licenceVorfeld . avsDataCardAreas) = r -- prefer 'F' cards | Just r <- pickBetter' (Set.member licenceVorfeld . avsDataCardAreas) = r -- prefer 'F' cards
| avsDataCardColor a > avsDataCardColor b = a -- prefer Yellow over Green, etc.
| avsDataCardColor a < avsDataCardColor b = b
| avsDataIssueDate a > avsDataIssueDate b = a -- prefer later issue date | avsDataIssueDate a > avsDataIssueDate b = a -- prefer later issue date
| avsDataIssueDate a < avsDataIssueDate b = b | avsDataIssueDate a < avsDataIssueDate b = b
| avsDataValidTo a > avsDataValidTo b = a -- prefer later validto date | avsDataValidTo a > avsDataValidTo b = a -- prefer later validto date

38
src/Model/Types/Csv.hs
View File

@ -60,10 +60,11 @@ data CsvOptions
data CsvFormatOptions data CsvFormatOptions
= CsvFormatOptions = CsvFormatOptions
{ csvDelimiter :: Char { csvDelimiter :: Char
, csvUseCrLf :: Bool , csvUseCrLf :: Bool
, csvQuoting :: Csv.Quoting , csvQuoting :: Csv.Quoting
, csvEncoding :: DynEncoding , csvEncoding :: DynEncoding
, csvIncludeHeader :: Bool
} }
| CsvXlsxFormatOptions | CsvXlsxFormatOptions
deriving (Eq, Ord, Read, Show, Generic, Typeable) deriving (Eq, Ord, Read, Show, Generic, Typeable)
@ -94,16 +95,18 @@ csvPreset = prism' fromPreset toPreset
where where
fromPreset :: CsvPreset -> CsvFormatOptions fromPreset :: CsvPreset -> CsvFormatOptions
fromPreset CsvPresetRFC = CsvFormatOptions fromPreset CsvPresetRFC = CsvFormatOptions
{ csvDelimiter = ',' { csvDelimiter = ','
, csvUseCrLf = True , csvUseCrLf = True
, csvQuoting = QuoteMinimal , csvIncludeHeader = True
, csvEncoding = "UTF8" , csvQuoting = QuoteMinimal
, csvEncoding = "UTF8"
} }
fromPreset CsvPresetExcel = CsvFormatOptions fromPreset CsvPresetExcel = CsvFormatOptions
{ csvDelimiter = ';' { csvDelimiter = ';'
, csvUseCrLf = True , csvUseCrLf = True
, csvQuoting = QuoteAll , csvIncludeHeader = True
, csvEncoding = "CP1252" , csvQuoting = QuoteAll
, csvEncoding = "CP1252"
} }
fromPreset CsvPresetXlsx = CsvXlsxFormatOptions fromPreset CsvPresetXlsx = CsvXlsxFormatOptions
@ -119,7 +122,7 @@ _CsvEncodeOptions = prism' fromEncode toEncode
{ Csv.encDelimiter = fromIntegral $ fromEnum csvDelimiter { Csv.encDelimiter = fromIntegral $ fromEnum csvDelimiter
, Csv.encUseCrLf = csvUseCrLf , Csv.encUseCrLf = csvUseCrLf
, Csv.encQuoting = csvQuoting , Csv.encQuoting = csvQuoting
, Csv.encIncludeHeader = True , Csv.encIncludeHeader = csvIncludeHeader
} }
toEncode CsvXlsxFormatOptions{} = Nothing toEncode CsvXlsxFormatOptions{} = Nothing
fromEncode encOpts = def fromEncode encOpts = def
@ -180,13 +183,14 @@ instance ToJSON CsvFormatOptions where
instance FromJSON CsvFormatOptions where instance FromJSON CsvFormatOptions where
parseJSON = JSON.withObject "CsvFormatOptions" $ \o -> do parseJSON = JSON.withObject "CsvFormatOptions" $ \o -> do
formatTag <- o JSON..:? "format" JSON..!= FormatCsv formatTag <- o JSON..:? "format" JSON..!= FormatCsv
case formatTag of case formatTag of
FormatCsv -> do FormatCsv -> do
csvDelimiter <- fmap (fmap toEnum) (o JSON..:? "delimiter") JSON..!= csvDelimiter def csvDelimiter <- fmap (fmap toEnum) (o JSON..:? "delimiter") JSON..!= csvDelimiter def
csvUseCrLf <- o JSON..:? "use-cr-lf" JSON..!= csvUseCrLf def csvUseCrLf <- o JSON..:? "use-cr-lf" JSON..!= csvUseCrLf def
csvQuoting <- o JSON..:? "quoting" JSON..!= csvQuoting def csvQuoting <- o JSON..:? "quoting" JSON..!= csvQuoting def
csvEncoding <- o JSON..:? "encoding" JSON..!= csvEncoding def csvEncoding <- o JSON..:? "encoding" JSON..!= csvEncoding def
csvIncludeHeader <- o JSON..:? "include-header" JSON..!= csvIncludeHeader def
return CsvFormatOptions{..} return CsvFormatOptions{..}
FormatXlsx -> return CsvXlsxFormatOptions FormatXlsx -> return CsvXlsxFormatOptions

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

@ -28,18 +28,26 @@ deriveJSON defaultOptions
} ''LmsIdent } ''LmsIdent
-- TODO: Is this a good idea? An ordinary Enum and a separate Day column in the DB would be better, e.g. allowing use of insertSelect in Jobs.Handler.LMS? -- TODO: Is this a good idea? An ordinary Enum and a separate Day column in the DB would be better, e.g. allowing use of insertSelect in Jobs.Handler.LMS?
-- ...also see similar type QualificationBlocked
data LmsStatus = LmsBlocked { lmsStatusDay :: Day } data LmsStatus = LmsBlocked { lmsStatusDay :: Day }
| LmsSuccess { lmsStatusDay :: Day } | LmsSuccess { lmsStatusDay :: Day }
deriving (Eq, Ord, Read, Show, Generic, Typeable, NFData) deriving (Eq, Read, Show, Generic, Typeable, NFData)
instance Ord LmsStatus where
compare a b
| daycmp <- compare (lmsStatusDay a) (lmsStatusDay b)
, daycmp /= EQ = daycmp
compare LmsSuccess{} LmsBlocked{} = GT
compare LmsBlocked{} LmsSuccess{} = LT
compare _ _ = EQ
isLmsSuccess :: LmsStatus -> Bool isLmsSuccess :: LmsStatus -> Bool
isLmsSuccess LmsSuccess{} = True isLmsSuccess LmsSuccess{} = True
isLmsSuccess _other = False isLmsSuccess _other = False
-- Entscheidung 08.04.22: LmsSuccess gewinnt immer über LmsBlocked oder umgekehrt; siehe Model.TypesSpec -- Entscheidung 16.09.22: Es gewinnt was zuerst gemeldet wurde. Das verhindert, dass eine Qualifikation doppelt verlängert wird! Siehe Model.TypesSpec
instance Semigroup LmsStatus where instance Semigroup LmsStatus where
a <> b | a >= b = a a <> b = min a b -- earliest date, otherwise LmsBlocked before LmsSuccess
| otherwise = b
deriveJSON defaultOptions deriveJSON defaultOptions
{ constructorTagModifier = camelToPathPiece' 1 -- remove lms from constructor, since the object is tagged with lms already { constructorTagModifier = camelToPathPiece' 1 -- remove lms from constructor, since the object is tagged with lms already
@ -54,6 +62,28 @@ instance Csv.ToField LmsStatus where
toField (LmsSuccess d) = "Success: " <> Csv.toField d toField (LmsSuccess d) = "Success: " <> Csv.toField d
data QualificationBlocked
= QualificationBlockedLms { qualificationBlockedDay :: Day }
| QualificationBlockedAvs { qualificationBlockedDay :: Day }
deriving (Eq, Ord, Read, Show, Generic, Typeable, NFData)
deriveJSON defaultOptions
{ constructorTagModifier = camelToPathPiece' 1 -- remove lms from constructor, since the object is tagged with lms already
, fieldLabelModifier = camelToPathPiece' 2 -- just day suffices for the day field
, omitNothingFields = True
, sumEncoding = TaggedObject "lms-status" "lms-result"
} ''QualificationBlocked
derivePersistFieldJSON ''QualificationBlocked
instance Csv.ToField QualificationBlocked where
toField (QualificationBlockedLms d) = "Blocked by LMS: " <> Csv.toField d
toField (QualificationBlockedAvs d) = "Blocked by AVS: " <> Csv.toField d
-- | ToMessage instance ignores contained timestamp
instance ToMessage QualificationBlocked where
toMessage (QualificationBlockedLms _) = "LMS"
toMessage (QualificationBlockedAvs _) = "AVS"
-- | LMS interface requires Bool to be encoded by 0 or 1 only -- | LMS interface requires Bool to be encoded by 0 or 1 only
newtype LmsBool = LmsBool { lms2bool :: Bool } newtype LmsBool = LmsBool { lms2bool :: Bool }
deriving (Eq, Ord, Read, Show, Generic, Typeable) deriving (Eq, Ord, Read, Show, Generic, Typeable)

26
src/Settings.hs
View File

@ -93,6 +93,8 @@ data AppSettings = AppSettings
-- ^ Configuration settings for accessing the database. -- ^ Configuration settings for accessing the database.
, appAutoDbMigrate :: Bool , appAutoDbMigrate :: Bool
, appLdapConf :: Maybe (PointedList LdapConf) , appLdapConf :: Maybe (PointedList LdapConf)
-- ^ Configuration settings for CSV export/import to LMS (= Learn Management System)
, appLmsConf :: LmsConf
-- ^ Configuration settings for accessing the LDAP-directory -- ^ Configuration settings for accessing the LDAP-directory
, appAvsConf :: Maybe AvsConf , appAvsConf :: Maybe AvsConf
-- ^ Configuration settings for accessing AVS Server (= Ausweis Verwaltungs System) -- ^ Configuration settings for accessing AVS Server (= Ausweis Verwaltungs System)
@ -301,6 +303,14 @@ data LdapConf = LdapConf
, ldapPool :: ResourcePoolConf , ldapPool :: ResourcePoolConf
} deriving (Show) } deriving (Show)
data LmsConf = LmsConf
{ lmsUploadHeader :: Bool
, lmsUploadDelimiter :: Maybe Char
, lmsDownloadHeader :: Bool
, lmsDownloadDelimiter :: Char
, lmsDownloadCrLf :: Bool
} deriving (Show)
data AvsConf = AvsConf data AvsConf = AvsConf
{ avsHost :: String { avsHost :: String
, avsPort :: Int , avsPort :: Int
@ -311,7 +321,7 @@ data AvsConf = AvsConf
data LprConf = LprConf data LprConf = LprConf
{ lprHost :: String { lprHost :: String
, lprPort :: Int , lprPort :: Int
, lprQueue:: String , lprQueue:: String
} deriving (Show) } deriving (Show)
data SmtpConf = SmtpConf data SmtpConf = SmtpConf
@ -480,6 +490,17 @@ deriveFromJSON
} }
''HaskellNet.AuthType ''HaskellNet.AuthType
instance FromJSON LmsConf where
parseJSON = withObject "LmsConf" $ \o -> do
lmsUploadHeader <- o .: "upload-header"
lmsUploadDelimiter <- o .:? "upload-delimiter"
lmsDownloadHeader <- o .: "download-header"
lmsDownloadDelimiter <- o .: "download-delimiter"
lmsDownloadCrLf <- o .: "download-cr-lf"
return LmsConf{..}
makeLenses_ ''LmsConf
instance FromJSON AvsConf where instance FromJSON AvsConf where
parseJSON = withObject "AvsConf" $ \o -> do parseJSON = withObject "AvsConf" $ \o -> do
avsHost <- o .: "host" avsHost <- o .: "host"
@ -492,7 +513,7 @@ instance FromJSON LprConf where
parseJSON = withObject "LprConf" $ \o -> do parseJSON = withObject "LprConf" $ \o -> do
lprHost <- o .: "host" lprHost <- o .: "host"
lprPort <- o .: "port" lprPort <- o .: "port"
lprQueue <- o .: "queue" lprQueue <- o .: "queue"
return LprConf{..} return LprConf{..}
instance FromJSON SmtpConf where instance FromJSON SmtpConf where
@ -576,6 +597,7 @@ instance FromJSON AppSettings where
Ldap.Tls host _ -> not $ null host Ldap.Tls host _ -> not $ null host
Ldap.Plain host -> not $ null host Ldap.Plain host -> not $ null host
appLdapConf <- P.fromList . mapMaybe (assertM nonEmptyHost) <$> o .:? "ldap" .!= [] appLdapConf <- P.fromList . mapMaybe (assertM nonEmptyHost) <$> o .:? "ldap" .!= []
appLmsConf <- o .: "lms-direct"
appAvsConf <- assertM (not . null . avsPass) <$> o .:? "avs" appAvsConf <- assertM (not . null . avsPass) <$> o .:? "avs"
appLprConf <- o .: "lpr" appLprConf <- o .: "lpr"
appSmtpConf <- assertM (not . null . smtpHost) <$> o .:? "smtp" appSmtpConf <- assertM (not . null . smtpHost) <$> o .:? "smtp"

7
src/Settings/Log.hs
View File

@ -15,9 +15,10 @@ import Utils.PathPiece
data LogSettings = LogSettings data LogSettings = LogSettings
{ logAll, logDetailed :: Bool { logDetailed :: Bool -- More details for incoming HTTP Requests?
, logMinimumLevel :: LogLevel , logAll :: Bool -- Show all LogLevels?
, logDestination :: LogDestination , logMinimumLevel :: LogLevel -- logAll => logMiniumLevel == Info
, logDestination :: LogDestination -- stderr, stdout (must both be lowercase) or a filename!
, logSerializableTransactionRetryLimit :: Maybe Natural , logSerializableTransactionRetryLimit :: Maybe Natural
} deriving (Show, Read, Generic, Eq, Ord) } deriving (Show, Read, Generic, Eq, Ord)

31
src/Utils.hs
View File

@ -275,14 +275,33 @@ addAttrsClass cl attrs = ("class", cl') : noClAttrs
stripAll :: Text -> Text stripAll :: Text -> Text
stripAll = Text.filter (not . isSpace) stripAll = Text.filter (not . isSpace)
-- | take first line, only
cropText :: Text -> Text
cropText (Text.lines -> l:_) = Text.take 80 l
cropText t = Text.take 80 t
-- | strip leading and trailing whitespace and make case insensitive
-- also helps to avoid the need to import just for CI.mk
stripCI :: Text -> CI Text
stripCI = CI.mk . Text.strip
citext2lower :: CI Text -> Text citext2lower :: CI Text -> Text
citext2lower = Text.toLower . CI.original citext2lower = Text.toLower . CI.original
-- avoids unnecessary imports
citext2string :: CI Text -> String
citext2string = Text.unpack . CI.original
-- | Convert text as it is to Html, may prevent ambiguous types -- | Convert text as it is to Html, may prevent ambiguous types
-- This function definition is mainly for documentation purposes -- This function definition is mainly for documentation purposes
text2Html :: Text -> Html text2Html :: Text -> Html
text2Html = toHtml text2Html = toHtml
char2Text :: Char -> Text
char2Text c
| isSpace c = "<Space>"
| otherwise = Text.singleton c
-- | Convert text as it is to Message, may prevent ambiguous types -- | Convert text as it is to Message, may prevent ambiguous types
-- This function definition is mainly for documentation purposes -- This function definition is mainly for documentation purposes
text2message :: Text -> SomeMessage site text2message :: Text -> SomeMessage site
@ -318,6 +337,18 @@ withFragment form html = flip fmap form $ over _2 (toWidget html >>)
charSet :: Text -> Set Char charSet :: Text -> Set Char
charSet = Text.foldl (flip Set.insert) mempty charSet = Text.foldl (flip Set.insert) mempty
-- | Returns Nothing iff both texts are identical,
-- otherwise a differing character is returned, preferable from the first argument
textDiff :: Text -> Text -> Maybe Char
textDiff (Text.uncons -> xs) (Text.uncons -> ys)
| Just (x,xt) <- xs
, Just (y,yt) <- ys
= if x == y
then textDiff xt yt
else Just x
| otherwise
= fst <$> (xs <|> ys)
-- | Convert `part` and `whole` into percentage including symbol -- | Convert `part` and `whole` into percentage including symbol
-- showing trailing zeroes and to decimal digits -- showing trailing zeroes and to decimal digits
textPercent :: Real a => a -> a -> Text textPercent :: Real a => a -> a -> Text

2
src/Utils/Form.hs
View File

@ -297,7 +297,7 @@ data FormIdentifier
| FIDAllocationRegister | FIDAllocationRegister
| FIDAllocationNotification | FIDAllocationNotification
| FIDAvsQueryPerson | FIDAvsQueryPerson
| FIDAvsQueryStatus | FIDAvsQueryStatus
| FIDLmsLetter | FIDLmsLetter
deriving (Eq, Ord, Read, Show) deriving (Eq, Ord, Read, Show)

18
src/Utils/Print.hs
View File

@ -14,9 +14,10 @@ module Utils.Print
) where ) where
-- import Import.NoModel -- import Import.NoModel
import qualified Data.Foldable as Fold import Data.Char (isSeparator)
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
import qualified Data.Foldable as Fold
import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Lazy as LBS
import Control.Monad.Except import Control.Monad.Except
@ -263,8 +264,8 @@ pdfRenewal' meta = do
-- PrintJobs -- -- PrintJobs --
--------------- ---------------
sendLetter :: Text -> LBS.ByteString -> Maybe UserId -> Maybe UserId -> Maybe CourseId -> Maybe QualificationId -> DB (Either Text (Text, FilePath)) sendLetter :: Text -> LBS.ByteString -> (Maybe UserId, Maybe UserId) -> Maybe CourseId -> Maybe QualificationId -> DB (Either Text (Text, FilePath))
sendLetter printJobName pdf printJobRecipient printJobSender printJobCourse printJobQualification = do sendLetter printJobName pdf (printJobRecipient, printJobSender) printJobCourse printJobQualification = do
recipient <- join <$> mapM get printJobRecipient recipient <- join <$> mapM get printJobRecipient
sender <- join <$> mapM get printJobSender sender <- join <$> mapM get printJobSender
course <- join <$> mapM get printJobCourse course <- join <$> mapM get printJobCourse
@ -332,12 +333,11 @@ readProcess' pc = do
sanitizeCmdArg :: Text -> Text sanitizeCmdArg :: Text -> Text
sanitizeCmdArg t = sanitizeCmdArg = T.filter (\c -> c /= '\'' && c /= '"' && c/= '\\' && not (isSeparator c))
T.snoc (T.cons '\'' $ T.filter (\c -> '\'' /= c && '"' /= c && '\\' /= c) t) '\'' -- | Returns Nothing if ok, otherwise the first mismatching character
-- | Pin Password is used as a commandline argument in Utils.Print.encryptPDF and hence poses a security risk -- Pin Password is used as a commandline argument in Utils.Print.encryptPDF and hence poses a security risk
validCmdArgument :: Text -> Bool validCmdArgument :: Text -> Maybe Char
validCmdArgument t = not (T.null t) && (T.cons '\'' (T.snoc t '\'') == sanitizeCmdArg t) validCmdArgument t = t `textDiff` sanitizeCmdArg t
----------- -----------

1
start.sh
View File

@ -23,6 +23,7 @@ export ENCRYPT_ERRORS=${ENCRYPT_ERRORS:-false}
export RIBBON=${RIBBON:-${__HOST:-localhost}} export RIBBON=${RIBBON:-${__HOST:-localhost}}
export APPROOT=${APPROOT:-http://localhost:$((${PORT_OFFSET:-0} + 3000))} export APPROOT=${APPROOT:-http://localhost:$((${PORT_OFFSET:-0} + 3000))}
export AVSPASS=${AVSPASS:-nopasswordset} export AVSPASS=${AVSPASS:-nopasswordset}
export PATH=${PATH:/home/jost/projects/fradrive}
unset HOST unset HOST
move-back() { move-back() {

15
templates/ldap.hamlet Normal file
View File

@ -0,0 +1,15 @@
<section>
<p>
LDAP Person Search:
^{personForm}
$maybe answers <- mbLdapData
<h1>
Antwort: #
<dl .deflist>
$forall (lk, lv) <- answers
<dt>
#{show lk}
<dd>
UTF8: #{presentUtf8 lv}
&#8212;
Latin: #{presentLatin1 lv}

7
templates/letter/fraport_renewal.md
View File

@ -6,7 +6,6 @@ en-subject: Renewal of apron driving License
author: Fraport AG - Fahrerausbildung (AVN-AR) author: Fraport AG - Fahrerausbildung (AVN-AR)
phone: +49 69 690-30306 phone: +49 69 690-30306
email: fahrerausbildung@fraport.de email: fahrerausbildung@fraport.de
url: <http://drive.fraport.de>
place: Frankfurt/Main place: Frankfurt/Main
return-address: return-address:
- 60547 Frankfurt - 60547 Frankfurt
@ -22,6 +21,8 @@ encludes:
hyperrefoptions: hidelinks hyperrefoptions: hidelinks
### Metadaten, welche automatisch ersetzt werden: ### Metadaten, welche automatisch ersetzt werden:
url-text: 'https://drive.fraport.de'
url: 'https://drive.fraport.de'
date: 11.11.1111 date: 11.11.1111
expiry: 00.00.0000 expiry: 00.00.0000
lang: de-de lang: de-de
@ -66,7 +67,7 @@ Prüfling
URL URL
: $url$ : [$url-text$]($url$)
Sobald die Frist abgelaufen ist, muss zur Wiedererlangung des Vorfeldführerscheins Sobald die Frist abgelaufen ist, muss zur Wiedererlangung des Vorfeldführerscheins
@ -93,7 +94,7 @@ Examinee
URL URL
: $url$ :[$url-text$]($url$)
Should your apron driving licence expire before completing this Should your apron driving licence expire before completing this

2
templates/mail/passwordReset.hamlet
View File

@ -13,4 +13,6 @@ $newline never
<h1> <h1>
<a href=#{resetUrl}> <a href=#{resetUrl}>
_{SomeMessage MsgResetPassword} _{SomeMessage MsgResetPassword}
<p>
<a href=#{resetUrl}>
_{SomeMessage $ MsgLinkActiveUntil activeTime} _{SomeMessage $ MsgLinkActiveUntil activeTime}

4
templates/mail/qualificationRenewal.hamlet
View File

@ -28,7 +28,9 @@ $newline never
<dd>#{expiryDate} <dd>#{expiryDate}
<p> <p>
_{SomeMessage MsgLmsRenewalInstructions} _{SomeMessage MsgLmsRenewalInstructions} #
<a href=#{lmsLogin}>
_{SomeMessage MsgMppURL} #{lmsUrl}
^{ihamletSomeMessage editNotifications} ^{ihamletSomeMessage editNotifications}

7
templates/mail/userAuthModeUpdate.hamlet
View File

@ -19,10 +19,15 @@ $newline never
_{SomeMessage MsgUserAuthModePWHashChangedToLDAP} _{SomeMessage MsgUserAuthModePWHashChangedToLDAP}
$of AuthPWHash _ $of AuthPWHash _
_{SomeMessage MsgUserAuthModeLDAPChangedToPWHash} _{SomeMessage MsgUserAuthModeLDAPChangedToPWHash}
<p>
<a href=@{NewsR}>
_{SomeMessage MsgMailFradrive} #
_{SomeMessage MsgMailBodyFradrive}
$if is _AuthPWHash userAuthentication $if is _AuthPWHash userAuthentication
<p> <p>
_{SomeMessage MsgAuthPWHashTip} _{SomeMessage MsgAuthPWHashTip}
<dd> <dl>
<dt> <dt>
_{SomeMessage MsgPWHashIdent} _{SomeMessage MsgPWHashIdent}
<dd .email> <dd .email>

203
test/Database/Fill.hs
View File

@ -37,13 +37,13 @@ import Data.List (foldl)
import System.Directory (getModificationTime, doesDirectoryExist) import System.Directory (getModificationTime, doesDirectoryExist)
import System.FilePath.Glob (glob) import System.FilePath.Glob (glob)
{- Needed for File Tests only {- Needed for File Tests only
import qualified Data.Conduit.Combinators as C import qualified Data.Conduit.Combinators as C
import Paths_uniworx (getDataFileName) import Paths_uniworx (getDataFileName)
testdataFile :: MonadIO m => FilePath -> m FilePath testdataFile :: MonadIO m => FilePath -> m FilePath
testdataFile = liftIO . getDataFileName . ("testdata" </>) testdataFile = liftIO . getDataFileName . ("testdata" </>)
insertFile :: ( HasFileReference fRef, PersistRecordBackend fRef SqlBackend ) => FileReferenceResidual fRef -> FilePath -> DB (Key fRef) insertFile :: ( HasFileReference fRef, PersistRecordBackend fRef SqlBackend ) => FileReferenceResidual fRef -> FilePath -> DB (Key fRef)
insertFile residual fileTitle = do insertFile residual fileTitle = do
filepath <- testdataFile fileTitle filepath <- testdataFile fileTitle
@ -60,25 +60,25 @@ fillDb = do
let let
insert' :: (PersistRecordBackend r (YesodPersistBackend UniWorX), AtLeastOneUniqueKey r) => r -> YesodDB UniWorX (Key r) insert' :: (PersistRecordBackend r (YesodPersistBackend UniWorX), AtLeastOneUniqueKey r) => r -> YesodDB UniWorX (Key r)
insert' = fmap (either entityKey id) . insertBy insert' = fmap (either entityKey id) . insertBy
addBDays = addBusinessDays Fraport -- holiday area to use addBDays = addBusinessDays Fraport -- holiday area to use
n_day n = addBDays n $ utctDay now n_day n = addBDays n $ utctDay now
n_day' n = now { utctDay = n_day n } n_day' n = now { utctDay = n_day n }
currentTerm = TermIdentifier . fst3 . toGregorian $ utctDay now currentTerm = TermIdentifier . fst3 . toGregorian $ utctDay now
-- (currentYear, currentMonth, currentDay) = toGregorian $ getTermDay currentTerm -- (currentYear, currentMonth, currentDay) = toGregorian $ getTermDay currentTerm
nextTerm n = toEnum . (+n) $ fromEnum currentTerm nextTerm n = toEnum . (+n) $ fromEnum currentTerm
termTime :: TermIdentifier -- ^ Term termTime :: TermIdentifier -- ^ Term
-> TermDay -- ^ Relative to which day? -> TermDay -- ^ Relative to which day?
-> Integer -- ^ Week offset from TermDayStart/End of Term (shuld be negative for TermDayEnd) -> Integer -- ^ Week offset from TermDayStart/End of Term (shuld be negative for TermDayEnd)
-> Maybe WeekDay -- ^ Move to weekday -> Maybe WeekDay -- ^ Move to weekday
-> (Day -> UTCTime) -- ^ Add time to day -> (Day -> UTCTime) -- ^ Add time to day
-> UTCTime -> UTCTime
termTime gTid gTD weekOffset mbWeekDay = ($ tDay) termTime gTid gTD weekOffset mbWeekDay = ($ tDay)
where where
gDay = addDays (7* weekOffset) $ guessDay gTid gTD gDay = addDays (7* weekOffset) $ guessDay gTid gTD
tDay = maybe gDay (`firstDayOfWeekOnAfter` gDay) mbWeekDay tDay = maybe gDay (`firstDayOfWeekOnAfter` gDay) mbWeekDay
gkleen <- insert User gkleen <- insert User
{ userIdent = "G.Kleen@campus.lmu.de" { userIdent = "G.Kleen@campus.lmu.de"
, userAuthentication = AuthLDAP , userAuthentication = AuthLDAP
@ -107,9 +107,9 @@ fillDb = do
, userCsvOptions = def { csvFormat = csvPreset # CsvPresetRFC } , userCsvOptions = def { csvFormat = csvPreset # CsvPresetRFC }
, userSex = Just SexMale , userSex = Just SexMale
, userShowSex = userDefaultShowSex , userShowSex = userDefaultShowSex
, userTelephone = Nothing , userTelephone = Nothing
, userMobile = Nothing , userMobile = Nothing
, userCompanyPersonalNumber = Nothing , userCompanyPersonalNumber = Nothing
, userCompanyDepartment = Nothing , userCompanyDepartment = Nothing
, userPinPassword = Nothing , userPinPassword = Nothing
, userPostAddress = Nothing , userPostAddress = Nothing
@ -145,9 +145,9 @@ fillDb = do
, userCsvOptions = def { csvFormat = csvPreset # CsvPresetExcel } , userCsvOptions = def { csvFormat = csvPreset # CsvPresetExcel }
, userSex = Just SexMale , userSex = Just SexMale
, userShowSex = userDefaultShowSex , userShowSex = userDefaultShowSex
, userMobile = Nothing , userMobile = Nothing
, userTelephone = Nothing , userTelephone = Nothing
, userCompanyPersonalNumber = Nothing , userCompanyPersonalNumber = Nothing
, userCompanyDepartment = Nothing , userCompanyDepartment = Nothing
, userPinPassword = Nothing , userPinPassword = Nothing
, userPostAddress = Nothing , userPostAddress = Nothing
@ -227,9 +227,9 @@ fillDb = do
, userCsvOptions = def , userCsvOptions = def
, userSex = Just SexMale , userSex = Just SexMale
, userShowSex = userDefaultShowSex , userShowSex = userDefaultShowSex
, userTelephone = Nothing , userTelephone = Nothing
, userMobile = Nothing , userMobile = Nothing
, userCompanyPersonalNumber = Nothing , userCompanyPersonalNumber = Nothing
, userCompanyDepartment = Nothing , userCompanyDepartment = Nothing
, userPinPassword = Nothing , userPinPassword = Nothing
, userPostAddress = Nothing , userPostAddress = Nothing
@ -265,9 +265,9 @@ fillDb = do
, userCsvOptions = def , userCsvOptions = def
, userSex = Just SexNotApplicable , userSex = Just SexNotApplicable
, userShowSex = userDefaultShowSex , userShowSex = userDefaultShowSex
, userTelephone = Nothing , userTelephone = Nothing
, userMobile = Nothing , userMobile = Nothing
, userCompanyPersonalNumber = Nothing , userCompanyPersonalNumber = Nothing
, userCompanyDepartment = Nothing , userCompanyDepartment = Nothing
, userPinPassword = Nothing , userPinPassword = Nothing
, userPostAddress = Nothing , userPostAddress = Nothing
@ -303,9 +303,9 @@ fillDb = do
, userCsvOptions = def , userCsvOptions = def
, userSex = Just SexFemale , userSex = Just SexFemale
, userShowSex = userDefaultShowSex , userShowSex = userDefaultShowSex
, userTelephone = Nothing , userTelephone = Nothing
, userMobile = Nothing , userMobile = Nothing
, userCompanyPersonalNumber = Nothing , userCompanyPersonalNumber = Nothing
, userCompanyDepartment = Nothing , userCompanyDepartment = Nothing
, userPinPassword = Nothing , userPinPassword = Nothing
, userPostAddress = Nothing , userPostAddress = Nothing
@ -341,9 +341,9 @@ fillDb = do
, userCsvOptions = def , userCsvOptions = def
, userSex = Just SexMale , userSex = Just SexMale
, userShowSex = userDefaultShowSex , userShowSex = userDefaultShowSex
, userTelephone = Nothing , userTelephone = Nothing
, userMobile = Nothing , userMobile = Nothing
, userCompanyPersonalNumber = Nothing , userCompanyPersonalNumber = Nothing
, userCompanyDepartment = Nothing , userCompanyDepartment = Nothing
, userPinPassword = Nothing , userPinPassword = Nothing
, userPostAddress = Nothing , userPostAddress = Nothing
@ -409,9 +409,9 @@ fillDb = do
, userCsvOptions = def , userCsvOptions = def
, userSex = Nothing , userSex = Nothing
, userShowSex = userDefaultShowSex , userShowSex = userDefaultShowSex
, userTelephone = Nothing , userTelephone = Nothing
, userMobile = Nothing , userMobile = Nothing
, userCompanyPersonalNumber = Nothing , userCompanyPersonalNumber = Nothing
, userCompanyDepartment = Nothing , userCompanyDepartment = Nothing
, userPinPassword = Nothing , userPinPassword = Nothing
, userPostAddress = Nothing , userPostAddress = Nothing
@ -426,7 +426,7 @@ fillDb = do
Nothing -> repack [st|#{firstName}.#{userSurname}@example.invalid|] Nothing -> repack [st|#{firstName}.#{userSurname}@example.invalid|]
matrikel <- toMatrikel <$> getRandomRs (0 :: Int, 9 :: Int) matrikel <- toMatrikel <$> getRandomRs (0 :: Int, 9 :: Int)
manyUsers <- insertMany . getZipList $ manyUser <$> ZipList ((,,) <$> firstNames <*> middlenames <*> surnames) <*> ZipList matrikel manyUsers <- insertMany . getZipList $ manyUser <$> ZipList ((,,) <$> firstNames <*> middlenames <*> surnames) <*> ZipList matrikel
let tmin = -1 let tmin = -1
tmax = 2 tmax = 2
trange = [tmin..tmax] trange = [tmin..tmax]
@ -434,21 +434,21 @@ fillDb = do
dmax = guessDay (nextTerm tmax) TermDayEnd dmax = guessDay (nextTerm tmax) TermDayEnd
hdys = foldl (<>) mempty $ [bankHolidaysAreaSet Fraport y | y <- [getYear dmin..getYear dmax]] hdys = foldl (<>) mempty $ [bankHolidaysAreaSet Fraport y | y <- [getYear dmin..getYear dmax]]
terms <- forM trange $ \nr -> do terms <- forM trange $ \nr -> do
let tid = nextTerm nr let tid = nextTerm nr
tk = TermKey tid tk = TermKey tid
tStart = guessDay tid TermDayStart tStart = guessDay tid TermDayStart
tEnd = guessDay tid TermDayEnd tEnd = guessDay tid TermDayEnd
term = Term { termName = tid term = Term { termName = tid
, termStart = tStart , termStart = tStart
, termEnd = tEnd , termEnd = tEnd
, termHolidays = toList $ Set.filter (\d -> tStart <= d && d <= tEnd) hdys , termHolidays = toList $ Set.filter (\d -> tStart <= d && d <= tEnd) hdys
, termLectureStart = guessDay tid TermDayLectureStart , termLectureStart = guessDay tid TermDayLectureStart
, termLectureEnd = guessDay tid TermDayLectureEnd , termLectureEnd = guessDay tid TermDayLectureEnd
} }
repsert tk term repsert tk term
insert_ $ TermActive tk (toMidnight $ termStart term) (Just . beforeMidnight $ termEnd term) Nothing insert_ $ TermActive tk (toMidnight $ termStart term) (Just . beforeMidnight $ termEnd term) Nothing
return tk return tk
ifiAuthorshipStatement <- insertAuthorshipStatement I18n ifiAuthorshipStatement <- insertAuthorshipStatement I18n
{ i18nFallback = htmlToStoredMarkup { i18nFallback = htmlToStoredMarkup
[shamlet| [shamlet|
@ -501,32 +501,41 @@ fillDb = do
let f_descr = Just $ htmlToStoredMarkup [shamlet|<p>Berechtigung zum Führen eines Fahrzeuges auf den Fahrstrassen des Vorfeldes.|] let f_descr = Just $ htmlToStoredMarkup [shamlet|<p>Berechtigung zum Führen eines Fahrzeuges auf den Fahrstrassen des Vorfeldes.|]
let r_descr = Just $ htmlToStoredMarkup [shamlet|<p>Berechtigung zum Führen eines Fahrzeuges auf dem gesamten Rollfeld.|] let r_descr = Just $ htmlToStoredMarkup [shamlet|<p>Berechtigung zum Führen eines Fahrzeuges auf dem gesamten Rollfeld.|]
let l_descr = Just $ htmlToStoredMarkup [shamlet|<p>für unhabilitierte|] let l_descr = Just $ htmlToStoredMarkup [shamlet|<p>für unhabilitierte|]
qid_f <- insert' $ Qualification avn "F" "Vorfeldführerschein" f_descr (Just 24) (Just 6) (Just $ CalendarDiffDays 0 60) True qid_f <- insert' $ Qualification avn "F" "Vorfeldführerschein" f_descr (Just 24) (Just 6) (Just $ CalendarDiffDays 0 60) True
qid_r <- insert' $ Qualification avn "R" "Rollfeldführerschein" r_descr (Just 24) (Just 6) (Just $ CalendarDiffDays 2 3) False qid_r <- insert' $ Qualification avn "R" "Rollfeldführerschein" r_descr (Just 24) (Just 6) (Just $ CalendarDiffDays 2 3) False
qid_l <- insert' $ Qualification ifi "L" "Lehrbefähigung" l_descr Nothing (Just 6) Nothing True qid_l <- insert' $ Qualification ifi "L" "Lehrbefähigung" l_descr Nothing (Just 6) Nothing True
void . insert' $ QualificationUser jost qid_f (n_day 9) (n_day $ -1) (n_day $ -22) -- TODO: better dates! void . insert' $ QualificationUser jost qid_f (n_day 9) (n_day $ -1) (n_day $ -22) Nothing -- TODO: better dates!
void . insert' $ QualificationUser gkleen qid_f (n_day $ -3) (n_day $ -4) (n_day $ -20) void . insert' $ QualificationUser gkleen qid_f (n_day $ -3) (n_day $ -4) (n_day $ -20) Nothing
void . insert' $ QualificationUser maxMuster qid_f (n_day 0) (n_day $ -2) (n_day $ -8) void . insert' $ QualificationUser maxMuster qid_f (n_day 0) (n_day $ -2) (n_day $ -8) Nothing
void . insert' $ QualificationUser svaupel qid_f (n_day 1) (n_day $ -1) (n_day $ -2) void . insert' $ QualificationUser svaupel qid_f (n_day 1) (n_day $ -1) (n_day $ -2) Nothing
void . insert' $ QualificationUser sbarth qid_f (n_day 400) (n_day $ -40) (n_day $ -1200) void . insert' $ QualificationUser sbarth qid_f (n_day 400) (n_day $ -40) (n_day $ -1200) Nothing
void . insert' $ QualificationUser tinaTester qid_f (n_day 3) (n_day $ -60) (n_day $ -250) void . insert' $ QualificationUser tinaTester qid_f (n_day 3) (n_day $ -60) (n_day $ -250) Nothing
void . insert' $ QualificationUser gkleen qid_r (n_day $ -7) (n_day $ -2) (n_day $ -9) void . insert' $ QualificationUser gkleen qid_r (n_day $ -7) (n_day $ -2) (n_day $ -9) Nothing
void . insert' $ QualificationUser maxMuster qid_r (n_day 1) (n_day $ -1) (n_day $ -2) void . insert' $ QualificationUser maxMuster qid_r (n_day 1) (n_day $ -1) (n_day $ -2) Nothing
void . insert' $ QualificationUser fhamann qid_r (n_day $ -3) (n_day $ -1) (n_day $ -2) void . insert' $ QualificationUser fhamann qid_r (n_day $ -3) (n_day $ -1) (n_day $ -2) Nothing
void . insert' $ QualificationUser svaupel qid_l (n_day 1) (n_day $ -1) (n_day $ -2) void . insert' $ QualificationUser svaupel qid_l (n_day 1) (n_day $ -1) (n_day $ -2) Nothing
void . insert' $ QualificationUser gkleen qid_l (n_day 9) (n_day $ -1) (n_day $ -7) void . insert' $ QualificationUser gkleen qid_l (n_day 9) (n_day $ -1) (n_day $ -7) Nothing
void . insert' $ LmsResult qid_f (LmsIdent "hijklmn") (n_day (-1)) now void . insert' $ LmsResult qid_f (LmsIdent "hijklmn") (n_day (-1)) now
void . insert' $ LmsResult qid_f (LmsIdent "opqgrs" ) (n_day (-2)) now void . insert' $ LmsResult qid_f (LmsIdent "opqgrs" ) (n_day (-2)) now
void . insert' $ LmsResult qid_f (LmsIdent "pqgrst" ) (n_day (-3)) now void . insert' $ LmsResult qid_f (LmsIdent "pqgrst" ) (n_day (-3)) now
void . insert' $ LmsUserlist qid_f (LmsIdent "hijklmn") False now void . insert' $ LmsUserlist qid_f (LmsIdent "hijklmn") False now
void . insert' $ LmsUserlist qid_f (LmsIdent "abcdefg") True now void . insert' $ LmsUserlist qid_f (LmsIdent "abcdefg") True now
void . insert' $ LmsUserlist qid_f (LmsIdent "ijk" ) False now void . insert' $ LmsUserlist qid_f (LmsIdent "ijk" ) False now
void . insert' $ LmsUser qid_f jost (LmsIdent "ijk" ) "123" False now Nothing now Nothing Nothing void . insert' $ LmsUser qid_f jost (LmsIdent "ijk" ) "123" False now Nothing now Nothing Nothing Nothing
void . insert' $ LmsUser qid_f svaupel (LmsIdent "abcdefg") "abc" False now (Just $ LmsSuccess $ n_day 1) now (Just now) Nothing void . insert' $ LmsUser qid_f svaupel (LmsIdent "abcdefg") "abc" False now (Just $ LmsSuccess $ n_day 1) now (Just now) Nothing Nothing
void . insert' $ LmsUser qid_f gkleen (LmsIdent "hijklmn") "@#!" True now (Just $ LmsBlocked $ utctDay now) now (Just now) Nothing void . insert' $ LmsUser qid_f gkleen (LmsIdent "hijklmn") "@#!" True now (Just $ LmsBlocked $ utctDay now) now (Just now) Nothing Nothing
void . insert' $ LmsUser qid_f tinaTester (LmsIdent "qwvu") "45678" True now (Just $ LmsSuccess $ n_day (-2)) now Nothing Nothing void . insert' $ LmsUser qid_f tinaTester (LmsIdent "qwvu") "45678" True now (Just $ LmsSuccess $ n_day (-2)) now Nothing (Just $ n_day' (-1)) Nothing
void . insert' $ LmsUser qid_f maxMuster (LmsIdent "xyz") "a1b2c3" False now (Just $ LmsBlocked $ n_day (-1)) now (Just $ n_day' (-2)) (Just $ n_day' (-1)) void . insert' $ LmsUser qid_f maxMuster (LmsIdent "xyz") "a1b2c3" False now (Just $ LmsBlocked $ n_day (-1)) now (Just $ n_day' (-2)) (Just $ n_day' (-2)) (Just $ n_day' (-1))
void . insert $ PrintJob "TestJob1" "job1" "No Text herein." (n_day' (-1)) Nothing Nothing (Just svaupel) Nothing (Just qid_f)
void . insert $ PrintJob "TestJob2" "job2" "No Text herein." (n_day' (-1)) Nothing (Just jost) (Just svaupel) Nothing (Just qid_f)
void . insert $ PrintJob "TestJob3" "job3" "No Text herein." (n_day' (-2)) Nothing Nothing Nothing Nothing Nothing
void . insert $ PrintJob "TestJob4" "job4" "No Text herein." (n_day' (-2)) Nothing (Just jost) Nothing Nothing Nothing
void . insert $ PrintJob "TestJob5" "job5" "No Text herein." (n_day' (-4)) Nothing (Just jost) (Just svaupel) Nothing (Just qid_r)
void . insert $ PrintJob "TestJob6" "job6" "No Text herein." (n_day' (-4)) Nothing (Just svaupel) Nothing Nothing (Just qid_r)
void . insert $ PrintJob "TestJob7" "job7" "No Text herein." (n_day' (-4)) Nothing (Just svaupel) Nothing Nothing Nothing
let let
examLabels = Map.fromList examLabels = Map.fromList
@ -709,19 +718,19 @@ fillDb = do
now now
True True
Nothing Nothing
-- Fahrschule F -- Fahrschule F
forM_ terms $ \tk -> do forM_ terms $ \tk -> do
let tid = unTermKey tk let tid = unTermKey tk
jtt = (((Just .) .) .) . termTime tid jtt = (((Just .) .) .) . termTime tid
firstDay = utctDay $ termTime tid TermDayLectureStart 0 Nothing toMidnight firstDay = utctDay $ termTime tid TermDayLectureStart 0 Nothing toMidnight
secondDay = utctDay $ termTime tid TermDayLectureStart 1 Nothing toMidnight secondDay = utctDay $ termTime tid TermDayLectureStart 1 Nothing toMidnight
weekDay = dayOfWeek firstDay weekDay = dayOfWeek firstDay
-- thirdDay = utctDay $ termTime tid TermDayLectureStart 2 Nothing toMidnight -- thirdDay = utctDay $ termTime tid TermDayLectureStart 2 Nothing toMidnight
capacity = Just 8 capacity = Just 8
mkName = CI.mk mkName = CI.mk
do do
c <- insert' Course c <- insert' Course
{ courseName = mkName "Vorfeldführerschein" { courseName = mkName "Vorfeldführerschein"
, courseDescription = Just $ htmlToStoredMarkup [shamlet| , courseDescription = Just $ htmlToStoredMarkup [shamlet|
@ -730,7 +739,7 @@ fillDb = do
<section> <section>
<h3>Benötigte Unterlagen <h3>Benötigte Unterlagen
<ul> <ul>
<li>Sehtest, <li>Sehtest,
<i>bitte vorab hochladen! <i>bitte vorab hochladen!
<li>Regulärer Führerschein, <li>Regulärer Führerschein,
<i>Bitte mitbringen. <i>Bitte mitbringen.
@ -744,7 +753,7 @@ fillDb = do
, courseVisibleTo = jtt TermDayEnd 0 Nothing beforeMidnight , courseVisibleTo = jtt TermDayEnd 0 Nothing beforeMidnight
, courseRegisterFrom = jtt TermDayStart 0 Nothing toMidnight , courseRegisterFrom = jtt TermDayStart 0 Nothing toMidnight
, courseRegisterTo = jtt TermDayLectureStart (-1) Nothing toMidnight , courseRegisterTo = jtt TermDayLectureStart (-1) Nothing toMidnight
, courseDeregisterUntil = jtt TermDayLectureStart (-5) (Just Monday) toMidnight , courseDeregisterUntil = jtt TermDayLectureStart (-5) (Just Monday) toMidnight
, courseRegisterSecret = Nothing , courseRegisterSecret = Nothing
, courseMaterialFree = True , courseMaterialFree = True
, courseApplicationsRequired = False , courseApplicationsRequired = False
@ -775,44 +784,44 @@ fillDb = do
, sheetAuthorshipStatementMode = SheetAuthorshipStatementModeExam , sheetAuthorshipStatementMode = SheetAuthorshipStatementModeExam
, sheetAuthorshipStatementExam = Nothing , sheetAuthorshipStatementExam = Nothing
, sheetAuthorshipStatement = Nothing , sheetAuthorshipStatement = Nothing
} }
-- TODO: Maybe split into to Tutorials with -- TODO: Maybe split into to Tutorials with
-- occurrencesSchedule = Set.fromList [ ScheduleWeekly { scheduleDayOfWeek = weekDay, scheduleStart = TimeOfDay 8 30 0, scheduleEnd = TimeOfDay 16 0 0} ] -- occurrencesSchedule = Set.fromList [ ScheduleWeekly { scheduleDayOfWeek = weekDay, scheduleStart = TimeOfDay 8 30 0, scheduleEnd = TimeOfDay 16 0 0} ]
tut1 <- insert Tutorial tut1 <- insert Tutorial
{ tutorialName = mkName "Theorieschulung" { tutorialName = mkName "Theorieschulung"
, tutorialCourse = c , tutorialCourse = c
, tutorialType = "Schulung" , tutorialType = "Schulung"
, tutorialCapacity = capacity , tutorialCapacity = capacity
, tutorialRoom = Just $ case weekDay of , tutorialRoom = Just $ case weekDay of
Monday -> "A380" Monday -> "A380"
Tuesday -> "B747" Tuesday -> "B747"
Wednesday -> "MD11" Wednesday -> "MD11"
Thursday -> "A380" Thursday -> "A380"
_ -> "B777" _ -> "B777"
, tutorialRoomHidden = False , tutorialRoomHidden = False
, tutorialTime = Occurrences , tutorialTime = Occurrences
{ occurrencesScheduled = Set.empty { occurrencesScheduled = Set.empty
, occurrencesExceptions = Set.fromList , occurrencesExceptions = Set.fromList
[ ExceptOccur [ ExceptOccur
{ exceptDay = firstDay { exceptDay = firstDay
, exceptStart = TimeOfDay 8 30 0 , exceptStart = TimeOfDay 8 30 0
, exceptEnd = TimeOfDay 16 0 0 , exceptEnd = TimeOfDay 16 0 0
} }
, ExceptOccur , ExceptOccur
{ exceptDay = secondDay { exceptDay = secondDay
, exceptStart = TimeOfDay 9 0 0 , exceptStart = TimeOfDay 9 0 0
, exceptEnd = TimeOfDay 16 0 0 , exceptEnd = TimeOfDay 16 0 0
} }
] ]
} }
, tutorialRegGroup = Just "schulung" , tutorialRegGroup = Just "schulung"
, tutorialRegisterFrom = jtt TermDayStart 0 Nothing toMidnight , tutorialRegisterFrom = jtt TermDayStart 0 Nothing toMidnight
, tutorialRegisterTo = jtt TermDayLectureStart (-1) Nothing toMidnight , tutorialRegisterTo = jtt TermDayLectureStart (-1) Nothing toMidnight
, tutorialDeregisterUntil = jtt TermDayLectureStart (-5) (Just Monday) toMidnight , tutorialDeregisterUntil = jtt TermDayLectureStart (-5) (Just Monday) toMidnight
, tutorialLastChanged = now , tutorialLastChanged = now
, tutorialTutorControlled = True , tutorialTutorControlled = True
} }
insert_ $ Tutor tut1 jost insert_ $ Tutor tut1 jost
void . insert' $ Exam void . insert' $ Exam
{ examCourse = c { examCourse = c
, examName = mkName "Theorieprüfung" , examName = mkName "Theorieprüfung"
@ -823,9 +832,9 @@ fillDb = do
, examVisibleFrom = jtt TermDayStart 0 Nothing toMidnight , examVisibleFrom = jtt TermDayStart 0 Nothing toMidnight
, examRegisterFrom = jtt TermDayStart 0 Nothing toMidnight , examRegisterFrom = jtt TermDayStart 0 Nothing toMidnight
, examRegisterTo = jtt TermDayLectureStart (-1) Nothing toMidnight , examRegisterTo = jtt TermDayLectureStart (-1) Nothing toMidnight
, examDeregisterUntil = jtt TermDayLectureStart (-5) (Just Monday) toMidnight , examDeregisterUntil = jtt TermDayLectureStart (-5) (Just Monday) toMidnight
, examPublishOccurrenceAssignments = Nothing , examPublishOccurrenceAssignments = Nothing
, examStart = Just $ toTimeOfDay 16 0 0 secondDay , examStart = Just $ toTimeOfDay 16 0 0 secondDay
, examEnd = Just $ toTimeOfDay 16 30 0 secondDay , examEnd = Just $ toTimeOfDay 16 30 0 secondDay
, examFinished = Nothing , examFinished = Nothing
, examPartsFrom = Nothing , examPartsFrom = Nothing
@ -842,7 +851,7 @@ fillDb = do
, examStaff = Just "Jost" , examStaff = Just "Jost"
, examAuthorshipStatement = Nothing , examAuthorshipStatement = Nothing
} }
testMsg <- insert SystemMessage testMsg <- insert SystemMessage
{ systemMessageNewsOnly = False { systemMessageNewsOnly = False
, systemMessageFrom = Just now , systemMessageFrom = Just now
@ -903,7 +912,7 @@ fillDb = do
, systemMessageCreated = now , systemMessageCreated = now
, systemMessageLastChanged = now , systemMessageLastChanged = now
, systemMessageLastUnhide = now , systemMessageLastUnhide = now
} }
void $ insert SystemMessage void $ insert SystemMessage
{ systemMessageNewsOnly = True { systemMessageNewsOnly = True
, systemMessageFrom = Just now , systemMessageFrom = Just now
@ -920,7 +929,7 @@ fillDb = do
, systemMessageLastUnhide = now , systemMessageLastUnhide = now
} }
{- {-
aSeedFunc <- liftIO $ getRandomBytes 40 aSeedFunc <- liftIO $ getRandomBytes 40
funAlloc <- insert' Allocation funAlloc <- insert' Allocation
{ allocationName = "Funktionale Zentralanmeldung" { allocationName = "Funktionale Zentralanmeldung"
@ -931,10 +940,10 @@ fillDb = do
, allocationDescription = Nothing , allocationDescription = Nothing
, allocationStaffDescription = Nothing , allocationStaffDescription = Nothing
, allocationStaffRegisterFrom = Just now , allocationStaffRegisterFrom = Just now
, allocationStaffRegisterTo = Just $ 300 `addUTCTime` now , allocationStaffRegisterTo = Just $ 300 `addUTCTime` now
, allocationStaffAllocationFrom = Just $ 300 `addUTCTime` now , allocationStaffAllocationFrom = Just $ 300 `addUTCTime` now
, allocationStaffAllocationTo = Just $ 900 `addUTCTime` now , allocationStaffAllocationTo = Just $ 900 `addUTCTime` now
, allocationRegisterFrom = Just $ 300 `addUTCTime` now , allocationRegisterFrom = Just $ 300 `addUTCTime` now
, allocationRegisterTo = Just $ 600 `addUTCTime` now , allocationRegisterTo = Just $ 600 `addUTCTime` now
, allocationRegisterByStaffFrom = Nothing , allocationRegisterByStaffFrom = Nothing
, allocationRegisterByStaffTo = Nothing , allocationRegisterByStaffTo = Nothing
@ -944,7 +953,7 @@ fillDb = do
} }
insert_ $ AllocationCourse funAlloc pmo 100 Nothing Nothing insert_ $ AllocationCourse funAlloc pmo 100 Nothing Nothing
insert_ $ AllocationCourse funAlloc ffp 2 (Just $ 2300 `addUTCTime` now) Nothing insert_ $ AllocationCourse funAlloc ffp 2 (Just $ 2300 `addUTCTime` now) Nothing
void . insertMany $ map (\(u, pState) -> CourseParticipant ffp u now (Just funAlloc) pState) void . insertMany $ map (\(u, pState) -> CourseParticipant ffp u now (Just funAlloc) pState)
[ (svaupel, CourseParticipantInactive False) [ (svaupel, CourseParticipantInactive False)
, (jost, CourseParticipantActive) , (jost, CourseParticipantActive)
@ -968,7 +977,7 @@ fillDb = do
Just User{ userMatrikelnummer = Just matr } -> Just User{ userMatrikelnummer = Just matr } ->
return . pure $ Csv.Only matr return . pure $ Csv.Only matr
_other -> return mempty _other -> return mempty
liftIO . handle (\(_ :: IOException) -> return ()) $ do liftIO . handle (\(_ :: IOException) -> return ()) $ do
haveTestdata <- doesDirectoryExist "testdata" haveTestdata <- doesDirectoryExist "testdata"
LBS.writeFile (bool id ("testdata" </>) haveTestdata "bigAlloc_numeric.csv") $ Csv.encode numericPriorities LBS.writeFile (bool id ("testdata" </>) haveTestdata "bigAlloc_numeric.csv") $ Csv.encode numericPriorities

7
test/Model/TypesSpec.hs
View File

@ -298,6 +298,7 @@ instance Arbitrary CsvFormatOptions where
<*> arbitrary <*> arbitrary
<*> arbitrary <*> arbitrary
<*> elements ["UTF8", "CP1252"] <*> elements ["UTF8", "CP1252"]
<*> pure True
, pure CsvXlsxFormatOptions , pure CsvXlsxFormatOptions
] ]
where where
@ -619,10 +620,8 @@ spec = do
showCompactCorrectorLoad Load{ byTutorial = Nothing, byProportion = 1, byDeficit = 0 } CorrectorMissing `shouldBe` "[1.0 - D]" showCompactCorrectorLoad Load{ byTutorial = Nothing, byProportion = 1, byDeficit = 0 } CorrectorMissing `shouldBe` "[1.0 - D]"
showCompactCorrectorLoad Load{ byTutorial = Nothing, byProportion = 1, byDeficit = 0 } CorrectorExcused `shouldBe` "{1.0 - D}" showCompactCorrectorLoad Load{ byTutorial = Nothing, byProportion = 1, byDeficit = 0 } CorrectorExcused `shouldBe` "{1.0 - D}"
describe "Semigroup LmsStatus" $ do describe "Semigroup LmsStatus" $ do
it "LmsSuccess supersedes LmsBlocked" . property $ it "lmsStatusDay merges to earliest" . property $
\p1 p2 -> (isLmsSuccess p1 || isLmsSuccess p2) == isLmsSuccess (p1 <> p2) \p1 p2 -> lmsStatusDay (p1 <> p2) == min (lmsStatusDay p1) (lmsStatusDay p2)
it "lmsStatusDay merges to latest" . property $
\p1 p2 -> (isLmsSuccess p1 == isLmsSuccess p2) ==> lmsStatusDay (p1 <> p2) == max (lmsStatusDay p1) (lmsStatusDay p2)
termExample :: (TermIdentifier, Text) -> Expectation termExample :: (TermIdentifier, Text) -> Expectation

BIN
testdata/test.pdf vendored Normal file
View File

Binary file not shown.