diff --git a/CHANGELOG.md b/CHANGELOG.md index c811b891e..80f16de6c 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. +## [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) diff --git a/config/settings.yml b/config/settings.yml index 1da144da9..190cd0670 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -125,6 +125,13 @@ ldap: 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: host: "_env:AVSHOST:skytest.fra.fraport.de" port: "_env:AVSPORT:443" diff --git a/lpr b/lpr new file mode 100755 index 000000000..3336a796f --- /dev/null +++ b/lpr @@ -0,0 +1,5 @@ +#!/usr/bin/env bash + +printf "lpr dummy called, arguments ignored.\n" +printf "Nothing is printed." +exit 0 \ No newline at end of file diff --git a/messages/uniworx/categories/authorization/de-de-formal.msg b/messages/uniworx/categories/authorization/de-de-formal.msg index fab2eb322..3f9d02ca2 100644 --- a/messages/uniworx/categories/authorization/de-de-formal.msg +++ b/messages/uniworx/categories/authorization/de-de-formal.msg @@ -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! DummyLoginTitle: Development-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 CampusUserInvalidDisplayName: Konnte anhand des Fraport Büko-Logins keinen vollen Namen ermitteln CampusUserInvalidGivenName: Konnte anhand des Fraport Büko-Logins keinen Vornamen ermitteln diff --git a/messages/uniworx/categories/jobs_handler/de-de-formal.msg b/messages/uniworx/categories/jobs_handler/de-de-formal.msg index 6fe682bdc..ddb653704 100644 --- a/messages/uniworx/categories/jobs_handler/de-de-formal.msg +++ b/messages/uniworx/categories/jobs_handler/de-de-formal.msg @@ -17,4 +17,4 @@ InvitationAcceptDecline: Einladung annehmen/ablehnen 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. InvitationUniWorXTip: FRADrive ist ein webbasiertes Schulungsverwaltungssystem der Fraport AG. -LinkActiveUntil time@Text: Der Link ist nur bis #{time} aktiv! \ No newline at end of file +LinkActiveUntil time@Text: Dieser Link ist nur bis #{time} aktiv! \ No newline at end of file diff --git a/messages/uniworx/categories/jobs_handler/en-eu.msg b/messages/uniworx/categories/jobs_handler/en-eu.msg index 8b938cb01..d20350bba 100644 --- a/messages/uniworx/categories/jobs_handler/en-eu.msg +++ b/messages/uniworx/categories/jobs_handler/en-eu.msg @@ -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. 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. -LinkActiveUntil time@Text: The link is only active until #{time}! \ No newline at end of file +LinkActiveUntil time@Text: This link is only active until #{time}! \ No newline at end of file diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index bf0630997..eb35d0c2c 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -12,6 +12,7 @@ TableQualificationCountTotal: Gesamt LmsQualificationValidUntil: Gültig bis TableQualificationLastRefresh: Zuletzt erneuert TableQualificationFirstHeld: Erstmalig +TableQualificationBlockedDue: Suspendiert LmsUser: Inhaber TableLmsEmail: E-Mail TableLmsIdent: Identifikation @@ -23,12 +24,14 @@ TableLmsDelete: Löschen? TableLmsStaff: Interner Mitarbeiter? TableLmsStarted: Begonnen TableLmsReceived: Letzte Rückmeldung +TableLmsNotified: Versand Benachrichtigung TableLmsEnded: Beended TableLmsStatus: Status E-Lernen TableLmsSuccess: Bestanden TableLmsFailed: Gesperrt FilterLmsValid: Aktuell gültig FilterLmsRenewal: Erneuerung anstehend +FilterLmsNotified: Benachrichtigt CsvColumnLmsIdent: E-Lernen Identifikator, einzigartig pro Qualifikation und Teilnehmer CsvColumnLmsPin: PIN des E-Lernen Zugangs 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 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! -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. LmsActNotify: Benachrichtigung E-Lernen erneut per Post oder E-Mail versenden 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 MppClosing: Grußformel MppDate: Datum -MppURL: Link Prüfung +MppURL: Link E-Lernen MppLogin !ident-ok: Login MppPin !ident-ok: Pin MppRecipient: Empfänger diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg index 9ac082788..934be1526 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/messages/uniworx/categories/qualification/en-eu.msg @@ -12,6 +12,7 @@ TableQualificationCountTotal: Total LmsQualificationValidUntil: Valid until TableQualificationLastRefresh: Last renewed TableQualificationFirstHeld: First held +TableQualificationBlockedDue: Suspended LmsUser: Licensee TableLmsEmail: Email TableLmsIdent: Identifier @@ -23,12 +24,14 @@ TableLmsDelete: Delete? TableLmsStaff: Staff? TableLmsStarted: Started TableLmsReceived: Last update +TableLmsNotified: Notification sent TableLmsEnded: Ended TableLmsStatus: Status e-learning TableLmsSuccess: Completed TableLmsFailed: Blocked FilterLmsValid: Currently valid FilterLmsRenewal: Renewal due +FilterLmsNotified: Notified CsvColumnLmsIdent: E-learning identifier, unique for each qualification and user CsvColumnLmsPin: PIN for e-learning access CsvColumnLmsResetPin: Will the e-learning PIN be reset upon next synchronisation? @@ -48,7 +51,7 @@ MailSubjectQualificationRenewal qname@Text: Qualification #{qname} must be renew MailSubjectQualificationExpiry qname@Text: Qualification #{qname} expires soon 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! -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. LmsActNotify: Resend e-learning notification by post or email 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 MppClosing: Closing MppDate: Date -MppURL: Link Examination +MppURL: Link e-learning MppLogin: Login MppPin: Pin MppRecipient: Recipient diff --git a/messages/uniworx/categories/send/send_notifications/de-de-formal.msg b/messages/uniworx/categories/send/send_notifications/de-de-formal.msg index 88ef6d0a3..4596da948 100644 --- a/messages/uniworx/categories/send/send_notifications/de-de-formal.msg +++ b/messages/uniworx/categories/send/send_notifications/de-de-formal.msg @@ -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 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. +MailFradrive !ident-ok: FRADrive +MailBodyFradrive: ist die Führerscheinverwaltungsapp der Fraport AG. #userRightsUpdate.hs + templates MailSubjectUserRightsUpdate name@Text: Berechtigungen für #{name} aktualisiert diff --git a/messages/uniworx/categories/send/send_notifications/en-eu.msg b/messages/uniworx/categories/send/send_notifications/en-eu.msg index d9a207576..788346b73 100644 --- a/messages/uniworx/categories/send/send_notifications/en-eu.msg +++ b/messages/uniworx/categories/send/send_notifications/en-eu.msg @@ -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 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. +MailFradrive: FRADrive +MailBodyFradrive: is the apron driving licence management app of Fraport AG. #userRightsUpdate.hs + templates MailSubjectUserRightsUpdate name: Permissions for #{name} changed diff --git a/messages/uniworx/categories/settings/de-de-formal.msg b/messages/uniworx/categories/settings/de-de-formal.msg index a83448d11..3e28acf22 100644 --- a/messages/uniworx/categories/settings/de-de-formal.msg +++ b/messages/uniworx/categories/settings/de-de-formal.msg @@ -27,9 +27,10 @@ WarningDaysTip: Wie viele Tage im Voraus sollen Fristen von Prüfungen etc. auf ShowSex: Geschlechter anderer Nutzer:innen anzeigen 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! -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? 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 diff --git a/messages/uniworx/categories/settings/en-eu.msg b/messages/uniworx/categories/settings/en-eu.msg index c8b275f6e..aabf912ab 100644 --- a/messages/uniworx/categories/settings/en-eu.msg +++ b/messages/uniworx/categories/settings/en-eu.msg @@ -29,7 +29,8 @@ ShowSexTip: Should users' sex be displayed in (among others) lists of course par PDFPassword: Password to lock PDF email attachments 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? PostalTip: Mailing may incur a fee and is currently only avaulable for qualification expiry notifications, such as driving lincence renewal. PostAddress: Postal address diff --git a/messages/uniworx/utils/navigation/menu/de-de-formal.msg b/messages/uniworx/utils/navigation/menu/de-de-formal.msg index 1c8948184..a6b97fc6c 100644 --- a/messages/uniworx/utils/navigation/menu/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/menu/de-de-formal.msg @@ -130,10 +130,12 @@ MenuLmsUsers: Export E-Lernen Benutzer MenuLmsUserlist: Melden E-Lernen Benutzer MenuLmsResult: Melden Ergebnisse E-Lernen MenuLmsUpload: Hochladen -MenuLmsDirect: Direkter Upload +MenuLmsDirectUpload: Direkter Upload +MenuLmsDirectDownload: Direkter Download MenuLmsFake: Testnutzer generieren MenuAvs: Schnittstelle AVS +MenuLdap: Schnittstelle LDAP MenuApc: Druckerei MenuPrintSend: Manueller Briefversand MenuPrintDownload: Brief herunterladen diff --git a/messages/uniworx/utils/navigation/menu/en-eu.msg b/messages/uniworx/utils/navigation/menu/en-eu.msg index b0e1779d1..391796b5d 100644 --- a/messages/uniworx/utils/navigation/menu/en-eu.msg +++ b/messages/uniworx/utils/navigation/menu/en-eu.msg @@ -131,10 +131,12 @@ MenuLmsUsers: Download E-Learning Users MenuLmsUserlist: Upload E-Learning Users MenuLmsResult: Upload E-Learning Results MenuLmsUpload: Upload -MenuLmsDirect: Direct Upload +MenuLmsDirectUpload: Direct Upload +MenuLmsDirectDownload: Direct Download MenuLmsFake: Generate test users MenuAvs: AVS Interface +MenuLdap: LDAP Interface MenuApc: Printing MenuPrintSend: Send Letter MenuPrintDownload: Download Letter diff --git a/models/lms.model b/models/lms.model index 986ee5d27..02bda1bb4 100644 --- a/models/lms.model +++ b/models/lms.model @@ -1,11 +1,11 @@ Qualification - -- INVARIANT: 2*refreshWithin < validDuration + -- INVARIANT: 2*refreshWithin < validDuration school SchoolId --TODO: Ansprechpartner der Schule in Briefe erwähnen shorthand (CI Text) name (CI Text) 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 - auditDuration Word Maybe -- number of month to keep audit log; or indefinitely + validDuration Word Maybe -- qualification is valid indefinitely or for a specified number of months, use with addMonthsDay + 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 elearningStart Bool -- automatically schedule e-refresher -- elearningOnly Bool -- successful E-learing automatically increases validity. NO! @@ -18,9 +18,9 @@ Qualification -- TODOs: -- - 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?! --- A: Der Inhaber per Email informieren! +-- A: Der Inhaber per Email informieren! -- 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: -- - LmsIdent muss für alle Qualificationen einzigartig sein! @@ -33,7 +33,7 @@ Qualification QualificationPrecondition 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 deriving Generic @@ -49,20 +49,21 @@ QualificationUser user UserId OnDeleteCascade OnUpdateCascade qualification QualificationId OnDeleteCascade OnUpdateCascade validUntil Day - lastRefresh Day -- lastRefresh > validUntil possible, if Qualification^elearningOnly == False - firstHeld Day -- first time the qualification was earned, should never change + lastRefresh Day -- lastRefresh > validUntil possible, if Qualification^elearningOnly == False + 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 - -- Begründungsfeld vorsehen + -- Begründungsfeld vorsehen UniqueQualificationUser qualification user deriving Generic -- LMS Interface Tables, need regular processing by background jobs, per QualificationId: - -- - -- 1. Daily Job: Add to LmsUser daily all qualification holders with - -- QualificationUserValidUntil >= now + -- + -- 1. Daily Job: Add to LmsUser daily all qualification holders with + -- QualificationUserValidUntil >= now -- /\ QualificationUserValudUntil <= now + QualificationRefreshWithin (time to schedule refresher) - -- /\ not already enlisted - -- + -- /\ not already enlisted + -- -- 2. REST GET User.csv: -- - where LmsUserReceived == Nothing \/ (LmsUserResetPin /\ LmsUserEnded == Nothing) -- - delete-flag: isJust LmsUserStatus @@ -76,59 +77,61 @@ QualificationUser -- - For all LmsUser: -- + if contained: -- 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() -- - move row to LmsAudit -- -- 6. When received: Daily Job LmsResult: - -- - set LmsUserReceived to Just now() - -- - set LmsUserStatus to Just Day -- always + -- - set LmsUserReceived to Just now() -- always + -- - set LmsUserStatus to Just LmsSuccess now -- conditional + -- - and renew QualificationValidTo -- - move row to LmsAudit -- -- 7. Daily Job: dequeue LMS Users - -- - renew qualification, if passed -- - remove from LmsUser after audit Period has passed LmsUser qualification QualificationId OnDeleteCascade OnUpdateCascade - user UserId OnDeleteCascade OnUpdateCascade - ident LmsIdent -- must be unique accross all LMS courses! + user UserId OnDeleteCascade OnUpdateCascade + ident LmsIdent -- must be unique accross all LMS courses! pin Text - resetPin Bool default=false -- should pin be reset? - datePin UTCTime default=now() -- time pin was created - status LmsStatus Maybe -- open, success or failure; isJust indicates user will be deleted from LMS + resetPin Bool default=false -- should pin be reset? + datePin UTCTime default=now() -- time pin was created + 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 - started UTCTime default=now() - received UTCTime Maybe -- last acknowledgement by LMS - ended UTCTime Maybe -- ident was deleted from LMS + started UTCTime default=now() + received UTCTime Maybe -- last acknowledgement by 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? - 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 + 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 deriving Generic --- LmsUserlist stores LMS upload for later processing only +-- LmsUserlist stores LMS upload for later processing only LmsUserlist - qualification QualificationId OnDeleteCascade OnUpdateCascade - ident LmsIdent + qualification QualificationId OnDeleteCascade OnUpdateCascade + ident LmsIdent failed Bool - timestamp UTCTime default=now() + timestamp UTCTime default=now() UniqueLmsUserlist qualification ident deriving Generic --- LmsResult stores LMS upload for later processing only +-- LmsResult stores LMS upload for later processing only LmsResult qualification QualificationId OnDeleteCascade OnUpdateCascade - ident LmsIdent + ident LmsIdent success Day - timestamp UTCTime default=now() + timestamp UTCTime default=now() UniqueLmsResult qualification ident -- required by DBTable deriving Generic -- Logs all processed rows from LmsUserlist and LmsResult -LmsAudit +LmsAudit qualification QualificationId OnDeleteCascade OnUpdateCascade ident LmsIdent - notificationType LmsStatus -- LmsBlocked Day | LmsSuccess Day + notificationType LmsStatus -- LmsBlocked Day | LmsSuccess Day + note Text Maybe received UTCTime -- timestamp from LmsUserlist/LmsResult - processed UTCTime default=now() + processed UTCTime default=now() deriving Generic diff --git a/models/mail.model b/models/mail.model index b24420e74..a9a3209d1 100644 --- a/models/mail.model +++ b/models/mail.model @@ -3,7 +3,7 @@ SentMail sentBy InstanceId objectId MailObjectId Maybe bounceSecret BounceSecret Maybe - recipient UserId Maybe + recipient UserId Maybe OnDeleteCascade headers MailHeaders contentRef SentMailContentId deriving Generic diff --git a/nix/docker/default.nix b/nix/docker/default.nix index 98edeb160..6b3eb2268 100644 --- a/nix/docker/default.nix +++ b/nix/docker/default.nix @@ -38,6 +38,7 @@ let # just for manual testing within the pod, may be removef for production? curl wget netcat openldap unixtools.netstat htop gnugrep + locale ] ++ optionals isDemo [ postgresql_12 memcached uniworx.uniworx.components.exes.uniworxdb ]; runAsRoot = '' diff --git a/nix/docker/demo-version.json b/nix/docker/demo-version.json index 9d550df50..91c667af5 100644 --- a/nix/docker/demo-version.json +++ b/nix/docker/demo-version.json @@ -1,3 +1,3 @@ { - "version": "26.3.1" + "version": "26.5.4" } diff --git a/nix/docker/version.json b/nix/docker/version.json index 9d550df50..91c667af5 100644 --- a/nix/docker/version.json +++ b/nix/docker/version.json @@ -1,3 +1,3 @@ { - "version": "26.3.1" + "version": "26.5.4" } diff --git a/package-lock.json b/package-lock.json index cf92b247b..a492b5885 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "26.3.1", + "version": "26.5.4", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index d3655ce6a..7fae7805c 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "26.3.1", + "version": "26.5.4", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 7c9939884..7bcf21ccb 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 26.3.1 +version: 26.5.4 dependencies: - base - yesod diff --git a/routes b/routes index 2e68773a5..f1c0adf0e 100644 --- a/routes +++ b/routes @@ -62,6 +62,7 @@ /admin/tokens AdminTokensR GET POST /admin/crontab AdminCrontabR GET /admin/avs AdminAvsR GET POST +/admin/ldap AdminLdapR GET POST /print PrintCenterR GET POST !system-printer /print/send PrintSendR GET POST diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index e96b1a90d..6d408e270 100644 --- a/src/Auth/LDAP.hs +++ b/src/Auth/LDAP.hs @@ -5,7 +5,7 @@ module Auth.LDAP , ADError(..), ADInvalidCredentials(..) , campusLogin , CampusUserException(..) - , campusUser, campusUser' + , campusUser, campusUser', campusUser'' , campusUserReTest, campusUserReTest' , campusUserMatr, campusUserMatr' , 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' 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 pool mode userMatr = either (throwM . CampusUserLdapError) return <=< withLdapFailover _2 pool mode $ \(conf@LdapConf{..}, ldap) -> liftIO $ do diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 2990ca28f..455076082 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -14,6 +14,7 @@ module Database.Esqueleto.Utils , mkExactFilter, mkExactFilterWith , mkExactFilterLast, mkExactFilterLastWith , mkContainsFilter, mkContainsFilterWith + , mkDayFilter, mkDayFilterFrom, mkDayFilterTo , mkExistsFilter , anyFilter, allFilter , orderByList @@ -222,7 +223,7 @@ mkExactFilterWith cast lenslike row criterias mkExactFilterLast :: (PersistField a) => (t -> E.SqlExpr (E.Value a)) -- ^ getter from query to searched element -> t -- ^ query row - -> Last a -- ^ needle collection + -> Last a -- ^ needle -> E.SqlExpr (E.Value Bool) mkExactFilterLast = mkExactFilterLastWith id @@ -231,7 +232,7 @@ mkExactFilterLastWith :: (PersistField b) => (a -> b) -- ^ type conversion -> (t -> E.SqlExpr (E.Value b)) -- ^ getter from query to searched element -> t -- ^ query row - -> Last a -- ^ needle collection + -> Last a -- ^ needle -> E.SqlExpr (E.Value Bool) mkExactFilterLastWith cast lenslike row criterias | Last (Just crit) <- criterias = lenslike row E.==. E.val (cast crit) @@ -258,6 +259,33 @@ mkContainsFilterWith cast lenslike row criterias | Set.null criterias = true | 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 => (t -> a -> E.SqlQuery ()) -> t diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 419c3de01..f4a95c6c3 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -105,6 +105,7 @@ breadcrumb AdminErrMsgR = i18nCrumb MsgMenuAdminErrMsg $ Just AdminR breadcrumb AdminTokensR = i18nCrumb MsgMenuAdminTokens $ Just AdminR breadcrumb AdminCrontabR = i18nCrumb MsgBreadcrumbAdminCrontab $ Just AdminR breadcrumb AdminAvsR = i18nCrumb MsgMenuAvs $ Just AdminR +breadcrumb AdminLdapR = i18nCrumb MsgMenuLdap $ Just AdminR breadcrumb PrintCenterR = i18nCrumb MsgMenuApc Nothing breadcrumb PrintSendR = i18nCrumb MsgMenuPrintSend $ Just PrintCenterR @@ -819,6 +820,14 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , navQuick' = mempty , navForceActive = False } + , NavLink + { navLabel = MsgMenuLdap + , navRoute = AdminLdapR + , navAccess' = NavAccessTrue + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } ] } , return NavHeaderContainer @@ -2464,21 +2473,21 @@ pageActions (LmsR sid qsh) = return [ NavPageActionPrimary { navLink = defNavLink MsgMenuLmsUsers $ LmsUsersR sid qsh , navChildren = - [ defNavLink MsgMenuLmsDirect $ LmsUsersDirectR sid qsh + [ defNavLink MsgMenuLmsDirectDownload $ LmsUsersDirectR sid qsh ] } , NavPageActionPrimary { navLink = defNavLink MsgMenuLmsUserlist $ LmsUserlistR sid qsh , navChildren = - [ defNavLink MsgMenuLmsUpload $ LmsUserlistUploadR sid qsh - , defNavLink MsgMenuLmsDirect $ LmsUserlistDirectR sid qsh + [ defNavLink MsgMenuLmsUpload $ LmsUserlistUploadR sid qsh + , defNavLink MsgMenuLmsDirectUpload $ LmsUserlistDirectR sid qsh ] } , NavPageActionPrimary { navLink = defNavLink MsgMenuLmsResult $ LmsResultR sid qsh , navChildren = - [ defNavLink MsgMenuLmsUpload $ LmsResultUploadR sid qsh - , defNavLink MsgMenuLmsDirect $ LmsResultDirectR sid qsh + [ defNavLink MsgMenuLmsUpload $ LmsResultUploadR sid qsh + , defNavLink MsgMenuLmsDirectUpload $ LmsResultDirectR sid qsh ] } , NavPageActionSecondary { diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs index 785acc5d1..0f186b8d0 100644 --- a/src/Foundation/Yesod/Auth.hs +++ b/src/Foundation/Yesod/Auth.hs @@ -1,6 +1,7 @@ module Foundation.Yesod.Auth ( authenticate , upsertCampusUser + , decodeUserTest , CampusUserConversionException(..) , campusUserFailoverMode, updateUserLanguage ) where @@ -154,124 +155,20 @@ upsertCampusUser :: forall m. => UpsertCampusUserMode -> Ldap.AttrList [] -> SqlPersistT m (Entity User) upsertCampusUser upsertMode ldapData = do now <- liftIO getCurrentTime - UserDefaultConf{..} <- getsYesod $ view _appUserDefaults + userDefaultConf <- getsYesod $ view _appUserDefaults - let - ldapMap :: Map.Map Ldap.Attr [Ldap.AttrValue] -- Recall: Ldap.AttrValue == ByteString - ldapMap = Map.fromListWith (++) $ ldapData <&> second (filter (not . ByteString.null)) - - -- 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 ] [] + (newUser,userUpdate) <- decodeUser now userDefaultConf upsertMode ldapData + + oldUsers <- for (userLdapPrimaryKey newUser) $ \pKey -> selectKeysList [ UserLdapPrimaryKey ==. Just pKey ] [] user@(Entity userId userRec) <- case oldUsers of Just [oldUserId] -> updateGetEntity oldUserId userUpdate - _other -> upsertBy (UniqueAuthentication userIdent) newUser userUpdate - unless (validDisplayName userTitle userFirstName userSurname $ userDisplayName userRec) $ - update userId [ UserDisplayName =. userDisplayName' ] + _other -> upsertBy (UniqueAuthentication (newUser ^. _userIdent)) newUser userUpdate + unless (validDisplayName (newUser ^. _userTitle) + (newUser ^. _userFirstName) + (newUser ^. _userSurname) + (userRec ^. _userDisplayName)) $ + update userId [ UserDisplayName =. (newUser ^. _userDisplayName) ] let userSystemFunctions = determineSystemFunctions . Set.fromList $ map CI.mk userSystemFunctions' @@ -289,6 +186,141 @@ upsertCampusUser upsertMode ldapData = do 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 uid = do sfs <- selectList [StudyFeaturesUser ==. uid] [] diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 262223ac4..12d71ee45 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -9,6 +9,7 @@ import Handler.Admin.ErrorMessage as Handler.Admin import Handler.Admin.Tokens as Handler.Admin import Handler.Admin.Crontab as Handler.Admin import Handler.Admin.Avs as Handler.Admin +import Handler.Admin.Ldap as Handler.Admin getAdminR :: Handler Html getAdminR = diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index 43ef56e44..6ee40f5c3 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -51,7 +51,7 @@ validateAvsQueryStatus = do AvsQueryStatus ids <- State.get guardValidation (MsgAvsQueryStatusInvalid $ tshow ids) $ not (null ids) -getAdminAvsR, postAdminAvsR :: Handler Html +getAdminAvsR, postAdminAvsR :: Handler Html getAdminAvsR = postAdminAvsR postAdminAvsR = do mAvsQuery <- getsYesod $ view _appAvsQuery diff --git a/src/Handler/Admin/Ldap.hs b/src/Handler/Admin/Ldap.hs new file mode 100644 index 000000000..9f305fb37 --- /dev/null +++ b/src/Handler/Admin/Ldap.hs @@ -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") + diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 292388fca..dc926f280 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -178,11 +178,13 @@ data LmsTableCsv = LmsTableCsv -- L..T..C.. -> ltc.. , ltcValidUntil :: Day , ltcLastRefresh :: Day , ltcFirstHeld :: Day + , ltcBlockedDue :: Maybe QualificationBlocked , ltcLmsIdent :: Maybe LmsIdent , ltcLmsStatus :: Maybe LmsStatus , ltcLmsStarted :: Maybe UTCTime , ltcLmsDatePin :: Maybe UTCTime , ltcLmsReceived :: Maybe UTCTime + , ltcLmsNotified :: Maybe UTCTime , ltcLmsEnded :: Maybe UTCTime } deriving Generic @@ -192,19 +194,23 @@ ltcExample :: LmsTableCsv ltcExample = LmsTableCsv { ltcDisplayName = "Max Mustermann" , ltcEmail = "m.mustermann@does.not.exist" - , ltcValidUntil = compday - , ltcLastRefresh = compday - , ltcFirstHeld = compday + , ltcValidUntil = compDay + , ltcLastRefresh = compDay + , ltcFirstHeld = compDay + , ltcBlockedDue = Nothing , ltcLmsIdent = Nothing , ltcLmsStatus = Nothing - , ltcLmsStarted = Nothing + , ltcLmsStarted = Just compTime , ltcLmsDatePin = Nothing , ltcLmsReceived = Nothing + , ltcLmsNotified = Nothing , ltcLmsEnded = Nothing } where - compday :: Day - compday = utctDay $compileTime + compTime :: UTCTime + compTime = $compileTime + compDay :: Day + compDay = utctDay compTime ltcOptions :: Csv.Options 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 ("last-refresh", SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh)) , single ("first-held" , SortColumn $ queryQualUser >>> (E.^. QualificationUserFirstHeld)) + , single ("blocked-due" , SortColumn $ queryQualUser >>> (E.^. QualificationUserBlockedDue)) , single ("lms-ident" , SortColumn $ queryLmsUser >>> (E.?. LmsUserIdent)) , single ("lms-status" , SortColumn $ views (to queryLmsUser) (E.?. LmsUserStatus)) , single ("lms-started" , SortColumn $ queryLmsUser >>> (E.?. LmsUserStarted)) , single ("lms-datepin" , SortColumn $ queryLmsUser >>> (E.?. LmsUserDatePin)) , single ("lms-received", SortColumn $ queryLmsUser >>> (E.?. LmsUserReceived)) + , single ("lms-notified", SortColumn $ queryLmsUser >>> (E.?. LmsUserNotified)) , single ("lms-ended" , SortColumn $ queryLmsUser >>> (E.?. LmsUserEnded)) ] dbtFilter = mconcat @@ -356,12 +364,20 @@ mkLmsTable (Entity qid quali) acts restrict cols psValidator = do E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday | 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 [ 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 "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 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 . _qualificationUserLastRefresh) <*> view (resultQualUser . _entityVal . _qualificationUserFirstHeld) + <*> view (resultQualUser . _entityVal . _qualificationUserBlockedDue) <*> preview (resultLmsUser . _entityVal . _lmsUserIdent) <*> (join . preview (resultLmsUser . _entityVal . _lmsUserStatus)) <*> preview (resultLmsUser . _entityVal . _lmsUserStarted) <*> preview (resultLmsUser . _entityVal . _lmsUserDatePin) <*> (join . preview (resultLmsUser . _entityVal . _lmsUserReceived)) + <*> (join . preview (resultLmsUser . _entityVal . _lmsUserNotified)) <*> (join . preview (resultLmsUser . _entityVal . _lmsUserEnded)) dbtCsvDecode = Nothing 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" , colUserNameLinkHdr MsgLmsUser AdminUserR , 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 "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-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-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-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 ] where diff --git a/src/Handler/LMS/Fake.hs b/src/Handler/LMS/Fake.hs index eabd8a656..11f66a0aa 100644 --- a/src/Handler/LMS/Fake.hs +++ b/src/Handler/LMS/Fake.hs @@ -113,6 +113,7 @@ fakeQualificationUsers (Entity qid Qualification{qualificationRefreshWithin}) (u qualificationUserValidUntil = addDays expOffset expiryNotifyDay qualificationUserFirstHeld = addGregorianMonthsClip (-24) qualificationUserValidUntil qualificationUserLastRefresh = qualificationUserFirstHeld + qualificationUserBlockedDue = Nothing _ <- upsert QualificationUser{..} [ QualificationUserValidUntil =. qualificationUserValidUntil , QualificationUserLastRefresh =. qualificationUserLastRefresh diff --git a/src/Handler/LMS/Result.hs b/src/Handler/LMS/Result.hs index 6e7fbc6b2..8d5abf085 100644 --- a/src/Handler/LMS/Result.hs +++ b/src/Handler/LMS/Result.hs @@ -1,8 +1,8 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances module Handler.LMS.Result - ( getLmsResultR, postLmsResultR - , getLmsResultUploadR, postLmsResultUploadR + ( getLmsResultR, postLmsResultR + , getLmsResultUploadR, postLmsResultUploadR , postLmsResultDirectR ) where @@ -29,11 +29,11 @@ data LmsResultTableCsv = LmsResultTableCsv deriving Generic makeLenses_ ''LmsResultTableCsv --- csv without headers -- TODO not yet supported ---instance Csv.ToRecord LmsResultTableCsv -- default suffices ---instance Csv.FromRecord LmsResultTableCsv -- default suffices +-- csv without headers +instance Csv.ToRecord LmsResultTableCsv -- default suffices +instance Csv.FromRecord LmsResultTableCsv -- default suffices --- csv with headers +-- csv with headers lmsResultTableCsvHeader :: Csv.Header lmsResultTableCsvHeader = Csv.header [ csvLmsIdent, csvLmsSuccess ] @@ -73,15 +73,15 @@ deriveJSON defaultOptions , sumEncoding = TaggedObject "action" "data" } ''LmsResultCsvAction -data LmsResultCsvException +data LmsResultCsvException = LmsResultCsvExceptionDuplicatedKey -- TODO: this is not used anywhere?! deriving (Show, Generic, Typeable) instance Exception LmsResultCsvException -embedRenderMessage ''UniWorX ''LmsResultCsvException id +embedRenderMessage ''UniWorX ''LmsResultCsvException id mkResultTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget) -mkResultTable sid qsh qid = do +mkResultTable sid qsh qid = do now_day <- utctDay <$> liftIO getCurrentTime dbtCsvName <- csvFilenameLmsResult qsh 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 csvLmsSuccess) (i18nCell MsgTableLmsSuccess) $ \(view $ _dbrOutput . _entityVal . _lmsResultSuccess -> success) -> dayCell success , sortable (Just csvLmsTimestamp) (i18nCell MsgTableLmsReceived) $ \(view $ _dbrOutput . _entityVal . _lmsResultTimestamp -> timestamp) -> dateTimeCell timestamp - ] + ] dbtSorting = Map.fromList [ (csvLmsIdent , SortColumn (E.^. LmsResultIdent)) , (csvLmsSuccess , SortColumn (E.^. LmsResultSuccess)) @@ -107,72 +107,72 @@ mkResultTable sid qsh qid = do [ (csvLmsIdent , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsResultIdent)) , (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 csvLmsSuccess . maybePrism _PathPiece) mPrev $ aopt (hoistField lift dayField) (fslI MsgTableLmsSuccess) ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtParams = def dbtIdent :: Text - dbtIdent = "lms-result" - dbtCsvEncode = Just DBTCsvEncode + dbtIdent = "lms-result" + dbtCsvEncode = Just DBTCsvEncode { dbtCsvExportForm = pure () , dbtCsvDoEncode = \() -> C.map (doEncode' . view _2) - , dbtCsvName + , dbtCsvName , dbtCsvSheetName , dbtCsvNoExportData = Just id , dbtCsvHeader = const $ return lmsResultTableCsvHeader - , dbtCsvExampleData = Just - [ LmsResultTableCsv{csvLRTident = LmsIdent lid, csvLRTsuccess = LmsDay $ addDays (-dos) now_day } - | (lid,dos) <- zip ["abcdefgh", "12345678", "ident8ch"] [1..] - ] + , dbtCsvExampleData = Just + [ LmsResultTableCsv{csvLRTident = LmsIdent lid, csvLRTsuccess = LmsDay $ addDays (-dos) now_day } + | (lid,dos) <- zip ["abcdefgh", "12345678", "ident8ch"] [1..] + ] } - where + where doEncode' = LmsResultTableCsv <$> view (_dbrOutput . _entityVal . _lmsResultIdent) <*> view (_dbrOutput . _entityVal . _lmsResultSuccess . _lmsDay) dbtCsvDecode = Just DBTCsvDecode -- Just save to DB; Job will process data later - { dbtCsvRowKey = \LmsResultTableCsv{..} -> - fmap E.Value . MaybeT . getKeyBy $ UniqueLmsResult qid csvLRTident + { dbtCsvRowKey = \LmsResultTableCsv{..} -> + fmap E.Value . MaybeT . getKeyBy $ UniqueLmsResult qid csvLRTident , dbtCsvComputeActions = \case -- purpose is to show a diff to the user first - DBCsvDiffNew{dbCsvNewKey = Nothing, dbCsvNew} -> do + DBCsvDiffNew{dbCsvNewKey = Nothing, dbCsvNew} -> do yield $ LmsResultInsertData { lmsResultInsertIdent = csvLRTident dbCsvNew , 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 - DBCsvDiffExisting{dbCsvNew = LmsResultTableCsv{..}, dbCsvOld} -> do + DBCsvDiffExisting{dbCsvNew = LmsResultTableCsv{..}, dbCsvOld} -> do let successDay = lms2day csvLRTsuccess - when (successDay /= dbCsvOld ^. _dbrOutput . _entityVal . _lmsResultSuccess) $ + when (successDay /= dbCsvOld ^. _dbrOutput . _entityVal . _lmsResultSuccess) $ yield $ LmsResultUpdateData { lmsResultInsertIdent = csvLRTident , lmsResultInsertSuccess = successDay - } + } DBCsvDiffMissing{} -> return () -- no deletion - , dbtCsvClassifyAction = \case + , dbtCsvClassifyAction = \case LmsResultInsertData{} -> LmsResultInsert - LmsResultUpdateData{} -> LmsResultUpdate + LmsResultUpdateData{} -> LmsResultUpdate , dbtCsvCoarsenActionClass = \case - LmsResultInsert -> DBCsvActionNew + LmsResultInsert -> DBCsvActionNew LmsResultUpdate -> DBCsvActionExisting , dbtCsvValidateActions = return () -- no validation, since this is an automatic upload, i.e. no user to review error , dbtCsvExecuteActions = do - C.mapM_ $ \actionData -> do + C.mapM_ $ \actionData -> do now <- liftIO getCurrentTime - void $ upsert + void $ upsert LmsResult - { lmsResultQualification = qid + { lmsResultQualification = qid , lmsResultIdent = lmsResultInsertIdent actionData , lmsResultSuccess = lmsResultInsertSuccess actionData , lmsResultTimestamp = now -- lmsResultInsertTimestamp -- does it matter which one to choose? } [ LmsResultSuccess =. lmsResultInsertSuccess actionData , LmsResultTimestamp =. now - ] + ] -- audit $ Transaction.. (add to Audit.Types) lift . queueDBJob $ JobLmsResults qid - return $ LmsResultR sid qsh - , dbtCsvRenderKey = const $ \case + return $ LmsResultR sid qsh + , dbtCsvRenderKey = const $ \case LmsResultInsertData{..} -> do -- TODO: i18n [whamlet| $newline never @@ -187,7 +187,7 @@ mkResultTable sid qsh qid = do |] , dbtCsvRenderActionClass = toWidget <=< ap getMessageRender . pure , dbtCsvRenderException = ap getMessageRender . pure :: LmsResultCsvException -> DB Text - } + } dbtExtraReps = [] resultDBTableValidator = def @@ -198,9 +198,9 @@ getLmsResultR, postLmsResultR :: SchoolId -> QualificationShorthand -> Handler getLmsResultR = postLmsResultR postLmsResultR sid qsh = do let directUploadLink = LmsResultUploadR sid qsh - lmsTable <- runDB $ do - qid <- getKeyBy404 $ SchoolQualificationShort sid qsh - view _2 <$> mkResultTable sid qsh qid + lmsTable <- runDB $ do + qid <- getKeyBy404 $ SchoolQualificationShort sid qsh + view _2 <$> mkResultTable sid qsh qid siteLayoutMsg MsgMenuLmsResult $ do setTitleI MsgMenuLmsResult $(widgetFile "lms-result") @@ -211,17 +211,17 @@ postLmsResultR sid qsh = do saveResultCsv :: QualificationId -> Int -> LmsResultTableCsv -> JobDB Int saveResultCsv qid i LmsResultTableCsv{..} = do now <- liftIO getCurrentTime - void $ upsert + void $ upsert LmsResult - { lmsResultQualification = qid + { lmsResultQualification = qid , lmsResultIdent = csvLRTident , lmsResultSuccess = csvLRTsuccess & lms2day - , lmsResultTimestamp = now + , lmsResultTimestamp = now } [ LmsResultSuccess =. (csvLRTsuccess & lms2day) , LmsResultTimestamp =. now ] - return $ succ i + return $ succ i makeResultUploadForm :: Form FileInfo makeResultUploadForm = renderAForm FormStandard $ fileAFormReq "Result CSV" @@ -230,23 +230,23 @@ getLmsResultUploadR, postLmsResultUploadR :: SchoolId -> QualificationShorthand getLmsResultUploadR = postLmsResultUploadR postLmsResultUploadR sid qsh = do ((result,widget), enctype) <- runFormPost makeResultUploadForm - case result of + case result of FormSuccess file -> do - -- content <- fileSourceByteString file - -- return $ Just (fileName file, content) - nr <- runDBJobs $ do - qid <- getKeyBy404 $ SchoolQualificationShort sid qsh - nr <- runConduit $ fileSource file + -- content <- fileSourceByteString file + -- return $ Just (fileName file, content) + nr <- runDBJobs $ do + qid <- getKeyBy404 $ SchoolQualificationShort sid qsh + nr <- runConduit $ fileSource file .| decodeCsv .| foldMC (saveResultCsv qid) 0 queueDBJob $ JobLmsResults qid return nr 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 forM_ errs $ addMessage Error . toHtml - redirect $ LmsResultUploadR sid qsh - FormMissing -> + redirect $ LmsResultUploadR sid qsh + FormMissing -> siteLayoutMsg MsgMenuLmsResult $ do setTitleI MsgMenuLmsUpload [whamlet|$newline never @@ -258,31 +258,32 @@ postLmsResultUploadR sid qsh = do postLmsResultDirectR :: SchoolId -> QualificationShorthand -> Handler Html -postLmsResultDirectR sid qsh = do - (_params, files) <- runRequestBody +postLmsResultDirectR sid qsh = do + (_params, files) <- runRequestBody (status, msg) <- case files of [(fhead,file)] -> do - runDBJobs $ do - qid <- getKeyBy404 $ SchoolQualificationShort sid qsh + lmsDecoder <- getLmsCsvDecoder + runDBJobs $ do + qid <- getKeyBy404 $ SchoolQualificationShort sid qsh enr <- try $ runConduit $ fileSource file - .| decodeCsv + .| lmsDecoder .| foldMC (saveResultCsv qid) 0 - case enr of + case enr of Left (e :: SomeException) -> do -- catch all to avoid ok220 in case of any error $logWarnS "LMS" $ "Result upload failed parsing: " <> 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 - $logWarnS "LMS" msg -- TODO: change to Info Level in the future - queueDBJob $ JobLmsResults qid - return (ok200, msg) + $logInfoS "LMS" msg + when (nr > 0) $ queueDBJob $ JobLmsResults qid + return (ok200, msg) [] -> do let msg = "Result upload file missing." - $logWarnS "LMS" msg + $logWarnS "LMS" msg return (badRequest400, msg) _other -> do let msg = "Result upload received multiple files; all ignored." - $logWarnS "LMS" msg + $logWarnS "LMS" msg return (badRequest400, msg) sendResponseStatus status msg - + diff --git a/src/Handler/LMS/Userlist.hs b/src/Handler/LMS/Userlist.hs index 2a1a4cf1f..0987aa442 100644 --- a/src/Handler/LMS/Userlist.hs +++ b/src/Handler/LMS/Userlist.hs @@ -1,8 +1,8 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances module Handler.LMS.Userlist - ( getLmsUserlistR, postLmsUserlistR - , getLmsUserlistUploadR, postLmsUserlistUploadR + ( getLmsUserlistR, postLmsUserlistR + , getLmsUserlistUploadR, postLmsUserlistUploadR , postLmsUserlistDirectR ) where @@ -23,20 +23,20 @@ import Jobs.Queue data LmsUserlistTableCsv = LmsUserlistTableCsv { csvLULident :: LmsIdent - , csvLULfailed :: LmsBool + , csvLULfailed :: LmsBool } deriving Generic makeLenses_ ''LmsUserlistTableCsv --- csv without headers -- TODO not yet supported ---instance Csv.ToRecord LmsUserlistTableCsv ---instance Csv.FromRecord LmsUserlistTableCsv +-- csv without headers +instance Csv.ToRecord LmsUserlistTableCsv +instance Csv.FromRecord LmsUserlistTableCsv --- csv with headers -instance DefaultOrdered LmsUserlistTableCsv where +-- csv with headers +instance DefaultOrdered LmsUserlistTableCsv where headerOrder = const $ Csv.header [ csvLmsIdent, csvLmsBlocked ] -instance ToNamedRecord LmsUserlistTableCsv where +instance ToNamedRecord LmsUserlistTableCsv where toNamedRecord LmsUserlistTableCsv{..} = Csv.namedRecord [ csvLmsIdent Csv..= csvLULident , csvLmsBlocked Csv..= csvLULfailed @@ -57,7 +57,7 @@ instance CsvColumnsExplained LmsUserlistTableCsv where single k v = singletonMap k [whamlet|_{v}|] -data LmsUserlistCsvActionClass = LmsUserlistInsert | LmsUserlistUpdate +data LmsUserlistCsvActionClass = LmsUserlistInsert | LmsUserlistUpdate deriving (Eq, Ord, Read, Show, Generic, Typeable, Enum, Bounded) embedRenderMessage ''UniWorX ''LmsUserlistCsvActionClass id @@ -72,12 +72,12 @@ deriveJSON defaultOptions } ''LmsUserlistCsvAction -data LmsUserlistCsvException +data LmsUserlistCsvException = LmsUserlistCsvExceptionDuplicatedKey -- TODO: this is not used anywhere?! deriving (Show, Generic, Typeable) instance Exception LmsUserlistCsvException -embedRenderMessage ''UniWorX ''LmsUserlistCsvException id +embedRenderMessage ''UniWorX ''LmsUserlistCsvException id mkUserlistTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget) mkUserlistTable sid qsh qid = do @@ -105,7 +105,7 @@ mkUserlistTable sid qsh qid = do [ (csvLmsIdent , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsUserlistIdent )) , (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 csvLmsBlocked . maybePrism _PathPiece) mPrev $ aopt (hoistField lift checkBoxField) (fslI MsgTableLmsFailed) ] @@ -114,9 +114,9 @@ mkUserlistTable sid qsh qid = do dbtIdent :: Text dbtIdent = "lms-userlist" dbtCsvEncode = simpleCsvEncode dbtCsvName dbtCsvSheetName doEncode' <&> addExample - where + where addExample dce = dce{ dbtCsvExampleData = csvExample } - csvExample = Just + csvExample = Just [ LmsUserlistTableCsv{csvLULident = LmsIdent lid, csvLULfailed = LmsBool ufl} | (lid,ufl) <- zip ["abcdefgh", "12345678", "ident8ch"] [False,True,False] ] @@ -125,47 +125,47 @@ mkUserlistTable sid qsh qid = do <*> view (_dbrOutput . _entityVal . _lmsUserlistFailed . _lmsBool) dbtCsvDecode = Just DBTCsvDecode {..} where - dbtCsvRowKey = \LmsUserlistTableCsv{csvLULident} -> + dbtCsvRowKey = \LmsUserlistTableCsv{csvLULident} -> fmap E.Value . MaybeT . getKeyBy $ UniqueLmsUserlist qid csvLULident dbtCsvComputeActions = \case -- shows a diff first - DBCsvDiffNew{dbCsvNew} -> do - yield $ LmsUserlistInsertData + DBCsvDiffNew{dbCsvNew} -> do + yield $ LmsUserlistInsertData { lmsUserlistInsertIdent = csvLULident dbCsvNew , lmsUserlistInsertFailed = lms2bool $ csvLULfailed dbCsvNew } - DBCsvDiffExisting{dbCsvNew = LmsUserlistTableCsv{..}, dbCsvOld} -> do + DBCsvDiffExisting{dbCsvNew = LmsUserlistTableCsv{..}, dbCsvOld} -> do let failedBool = lms2bool csvLULfailed when (failedBool /= dbCsvOld ^. _dbrOutput . _entityVal . _lmsUserlistFailed) $ - yield $ LmsUserlistUpdateData - { lmsUserlistInsertIdent = csvLULident - , lmsUserlistInsertFailed = csvLULfailed & lms2bool + yield $ LmsUserlistUpdateData + { lmsUserlistInsertIdent = csvLULident + , lmsUserlistInsertFailed = csvLULfailed & lms2bool } - DBCsvDiffMissing{} -> return () -- no deletion - dbtCsvClassifyAction = \case + DBCsvDiffMissing{} -> return () -- no deletion + dbtCsvClassifyAction = \case LmsUserlistInsertData{} -> LmsUserlistInsert - LmsUserlistUpdateData{} -> LmsUserlistUpdate - dbtCsvCoarsenActionClass = \case - LmsUserlistInsert -> DBCsvActionNew + LmsUserlistUpdateData{} -> LmsUserlistUpdate + dbtCsvCoarsenActionClass = \case + LmsUserlistInsert -> DBCsvActionNew 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 C.mapM_ $ \actionData -> do now <- liftIO getCurrentTime void $ upsert LmsUserlist { - lmsUserlistQualification = qid + lmsUserlistQualification = qid , lmsUserlistIdent = lmsUserlistInsertIdent actionData , lmsUserlistFailed = lmsUserlistInsertFailed actionData - , lmsUserlistTimestamp = now + , lmsUserlistTimestamp = now } [ LmsUserlistFailed =. lmsUserlistInsertFailed actionData -- TODO: should we allow a reset from failed: True to False? , LmsUserlistTimestamp =. now - ] - -- audit + ] + -- audit lift . queueDBJob $ JobLmsUserlist qid return $ LmsUserlistR sid qsh - dbtCsvRenderKey = const $ \case + dbtCsvRenderKey = const $ \case LmsUserlistInsertData{..} -> do -- TODO: i18n [whamlet| $newline never @@ -195,7 +195,7 @@ mkUserlistTable sid qsh qid = do getLmsUserlistR, postLmsUserlistR :: SchoolId -> QualificationShorthand -> Handler Html -getLmsUserlistR = postLmsUserlistR +getLmsUserlistR = postLmsUserlistR postLmsUserlistR sid qsh = do lmsTable <- runDB $ do qid <- getKeyBy404 $ SchoolQualificationShort sid qsh @@ -211,17 +211,17 @@ postLmsUserlistR sid qsh = do saveUserlistCsv :: QualificationId -> Int -> LmsUserlistTableCsv -> JobDB Int saveUserlistCsv qid i LmsUserlistTableCsv{..} = do now <- liftIO getCurrentTime - void $ upsert + void $ upsert LmsUserlist - { lmsUserlistQualification = qid + { lmsUserlistQualification = qid , lmsUserlistIdent = csvLULident , lmsUserlistFailed = csvLULfailed & lms2bool - , lmsUserlistTimestamp = now + , lmsUserlistTimestamp = now } [ LmsUserlistFailed =. (csvLULfailed & lms2bool) , LmsUserlistTimestamp =. now ] - return $ succ i + return $ succ i makeUserlistUploadForm :: Form FileInfo makeUserlistUploadForm = renderAForm FormStandard $ fileAFormReq "Userlist CSV" @@ -230,19 +230,19 @@ getLmsUserlistUploadR, postLmsUserlistUploadR :: SchoolId -> QualificationShorth getLmsUserlistUploadR = postLmsUserlistUploadR postLmsUserlistUploadR sid qsh = do ((result,widget), enctype) <- runFormPost makeUserlistUploadForm - case result of + case result of FormSuccess file -> do - nr <- runDBJobs $ do - qid <- getKeyBy404 $ SchoolQualificationShort sid qsh + nr <- runDBJobs $ do + qid <- getKeyBy404 $ SchoolQualificationShort sid qsh nr <- runConduit $ fileSource file .| decodeCsv .| foldMC (saveUserlistCsv qid) 0 queueDBJob $ JobLmsUserlist qid return nr 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 forM_ errs $ addMessage Error . toHtml - redirect $ LmsUserlistUploadR sid qsh - FormMissing -> + redirect $ LmsUserlistUploadR sid qsh + FormMissing -> siteLayoutMsg MsgMenuLmsUserlist $ do setTitleI MsgMenuLmsUpload [whamlet|$newline never @@ -255,30 +255,30 @@ postLmsUserlistUploadR sid qsh = do postLmsUserlistDirectR :: SchoolId -> QualificationShorthand -> Handler Html postLmsUserlistDirectR sid qsh = do - (_params, files) <- runRequestBody + (_params, files) <- runRequestBody (status, msg) <- case files of [(fhead,file)] -> do - runDBJobs $ do - qid <- getKeyBy404 $ SchoolQualificationShort sid qsh + lmsDecoder <- getLmsCsvDecoder + runDBJobs $ do + qid <- getKeyBy404 $ SchoolQualificationShort sid qsh enr <- try $ runConduit $ fileSource file - .| decodeCsv + .| lmsDecoder .| foldMC (saveUserlistCsv qid) 0 - case enr of + case enr of Left (e :: SomeException) -> do $logWarnS "LMS" $ "Userlist upload failed parsing: " <> 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 - $logWarnS "LMS" msg -- TODO: change to Info Level in the future - queueDBJob $ JobLmsResults qid + $logInfoS "LMS" msg + when (nr > 0) $ queueDBJob $ JobLmsUserlist qid return (ok200, msg) [] -> do let msg = "Userlist upload file missing." - $logWarnS "LMS" msg + $logWarnS "LMS" msg return (badRequest400, msg) _other -> do let msg = "Userlist upload received multiple files; all ignored." - $logWarnS "LMS" msg + $logWarnS "LMS" msg return (badRequest400, msg) sendResponseStatus status msg - \ No newline at end of file diff --git a/src/Handler/LMS/Users.hs b/src/Handler/LMS/Users.hs index 57954e912..216c74270 100644 --- a/src/Handler/LMS/Users.hs +++ b/src/Handler/LMS/Users.hs @@ -27,30 +27,30 @@ data LmsUserTableCsv = LmsUserTableCsv -- for csv export only , csvLUTresetPin, csvLUTdelete, csvLUTstaff :: LmsBool } deriving Generic -makeLenses_ ''LmsUserTableCsv +makeLenses_ ''LmsUserTableCsv -- | Mundane conversion needed for direct download without dbTable onlu lmsUser2csv :: LmsUser -> LmsUserTableCsv lmsUser2csv lu@LmsUser{..} = LmsUserTableCsv - { csvLUTident = lmsUserIdent + { csvLUTident = lmsUserIdent , csvLUTpin = lmsUserPin - , csvLUTresetPin = lmsUserResetPin & LmsBool + , csvLUTresetPin = lmsUserResetPin & LmsBool , csvLUTdelete = lmsUserToDelete lu & LmsBool , csvLUTstaff = False & LmsBool } --- csv without headers -- TODO not yet supported --- instance Csv.ToRecord LmsUserTableCsv --- instance Csv.FromRecord LmsUserTableCsv +-- csv without headers +instance Csv.ToRecord LmsUserTableCsv +instance Csv.FromRecord LmsUserTableCsv --- csv with headers +-- csv with headers lmsUserTableCsvHeader :: Csv.Header lmsUserTableCsvHeader = Csv.header [ csvLmsIdent, csvLmsPin, csvLmsResetPin, csvLmsDelete, csvLmsStaff ] -instance ToNamedRecord LmsUserTableCsv where +instance ToNamedRecord LmsUserTableCsv where toNamedRecord LmsUserTableCsv{..} = Csv.namedRecord [ csvLmsIdent Csv..= csvLUTident - , csvLmsPin Csv..= csvLUTpin + , csvLmsPin Csv..= csvLUTpin , csvLmsResetPin Csv..= csvLUTresetPin , csvLmsDelete Csv..= csvLUTdelete , csvLmsStaff Csv..= csvLUTstaff @@ -79,14 +79,14 @@ instance CsvColumnsExplained LmsUserTableCsv where mkUserTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget) -mkUserTable _sid qsh qid = do +mkUserTable _sid qsh qid = do dbtCsvName <- csvFilenameLmsUser qsh let dbtCsvSheetName = dbtCsvName let userDBTable = DBTable{..} where 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) return lmsuser dbtRowKey = (E.^. LmsUserId) @@ -94,7 +94,7 @@ mkUserTable _sid qsh qid = do dbtColonnade = dbColonnade $ mconcat [ 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)] - ) $ \(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 csvLmsDelete) (i18nCell MsgTableLmsDelete) $ \(view $ _dbrOutput . _entityVal . _lmsUserToDelete -> del ) -> ifIconCell del IconRemoveUser , sortable Nothing (i18nCell MsgTableLmsStaff) $ const mempty @@ -109,16 +109,16 @@ mkUserTable _sid qsh qid = do [ (csvLmsIdent , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsUserIdent )) , (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 csvLmsResetPin . maybePrism _PathPiece) mPrev $ aopt (hoistField lift checkBoxField) (fslI MsgTableLmsResetPin) ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtParams = def dbtIdent :: Text - dbtIdent = "lms-user" + dbtIdent = "lms-user" dbtCsvEncode = Just DBTCsvEncode {..} - where + where dbtCsvExportForm = pure () dbtCsvNoExportData = Just id dbtCsvExampleData = Nothing @@ -129,7 +129,7 @@ mkUserTable _sid qsh qid = do <*> view (_dbrOutput . _entityVal . _lmsUserPin) <*> view (_dbrOutput . _entityVal . _lmsUserResetPin . _lmsBool) <*> view (_dbrOutput . _entityVal . _lmsUserToDelete . _lmsBool) - <*> const (LmsBool False) + <*> const (LmsBool False) dbtCsvDecode = Nothing dbtExtraReps = [] @@ -140,9 +140,9 @@ mkUserTable _sid qsh qid = do getLmsUsersR :: SchoolId -> QualificationShorthand -> Handler Html getLmsUsersR sid qsh = do - lmsTable <- runDB $ do - qid <- getKeyBy404 $ SchoolQualificationShort sid qsh - view _2 <$> mkUserTable sid qsh qid + lmsTable <- runDB $ do + qid <- getKeyBy404 $ SchoolQualificationShort sid qsh + view _2 <$> mkUserTable sid qsh qid siteLayoutMsg MsgMenuLmsUsers $ do setTitleI MsgMenuLmsUsers $(widgetFile "lms-user") @@ -150,26 +150,34 @@ getLmsUsersR sid qsh = do getLmsUsersDirectR :: SchoolId -> QualificationShorthand -> Handler TypedContent getLmsUsersDirectR sid qsh = do lms_users <- runDB $ do - qid <- getKeyBy404 $ SchoolQualificationShort sid qsh - 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 - Ex.select $ do + qid <- getKeyBy404 $ SchoolQualificationShort sid qsh + 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 + Ex.select $ do 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) pure $ LmsUserTableCsv - { csvLUTident = lmsuser Ex.^. LmsUserIdent - , csvLUTpin = lmsuser Ex.^. LmsUserPin + { csvLUTident = lmsuser Ex.^. LmsUserIdent + , csvLUTpin = lmsuser Ex.^. LmsUserPin , csvLUTresetPin = LmsBool . Ex.unValue $ lmsuser Ex.^. LmsUserResetPin , csvLUTdelete = LmsBool . Ex.unValue $ Ex.isNothing (lmsuser Ex.^. LmsUserEnded) Ex.&&. Ex.not_ (Ex.isNothing $ lmsuser Ex.^. LmsUserStatus) , csvLUTstaff = LmsBool False } - -} - let csvRenderedData = toNamedRecord . lmsUser2csv . entityVal <$> lms_users - csvRenderedHeader = lmsUserTableCsvHeader - csvSheetName <- csvFilenameLmsUser qsh + -} + LmsConf{..} <- getsYesod $ view _appLmsConf + let --csvRenderedData = toNamedRecord . lmsUser2csv . entityVal <$> lms_users + --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 <> "\"" - csvRenderedToTypedContent csvSheetName CsvRendered{..} - + csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered + -- direct Download see: -- https://ersocon.net/blog/2017/2/22/creating-csv-files-in-yesod \ No newline at end of file diff --git a/src/Handler/PrintCenter.hs b/src/Handler/PrintCenter.hs index 2768ff791..784ce47a1 100644 --- a/src/Handler/PrintCenter.hs +++ b/src/Handler/PrintCenter.hs @@ -3,7 +3,7 @@ module Handler.PrintCenter ( getPrintCenterR, postPrintCenterR , getPrintSendR , postPrintSendR - , getPrintDownloadR + , getPrintDownloadR ) where import Import @@ -98,10 +98,10 @@ mprToMeta MetaPinRenewal{..} = mkMeta where deOrEn = if isDe mppLang then "de" else "en" keyOpening = deOrEn <> "-opening" - keyClosing = deOrEn <> "-closing" + keyClosing = deOrEn <> "-closing" 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` meta = mprToMeta mpr{ mppRecipient = userDisplayName u -- , 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 currentRoute <- fromMaybe (error "mkPJTable called from 404-handler") <$> liftHandler getCurrentRoute -- albeit we do know the route here let - showId :: PrintJobId -> Widget - showId k = do - c <- encrypt k - let f :: CryptoUUIDPrintJob -> Text - f x = toPathPiece x - [whamlet|#{f c}|] dbtSQLQuery = pjTableQuery dbtRowKey = queryPrintJob >>> (E.^. PrintJobId) dbtProj = dbtProjFilteredPostId @@ -196,11 +190,10 @@ mkPJTable = do [ dbSelectIf (applying _2) id (return . view (resultPrintJob . _entityKey)) (\r -> isNothing $ r ^. resultPrintJob . _entityVal . _printJobAcknowledged) , sortable (Just "pj-created") (i18nCell MsgPrintJobCreated) $ \( view $ resultPrintJob . _entityVal . _printJobCreated -> t) -> dateTimeCell t , sortable (Just "pj-acknowledged") (i18nCell MsgPrintJobAcknowledged) $ \( view $ resultPrintJob . _entityVal . _printJobAcknowledged -> t) -> maybeDateTimeCell t - , sortable (Just "pj-filename") (i18nCell MsgPrintJobFilename) $ \( view $ resultPrintJob . _entityVal . _printJobFilename -> t) -> textCell t - , sortable (toNothingS "pdf") (i18nCell MsgPrintPDF) $ \( view $ resultPrintJob . _entityKey -> k) -> anchorCellM (PrintDownloadR <$> encrypt k) (showId k) - -- , sortable (Just "pj-id") (i18nCell MsgPrintJobId) $ \( view $ resultPrintJob . _entityKey -> k) -> textCell (tshow . E.unSqlBackendKey $ unPrintJobKey k) - -- , 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-filename") (i18nCell MsgPrintPDF) $ \r -> let k = r ^. resultPrintJob . _entityKey + t = r ^. resultPrintJob . _entityVal . _printJobFilename + in anchorCellM (PrintDownloadR <$> encrypt k) (toWgt t) + , sortable (Just "pj-name") (i18nCell MsgPrintJobName) $ \( view $ resultPrintJob . _entityVal . _printJobName -> n) -> textCell n , sortable (Just "pj-recipient") (i18nCell MsgPrintRecipient) $ \(preview resultRecipient -> u) -> maybeCell u $ cellHasUserLink AdminUserR , sortable (Just "pj-sender") (i18nCell MsgPrintSender) $ \(preview resultSender -> u) -> maybeCell u $ cellHasUserLink AdminUserR , sortable (Just "pj-course") (i18nCell MsgPrintCourse) $ \(preview $ resultCourse . _entityVal -> c) -> maybeCell c courseCell @@ -209,7 +202,6 @@ mkPJTable = do dbtSorting = mconcat [ single ("pj-name" , SortColumn $ queryPrintJob >>> (E.^. PrintJobName)) , single ("pj-filename" , SortColumn $ queryPrintJob >>> (E.^. PrintJobFilename)) - -- , single ("pj-id" , SortColumn $ queryPrintJob >>> (E.^. PrintJobId)) , single ("pj-created" , SortColumn $ queryPrintJob >>> (E.^. PrintJobCreated)) , single ("pj-acknowledged" , SortColumn $ queryPrintJob >>> (E.^. PrintJobAcknowledged)) , single ("pj-recipient" , sortUserNameBareM queryRecipient) @@ -220,6 +212,8 @@ mkPJTable = do dbtFilter = mconcat [ single ("pj-name" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobName)) , single ("pj-filename" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobFilename)) + , single ("pj-created" , FilterColumn . E.mkDayFilter $ views (to queryPrintJob) (E.^. PrintJobCreated)) + --, single ("pj-created" , FilterColumn . E.mkDayBetweenFilter $ views (to queryPrintJob) (E.^. PrintJobCreated)) , single ("pj-recipient" , FilterColumn . E.mkContainsFilterWith Just $ views (to queryRecipient) (E.?. UserDisplayName)) , single ("pj-sender" , FilterColumn . E.mkContainsFilterWith Just $ views (to querySender) (E.?. UserDisplayName)) , single ("pj-course" , FilterColumn . E.mkContainsFilterWith Just $ views (to queryCourse) (E.?. CourseName)) @@ -227,8 +221,12 @@ mkPJTable = do , single ("acknowledged" , FilterColumn . E.mkExactFilterLast $ views (to queryPrintJob) (E.isJust . (E.^. PrintJobAcknowledged))) ] 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-sender" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintSender) , 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 -- addMessage Warning "PDF momentan nur gespeicher unter /tmp/generated.pdf" 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 let msg = "PDF printing failed with error: " <> err $logErrorS "LPR" msg addMessage Error $ toHtml msg pure False - Right (ok, fpath) -> do + Right (ok, fpath) -> do let response = if null ok then mempty else " Response: " <> ok addMessage Success $ toHtml $ "Druckauftrag angelegt: " <> pack fpath <> response pure True @@ -325,7 +323,7 @@ postPrintSendR = do pure False when (or oks) $ redirect PrintCenterR formResult sendResult procFormSend - -- actionUrl <- fromMaybe AdminAvsR <$> getCurrentRoute + -- actionUrl <- fromMaybe AdminAvsR <$> getCurrentRoute siteLayoutMsg MsgPrintManualRenewal $ do setTitleI MsgMenuPrintSend let sendForm = wrapForm sendWidget def diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index b014a6a4e..3b79e91f7 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -439,11 +439,14 @@ validateSettings :: User -> FormValidator SettingsForm Handler () validateSettings User{..} = do userDisplayName' <- use _stgDisplayName 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 - guardValidation MsgPDFPasswordInvalid $ - validCmdArgument userPinPassword' -- used as CMD argument for pdftk + let pinBad = validCmdArgument userPinPassword' + pinMinChar = 5 + whenIsJust pinBad (tellValidationError . MsgPDFPasswordInvalid) -- used as CMD argument for pdftk + guardValidation (MsgPDFPasswordTooShort pinMinChar) $ pinMinChar <= length userPinPassword' userPostAddress' <- use _stgPostAddress let postalNotSet = isNothing userPostAddress' diff --git a/src/Handler/Utils/Csv.hs b/src/Handler/Utils/Csv.hs index 813527281..b9581486f 100644 --- a/src/Handler/Utils/Csv.hs +++ b/src/Handler/Utils/Csv.hs @@ -1,7 +1,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Handler.Utils.Csv - ( decodeCsv, decodeCsvPositional + ( decodeCsv, decodeCsvPositional, decodeCsvWith , encodeCsv, encodeCsvWith, encodeCsvRendered, encodeCsvRenderedWith , csvRenderedToTypedContent, csvRenderedToTypedContentWith , 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 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. ( MonadHandler m, HandlerSite m ~ UniWorX diff --git a/src/Handler/Utils/DateTime.hs b/src/Handler/Utils/DateTime.hs index 550175e02..fb82e3d6d 100644 --- a/src/Handler/Utils/DateTime.hs +++ b/src/Handler/Utils/DateTime.hs @@ -4,7 +4,7 @@ module Handler.Utils.DateTime ( utcToLocalTime, utcToZonedTime , localTimeToUTC, TZ.LocalToUTCResult(..), localTimeToUTCSimple , toTimeOfDay - , toMidnight, beforeMidnight, toMidday, toMorning + , toMidnight, beforeMidnight, toMidday, toMorning, addHours , formatDiffDays, formatCalendarDiffDays , formatTime' , formatTime, formatTimeUser, formatTimeW, formatTimeMail @@ -12,9 +12,10 @@ module Handler.Utils.DateTime , getTimeLocale, getDateTimeFormat , getDateTimeFormatter , validDateTimeFormats, dateTimeFormatOptions - , addLocalDays, addDiffDays, addMonths + , addLocalDays + , addDiffDaysClip, addDiffDaysRollOver , addOneWeek, addWeeks - , fromMonths + , fromDays, fromMonths , weeksToAdd , setYear, getYear , firstDayOfWeekOnAfter @@ -73,6 +74,9 @@ toMorning = toTimeOfDay 6 0 0 toTimeOfDay :: Int -> Int -> Pico -> Day -> UTCTime toTimeOfDay todHour todMin todSec d = localTimeToUTCTZ appTZ $ LocalTime d TimeOfDay{..} +addHours :: Integer -> UTCTime -> UTCTime +addHours = addUTCTime . secondsToNominalDiffTime . fromInteger . (* 3600) + instance HasLocalTime UTCTime where toLocalTime = utcToLocalTime @@ -261,15 +265,17 @@ addLocalDays n utct = localTimeToUTCTZ appTZ newLocal -- CalendarDiffDays -- ---------------------- -fromMonths :: Word -> CalendarDiffDays -fromMonths m = scaleCalendarDiffDays (toInteger m) calendarMonth --- fromMonths m = CalendarDiffDays { cdMonths = m, cdDays = 0 } -- above is equivalent +fromMonths :: Integral a => a -> CalendarDiffDays +fromMonths (toInteger -> m) = CalendarDiffDays { cdMonths = m, cdDays = 0 } -- above is equivalent -addDiffDays :: CalendarDiffDays -> UTCTime -> UTCTime -addDiffDays = over _utctDay . addGregorianDurationClip +fromDays :: Integral a => a -> CalendarDiffDays +fromDays (toInteger -> d) = CalendarDiffDays { cdMonths = 0, cdDays = d } -addMonths :: Word -> UTCTime -> UTCTime -addMonths = addDiffDays . fromMonths +addDiffDaysClip :: CalendarDiffDays -> UTCTime -> UTCTime +addDiffDaysClip = over _utctDay . addGregorianDurationClip + +addDiffDaysRollOver :: CalendarDiffDays -> UTCTime -> UTCTime +addDiffDaysRollOver = over _utctDay . addGregorianDurationRollOver weeksToAdd :: UTCTime -> UTCTime -> Integer -- ^ Number of weeks needed to add so that first diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index bb5903487..2c00f2317 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -2067,6 +2067,7 @@ csvFormatOptionsForm fs mPrev = hoistAForm liftHandler . multiActionA csvActs fs <*> apreq (selectField lineEndOpts) (fslI MsgCsvUseCrLf) (preview _csvUseCrLf =<< mPrev) <*> apreq (selectField quoteOpts) (fslI MsgCsvQuoting & setTooltip MsgCsvQuotingTip) (preview _csvQuoting =<< mPrev) <*> apreq (selectField encodingOpts) (fslI MsgCsvEncoding & setTooltip MsgCsvEncodingTip) (preview _csvEncoding =<< mPrev) + <*> pure True FormatXlsx -> pure CsvXlsxFormatOptions delimiterOpts :: Handler (OptionList Char) diff --git a/src/Handler/Utils/LMS.hs b/src/Handler/Utils/LMS.hs index 3cd3e3403..7556085ca 100644 --- a/src/Handler/Utils/LMS.hs +++ b/src/Handler/Utils/LMS.hs @@ -1,17 +1,18 @@ {-# OPTIONS -Wno-redundant-constraints #-} -- needed for Getter module Handler.Utils.LMS - ( csvLmsIdent + ( getLmsCsvDecoder + , csvLmsIdent , csvLmsTimestamp , csvLmsBlocked , csvLmsSuccess - , csvLmsPin + , csvLmsPin , csvLmsResetPin - , csvLmsDelete - , csvLmsStaff - , csvFilenameLmsUser + , csvLmsDelete + , csvLmsStaff + , csvFilenameLmsUser , csvFilenameLmsUserlist - , csvFilenameLmsResult + , csvFilenameLmsResult , lmsUserToDelete, _lmsUserToDelete , lmsUserToDeleteExpr , randomLMSIdent, randomLMSpw, maxLmsUserIdentRetries @@ -19,14 +20,30 @@ module Handler.Utils.LMS -- general utils for LMS Interface Handlers -import Import +import Import import Handler.Utils +import Handler.Utils.Csv +import Data.Csv (HasHeader(..), FromRecord) + import qualified Database.Esqueleto.Legacy as E import Control.Monad.Random.Class (uniform) 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 = 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 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 :: Getter LmsUser Bool +_lmsUserToDelete :: Getter LmsUser Bool _lmsUserToDelete = to lmsUserToDelete -- random generation of LmsIdentifiers, maybe this should be in Model.Types.Lms since length specifications are type-y? -lengthIdent :: Int -lengthIdent = 8 +lengthIdent :: Int +lengthIdent = 8 -lengthPassword :: Int -lengthPassword = 8 +lengthPassword :: Int +lengthPassword = 8 --- | Maximal number of times, randomLMSIdent should be called in a row to find an unused LmsIdent -maxLmsUserIdentRetries :: Int +-- | Maximal number of times, randomLMSIdent should be called in a row to find an unused LmsIdent +maxLmsUserIdentRetries :: Int maxLmsUserIdentRetries = 27 -- | Generate Random Text of specified length using numbers and lower case letters plus supplied extra characters -randomText :: MonadIO m => String -> Int -> m Text -randomText extra n = fmap pack . evalRandTIO . replicateM n $ uniform range - where +randomText :: MonadIO m => String -> Int -> m Text +randomText extra n = fmap pack . evalRandTIO . replicateM n $ uniform range + where num_letters = ['0'..'9'] ++ ['a'..'z'] range = extra ++ num_letters --TODO: consider using package elocrypt for user-friendly passwords here, licence requires mentioning of author, etc. though -- import qualified Data.Elocrypt as Elo --- randomLMSIdent :: MonadRandom m => m LmsIdent --- randomLMSIdent = LmsIdent . T.pack <$> Elo.mkPassword lengthIdent eopt --- where +-- randomLMSIdent :: MonadRandom m => m LmsIdent +-- randomLMSIdent = LmsIdent . T.pack <$> Elo.mkPassword lengthIdent eopt +-- where -- eopt = Elo.genOptions -- { genCapitals = False, genSpecials = False, genDigitis = True } -randomLMSIdent :: MonadIO m => m LmsIdent +randomLMSIdent :: MonadIO m => m LmsIdent randomLMSIdent = LmsIdent <$> randomText [] lengthIdent -randomLMSpw :: MonadIO m => m Text +randomLMSpw :: MonadIO m => m Text randomLMSpw = randomText extra lengthPassword - where - extra = "_-+*.:;=!?#" - \ No newline at end of file + where + extra = "-+*.:;=!?#$" diff --git a/src/Handler/Utils/Profile.hs b/src/Handler/Utils/Profile.hs index 082048456..7732d66af 100644 --- a/src/Handler/Utils/Profile.hs +++ b/src/Handler/Utils/Profile.hs @@ -14,12 +14,16 @@ import qualified Data.Text.Lazy as LT import qualified Data.MultiSet as MultiSet 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". -- Input "givennames surname" is left unchanged, except for removing excess whitespace fixDisplayName :: UserDisplayName -> UserDisplayName fixDisplayName 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 checkDisplayName :: Maybe UserTitle -> UserFirstName -> UserSurname -> UserDisplayName -> Maybe UserDisplayName @@ -32,7 +36,7 @@ validDisplayName :: Maybe UserTitle -> UserSurname -> UserDisplayName -> 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] , sName `Text.isInfixOf` 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) splitAdd = Text.split isAdd makeMultiSet = MultiSet.fromList . filter (not . Text.null) . splitAdd + -- | Primitive postal address requires at least one alphabetic character, one digit and a line break validPostAddress :: Maybe StoredMarkup -> Bool diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 1c0034189..31a157e9b 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -315,4 +315,8 @@ lmsStatusCell :: IsDBTable m a => LmsStatus -> DBCell m a lmsStatusCell ls = iconCell ic <> spacerCell <> dayCell (lmsStatusDay ls) where ic | isLmsSuccess ls = IconOK - | otherwise = IconNotOK \ No newline at end of file + | otherwise = IconNotOK + +qualificationBlockedCell :: IsDBTable m a => Maybe QualificationBlocked -> DBCell m a +qualificationBlockedCell Nothing = mempty +qualificationBlockedCell (Just qb) = iconCell IconBlocked <> msgCell qb <> dayCell (qualificationBlockedDay qb) diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index a23ca6467..9b0a275dd 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -1,15 +1,15 @@ {-# LANGUAGE TypeApplications #-} -module Jobs.Handler.LMS +module Jobs.Handler.LMS ( dispatchJobLmsQualificationsEnqueue , dispatchJobLmsQualificationsDequeue , dispatchJobLmsEnqueue, dispatchJobLmsEnqueueUser , dispatchJobLmsDequeue , dispatchJobLmsResults , dispatchJobLmsUserlist - ) where + ) where -import Import +import Import import Jobs.Queue -- 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.Utils as E -import Handler.Utils.DateTime (fromMonths, addMonths) +import Handler.Utils.DateTime import Handler.Utils.LMS (randomLMSIdent, randomLMSpw, maxLmsUserIdentRetries) +import qualified Data.CaseInsensitive as CI + dispatchJobLmsQualificationsEnqueue :: JobHandler UniWorX -dispatchJobLmsQualificationsEnqueue = JobHandlerAtomic act - where - 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 +dispatchJobLmsQualificationsEnqueue = JobHandlerAtomic $ fetchRefreshQualifications JobLmsEnqueue + +dispatchJobLmsQualificationsDequeue :: JobHandler UniWorX +dispatchJobLmsQualificationsDequeue = JobHandlerAtomic $ fetchRefreshQualifications JobLmsDequeue + +-- execute given job for all qualifications that allow refreshs +fetchRefreshQualifications :: (QualificationId -> Job) -> YesodJobDB UniWorX () +fetchRefreshQualifications qidJob = do + qids <- E.select $ do + q <- E.from $ E.table @Qualification + 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 dispatchJobLmsEnqueue :: QualificationId -> JobHandler UniWorX dispatchJobLmsEnqueue qid = JobHandlerAtomic act - where + where -- act :: YesodJobDB UniWorX () - act = do - $logInfoS "lms" $ "Start e-learning users for qualification " <> tshow qid <> "." + act = do quali <- getJust qid -- may throw an error, aborting the job - now <- liftIO getCurrentTime - case qualificationRefreshWithin quali of - Nothing -> return () -- no automatic scheduling for this qid + let qshort = CI.original $ qualificationShorthand quali + $logInfoS "lms" $ "Notifying about exipiring qualification " <> qshort + now <- liftIO getCurrentTime + case qualificationRefreshWithin quali of + Nothing -> return () -- no automatic scheduling for this qid (Just renewalPeriod) -> do let now_day = utctDay now renewalDate = addGregorianDurationClip renewalPeriod now_day renewalUsers <- E.select $ do - quser <- E.from $ E.table @QualificationUser - E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid + quser <- E.from $ E.table @QualificationUser + 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 renewalDate E.&&. E.notExists (do 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 ) pure quser - let usr_job :: Entity QualificationUser -> Job - usr_job quser = - let uid = quser ^. _entityVal . _qualificationUserUser + let usr_job :: Entity QualificationUser -> Job + usr_job quser = + let uid = quser ^. _entityVal . _qualificationUserUser uex = quser ^. _entityVal . _qualificationUserValidUntil in if qualificationElearningStart quali then JobLmsEnqueueUser { jQualification = qid, jUser = uid } - else JobSendNotification { jRecipient = uid, jNotification = + else JobSendNotification { jRecipient = uid, jNotification = NotificationQualificationExpiry { nQualification = qid, nExpiry = uex } } 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 qid uid = JobHandlerAtomic act - where +dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act + where act :: YesodJobDB UniWorX () - act = do + act = do now <- liftIO getCurrentTime let mkLmsUser lid lpin = LmsUser { lmsUserQualification = qid - , lmsUserUser = uid - , lmsUserIdent = lid - , lmsUserPin = lpin - , lmsUserResetPin = False + , lmsUserUser = uid + , lmsUserIdent = lid + , lmsUserPin = lpin + , lmsUserResetPin = False , lmsUserDatePin = now , lmsUserStatus = Nothing - , lmsUserStarted = now + , lmsUserStarted = now , lmsUserReceived = Nothing - , lmsUserEnded = Nothing + , lmsUserNotified = Nothing + , lmsUserEnded = Nothing } -- startLmsUser :: YesodJobDB UniWorX (Maybe (Entity LmsUser)) startLmsUser = E.insertUniqueEntity =<< (mkLmsUser <$> randomLMSIdent <*> randomLMSpw) inserted <- untilJustMaxM maxLmsUserIdentRetries startLmsUser - case inserted of - Nothing -> $logErrorS "LMS" $ "Generating and inserting fresh LmsIdent failed for uid " <> tshow uid <> " and qid " <> tshow qid <> "!" - (Just _) -> queueDBJob JobSendNotification { jRecipient = uid, jNotification = - NotificationQualificationRenewal { nQualification = qid } - } + case inserted of + Nothing -> do + uuid :: CryptoUUIDUser <- encrypt uid + $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 -dispatchJobLmsQualificationsDequeue = JobHandlerAtomic act +-- purge LmsIdent adter QualificationAuditDuration expired +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 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 - $logInfoS "lms" $ "Process e-learning results for qualification " <> tshow qid <> "." - 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 + now <- liftIO getCurrentTime -- result :: [(Entity LmsUser, Entity LmsUserlist)] - results <- E.select $ do - (luser E.:& lulist) <- E.from $ + results <- E.select $ do + (luser E.:& lulist) <- E.from $ 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.where_ $ luser E.^. LmsUserQualification E.==. E.val qid E.&&. E.isNothing (luser E.^. LmsUserEnded) -- do not process closed learners return (luser, lulist) - forM_ results $ \case - (Entity luid luser, Nothing) - | isJust $ lmsUserReceived luser - , isNothing $ lmsUserEnded luser -> + forM_ results $ \case + (Entity luid luser, Nothing) + | isJust $ lmsUserReceived luser -- mark all previuosly reported, but now unreported users as ended (LMS deleted them as expected) + , isNothing $ lmsUserEnded luser -> 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 isBlocked = lmsUserlistFailed lulist - newStatus = LmsBlocked $ utctDay lReceived - oldStatus = lmsUserStatus luser - update luid [ LmsUserStatus =. (oldStatus <> toMaybe isBlocked newStatus) - , LmsUserReceived =. Just lReceived ] - when isBlocked . insert_ $ LmsAudit qid (lmsUserIdent luser) newStatus lReceived now -- always log blocked - delete lulid - + update luid [LmsUserReceived =. Just lReceived] + when isBlocked $ do + let newStatus = LmsBlocked $ utctDay lReceived + oldStatus = lmsUserStatus luser + insert_ $ LmsAudit qid (lmsUserIdent luser) newStatus (Just $ "Old Status was " <> tshow oldStatus) lReceived now + 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|] diff --git a/src/Jobs/Handler/SendNotification/Qualification.hs b/src/Jobs/Handler/SendNotification/Qualification.hs index 52334c689..35778e8c4 100644 --- a/src/Jobs/Handler/SendNotification/Qualification.hs +++ b/src/Jobs/Handler/SendNotification/Qualification.hs @@ -49,7 +49,7 @@ dispatchNotificationQualificationExpiry nQualification _nExpiry jRecipient = use -- NOTE: qualificationRenewal expects that LmsUser already exists for recipient dispatchNotificationQualificationRenewal :: QualificationId -> UserId -> Handler () dispatchNotificationQualificationRenewal nQualification jRecipient = do - (recipient@User{..}, Qualification{..}, Entity _ QualificationUser{..}, Entity _ LmsUser{..}) <- runDB $ (,,,) + (recipient@User{..}, Qualification{..}, Entity _ QualificationUser{..}, Entity luid LmsUser{..}) <- runDB $ (,,,) <$> getJust jRecipient <*> getJust nQualification <*> getJustBy (UniqueQualificationUser nQualification jRecipient) @@ -59,62 +59,74 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do let entRecipient = Entity jRecipient recipient 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 letterDate <- formatTimeUser SelFormatDate now $ Just entRecipient expiryDate <- formatTimeUser SelFormatDate qualificationUserValidUntil $ Just entRecipient let printJobName = "RenewalPin" - prepAddress upa = userDisplayName : (upa & html2textlines) -- TODO: use supervisor's address - pdfMeta = mkMeta + fileName = printJobName <> "_" <> abbrvName recipient <> ".pdf" + 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 "lang" (selectDeEn userLanguages) -- select either German or English only, see Utils.Lang - , toMeta "login" (lmsUserIdent & getLmsIdent) + , toMeta "login" lmsIdent , toMeta "pin" lmsUserPin , toMeta "recipient" userDisplayName , mbMeta "address" (prepAddress <$> userPostAddress) , toMeta "expiry" expiryDate , mbMeta "validduration" (show <$> qualificationValidDuration) + , toMeta "url-text" lmsUrl + , toMeta "url" lmsLogin ] - pdfRenewal pdfMeta >>= \case - Left err -> do - let msg = "Notify " <> tshow encRecipient <> " PDF generation failed with error: " <> err - $logErrorS "LMS" msg - error $ unpack msg - - Right pdf | userPrefersLetter recipient -> do - let printSender = Nothing - runDB (sendLetter printJobName pdf printSender (Just jRecipient) Nothing (Just nQualification)) >>= \case - 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 + emailRenewal attachment = do + when (Text.null (CI.original userEmail)) $ do + let msg = "Notify " <> tshow encRecipient <> " failed: no email nor address for user known!" + $logErrorS "LMS" msg + error $ unpack msg -- if neither email nor postal address is known, we must abort! + userMailT jRecipient $ do + replaceMailHeader "Auto-Submitted" $ Just "auto-generated" + setSubjectI $ MsgMailSubjectQualificationRenewal qname + whenIsJust attachment $ \afile -> addPart (File { fileTitle = Text.unpack fileName , fileModified = now - , fileContent = Just $ yield $ LBS.toStrict pdffile + , fileContent = Just $ yield $ LBS.toStrict afile } :: PureFile) + editNotifications <- mkEditNotifications jRecipient + addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/qualificationRenewal.hamlet") - editNotifications <- mkEditNotifications jRecipient - addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/qualificationRenewal.hamlet") + pdfRenewal pdfMeta >>= \case + 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] \ No newline at end of file diff --git a/src/Jobs/Handler/SendNotification/UserAuthModeUpdate.hs b/src/Jobs/Handler/SendNotification/UserAuthModeUpdate.hs index 2c9064fad..602636a05 100644 --- a/src/Jobs/Handler/SendNotification/UserAuthModeUpdate.hs +++ b/src/Jobs/Handler/SendNotification/UserAuthModeUpdate.hs @@ -9,6 +9,7 @@ import Import import Auth.PWHash (PWHashMessage(..)) import Handler.Utils.Mail +-- import Handler.Utils.Widgets (simpleLink, simpleLinkI) import Jobs.Handler.SendNotification.Utils import Text.Hamlet @@ -21,6 +22,6 @@ dispatchNotificationUserAuthModeUpdate nUser _nOriginalAuthMode jRecipient = us setSubjectI MsgMailSubjectUserAuthModeUpdate 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)) diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index f62bbd73f..e332e7e20 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -322,19 +322,32 @@ data JobNoQueueSame = JobNoQueueSame | JobNoQueueSameTag jobNoQueueSame :: Job -> Maybe JobNoQueueSame jobNoQueueSame = \case - JobSendPasswordReset{} -> Just JobNoQueueSame - JobTruncateTransactionLog{} -> Just JobNoQueueSame - JobPruneInvitations{} -> Just JobNoQueueSame - JobDeleteTransactionLogIPs{} -> Just JobNoQueueSame - JobSynchroniseLdapUser{} -> Just JobNoQueueSame - JobChangeUserDisplayEmail{} -> Just JobNoQueueSame - JobPruneSessionFiles{} -> Just JobNoQueueSameTag - JobPruneUnreferencedFiles{} -> Just JobNoQueueSameTag - JobInjectFiles{} -> Just JobNoQueueSameTag + JobSendNotification{jNotification} -> notifyNoQueueSame jNotification + JobSendPasswordReset{} -> Just JobNoQueueSame + JobTruncateTransactionLog{} -> Just JobNoQueueSame + JobPruneInvitations{} -> Just JobNoQueueSame + JobDeleteTransactionLogIPs{} -> Just JobNoQueueSame + JobSynchroniseLdapUser{} -> Just JobNoQueueSame + JobChangeUserDisplayEmail{} -> Just JobNoQueueSame + JobPruneSessionFiles{} -> Just JobNoQueueSameTag + JobPruneUnreferencedFiles{} -> Just JobNoQueueSameTag + JobInjectFiles{} -> Just JobNoQueueSameTag JobPruneFallbackPersonalisedSheetFilesKeys{} -> Just JobNoQueueSameTag - JobRechunkFiles{} -> Just JobNoQueueSameTag - JobDetectMissingFiles{} -> Just JobNoQueueSameTag - _ -> Nothing + JobRechunkFiles{} -> Just JobNoQueueSameTag + JobDetectMissingFiles{} -> Just JobNoQueueSameTag + 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 = isn't _JobCtlTest diff --git a/src/Model/Migration/Definitions.hs b/src/Model/Migration/Definitions.hs index 7b1526437..ead829102 100644 --- a/src/Model/Migration/Definitions.hs +++ b/src/Model/Migration/Definitions.hs @@ -432,7 +432,7 @@ customMigrations = mapF $ \case whenM ((&&) <$> tableExists "allocation_course_file" <*> (not <$> tableExists "course_app_instruction_file")) $ do [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 "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"); @@ -463,7 +463,7 @@ customMigrations = mapF $ \case Migration20190828UserFunction -> do [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 @@ -1002,7 +1002,7 @@ customMigrations = mapF $ \case whenM (and2M (tableExists "term") (not <$> tableExists "term_active")) $ do [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"|] diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs index 46abe8659..7f84fa578 100644 --- a/src/Model/Types/Avs.hs +++ b/src/Model/Types/Avs.hs @@ -79,7 +79,7 @@ licence2char AvsLicenceVorfeld = 'F' 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 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 , avsDataValidTo :: 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 , avsDataStreet :: 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 - , avsDataFirm :: Maybe Text -- always Nothing if returned with AvsResponseStatus - , avsDataCardColor :: AvsDataCardColor + , avsDataFirm :: Maybe Text -- always Nothing if returned with AvsResponseStatus , avsDataCardNo :: Text -- always 8 digits , avsDataVersionNo :: Text } @@ -134,12 +134,12 @@ instance FromJSON AvsDataPersonCard where <$> ((v .: "Valid") <&> sloppyBool) <*> v .:? "ValidTo" <*> v .:? "IssueDate" + <*> v .: "CardColor" <*> ((v .: "CardAreas") <&> charSet) <*> v .:? "Street" <*> v .:? "PostalCode" <*> v .:? "City" - <*> v .:? "Firm" - <*> v .: "CardColor" + <*> v .:? "Firm" <*> v .: "CardNo" <*> v .: "VersionNo" @@ -230,6 +230,8 @@ deriveJSON defaultOptions , rejectUnknownFields = False } ''AvsResponsePerson + + ------------- -- Queries -- ------------- @@ -296,6 +298,8 @@ pickLicenceAddress a b | Just r <- pickBetter' avsDataValid = r -- prefer valid cards | Just r <- pickBetter' (Set.member licenceRollfeld . avsDataCardAreas) = r -- prefer 'R' 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 = b | avsDataValidTo a > avsDataValidTo b = a -- prefer later validto date diff --git a/src/Model/Types/Csv.hs b/src/Model/Types/Csv.hs index ca7ec802b..e6053b6ac 100644 --- a/src/Model/Types/Csv.hs +++ b/src/Model/Types/Csv.hs @@ -60,10 +60,11 @@ data CsvOptions data CsvFormatOptions = CsvFormatOptions - { csvDelimiter :: Char - , csvUseCrLf :: Bool - , csvQuoting :: Csv.Quoting - , csvEncoding :: DynEncoding + { csvDelimiter :: Char + , csvUseCrLf :: Bool + , csvQuoting :: Csv.Quoting + , csvEncoding :: DynEncoding + , csvIncludeHeader :: Bool } | CsvXlsxFormatOptions deriving (Eq, Ord, Read, Show, Generic, Typeable) @@ -94,16 +95,18 @@ csvPreset = prism' fromPreset toPreset where fromPreset :: CsvPreset -> CsvFormatOptions fromPreset CsvPresetRFC = CsvFormatOptions - { csvDelimiter = ',' - , csvUseCrLf = True - , csvQuoting = QuoteMinimal - , csvEncoding = "UTF8" + { csvDelimiter = ',' + , csvUseCrLf = True + , csvIncludeHeader = True + , csvQuoting = QuoteMinimal + , csvEncoding = "UTF8" } fromPreset CsvPresetExcel = CsvFormatOptions - { csvDelimiter = ';' - , csvUseCrLf = True - , csvQuoting = QuoteAll - , csvEncoding = "CP1252" + { csvDelimiter = ';' + , csvUseCrLf = True + , csvIncludeHeader = True + , csvQuoting = QuoteAll + , csvEncoding = "CP1252" } fromPreset CsvPresetXlsx = CsvXlsxFormatOptions @@ -119,7 +122,7 @@ _CsvEncodeOptions = prism' fromEncode toEncode { Csv.encDelimiter = fromIntegral $ fromEnum csvDelimiter , Csv.encUseCrLf = csvUseCrLf , Csv.encQuoting = csvQuoting - , Csv.encIncludeHeader = True + , Csv.encIncludeHeader = csvIncludeHeader } toEncode CsvXlsxFormatOptions{} = Nothing fromEncode encOpts = def @@ -180,13 +183,14 @@ instance ToJSON CsvFormatOptions where instance FromJSON CsvFormatOptions where parseJSON = JSON.withObject "CsvFormatOptions" $ \o -> do formatTag <- o JSON..:? "format" JSON..!= FormatCsv - + case formatTag of FormatCsv -> do csvDelimiter <- fmap (fmap toEnum) (o JSON..:? "delimiter") JSON..!= csvDelimiter def - csvUseCrLf <- o JSON..:? "use-cr-lf" JSON..!= csvUseCrLf def - csvQuoting <- o JSON..:? "quoting" JSON..!= csvQuoting def - csvEncoding <- o JSON..:? "encoding" JSON..!= csvEncoding def + csvUseCrLf <- o JSON..:? "use-cr-lf" JSON..!= csvUseCrLf def + csvQuoting <- o JSON..:? "quoting" JSON..!= csvQuoting def + csvEncoding <- o JSON..:? "encoding" JSON..!= csvEncoding def + csvIncludeHeader <- o JSON..:? "include-header" JSON..!= csvIncludeHeader def return CsvFormatOptions{..} FormatXlsx -> return CsvXlsxFormatOptions diff --git a/src/Model/Types/Lms.hs b/src/Model/Types/Lms.hs index 50f50090c..3bc7b2a64 100644 --- a/src/Model/Types/Lms.hs +++ b/src/Model/Types/Lms.hs @@ -28,18 +28,26 @@ deriveJSON defaultOptions } ''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? +-- ...also see similar type QualificationBlocked data LmsStatus = LmsBlocked { 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 LmsSuccess{} = True 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 - a <> b | a >= b = a - | otherwise = b + a <> b = min a b -- earliest date, otherwise LmsBlocked before LmsSuccess deriveJSON defaultOptions { 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 +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 newtype LmsBool = LmsBool { lms2bool :: Bool } deriving (Eq, Ord, Read, Show, Generic, Typeable) diff --git a/src/Settings.hs b/src/Settings.hs index 33c2f40ca..fb471d603 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -93,6 +93,8 @@ data AppSettings = AppSettings -- ^ Configuration settings for accessing the database. , appAutoDbMigrate :: Bool , appLdapConf :: Maybe (PointedList LdapConf) + -- ^ Configuration settings for CSV export/import to LMS (= Learn Management System) + , appLmsConf :: LmsConf -- ^ Configuration settings for accessing the LDAP-directory , appAvsConf :: Maybe AvsConf -- ^ Configuration settings for accessing AVS Server (= Ausweis Verwaltungs System) @@ -301,6 +303,14 @@ data LdapConf = LdapConf , ldapPool :: ResourcePoolConf } deriving (Show) +data LmsConf = LmsConf + { lmsUploadHeader :: Bool + , lmsUploadDelimiter :: Maybe Char + , lmsDownloadHeader :: Bool + , lmsDownloadDelimiter :: Char + , lmsDownloadCrLf :: Bool + } deriving (Show) + data AvsConf = AvsConf { avsHost :: String , avsPort :: Int @@ -311,7 +321,7 @@ data AvsConf = AvsConf data LprConf = LprConf { lprHost :: String , lprPort :: Int - , lprQueue:: String + , lprQueue:: String } deriving (Show) data SmtpConf = SmtpConf @@ -480,6 +490,17 @@ deriveFromJSON } ''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 parseJSON = withObject "AvsConf" $ \o -> do avsHost <- o .: "host" @@ -492,7 +513,7 @@ instance FromJSON LprConf where parseJSON = withObject "LprConf" $ \o -> do lprHost <- o .: "host" lprPort <- o .: "port" - lprQueue <- o .: "queue" + lprQueue <- o .: "queue" return LprConf{..} instance FromJSON SmtpConf where @@ -576,6 +597,7 @@ instance FromJSON AppSettings where Ldap.Tls host _ -> not $ null host Ldap.Plain host -> not $ null host appLdapConf <- P.fromList . mapMaybe (assertM nonEmptyHost) <$> o .:? "ldap" .!= [] + appLmsConf <- o .: "lms-direct" appAvsConf <- assertM (not . null . avsPass) <$> o .:? "avs" appLprConf <- o .: "lpr" appSmtpConf <- assertM (not . null . smtpHost) <$> o .:? "smtp" diff --git a/src/Settings/Log.hs b/src/Settings/Log.hs index 57742ad0b..412308666 100644 --- a/src/Settings/Log.hs +++ b/src/Settings/Log.hs @@ -15,9 +15,10 @@ import Utils.PathPiece data LogSettings = LogSettings - { logAll, logDetailed :: Bool - , logMinimumLevel :: LogLevel - , logDestination :: LogDestination + { logDetailed :: Bool -- More details for incoming HTTP Requests? + , logAll :: Bool -- Show all LogLevels? + , logMinimumLevel :: LogLevel -- logAll => logMiniumLevel == Info + , logDestination :: LogDestination -- stderr, stdout (must both be lowercase) or a filename! , logSerializableTransactionRetryLimit :: Maybe Natural } deriving (Show, Read, Generic, Eq, Ord) diff --git a/src/Utils.hs b/src/Utils.hs index 14e70d231..7b29b7704 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -275,14 +275,33 @@ addAttrsClass cl attrs = ("class", cl') : noClAttrs stripAll :: Text -> Text 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 = 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 -- This function definition is mainly for documentation purposes text2Html :: Text -> Html text2Html = toHtml +char2Text :: Char -> Text +char2Text c + | isSpace c = "" + | otherwise = Text.singleton c + -- | Convert text as it is to Message, may prevent ambiguous types -- This function definition is mainly for documentation purposes text2message :: Text -> SomeMessage site @@ -318,6 +337,18 @@ withFragment form html = flip fmap form $ over _2 (toWidget html >>) charSet :: Text -> Set Char 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 -- showing trailing zeroes and to decimal digits textPercent :: Real a => a -> a -> Text diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index a26776c30..13e9e703f 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -297,7 +297,7 @@ data FormIdentifier | FIDAllocationRegister | FIDAllocationNotification | FIDAvsQueryPerson - | FIDAvsQueryStatus + | FIDAvsQueryStatus | FIDLmsLetter deriving (Eq, Ord, Read, Show) diff --git a/src/Utils/Print.hs b/src/Utils/Print.hs index e6b7f3f5d..1bf9088b4 100644 --- a/src/Utils/Print.hs +++ b/src/Utils/Print.hs @@ -14,9 +14,10 @@ module Utils.Print ) where -- import Import.NoModel -import qualified Data.Foldable as Fold +import Data.Char (isSeparator) import qualified Data.Text as T import qualified Data.CaseInsensitive as CI +import qualified Data.Foldable as Fold import qualified Data.ByteString.Lazy as LBS import Control.Monad.Except @@ -263,8 +264,8 @@ pdfRenewal' meta = do -- PrintJobs -- --------------- -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 :: Text -> LBS.ByteString -> (Maybe UserId, Maybe UserId) -> Maybe CourseId -> Maybe QualificationId -> DB (Either Text (Text, FilePath)) +sendLetter printJobName pdf (printJobRecipient, printJobSender) printJobCourse printJobQualification = do recipient <- join <$> mapM get printJobRecipient sender <- join <$> mapM get printJobSender course <- join <$> mapM get printJobCourse @@ -332,12 +333,11 @@ readProcess' pc = do sanitizeCmdArg :: Text -> Text -sanitizeCmdArg t = - T.snoc (T.cons '\'' $ T.filter (\c -> '\'' /= c && '"' /= c && '\\' /= c) t) '\'' --- | Pin Password is used as a commandline argument in Utils.Print.encryptPDF and hence poses a security risk -validCmdArgument :: Text -> Bool -validCmdArgument t = not (T.null t) && (T.cons '\'' (T.snoc t '\'') == sanitizeCmdArg t) - +sanitizeCmdArg = T.filter (\c -> c /= '\'' && c /= '"' && c/= '\\' && not (isSeparator c)) +-- | Returns Nothing if ok, otherwise the first mismatching character +-- Pin Password is used as a commandline argument in Utils.Print.encryptPDF and hence poses a security risk +validCmdArgument :: Text -> Maybe Char +validCmdArgument t = t `textDiff` sanitizeCmdArg t ----------- diff --git a/start.sh b/start.sh index a663c3ef7..e62af13a4 100755 --- a/start.sh +++ b/start.sh @@ -23,6 +23,7 @@ export ENCRYPT_ERRORS=${ENCRYPT_ERRORS:-false} export RIBBON=${RIBBON:-${__HOST:-localhost}} export APPROOT=${APPROOT:-http://localhost:$((${PORT_OFFSET:-0} + 3000))} export AVSPASS=${AVSPASS:-nopasswordset} +export PATH=${PATH:/home/jost/projects/fradrive} unset HOST move-back() { diff --git a/templates/ldap.hamlet b/templates/ldap.hamlet new file mode 100644 index 000000000..0b5873a55 --- /dev/null +++ b/templates/ldap.hamlet @@ -0,0 +1,15 @@ +
+

