Merge branch 'master' into fradrive/api-avs
This commit is contained in:
Steffen Jost
commit
a2f22b389a
34
CHANGELOG.md
34
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)
|
||||
|
||||
|
||||
|
||||
@ -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"
|
||||
|
||||
5
lpr
Executable file
5
lpr
Executable file
@ -0,0 +1,5 @@
|
||||
#!/usr/bin/env bash
|
||||
|
||||
printf "lpr dummy called, arguments ignored.\n"
|
||||
printf "Nothing is printed."
|
||||
exit 0
|
||||
@ -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
|
||||
|
||||
@ -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!
|
||||
LinkActiveUntil time@Text: Dieser Link ist nur bis #{time} aktiv!
|
||||
@ -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}!
|
||||
LinkActiveUntil time@Text: This link is only active until #{time}!
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -4,8 +4,8 @@ Qualification
|
||||
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!
|
||||
@ -49,8 +49,9 @@ 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
|
||||
UniqueQualificationUser qualification user
|
||||
@ -76,34 +77,35 @@ 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
|
||||
@ -111,7 +113,7 @@ LmsUserlist
|
||||
qualification QualificationId OnDeleteCascade OnUpdateCascade
|
||||
ident LmsIdent
|
||||
failed Bool
|
||||
timestamp UTCTime default=now()
|
||||
timestamp UTCTime default=now()
|
||||
UniqueLmsUserlist qualification ident
|
||||
deriving Generic
|
||||
|
||||
@ -120,7 +122,7 @@ LmsResult
|
||||
qualification QualificationId OnDeleteCascade OnUpdateCascade
|
||||
ident LmsIdent
|
||||
success Day
|
||||
timestamp UTCTime default=now()
|
||||
timestamp UTCTime default=now()
|
||||
UniqueLmsResult qualification ident -- required by DBTable
|
||||
deriving Generic
|
||||
|
||||
@ -129,6 +131,7 @@ LmsAudit
|
||||
qualification QualificationId OnDeleteCascade OnUpdateCascade
|
||||
ident LmsIdent
|
||||
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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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 = ''
|
||||
|
||||
@ -1,3 +1,3 @@
|
||||
{
|
||||
"version": "26.3.1"
|
||||
"version": "26.5.4"
|
||||
}
|
||||
|
||||
@ -1,3 +1,3 @@
|
||||
{
|
||||
"version": "26.3.1"
|
||||
"version": "26.5.4"
|
||||
}
|
||||
|
||||
2
package-lock.json
generated
2
package-lock.json
generated
@ -1,6 +1,6 @@
|
||||
{
|
||||
"name": "uni2work",
|
||||
"version": "26.3.1",
|
||||
"version": "26.5.4",
|
||||
"lockfileVersion": 1,
|
||||
"requires": true,
|
||||
"dependencies": {
|
||||
|
||||
@ -1,6 +1,6 @@
|
||||
{
|
||||
"name": "uni2work",
|
||||
"version": "26.3.1",
|
||||
"version": "26.5.4",
|
||||
"description": "",
|
||||
"keywords": [],
|
||||
"author": "",
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: uniworx
|
||||
version: 26.3.1
|
||||
version: 26.5.4
|
||||
dependencies:
|
||||
- base
|
||||
- yesod
|
||||
|
||||
1
routes
1
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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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 {
|
||||
|
||||
@ -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))
|
||||
(newUser,userUpdate) <- decodeUser now userDefaultConf upsertMode ldapData
|
||||
|
||||
-- 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 ] []
|
||||
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] []
|
||||
|
||||
@ -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 =
|
||||
|
||||
@ -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
|
||||
|
||||
81
src/Handler/Admin/Ldap.hs
Normal file
81
src/Handler/Admin/Ldap.hs
Normal file
@ -0,0 +1,81 @@
|
||||
|
||||
|
||||
module Handler.Admin.Ldap
|
||||
( getAdminLdapR
|
||||
, postAdminLdapR
|
||||
) where
|
||||
|
||||
import Import
|
||||
-- import qualified Control.Monad.State.Class as State
|
||||
-- import Data.Aeson (encode)
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Text.Encoding as Text
|
||||
-- import qualified Data.Set as Set
|
||||
import Foundation.Yesod.Auth (decodeUserTest)
|
||||
|
||||
import Handler.Utils
|
||||
|
||||
import qualified Ldap.Client as Ldap
|
||||
import Auth.LDAP
|
||||
|
||||
newtype LdapQueryPerson = LdapQueryPerson
|
||||
{ ldapQueryIdent :: Text
|
||||
-- , ldapQueryName :: Maybe Text
|
||||
-- , ldapQueryPNum :: Maybe Text
|
||||
}
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
makeLdapPersonForm :: Maybe LdapQueryPerson -> Form LdapQueryPerson
|
||||
makeLdapPersonForm tmpl = validateForm validateLdapQueryPerson $ \html ->
|
||||
flip (renderAForm FormStandard) html $ LdapQueryPerson
|
||||
<$> areq textField (fslI MsgAdminUserIdent) (ldapQueryIdent <$> tmpl)
|
||||
-- <*> aopt textField (fslI MsgAdminUserSurname) (ldapQueryName <$> tmpl)
|
||||
-- <*> aopt textField (fslI MsgAdminUserFPersonalNumber) (ldapQueryPNum <$> tmpl)
|
||||
|
||||
validateLdapQueryPerson :: FormValidator LdapQueryPerson Handler ()
|
||||
validateLdapQueryPerson = return () -- currently no tests needed
|
||||
--LdapQueryPerson{..} <- State.get
|
||||
--guardValidation MsgAvsQueryEmpty
|
||||
--is _Just ldapQueryIdent ||
|
||||
--is _Just ldapQueryName ||
|
||||
--is _Just ldapQueryPNum
|
||||
|
||||
|
||||
|
||||
getAdminLdapR, postAdminLdapR :: Handler Html
|
||||
getAdminLdapR = postAdminLdapR
|
||||
postAdminLdapR = do
|
||||
((presult, pwidget), penctype) <- runFormPost $ makeLdapPersonForm Nothing
|
||||
|
||||
let procFormPerson :: LdapQueryPerson -> Handler (Maybe (Ldap.AttrList []))
|
||||
procFormPerson LdapQueryPerson{..} = do
|
||||
ldapPool' <- getsYesod $ view _appLdapPool
|
||||
|
||||
if isNothing ldapPool'
|
||||
then addMessage Warning $ text2Html "LDAP Configuration missing."
|
||||
else addMessage Info $ text2Html "Input for LDAP test received."
|
||||
fmap join . for ldapPool' $ \ldapPool -> do
|
||||
ldapData <- campusUser'' ldapPool FailoverUnlimited ldapQueryIdent
|
||||
decodedErr <- decodeUserTest (Just $ CI.mk ldapQueryIdent) $ concat ldapData
|
||||
whenIsLeft decodedErr $ addMessageI Error
|
||||
return ldapData
|
||||
|
||||
|
||||
mbLdapData <- formResultMaybe presult procFormPerson
|
||||
|
||||
|
||||
actionUrl <- fromMaybe AdminLdapR <$> getCurrentRoute
|
||||
siteLayoutMsg MsgMenuLdap $ do
|
||||
setTitleI MsgMenuLdap
|
||||
let personForm = wrapForm pwidget def
|
||||
{ formAction = Just $ SomeRoute actionUrl
|
||||
, formEncoding = penctype
|
||||
}
|
||||
|
||||
presentUtf8 lv = Text.intercalate ", " (either tshow id . Text.decodeUtf8' <$> lv)
|
||||
presentLatin1 lv = Text.intercalate ", " ( Text.decodeLatin1 <$> lv)
|
||||
|
||||
-- TODO: use i18nWidgetFile instead if this is to become permanent
|
||||
$(widgetFile "ldap")
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -29,9 +29,9 @@ 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
|
||||
lmsResultTableCsvHeader :: Csv.Header
|
||||
@ -262,10 +262,11 @@ postLmsResultDirectR sid qsh = do
|
||||
(_params, files) <- runRequestBody
|
||||
(status, msg) <- case files of
|
||||
[(fhead,file)] -> do
|
||||
lmsDecoder <- getLmsCsvDecoder
|
||||
runDBJobs $ do
|
||||
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
|
||||
enr <- try $ runConduit $ fileSource file
|
||||
.| decodeCsv
|
||||
.| lmsDecoder
|
||||
.| foldMC (saveResultCsv qid) 0
|
||||
case enr of
|
||||
Left (e :: SomeException) -> do -- catch all to avoid ok220 in case of any error
|
||||
@ -273,8 +274,8 @@ postLmsResultDirectR sid qsh = do
|
||||
return (badRequest400, "Exception: " <> tshow e)
|
||||
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
|
||||
$logInfoS "LMS" msg
|
||||
when (nr > 0) $ queueDBJob $ JobLmsResults qid
|
||||
return (ok200, msg)
|
||||
[] -> do
|
||||
let msg = "Result upload file missing."
|
||||
|
||||
@ -28,9 +28,9 @@ data LmsUserlistTableCsv = LmsUserlistTableCsv
|
||||
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
|
||||
@ -258,10 +258,11 @@ postLmsUserlistDirectR sid qsh = do
|
||||
(_params, files) <- runRequestBody
|
||||
(status, msg) <- case files of
|
||||
[(fhead,file)] -> do
|
||||
lmsDecoder <- getLmsCsvDecoder
|
||||
runDBJobs $ do
|
||||
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
|
||||
enr <- try $ runConduit $ fileSource file
|
||||
.| decodeCsv
|
||||
.| lmsDecoder
|
||||
.| foldMC (saveUserlistCsv qid) 0
|
||||
case enr of
|
||||
Left (e :: SomeException) -> do
|
||||
@ -269,8 +270,8 @@ postLmsUserlistDirectR sid qsh = do
|
||||
return (badRequest400, "Exception: " <> tshow e)
|
||||
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."
|
||||
@ -281,4 +282,3 @@ postLmsUserlistDirectR sid qsh = do
|
||||
$logWarnS "LMS" msg
|
||||
return (badRequest400, msg)
|
||||
sendResponseStatus status msg
|
||||
|
||||
@ -39,9 +39,9 @@ lmsUser2csv lu@LmsUser{..} = LmsUserTableCsv
|
||||
, 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
|
||||
lmsUserTableCsvHeader :: Csv.Header
|
||||
@ -165,11 +165,19 @@ getLmsUsersDirectR sid qsh = do
|
||||
, csvLUTstaff = LmsBool False
|
||||
}
|
||||
-}
|
||||
let csvRenderedData = toNamedRecord . lmsUser2csv . entityVal <$> lms_users
|
||||
csvRenderedHeader = lmsUserTableCsvHeader
|
||||
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
|
||||
@ -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,10 +190,9 @@ 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-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
|
||||
@ -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,7 +305,7 @@ 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
|
||||
|
||||
@ -439,11 +439,14 @@ validateSettings :: User -> FormValidator SettingsForm Handler ()
|
||||
validateSettings User{..} = do
|
||||
userDisplayName' <- use _stgDisplayName
|
||||
guardValidation MsgUserDisplayNameInvalid $
|
||||
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'
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -1,7 +1,8 @@
|
||||
{-# OPTIONS -Wno-redundant-constraints #-} -- needed for Getter
|
||||
|
||||
module Handler.Utils.LMS
|
||||
( csvLmsIdent
|
||||
( getLmsCsvDecoder
|
||||
, csvLmsIdent
|
||||
, csvLmsTimestamp
|
||||
, csvLmsBlocked
|
||||
, csvLmsSuccess
|
||||
@ -21,11 +22,27 @@ module Handler.Utils.LMS
|
||||
|
||||
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)
|
||||
|
||||
|
||||
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"
|
||||
@ -120,5 +137,4 @@ randomLMSIdent = LmsIdent <$> randomText [] lengthIdent
|
||||
randomLMSpw :: MonadIO m => m Text
|
||||
randomLMSpw = randomText extra lengthPassword
|
||||
where
|
||||
extra = "_-+*.:;=!?#"
|
||||
|
||||
extra = "-+*.:;=!?#$"
|
||||
|
||||
@ -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
|
||||
@ -54,6 +58,7 @@ validDisplayName (fmap Text.strip -> mTitle) (Text.strip -> fName) (Text.strip -
|
||||
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
|
||||
validPostAddress (Just StoredMarkup {markupInput = addr})
|
||||
|
||||
@ -316,3 +316,7 @@ lmsStatusCell ls = iconCell ic <> spacerCell <> dayCell (lmsStatusDay ls)
|
||||
where
|
||||
ic | isLmsSuccess ls = IconOK
|
||||
| otherwise = IconNotOK
|
||||
|
||||
qualificationBlockedCell :: IsDBTable m a => Maybe QualificationBlocked -> DBCell m a
|
||||
qualificationBlockedCell Nothing = mempty
|
||||
qualificationBlockedCell (Just qb) = iconCell IconBlocked <> msgCell qb <> dayCell (qualificationBlockedDay qb)
|
||||
|
||||
@ -18,22 +18,27 @@ 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
|
||||
@ -43,8 +48,9 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act
|
||||
where
|
||||
-- act :: YesodJobDB UniWorX ()
|
||||
act = do
|
||||
$logInfoS "lms" $ "Start e-learning users for qualification " <> tshow qid <> "."
|
||||
quali <- getJust qid -- may throw an error, aborting the job
|
||||
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
|
||||
@ -72,11 +78,6 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act
|
||||
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
|
||||
@ -94,109 +95,114 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act
|
||||
, lmsUserStatus = Nothing
|
||||
, lmsUserStarted = now
|
||||
, lmsUserReceived = 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 }
|
||||
}
|
||||
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
|
||||
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
|
||||
|
||||
-- purge LmsIdent adter QualificationAuditDuration expired
|
||||
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
|
||||
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
|
||||
-- result :: [(Entity LmsUser, Entity LmsResult)]
|
||||
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
|
||||
(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
|
||||
(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 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
|
||||
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
|
||||
]
|
||||
else
|
||||
$logErrorS "LmsResult" [st|LMS success with insane date #{tshow (lmsResultSuccess lresult)} received|]
|
||||
insert_ $ LmsAudit qid (lmsUserIdent luser) newStatus lreceived now
|
||||
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 = hoist lift $ do
|
||||
act :: YesodJobDB UniWorX ()
|
||||
act = do
|
||||
now <- liftIO getCurrentTime
|
||||
-- result :: [(Entity LmsUser, Entity LmsUserlist)]
|
||||
results <- E.select $ do
|
||||
@ -209,19 +215,26 @@ dispatchJobLmsUserlist qid = JobHandlerAtomic act
|
||||
return (luser, lulist)
|
||||
forM_ results $ \case
|
||||
(Entity luid luser, Nothing)
|
||||
| isJust $ lmsUserReceived luser
|
||||
| isJust $ lmsUserReceived luser -- mark all previuosly reported, but now unreported users as ended (LMS deleted them as expected)
|
||||
, isNothing $ lmsUserEnded luser ->
|
||||
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
|
||||
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
|
||||
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|]
|
||||
|
||||
@ -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"
|
||||
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
|
||||
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]
|
||||
|
||||
@ -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))
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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"|]
|
||||
|
||||
@ -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
|
||||
, 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 .: "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
|
||||
|
||||
@ -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
|
||||
@ -184,9 +187,10 @@ instance FromJSON CsvFormatOptions where
|
||||
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
|
||||
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
@ -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"
|
||||
@ -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"
|
||||
|
||||
@ -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)
|
||||
|
||||
|
||||
31
src/Utils.hs
31
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 = "<Space>"
|
||||
| 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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
-----------
|
||||
|
||||
1
start.sh
1
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() {
|
||||
|
||||
15
templates/ldap.hamlet
Normal file
15
templates/ldap.hamlet
Normal file
@ -0,0 +1,15 @@
|
||||
<section>
|
||||
<p>
|
||||
LDAP Person Search:
|
||||
^{personForm}
|
||||
$maybe answers <- mbLdapData
|
||||
<h1>
|
||||
Antwort: #
|
||||
<dl .deflist>
|
||||
$forall (lk, lv) <- answers
|
||||
<dt>
|
||||
#{show lk}
|
||||
<dd>
|
||||
UTF8: #{presentUtf8 lv}
|
||||
—
|
||||
Latin: #{presentLatin1 lv}
|
||||
@ -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: <http://drive.fraport.de>
|
||||
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
|
||||
|
||||
@ -13,4 +13,6 @@ $newline never
|
||||
<h1>
|
||||
<a href=#{resetUrl}>
|
||||
_{SomeMessage MsgResetPassword}
|
||||
<p>
|
||||
<a href=#{resetUrl}>
|
||||
_{SomeMessage $ MsgLinkActiveUntil activeTime}
|
||||
|
||||
@ -28,7 +28,9 @@ $newline never
|
||||
<dd>#{expiryDate}
|
||||
|
||||
<p>
|
||||
_{SomeMessage MsgLmsRenewalInstructions}
|
||||
_{SomeMessage MsgLmsRenewalInstructions} #
|
||||
|
||||
<a href=#{lmsLogin}>
|
||||
_{SomeMessage MsgMppURL} #{lmsUrl}
|
||||
|
||||
^{ihamletSomeMessage editNotifications}
|
||||
|
||||
@ -19,10 +19,15 @@ $newline never
|
||||
_{SomeMessage MsgUserAuthModePWHashChangedToLDAP}
|
||||
$of AuthPWHash _
|
||||
_{SomeMessage MsgUserAuthModeLDAPChangedToPWHash}
|
||||
<p>
|
||||
<a href=@{NewsR}>
|
||||
_{SomeMessage MsgMailFradrive} #
|
||||
_{SomeMessage MsgMailBodyFradrive}
|
||||
|
||||
$if is _AuthPWHash userAuthentication
|
||||
<p>
|
||||
_{SomeMessage MsgAuthPWHashTip}
|
||||
<dd>
|
||||
<dl>
|
||||
<dt>
|
||||
_{SomeMessage MsgPWHashIdent}
|
||||
<dd .email>
|
||||
|
||||
@ -505,28 +505,37 @@ fillDb = do
|
||||
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' $ 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
|
||||
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' $ 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
|
||||
|
||||
@ -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
|
||||
|
||||
BIN
testdata/test.pdf
vendored
Normal file
BIN
testdata/test.pdf
vendored
Normal file
Binary file not shown.
Reference in New Issue
Block a user