+ LDAP Person Search: + ^{personForm} + $maybe answers <- mbLdapData +

+ Antwort: # +
+ $forall (lk, lv) <- answers +
+ #{show lk} +
+ UTF8: #{presentUtf8 lv} + — + Latin: #{presentLatin1 lv} diff --git a/templates/letter/fraport_renewal.md b/templates/letter/fraport_renewal.md index 0c0510006..a23833298 100644 --- a/templates/letter/fraport_renewal.md +++ b/templates/letter/fraport_renewal.md @@ -6,7 +6,6 @@ en-subject: Renewal of apron driving License author: Fraport AG - Fahrerausbildung (AVN-AR) phone: +49 69 690-30306 email: fahrerausbildung@fraport.de -url: place: Frankfurt/Main return-address: - 60547 Frankfurt @@ -22,6 +21,8 @@ encludes: hyperrefoptions: hidelinks ### Metadaten, welche automatisch ersetzt werden: +url-text: 'https://drive.fraport.de' +url: 'https://drive.fraport.de' date: 11.11.1111 expiry: 00.00.0000 lang: de-de @@ -66,7 +67,7 @@ Prüfling URL - : $url$ + : [$url-text$]($url$) Sobald die Frist abgelaufen ist, muss zur Wiedererlangung des Vorfeldführerscheins @@ -93,7 +94,7 @@ Examinee URL - : $url$ + :[$url-text$]($url$) Should your apron driving licence expire before completing this diff --git a/templates/mail/passwordReset.hamlet b/templates/mail/passwordReset.hamlet index fa448db58..9f0453db4 100644 --- a/templates/mail/passwordReset.hamlet +++ b/templates/mail/passwordReset.hamlet @@ -13,4 +13,6 @@ $newline never

_{SomeMessage MsgResetPassword} +

+ _{SomeMessage $ MsgLinkActiveUntil activeTime} diff --git a/templates/mail/qualificationRenewal.hamlet b/templates/mail/qualificationRenewal.hamlet index 0de1f400d..a2455c51b 100644 --- a/templates/mail/qualificationRenewal.hamlet +++ b/templates/mail/qualificationRenewal.hamlet @@ -28,7 +28,9 @@ $newline never

#{expiryDate}

- _{SomeMessage MsgLmsRenewalInstructions} + _{SomeMessage MsgLmsRenewalInstructions} # + + _{SomeMessage MsgMppURL} #{lmsUrl} ^{ihamletSomeMessage editNotifications} diff --git a/templates/mail/userAuthModeUpdate.hamlet b/templates/mail/userAuthModeUpdate.hamlet index 10938a372..82c221b8b 100644 --- a/templates/mail/userAuthModeUpdate.hamlet +++ b/templates/mail/userAuthModeUpdate.hamlet @@ -19,10 +19,15 @@ $newline never _{SomeMessage MsgUserAuthModePWHashChangedToLDAP} $of AuthPWHash _ _{SomeMessage MsgUserAuthModeLDAPChangedToPWHash} +

+ + _{SomeMessage MsgMailFradrive} # + _{SomeMessage MsgMailBodyFradrive} + $if is _AuthPWHash userAuthentication

_{SomeMessage MsgAuthPWHashTip} -

+
_{SomeMessage MsgPWHashIdent}
diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 8056ccd87..b08851225 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -37,13 +37,13 @@ import Data.List (foldl) import System.Directory (getModificationTime, doesDirectoryExist) import System.FilePath.Glob (glob) -{- Needed for File Tests only +{- Needed for File Tests only import qualified Data.Conduit.Combinators as C import Paths_uniworx (getDataFileName) testdataFile :: MonadIO m => FilePath -> m FilePath testdataFile = liftIO . getDataFileName . ("testdata" ) - + insertFile :: ( HasFileReference fRef, PersistRecordBackend fRef SqlBackend ) => FileReferenceResidual fRef -> FilePath -> DB (Key fRef) insertFile residual fileTitle = do filepath <- testdataFile fileTitle @@ -60,25 +60,25 @@ fillDb = do let insert' :: (PersistRecordBackend r (YesodPersistBackend UniWorX), AtLeastOneUniqueKey r) => r -> YesodDB UniWorX (Key r) insert' = fmap (either entityKey id) . insertBy - - addBDays = addBusinessDays Fraport -- holiday area to use - n_day n = addBDays n $ utctDay now + + addBDays = addBusinessDays Fraport -- holiday area to use + n_day n = addBDays n $ utctDay now n_day' n = now { utctDay = n_day n } currentTerm = TermIdentifier . fst3 . toGregorian $ utctDay now - -- (currentYear, currentMonth, currentDay) = toGregorian $ getTermDay currentTerm + -- (currentYear, currentMonth, currentDay) = toGregorian $ getTermDay currentTerm nextTerm n = toEnum . (+n) $ fromEnum currentTerm - termTime :: TermIdentifier -- ^ Term - -> TermDay -- ^ Relative to which day? + termTime :: TermIdentifier -- ^ Term + -> TermDay -- ^ Relative to which day? -> Integer -- ^ Week offset from TermDayStart/End of Term (shuld be negative for TermDayEnd) -> Maybe WeekDay -- ^ Move to weekday -> (Day -> UTCTime) -- ^ Add time to day -> UTCTime termTime gTid gTD weekOffset mbWeekDay = ($ tDay) - where - gDay = addDays (7* weekOffset) $ guessDay gTid gTD - tDay = maybe gDay (`firstDayOfWeekOnAfter` gDay) mbWeekDay - + where + gDay = addDays (7* weekOffset) $ guessDay gTid gTD + tDay = maybe gDay (`firstDayOfWeekOnAfter` gDay) mbWeekDay + gkleen <- insert User { userIdent = "G.Kleen@campus.lmu.de" , userAuthentication = AuthLDAP @@ -107,9 +107,9 @@ fillDb = do , userCsvOptions = def { csvFormat = csvPreset # CsvPresetRFC } , userSex = Just SexMale , userShowSex = userDefaultShowSex - , userTelephone = Nothing - , userMobile = Nothing - , userCompanyPersonalNumber = Nothing + , userTelephone = Nothing + , userMobile = Nothing + , userCompanyPersonalNumber = Nothing , userCompanyDepartment = Nothing , userPinPassword = Nothing , userPostAddress = Nothing @@ -145,9 +145,9 @@ fillDb = do , userCsvOptions = def { csvFormat = csvPreset # CsvPresetExcel } , userSex = Just SexMale , userShowSex = userDefaultShowSex - , userMobile = Nothing - , userTelephone = Nothing - , userCompanyPersonalNumber = Nothing + , userMobile = Nothing + , userTelephone = Nothing + , userCompanyPersonalNumber = Nothing , userCompanyDepartment = Nothing , userPinPassword = Nothing , userPostAddress = Nothing @@ -227,9 +227,9 @@ fillDb = do , userCsvOptions = def , userSex = Just SexMale , userShowSex = userDefaultShowSex - , userTelephone = Nothing - , userMobile = Nothing - , userCompanyPersonalNumber = Nothing + , userTelephone = Nothing + , userMobile = Nothing + , userCompanyPersonalNumber = Nothing , userCompanyDepartment = Nothing , userPinPassword = Nothing , userPostAddress = Nothing @@ -265,9 +265,9 @@ fillDb = do , userCsvOptions = def , userSex = Just SexNotApplicable , userShowSex = userDefaultShowSex - , userTelephone = Nothing - , userMobile = Nothing - , userCompanyPersonalNumber = Nothing + , userTelephone = Nothing + , userMobile = Nothing + , userCompanyPersonalNumber = Nothing , userCompanyDepartment = Nothing , userPinPassword = Nothing , userPostAddress = Nothing @@ -303,9 +303,9 @@ fillDb = do , userCsvOptions = def , userSex = Just SexFemale , userShowSex = userDefaultShowSex - , userTelephone = Nothing - , userMobile = Nothing - , userCompanyPersonalNumber = Nothing + , userTelephone = Nothing + , userMobile = Nothing + , userCompanyPersonalNumber = Nothing , userCompanyDepartment = Nothing , userPinPassword = Nothing , userPostAddress = Nothing @@ -341,9 +341,9 @@ fillDb = do , userCsvOptions = def , userSex = Just SexMale , userShowSex = userDefaultShowSex - , userTelephone = Nothing - , userMobile = Nothing - , userCompanyPersonalNumber = Nothing + , userTelephone = Nothing + , userMobile = Nothing + , userCompanyPersonalNumber = Nothing , userCompanyDepartment = Nothing , userPinPassword = Nothing , userPostAddress = Nothing @@ -409,9 +409,9 @@ fillDb = do , userCsvOptions = def , userSex = Nothing , userShowSex = userDefaultShowSex - , userTelephone = Nothing - , userMobile = Nothing - , userCompanyPersonalNumber = Nothing + , userTelephone = Nothing + , userMobile = Nothing + , userCompanyPersonalNumber = Nothing , userCompanyDepartment = Nothing , userPinPassword = Nothing , userPostAddress = Nothing @@ -426,7 +426,7 @@ fillDb = do Nothing -> repack [st|#{firstName}.#{userSurname}@example.invalid|] matrikel <- toMatrikel <$> getRandomRs (0 :: Int, 9 :: Int) manyUsers <- insertMany . getZipList $ manyUser <$> ZipList ((,,) <$> firstNames <*> middlenames <*> surnames) <*> ZipList matrikel - + let tmin = -1 tmax = 2 trange = [tmin..tmax] @@ -434,21 +434,21 @@ fillDb = do dmax = guessDay (nextTerm tmax) TermDayEnd hdys = foldl (<>) mempty $ [bankHolidaysAreaSet Fraport y | y <- [getYear dmin..getYear dmax]] terms <- forM trange $ \nr -> do - let tid = nextTerm nr - tk = TermKey tid + let tid = nextTerm nr + tk = TermKey tid tStart = guessDay tid TermDayStart tEnd = guessDay tid TermDayEnd - term = Term { termName = tid + term = Term { termName = tid , termStart = tStart , 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 , termLectureEnd = guessDay tid TermDayLectureEnd } - repsert tk term + repsert tk term insert_ $ TermActive tk (toMidnight $ termStart term) (Just . beforeMidnight $ termEnd term) Nothing return tk - + ifiAuthorshipStatement <- insertAuthorshipStatement I18n { i18nFallback = htmlToStoredMarkup [shamlet| @@ -501,32 +501,41 @@ fillDb = do let f_descr = Just $ htmlToStoredMarkup [shamlet|

Berechtigung zum Führen eines Fahrzeuges auf den Fahrstrassen des Vorfeldes.|] let r_descr = Just $ htmlToStoredMarkup [shamlet|

Berechtigung zum Führen eines Fahrzeuges auf dem gesamten Rollfeld.|] - let l_descr = Just $ htmlToStoredMarkup [shamlet|

für unhabilitierte|] - qid_f <- insert' $ Qualification avn "F" "Vorfeldführerschein" f_descr (Just 24) (Just 6) (Just $ CalendarDiffDays 0 60) True + let l_descr = Just $ htmlToStoredMarkup [shamlet|

für unhabilitierte|] + 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_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 gkleen qid_f (n_day $ -3) (n_day $ -4) (n_day $ -20) - void . insert' $ QualificationUser maxMuster qid_f (n_day 0) (n_day $ -2) (n_day $ -8) - void . insert' $ QualificationUser svaupel qid_f (n_day 1) (n_day $ -1) (n_day $ -2) - void . insert' $ QualificationUser sbarth qid_f (n_day 400) (n_day $ -40) (n_day $ -1200) - void . insert' $ QualificationUser tinaTester qid_f (n_day 3) (n_day $ -60) (n_day $ -250) - void . insert' $ QualificationUser gkleen qid_r (n_day $ -7) (n_day $ -2) (n_day $ -9) - void . insert' $ QualificationUser maxMuster qid_r (n_day 1) (n_day $ -1) (n_day $ -2) - void . insert' $ QualificationUser fhamann qid_r (n_day $ -3) (n_day $ -1) (n_day $ -2) - void . insert' $ QualificationUser svaupel qid_l (n_day 1) (n_day $ -1) (n_day $ -2) - void . insert' $ QualificationUser gkleen qid_l (n_day 9) (n_day $ -1) (n_day $ -7) - 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 "pqgrst" ) (n_day (-3)) 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 "ijk" ) False now - void . insert' $ LmsUser qid_f jost (LmsIdent "ijk" ) "123" False now Nothing now 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 gkleen (LmsIdent "hijklmn") "@#!" True now (Just $ LmsBlocked $ utctDay now) now (Just now) 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 maxMuster (LmsIdent "xyz") "a1b2c3" False now (Just $ LmsBlocked $ n_day (-1)) now (Just $ n_day' (-2)) (Just $ n_day' (-1)) + 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) Nothing + 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) Nothing + 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) Nothing + 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) Nothing + 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) Nothing + 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 "opqgrs" ) (n_day (-2)) 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 "abcdefg") True 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 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 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' (-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 examLabels = Map.fromList @@ -709,19 +718,19 @@ fillDb = do now True Nothing - - + + -- Fahrschule F forM_ terms $ \tk -> do - let tid = unTermKey tk - jtt = (((Just .) .) .) . termTime tid + let tid = unTermKey tk + jtt = (((Just .) .) .) . termTime tid firstDay = utctDay $ termTime tid TermDayLectureStart 0 Nothing toMidnight secondDay = utctDay $ termTime tid TermDayLectureStart 1 Nothing toMidnight - weekDay = dayOfWeek firstDay + weekDay = dayOfWeek firstDay -- thirdDay = utctDay $ termTime tid TermDayLectureStart 2 Nothing toMidnight capacity = Just 8 - mkName = CI.mk - do + mkName = CI.mk + do c <- insert' Course { courseName = mkName "Vorfeldführerschein" , courseDescription = Just $ htmlToStoredMarkup [shamlet| @@ -730,7 +739,7 @@ fillDb = do

Benötigte Unterlagen
    -
  • Sehtest, +
  • Sehtest, bitte vorab hochladen!
  • Regulärer Führerschein, Bitte mitbringen. @@ -744,7 +753,7 @@ fillDb = do , courseVisibleTo = jtt TermDayEnd 0 Nothing beforeMidnight , courseRegisterFrom = jtt TermDayStart 0 Nothing toMidnight , courseRegisterTo = jtt TermDayLectureStart (-1) Nothing toMidnight - , courseDeregisterUntil = jtt TermDayLectureStart (-5) (Just Monday) toMidnight + , courseDeregisterUntil = jtt TermDayLectureStart (-5) (Just Monday) toMidnight , courseRegisterSecret = Nothing , courseMaterialFree = True , courseApplicationsRequired = False @@ -775,44 +784,44 @@ fillDb = do , sheetAuthorshipStatementMode = SheetAuthorshipStatementModeExam , sheetAuthorshipStatementExam = 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} ] - tut1 <- insert Tutorial + tut1 <- insert Tutorial { tutorialName = mkName "Theorieschulung" , tutorialCourse = c , tutorialType = "Schulung" , tutorialCapacity = capacity - , tutorialRoom = Just $ case weekDay of + , tutorialRoom = Just $ case weekDay of Monday -> "A380" Tuesday -> "B747" Wednesday -> "MD11" Thursday -> "A380" - _ -> "B777" + _ -> "B777" , tutorialRoomHidden = False , tutorialTime = Occurrences - { occurrencesScheduled = Set.empty - , occurrencesExceptions = Set.fromList - [ ExceptOccur + { occurrencesScheduled = Set.empty + , occurrencesExceptions = Set.fromList + [ ExceptOccur { exceptDay = firstDay - , exceptStart = TimeOfDay 8 30 0 - , exceptEnd = TimeOfDay 16 0 0 + , exceptStart = TimeOfDay 8 30 0 + , exceptEnd = TimeOfDay 16 0 0 } , ExceptOccur { exceptDay = secondDay - , exceptStart = TimeOfDay 9 0 0 - , exceptEnd = TimeOfDay 16 0 0 + , exceptStart = TimeOfDay 9 0 0 + , exceptEnd = TimeOfDay 16 0 0 } - ] + ] } , tutorialRegGroup = Just "schulung" , tutorialRegisterFrom = jtt TermDayStart 0 Nothing toMidnight , tutorialRegisterTo = jtt TermDayLectureStart (-1) Nothing toMidnight - , tutorialDeregisterUntil = jtt TermDayLectureStart (-5) (Just Monday) toMidnight + , tutorialDeregisterUntil = jtt TermDayLectureStart (-5) (Just Monday) toMidnight , tutorialLastChanged = now , tutorialTutorControlled = True } - insert_ $ Tutor tut1 jost + insert_ $ Tutor tut1 jost void . insert' $ Exam { examCourse = c , examName = mkName "Theorieprüfung" @@ -823,9 +832,9 @@ fillDb = do , examVisibleFrom = jtt TermDayStart 0 Nothing toMidnight , examRegisterFrom = jtt TermDayStart 0 Nothing toMidnight , examRegisterTo = jtt TermDayLectureStart (-1) Nothing toMidnight - , examDeregisterUntil = jtt TermDayLectureStart (-5) (Just Monday) toMidnight + , examDeregisterUntil = jtt TermDayLectureStart (-5) (Just Monday) toMidnight , examPublishOccurrenceAssignments = Nothing - , examStart = Just $ toTimeOfDay 16 0 0 secondDay + , examStart = Just $ toTimeOfDay 16 0 0 secondDay , examEnd = Just $ toTimeOfDay 16 30 0 secondDay , examFinished = Nothing , examPartsFrom = Nothing @@ -842,7 +851,7 @@ fillDb = do , examStaff = Just "Jost" , examAuthorshipStatement = Nothing } - + testMsg <- insert SystemMessage { systemMessageNewsOnly = False , systemMessageFrom = Just now @@ -903,7 +912,7 @@ fillDb = do , systemMessageCreated = now , systemMessageLastChanged = now , systemMessageLastUnhide = now - } + } void $ insert SystemMessage { systemMessageNewsOnly = True , systemMessageFrom = Just now @@ -920,7 +929,7 @@ fillDb = do , systemMessageLastUnhide = now } - {- + {- aSeedFunc <- liftIO $ getRandomBytes 40 funAlloc <- insert' Allocation { allocationName = "Funktionale Zentralanmeldung" @@ -931,10 +940,10 @@ fillDb = do , allocationDescription = Nothing , allocationStaffDescription = Nothing , allocationStaffRegisterFrom = Just now - , allocationStaffRegisterTo = Just $ 300 `addUTCTime` now + , allocationStaffRegisterTo = Just $ 300 `addUTCTime` now , allocationStaffAllocationFrom = Just $ 300 `addUTCTime` now , allocationStaffAllocationTo = Just $ 900 `addUTCTime` now - , allocationRegisterFrom = Just $ 300 `addUTCTime` now + , allocationRegisterFrom = Just $ 300 `addUTCTime` now , allocationRegisterTo = Just $ 600 `addUTCTime` now , allocationRegisterByStaffFrom = Nothing , allocationRegisterByStaffTo = Nothing @@ -944,7 +953,7 @@ fillDb = do } insert_ $ AllocationCourse funAlloc pmo 100 Nothing Nothing insert_ $ AllocationCourse funAlloc ffp 2 (Just $ 2300 `addUTCTime` now) Nothing - + void . insertMany $ map (\(u, pState) -> CourseParticipant ffp u now (Just funAlloc) pState) [ (svaupel, CourseParticipantInactive False) , (jost, CourseParticipantActive) @@ -968,7 +977,7 @@ fillDb = do Just User{ userMatrikelnummer = Just matr } -> return . pure $ Csv.Only matr _other -> return mempty - + liftIO . handle (\(_ :: IOException) -> return ()) $ do haveTestdata <- doesDirectoryExist "testdata" LBS.writeFile (bool id ("testdata" ) haveTestdata "bigAlloc_numeric.csv") $ Csv.encode numericPriorities diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs index 53d8ab8dc..4830ffca3 100644 --- a/test/Model/TypesSpec.hs +++ b/test/Model/TypesSpec.hs @@ -298,6 +298,7 @@ instance Arbitrary CsvFormatOptions where <*> arbitrary <*> arbitrary <*> elements ["UTF8", "CP1252"] + <*> pure True , pure CsvXlsxFormatOptions ] 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 } CorrectorExcused `shouldBe` "{1.0 - D}" describe "Semigroup LmsStatus" $ do - it "LmsSuccess supersedes LmsBlocked" . property $ - \p1 p2 -> (isLmsSuccess p1 || isLmsSuccess p2) == isLmsSuccess (p1 <> p2) - it "lmsStatusDay merges to latest" . property $ - \p1 p2 -> (isLmsSuccess p1 == isLmsSuccess p2) ==> lmsStatusDay (p1 <> p2) == max (lmsStatusDay p1) (lmsStatusDay p2) + it "lmsStatusDay merges to earliest" . property $ + \p1 p2 -> lmsStatusDay (p1 <> p2) == min (lmsStatusDay p1) (lmsStatusDay p2) termExample :: (TermIdentifier, Text) -> Expectation diff --git a/testdata/test.pdf b/testdata/test.pdf new file mode 100644 index 000000000..ce7a65698 Binary files /dev/null and b/testdata/test.pdf differ