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

Merge branch 'master' into srv01

Browse Source
This commit is contained in:
Sarah Vaupel 2023-05-05 12:38:41 +00:00
commit e25af0d25a
67 changed files with 1104 additions and 463 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
CHANGELOG.md
View File

@ -2,6 +2,36 @@
All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines. All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines.
## [27.3.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.3.1...v27.3.2) (2023-05-05)
### Bug Fixes
* **build:** remove impossible ([90b38ca](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/90b38ca5dc319f2d175978242b2fdd4477568a3c))
## [27.3.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.3.0...v27.3.1) (2023-05-04)
## [27.3.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.2.0...v27.3.0) (2023-05-02)
### Features
* **qualfications:** renewal actions and filtering by card and personal number ([4df0243](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/4df024374d387fc85a833b3faffe1b6ef8edc7d9))
### Bug Fixes
* **avs:** chunk avs status query automatically ([352ee21](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/352ee215b4075c70dbf9229434e62c8e6d847ae4))
* **build:** minor move parenthesis to make linter happy ([02bf1d9](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/02bf1d9a2ca433e55cf7d1e06f0ff300b53c7efb))
* **build:** remove redundant constraints ([ea82d75](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ea82d75a0934f8e13f26af5cb8a06c11d32dc0c5))
* **cvs:** export company in e-learning view ([2093cf5](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/2093cf501827ab2305f26ab5cf742f2b0be4a7de))
* **email:** better wording for qualifcation expired notice ([412c56e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/412c56e78ceaef263e4ca8b8678bb0e8ea2efb9a))
* **letter:** update receiver postal address before sending ([7d5c4bf](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/7d5c4bff2512154c087133e029713efa0657fa5a))
* **profile:** bad email indicator ([6699f1d](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/6699f1d72f148ccd2c82bebb3f582cf61d711425))
* **qualifications:** counts for lms/quals correct now ([33a847b](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/33a847baa3310e6e261409f2cda9d964cf5a821d))
* **users:** assimilate merges possibly incomplete user fields ([52afd13](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/52afd13b6dc2b870ab8dbba956874e8950e07973))
* **users:** prevent accidental user hijacking ([014d479](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/014d479df8f36515915bc7991bb97bad24dcbef9))
## [27.2.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.1.6...v27.2.0) (2023-04-06) ## [27.2.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.1.6...v27.2.0) (2023-04-06)

2
build.sh
View File

@ -9,5 +9,5 @@ set -e
[ "${FLOCKER}" != "$0" ] && exec env FLOCKER="$0" flock -en .stack-work.lock "$0" "$@" || : [ "${FLOCKER}" != "$0" ] && exec env FLOCKER="$0" flock -en .stack-work.lock "$0" "$@" || :
echo "Building..." echo "Building..."
stack build --fast --flag uniworx:-library-only --flag uniworx:dev $@ stack build --fast --profile --library-profiling --executable-profiling --flag uniworx:-library-only --flag uniworx:dev $@
echo "Done." echo "Done."

4
messages/auth/campus/de.msg
View File

@ -2,7 +2,7 @@
# #
# SPDX-License-Identifier: AGPL-3.0-or-later # SPDX-License-Identifier: AGPL-3.0-or-later
CampusIdentPlaceholder: V.Nachname@fraport.de CampusIdentPlaceholder: V.Nachname@fraport.de / E12345
CampusIdent: Fraport AG Kennung CampusIdent: Fraport Kennung
CampusPassword: Passwort CampusPassword: Passwort
CampusPasswordPlaceholder: Passwort CampusPasswordPlaceholder: Passwort

4
messages/auth/campus/en.msg
View File

@ -2,7 +2,7 @@
# #
# SPDX-License-Identifier: AGPL-3.0-or-later # SPDX-License-Identifier: AGPL-3.0-or-later
CampusIdentPlaceholder: F.Last@fraport.de CampusIdentPlaceholder: F.Last@fraport.de / E12345
CampusIdent: Fraport AG account CampusIdent: Fraport account
CampusPassword: Password CampusPassword: Password
CampusPasswordPlaceholder: Password CampusPasswordPlaceholder: Password

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

@ -96,9 +96,9 @@ TutorialNoCapacity: In dieser Übung sind keine Plätze mehr frei.
ExamOccurrenceNoCapacity: Zu diesem Termin/Raum sind keine Plätze mehr frei. ExamOccurrenceNoCapacity: Zu diesem Termin/Raum sind keine Plätze mehr frei.
CourseNotEmpty: In diesem Kurs sind momentan Teilnehmer:innen angemeldet. CourseNotEmpty: In diesem Kurs sind momentan Teilnehmer:innen angemeldet.
LDAPLoginTitle: Fraport AG Login (Büko) LDAPLoginTitle: Fraport Login für interne und externe Nutzer
PWHashLoginTitle: FRADrive Login PWHashLoginTitle: Spezieller Funktionsnutzer Login
PWHashLoginNote: Verwenden Sie dieses Formular für zugesandte FRADrive Logindaten. Angestellte der Fraport AG sollten stattdessen den Büko-Login verwenden! PWHashLoginNote: Verwenden Sie dieses Formular nur, wenn Sie explizit dazu aufgefordert wurden. Alle anderen sollten das andere Login Formular verwenden!
DummyLoginTitle: Development-Login DummyLoginTitle: Development-Login
InternalLdapError: Interner Fehler beim Fraport Büko-Login InternalLdapError: Interner Fehler beim Fraport Büko-Login
CampusUserInvalidIdent: Konnte anhand des Fraport Büko-Logins keine eindeutige Identifikation ermitteln CampusUserInvalidIdent: Konnte anhand des Fraport Büko-Logins keine eindeutige Identifikation ermitteln

6
messages/uniworx/categories/authorization/en-eu.msg
View File

@ -97,9 +97,9 @@ TutorialNoCapacity: Tutorial has reached maximum capacity
ExamOccurrenceNoCapacity: Occurrence/Room has reached maximum capacity ExamOccurrenceNoCapacity: Occurrence/Room has reached maximum capacity
CourseNotEmpty: There are currently no participants enrolled for this course. CourseNotEmpty: There are currently no participants enrolled for this course.
LDAPLoginTitle: Fraport AG login (Büko) LDAPLoginTitle: Fraport login for intern and extern users
PWHashLoginTitle: FRADrive login PWHashLoginTitle: Special function user login
PWHashLoginNote: Use this form if you have received special FRADrive credentials. Fraport AG employees should use the Büko login instead! PWHashLoginNote: Only use this login form if you have received special instructions to do so. All others should use the other login field.
DummyLoginTitle: Development login DummyLoginTitle: Development login
InternalLdapError: Internal error during Fraport Büko login InternalLdapError: Internal error during Fraport Büko login
CampusUserInvalidIdent: Could not determine unique identification during Fraport Büko login CampusUserInvalidIdent: Could not determine unique identification during Fraport Büko login

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

@ -46,8 +46,8 @@ TutorialUsersDeregistered count: Successfully deregistered #{show count} partici
TutorialUserDeregister: Deregister from tutorial TutorialUserDeregister: Deregister from tutorial
TutorialUserSendMail: Send mail TutorialUserSendMail: Send mail
TutorialUserPrintQualification: Print certificate TutorialUserPrintQualification: Print certificate
TutorialUserGrantQualification: Grant Qualification TutorialUserGrantQualification: Grant qualification
TutorialUserRenewQualification: Renew Qualification TutorialUserRenewQualification: Renew qualification
TutorialUserRenewedQualification n@Int: Successfully renewed qualification #{tshow n} tutorial #{pluralEN n "user" "users"} TutorialUserRenewedQualification n@Int: Successfully renewed qualification #{tshow n} tutorial #{pluralEN n "user" "users"}
TutorialUserGrantedQualification n: Successfully granted qualification #{tshow n} tutorial #{pluralEN n "user" "users"} TutorialUserGrantedQualification n: Successfully granted qualification #{tshow n} tutorial #{pluralEN n "user" "users"}
CommTutorial: Tutorial message CommTutorial: Tutorial message

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

@ -25,9 +25,11 @@ TableQualificationBlockedTooltip: Wann wurde die Qualifikation vorübergehend au
TableQualificationBlockedTooltipSimple: Wann wurde die Qualifikation aus besonderem Grund wiederrufen? TableQualificationBlockedTooltipSimple: Wann wurde die Qualifikation aus besonderem Grund wiederrufen?
TableQualificationNoRenewal: Auslaufend TableQualificationNoRenewal: Auslaufend
TableQualificationNoRenewalTooltip: Es wird keine Benachrichtigung mehr versendet, wenn diese Qualifikation ablaufen sollte. Die Qualifikation kann noch weiterhin gültig sein. TableQualificationNoRenewalTooltip: Es wird keine Benachrichtigung mehr versendet, wenn diese Qualifikation ablaufen sollte. Die Qualifikation kann noch weiterhin gültig sein.
QualificationScheduleRenewalTooltip: Wird eine Benachrichtigung versendet, falls diese Qualikation bald ablaufen sollte?
QualificationUserNoRenewal: Läuft ohne Benachrichtigung aus QualificationUserNoRenewal: Läuft ohne Benachrichtigung aus
QualificationUserNone: Für diese Person sind keine Qualifikationen registriert. QualificationUserNone: Für diese Person sind keine Qualifikationen registriert.
QualificationBlockReason: Entzugsbegründung QualificationBlockReason: Entzugsbegründung
QualificationExpired: Ungültig seit
LmsUser: Inhaber LmsUser: Inhaber
LmsURL: Link E‑Learning LmsURL: Link E‑Learning
TableLmsEmail: E‑Mail TableLmsEmail: E‑Mail
@ -81,9 +83,11 @@ QualificationActExpire: Auslaufend markieren - keine Benachrichtigung zur Erneue
QualificationActUnexpire: Auslaufend aufheben - kostenpflichtige Benachrichtigung bei anstehender Erneuerung senden QualificationActUnexpire: Auslaufend aufheben - kostenpflichtige Benachrichtigung bei anstehender Erneuerung senden
QualificationSetExpire n@Int64: Benachrichtigung bei anstehender Erneuerung und E‑Learning abgeschaltet für #{n} #{pluralDE n "Person" "Personen"} QualificationSetExpire n@Int64: Benachrichtigung bei anstehender Erneuerung und E‑Learning abgeschaltet für #{n} #{pluralDE n "Person" "Personen"}
QualificationSetUnexpire n@Int64: Benachrichtigung bei anstehender Erneuerung und E‑Learning aktiviert für #{n} #{pluralDE n "Person" "Personen"} QualificationSetUnexpire n@Int64: Benachrichtigung bei anstehender Erneuerung und E‑Learning aktiviert für #{n} #{pluralDE n "Person" "Personen"}
QualificationActBlockSupervisor: Dauerhaft entziehen, mit sofortiger Wirkung QualificationActBlockSupervisor: Dauerhaft entziehen und Ansprechpartner entfernen, mit sofortiger Wirkung
QualificationActBlock: Entziehen QualificationActBlock: Entziehen
QualificationActUnblock: Entzug löschen QualificationActUnblock: Entzug löschen
QualificationActGrant: Qualifikation vergeben
QualificationActRenew: Qualifikation regulär verlängern
QualificationStatusBlock l@QualificationShorthand n@Int m@Int: #{n}/#{m} #{l} entzogen QualificationStatusBlock l@QualificationShorthand n@Int m@Int: #{n}/#{m} #{l} entzogen
QualificationStatusUnblock l@QualificationShorthand n@Int m@Int: #{n}/#{m} #{l} reaktiviert QualificationStatusUnblock l@QualificationShorthand n@Int m@Int: #{n}/#{m} #{l} reaktiviert
LmsRenewalInstructions: Weitere Anweisungen zur Verlängerung finden Sie im angehängten PDF. Um Missbrauch zu verhindern wurde das PDF mit dem im FRADrive hinterlegten PDF-Passwort des Prüflings verschlüsselt. Falls kein PDF-Passwort manuell hinterlegt wurde, ist das PDF-Passwort die Flughafen Ausweisnummer, inklusive Punkt und der Ziffer danach. LmsRenewalInstructions: Weitere Anweisungen zur Verlängerung finden Sie im angehängten PDF. Um Missbrauch zu verhindern wurde das PDF mit dem im FRADrive hinterlegten PDF-Passwort des Prüflings verschlüsselt. Falls kein PDF-Passwort manuell hinterlegt wurde, ist das PDF-Passwort die Flughafen Ausweisnummer, inklusive Punkt und der Ziffer danach.

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

@ -25,9 +25,11 @@ TableQualificationBlockedTooltip: Why and when was this qualification temporaril
TableQualificationBlockedTooltipSimple: When was this qualification revoked due to extraordinary reasons? TableQualificationBlockedTooltipSimple: When was this qualification revoked due to extraordinary reasons?
TableQualificationNoRenewal: Discontinued TableQualificationNoRenewal: Discontinued
TableQualificationNoRenewalTooltip: No renewal notifications will be send for this qualification upon expiry. The qualification may still be valid. TableQualificationNoRenewalTooltip: No renewal notifications will be send for this qualification upon expiry. The qualification may still be valid.
QualificationScheduleRenewalTooltip: Will there be a notification, if this qualification is about to expire soon?
QualificationUserNoRenewal: Expires without further notification QualificationUserNoRenewal: Expires without further notification
QualificationUserNone: No registered qualifications for this person. QualificationUserNone: No registered qualifications for this person.
QualificationBlockReason: Reason for revoking QualificationBlockReason: Reason for revoking
QualificationExpired: Expired on
LmsUser: Licensee LmsUser: Licensee
LmsURL: Link E-learning LmsURL: Link E-learning
TableLmsEmail: Email TableLmsEmail: Email
@ -63,13 +65,13 @@ CsvColumnLmsDelete: Will the identifier be deleted from the E-learning platfrom
CsvColumnLmsStaff: Is the user an internal staff member? (Legacy, currently ignored) CsvColumnLmsStaff: Is the user an internal staff member? (Legacy, currently ignored)
CsvColumnLmsSuccess: Timestamp of successful completion (UTC) CsvColumnLmsSuccess: Timestamp of successful completion (UTC)
CsvColumnLmsFailed: Blockier durch LMS, üblicherweise wegen zu vieler Fehlversuche CsvColumnLmsFailed: Blockier durch LMS, üblicherweise wegen zu vieler Fehlversuche
LmsUserlistInsert: New LMS User LmsUserlistInsert: New LMS user
LmsUserlistUpdate: Update of LMS User LmsUserlistUpdate: Update of LMS user
LmsResultInsert: New LMS result LmsResultInsert: New LMS result
LmsResultUpdate: Update of LMS result LmsResultUpdate: Update of LMS result
LmsResultCsvExceptionDuplicatedKey: CSV import with ambiguous key LmsResultCsvExceptionDuplicatedKey: CSV import with ambiguous key
LmsUserlistCsvExceptionDuplicatedKey: CSV import with ambiguous key LmsUserlistCsvExceptionDuplicatedKey: CSV import with ambiguous key
LmsDirectUpload: Direct upload for automated Systems LmsDirectUpload: Direct upload for automated systems
LmsErrorNoRefreshElearning: Error: E-learning will not be started automatically due to refresh-within time period not being set. LmsErrorNoRefreshElearning: Error: E-learning will not be started automatically due to refresh-within time period not being set.
MailSubjectQualificationRenewal qname: Qualification #{qname} must be renewed shortly MailSubjectQualificationRenewal qname: Qualification #{qname} must be renewed shortly
MailSubjectQualificationExpiry qname: Qualification #{qname} expires soon MailSubjectQualificationExpiry qname: Qualification #{qname} expires soon
@ -81,9 +83,11 @@ QualificationActExpire: Discontinue - qualification expires silently
QualificationActUnexpire: Continue - send a possibly fee-paying notification upon due renewal QualificationActUnexpire: Continue - send a possibly fee-paying notification upon due renewal
QualificationSetExpire n: Expiry notification and e‑learning deactivated for #{n} #{pluralENs n "person"} QualificationSetExpire n: Expiry notification and e‑learning deactivated for #{n} #{pluralENs n "person"}
QualificationSetUnexpire n: Expiry notification and e‑learning activated for #{n} #{pluralENs n "person"} QualificationSetUnexpire n: Expiry notification and e‑learning activated for #{n} #{pluralENs n "person"}
QualificationActBlockSupervisor: Waive permanently, effective immediately QualificationActBlockSupervisor: Waive permanently and remove all supervisiors, effective immediately
QualificationActBlock: Revoke QualificationActBlock: Revoke
QualificationActUnblock: Clear revocation QualificationActUnblock: Clear revocation
QualificationActGrant: Grant qualification
QualificationActRenew: Renew qualification
QualificationStatusBlock l n m: #{n}/#{m} #{l} revoked QualificationStatusBlock l n m: #{n}/#{m} #{l} revoked
QualificationStatusUnblock l n m: #{n}/#{m} #{l} reactivated QualificationStatusUnblock l n m: #{n}/#{m} #{l} reactivated
LmsRenewalInstructions: Instruction on how to accomplish the renewal are enclosed in the attached PDF. In order to avoid misuse, the PDF is encrypted with the FRADrive PDF-password of the examinee. If no PDF-password had been chosen yet, then the password is the Fraport id card number of the examinee, including the punctuation mark and the digit thereafter. LmsRenewalInstructions: Instruction on how to accomplish the renewal are enclosed in the attached PDF. In order to avoid misuse, the PDF is encrypted with the FRADrive PDF-password of the examinee. If no PDF-password had been chosen yet, then the password is the Fraport id card number of the examinee, including the punctuation mark and the digit thereafter.

4
messages/uniworx/categories/term/de-de-formal.msg
View File

@ -1,4 +1,4 @@
# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de> # SPDX-FileCopyrightText: 2023 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
# #
# SPDX-License-Identifier: AGPL-3.0-or-later # SPDX-License-Identifier: AGPL-3.0-or-later
@ -14,7 +14,7 @@ TermEnd: Ende Kursperiode
LectureStart: Beginn Kurse LectureStart: Beginn Kurse
TermEdited tid@TermId: Semester #{tid} erfolgreich editiert. TermEdited tid@TermId: Semester #{tid} erfolgreich editiert.
TermNewTitle: Semester editieren/anlegen. TermNewTitle: Semester editieren/anlegen.
InvalidInput: Eingaben bitte korrigieren. InvalidInput: Ungültige Eingabe, bitte korrigieren.
Term !ident-ok: Semester Term !ident-ok: Semester
TermPlaceholder: JJJJ TermPlaceholder: JJJJ
TermStartDay: Erster Tag TermStartDay: Erster Tag

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

@ -22,7 +22,7 @@ AdminUserPostAddress: Postalische Anschrift
AdminUserPrefersPostal: Briefe anstatt Email bevorzugt AdminUserPrefersPostal: Briefe anstatt Email bevorzugt
AdminUserPinPassword: Passwort zur Verschlüsselung von PDF Anhängen in Emails AdminUserPinPassword: Passwort zur Verschlüsselung von PDF Anhängen in Emails
AdminUserNoPassword: Kein Passwort gesetzt AdminUserNoPassword: Kein Passwort gesetzt
AdminUserAssimilate: Benutzer assimilieren AdminUserAssimilate: Diesen Benutzer assimilieren von
UserAdded: Benutzer erfolgreich angelegt UserAdded: Benutzer erfolgreich angelegt
UserCollision: Benutzer konnte wegen Eindeutigkeit nicht angelegt werden UserCollision: Benutzer konnte wegen Eindeutigkeit nicht angelegt werden
HeadingUserAdd: Benutzer:in anlegen HeadingUserAdd: Benutzer:in anlegen

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

@ -22,7 +22,7 @@ AdminUserPostAddress: Postal Address
AdminUserPrefersPostal: Prefers postal letters over email AdminUserPrefersPostal: Prefers postal letters over email
AdminUserPinPassword: Password used for PDF attachments to emails AdminUserPinPassword: Password used for PDF attachments to emails
AdminUserNoPassword: No password set AdminUserNoPassword: No password set
AdminUserAssimilate: Assimilate user AdminUserAssimilate: Assimilate user by another user
UserAdded: Successfully added user UserAdded: Successfully added user
UserCollision: Could not create user due to uniqueness constraint UserCollision: Could not create user due to uniqueness constraint
HeadingUserAdd: Add user HeadingUserAdd: Add user

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

@ -74,4 +74,6 @@ TableExamOfficeLabelStatus: Label-Farbe
TableExamOfficeLabelPriority: Label-Priorität TableExamOfficeLabelPriority: Label-Priorität
TableQualifications: Qualifikationen TableQualifications: Qualifikationen
TableCompany: Firma TableCompany: Firma
TableCompanies: Firmen
TableCompanyNos: Firmennummern
TableSupervisor: Ansprechpartner TableSupervisor: Ansprechpartner

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

@ -74,4 +74,6 @@ TableExamOfficeLabelStatus: Label colour
TableExamOfficeLabelPriority: Label priority TableExamOfficeLabelPriority: Label priority
TableQualifications: Qualifications TableQualifications: Qualifications
TableCompany: Company TableCompany: Company
TableCompanies: Companies
TableCompanyNos: Company numbers
TableSupervisor: Supervisor TableSupervisor: Supervisor

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

@ -1,4 +1,4 @@
# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de> # SPDX-FileCopyrightText: 2023 Steffen Jost <jost@tcs.ifi.lmu.de>,Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
# #
# SPDX-License-Identifier: AGPL-3.0-or-later # SPDX-License-Identifier: AGPL-3.0-or-later
@ -151,3 +151,5 @@ SheetGradingPassBinary': Bestanden/Nicht bestanden
SheetGradingPassAlways': Automatisch bestanden, sobald korrigiert SheetGradingPassAlways': Automatisch bestanden, sobald korrigiert
SheetTypeNormal !ident-ok: Normal SheetTypeNormal !ident-ok: Normal
SheetTypeBonus !ident-ok: Bonus SheetTypeBonus !ident-ok: Bonus
InvalidFormAction: Keine Aktion ausgeführt wegen ungültigen Formulardaten

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

@ -1,4 +1,4 @@
# SPDX-FileCopyrightText: 2022 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de> # SPDX-FileCopyrightText: 2023 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
# #
# SPDX-License-Identifier: AGPL-3.0-or-later # SPDX-License-Identifier: AGPL-3.0-or-later
@ -151,3 +151,5 @@ SheetGradingPassBinary': Pass/Fail
SheetGradingPassAlways': Automatically passed when corrected SheetGradingPassAlways': Automatically passed when corrected
SheetTypeNormal: Normal SheetTypeNormal: Normal
SheetTypeBonus: Bonus SheetTypeBonus: Bonus
InvalidFormAction: No action taken due to invalid form data

2
models/avs.model
View File

@ -29,5 +29,5 @@ UserAvsCard
cardNo AvsFullCardNo cardNo AvsFullCardNo
card AvsDataPersonCard card AvsDataPersonCard
lastSynch UTCTime lastSynch UTCTime
UniqueAvsCard cardNo -- UniqueAvsCard cardNo -- Note: cardNo is not unique; invalid cardNo may be reissued to different persons
deriving Generic deriving Generic

2
models/company.model
View File

@ -14,7 +14,7 @@ Company
UniqueCompanyShorthand shorthand UniqueCompanyShorthand shorthand
-- UniqueCompanyAvsId avsId -- should be the case, unclear if enforcing works here, since we cannot query avs by company id -- UniqueCompanyAvsId avsId -- should be the case, unclear if enforcing works here, since we cannot query avs by company id
Primary shorthand -- newtype Key Company = CompanyKey { unSchoolKey :: CompanyShorthand } Primary shorthand -- newtype Key Company = CompanyKey { unSchoolKey :: CompanyShorthand }
deriving Ord Eq Show Generic deriving Ord Eq Show Generic Binary
-- TODO: a way to populate this table (manually) -- TODO: a way to populate this table (manually)
CompanySynonym CompanySynonym

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

@ -1,3 +1,3 @@
{ {
"version": "27.2.0" "version": "27.3.2"
} }

2
nix/docker/version.json
View File

@ -1,3 +1,3 @@
{ {
"version": "27.2.0" "version": "27.3.2"
} }

2
package-lock.json generated
View File

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

2
package.json
View File

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

5
package.yaml
View File

@ -1,5 +1,5 @@
name: uniworx name: uniworx
version: 27.2.0 version: 27.3.2
dependencies: dependencies:
- base - base
- yesod - yesod
@ -147,6 +147,8 @@ dependencies:
- extended-reals - extended-reals
- rfc5051 - rfc5051
- unidecode - unidecode
- doctemplates
- doclayout
- pandoc - pandoc
- pandoc-types - pandoc-types
- typed-process - typed-process
@ -256,6 +258,7 @@ ghc-options:
- -fno-max-relevant-binds - -fno-max-relevant-binds
- -j - -j
- -freduction-depth=0 - -freduction-depth=0
- -fprof-auto-calls
when: when:
- condition: flag(pedantic) - condition: flag(pedantic)
ghc-options: ghc-options:

2
src/Handler/Admin.hs
View File

@ -137,7 +137,7 @@ mkUnreachableUsersTable = do
E.&&. E.not_ ((user E.^. UserEmail) `E.like` E.val "%@%.%") E.&&. E.not_ ((user E.^. UserEmail) `E.like` E.val "%@%.%")
pure user pure user
dbtRowKey = (E.^. UserId) dbtRowKey = (E.^. UserId)
dbtProj = dbtProjFilteredPostId -- TODO: still don't understand the choices here dbtProj = dbtProjId
dbtColonnade = dbtColonnade =
-} -}

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

@ -531,14 +531,13 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do
dbtRowKey = queryUserAvs >>> (E.^. UserAvsPersonId) -- ) &&& (queryQualification >>> (E.?. QualificationId)) -- WHY IS THIS AN ERROR? dbtRowKey = queryUserAvs >>> (E.^. UserAvsPersonId) -- ) &&& (queryQualification >>> (E.?. QualificationId)) -- WHY IS THIS AN ERROR?
-- Not sure what changes here: -- Not sure what changes here:
dbtProj = dbtProjId -- Simple $ \(userAvs, user, qualUsr, quali) -> return (userAvs, user, qualUsr, quali) dbtProj = dbtProjId -- Simple $ \(userAvs, user, qualUsr, quali) -> return (userAvs, user, qualUsr, quali)
-- dbtProj = dbtProjFilteredPostId
dbtColonnade = mconcat dbtColonnade = mconcat
[ dbSelect (applying _2) id $ return . view (resultUserAvs . _userAvsPersonId) [ dbSelect (applying _2) id $ return . view (resultUserAvs . _userAvsPersonId)
-- $ \DBRow{dbrOutput=(_,_,apid,_)} -> return apid -- return . view resultAvsPID -- does not type due to traversal -- $ \DBRow{dbrOutput=(_,_,apid,_)} -> return apid -- return . view resultAvsPID -- does not type due to traversal
, colUserNameLink AdminUserR , colUserNameLink AdminUserR
, sortable (Just "avspersonno") (i18nCell MsgAvsPersonNo) $ \(view resultUserAvs -> a) -> avsPersonNoLinkedCell a , sortable (Just "avspersonno") (i18nCell MsgAvsPersonNo) $ \(view resultUserAvs -> a) -> avsPersonNoLinkedCell a
-- , colUserCompany -- , colUserCompany
, sortable (Just "user-company") (i18nCell MsgTableCompany) $ \(view (resultUser . _entityKey) -> uid) -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX" , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \(view (resultUser . _entityKey) -> uid) -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX"
companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid
@ -554,6 +553,8 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do
, sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \(preview $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> cellMaybe dayCell d , sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \(preview $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> cellMaybe dayCell d
, sortable (Just "blocked-due") (i18nCell MsgTableQualificationBlockedDue & cellTooltip MsgTableQualificationBlockedTooltip , sortable (Just "blocked-due") (i18nCell MsgTableQualificationBlockedDue & cellTooltip MsgTableQualificationBlockedTooltip
) $ \(preview $ resultQualUser . _entityVal . _qualificationUserBlockedDue -> b) -> cellMaybe qualificationBlockedCell b ) $ \(preview $ resultQualUser . _entityVal . _qualificationUserBlockedDue -> b) -> cellMaybe qualificationBlockedCell b
, sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip
) $ \(preview $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> cellMaybe (flip ifIconCell IconNoNotification . not) b
, sortable Nothing (i18nCell MsgTableAvsActiveCards) $ \(view $ resultUserAvs . _userAvsPersonId -> apid) -> foldMap avsPersonCardCell $ Map.lookup apid apidStatus , sortable Nothing (i18nCell MsgTableAvsActiveCards) $ \(view $ resultUserAvs . _userAvsPersonId -> apid) -> foldMap avsPersonCardCell $ Map.lookup apid apidStatus
] ]
dbtSorting = mconcat dbtSorting = mconcat
@ -565,6 +566,7 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do
, single ("last-refresh" , SortColumn $ queryQualUser >>> (E.?. QualificationUserLastRefresh)) , single ("last-refresh" , SortColumn $ queryQualUser >>> (E.?. QualificationUserLastRefresh))
, single ("first-held" , SortColumn $ queryQualUser >>> (E.?. QualificationUserFirstHeld)) , single ("first-held" , SortColumn $ queryQualUser >>> (E.?. QualificationUserFirstHeld))
, single ("blocked-due" , SortColumn $ queryQualUser >>> (E.?. QualificationUserBlockedDue)) , single ("blocked-due" , SortColumn $ queryQualUser >>> (E.?. QualificationUserBlockedDue))
, single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.?. QualificationUserScheduleRenewal))
] ]
dbtFilter = mconcat dbtFilter = mconcat

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

@ -14,6 +14,7 @@ import Utils.Print
import Handler.Utils import Handler.Utils
import Jobs import Jobs
import Data.Ratio ((%))
import Data.Char (isDigit) import Data.Char (isDigit)
import qualified Data.Text as Text import qualified Data.Text as Text
-- import qualified Data.Text.IO as Text -- import qualified Data.Text.IO as Text
@ -97,7 +98,7 @@ postAdminTestR = do
case btnResult of case btnResult of
(FormSuccess CreateInf) -> addMessage Info "Informatik-Knopf gedrückt" (FormSuccess CreateInf) -> addMessage Info "Informatik-Knopf gedrückt"
(FormSuccess CreateMath) -> addMessage Warning "Knopf Mathematik erkannt" (FormSuccess CreateMath) -> addMessage Warning "Knopf Mathematik erkannt"
(FormSuccess CrashApp) -> addMessage Error "Crash Button betätigt" >> error "Crash Button" (FormSuccess CrashApp) -> addMessage Error "Crash Button Ratio 0 betätigt" >> error ("Crash Button" <> show (1 % 0))
FormMissing -> return () FormMissing -> return ()
_other -> addMessage Warning "KEIN Knopf erkannt" _other -> addMessage Warning "KEIN Knopf erkannt"

7
src/Handler/Health.hs
View File

@ -17,6 +17,8 @@ import qualified Data.Set as Set
import Control.Concurrent.STM.Delay import Control.Concurrent.STM.Delay
import System.Environment (lookupEnv) -- while git version number is not working
-- import Data.FileEmbed (embedStringFile) -- import Data.FileEmbed (embedStringFile)
getHealthR :: Handler TypedContent getHealthR :: Handler TypedContent
@ -107,7 +109,7 @@ getInstanceR = do
getStatusR :: Handler Html getStatusR :: Handler Html
getStatusR = do getStatusR = do
starttime <- getsYesod appStartTime starttime <- getsYesod appStartTime
currtime <- liftIO getCurrentTime (currtime, env_version) <- liftIO $ (,) <$> getCurrentTime <*> lookupEnv "VERSION_NR"
-- ft <- formatTime' "%Y-%m-%d %H:%M:%S" currtime -- ft <- formatTime' "%Y-%m-%d %H:%M:%S" currtime
withUrlRenderer withUrlRenderer
[hamlet| [hamlet|
@ -116,6 +118,9 @@ getStatusR = do
<head> <head>
<title>Status <title>Status
<body> <body>
$maybe env_ver <- env_version
<p>
Environment version #{env_ver}
<p> <p>
Current Time <br> Current Time <br>
#{show currtime} <br> #{show currtime} <br>

295
src/Handler/LMS.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de> -- SPDX-FileCopyrightText: 2023 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
-- --
-- SPDX-License-Identifier: AGPL-3.0-or-later -- SPDX-License-Identifier: AGPL-3.0-or-later
@ -25,7 +25,7 @@ import Import
import Jobs import Jobs
import Handler.Utils import Handler.Utils
-- import Handler.Utils.Csv import Handler.Utils.Users
import Handler.Utils.LMS import Handler.Utils.LMS
@ -47,7 +47,6 @@ import Handler.LMS.Userlist as Handler.LMS
import Handler.LMS.Result as Handler.LMS import Handler.LMS.Result as Handler.LMS
import Handler.LMS.Fake as Handler.LMS -- TODO: remove in production! import Handler.LMS.Fake as Handler.LMS -- TODO: remove in production!
-- import Handler.Utils.Qualification (validQualification)
-- avoids repetition of local definitions -- avoids repetition of local definitions
single :: (k,a) -> Map k a single :: (k,a) -> Map k a
@ -108,23 +107,23 @@ resultAllQualificationTotal = _dbrOutput . _3 . _unValue
mkLmsAllTable :: Bool -> DB (Any, Widget) mkLmsAllTable :: Bool -> DB (Any, Widget)
mkLmsAllTable isAdmin = do mkLmsAllTable isAdmin = do
now <- liftIO getCurrentTime svs <- getSupervisees
let let
resultDBTable = DBTable{..} resultDBTable = DBTable{..}
where where
dbtSQLQuery quali = do dbtSQLQuery quali = do
let cusers = Ex.subSelectCount $ do let filterSvs luser = luser Ex.^. LmsUserQualification Ex.==. quali Ex.^. QualificationId
quser <- Ex.from $ Ex.table @QualificationUser Ex.&&. (E.val isAdmin E.||. luser Ex.^. LmsUserUser `Ex.in_` E.vals svs)
Ex.where_ $ quser Ex.^. QualificationUserQualification Ex.==. quali Ex.^. QualificationId cusers = Ex.subSelectCount $ do
luser <- Ex.from $ Ex.table @LmsUser
Ex.where_ $ filterSvs luser
cactive = Ex.subSelectCount $ do cactive = Ex.subSelectCount $ do
quser <- Ex.from $ Ex.table @QualificationUser luser <- Ex.from $ Ex.table @LmsUser
Ex.where_ $ quser Ex.^. QualificationUserQualification Ex.==. quali Ex.^. QualificationId Ex.where_ $ filterSvs luser Ex.&&. E.isNothing (luser E.^. LmsUserStatus)
Ex.&&. validQualification (utctDay now) quser
-- Failed attempt using Join/GroupBy instead of subselect: see branch csv-osis-demo-groupby-problem -- Failed attempt using Join/GroupBy instead of subselect: see branch csv-osis-demo-groupby-problem
return (quali, cactive, cusers) return (quali, cactive, cusers)
dbtRowKey = (Ex.^. QualificationId) dbtRowKey = (Ex.^. QualificationId)
dbtProj = dbtProjId -- TODO: or dbtProjSimple what is the difference? dbtProj = dbtProjId
adminable = if isAdmin then sortable else \_ _ _ -> mempty adminable = if isAdmin then sortable else \_ _ _ -> mempty
dbtColonnade = dbColonnade $ mconcat dbtColonnade = dbColonnade $ mconcat
[ colSchool $ resultAllQualification . _qualificationSchool [ colSchool $ resultAllQualification . _qualificationSchool
@ -195,38 +194,42 @@ postLmsEditR = error "TODO: STUB"
data LmsTableCsv = LmsTableCsv -- L..T..C.. -> ltc.. data LmsTableCsv = LmsTableCsv -- L..T..C.. -> ltc..
{ ltcDisplayName :: UserDisplayName { ltcDisplayName :: UserDisplayName
, ltcEmail :: UserEmail , ltcEmail :: UserEmail
, ltcValidUntil :: Day , ltcCompany :: Maybe Text
, ltcLastRefresh :: Day , ltcCompanyNumbers :: CsvSemicolonList Int
, ltcFirstHeld :: Day , ltcValidUntil :: Day
, ltcBlockedDue :: Maybe QualificationBlocked , ltcLastRefresh :: Day
, ltcLmsIdent :: Maybe LmsIdent , ltcFirstHeld :: Day
, ltcLmsStatus :: Maybe LmsStatus , ltcBlockedDue :: Maybe QualificationBlocked
, ltcLmsStarted :: Maybe UTCTime , ltcLmsIdent :: Maybe LmsIdent
, ltcLmsDatePin :: Maybe UTCTime , ltcLmsStatus :: Maybe LmsStatus
, ltcLmsReceived :: Maybe UTCTime , ltcLmsStarted :: Maybe UTCTime
, ltcLmsNotified :: Maybe UTCTime , ltcLmsDatePin :: Maybe UTCTime
, ltcLmsEnded :: Maybe UTCTime , ltcLmsReceived :: Maybe UTCTime
, ltcLmsNotified :: Maybe UTCTime
, ltcLmsEnded :: Maybe UTCTime
} }
deriving Generic deriving Generic
makeLenses_ ''LmsTableCsv makeLenses_ ''LmsTableCsv
ltcExample :: LmsTableCsv ltcExample :: LmsTableCsv
ltcExample = LmsTableCsv ltcExample = LmsTableCsv
{ ltcDisplayName = "Max Mustermann" { ltcDisplayName = "Max Mustermann"
, ltcEmail = "m.mustermann@example.com" , ltcEmail = "m.mustermann@example.com"
, ltcValidUntil = compDay , ltcCompany = Just "Example Brothers LLC, SecondaryJobs Inc"
, ltcLastRefresh = compDay , ltcCompanyNumbers = CsvSemicolonList [27,69]
, ltcFirstHeld = compDay , ltcValidUntil = compDay
, ltcBlockedDue = Nothing , ltcLastRefresh = compDay
, ltcLmsIdent = Nothing , ltcFirstHeld = compDay
, ltcLmsStatus = Nothing , ltcBlockedDue = Nothing
, ltcLmsStarted = Just compTime , ltcLmsIdent = Nothing
, ltcLmsDatePin = Nothing , ltcLmsStatus = Nothing
, ltcLmsReceived = Nothing , ltcLmsStarted = Just compTime
, ltcLmsNotified = Nothing , ltcLmsDatePin = Nothing
, ltcLmsEnded = Nothing , ltcLmsReceived = Nothing
, ltcLmsNotified = Nothing
, ltcLmsEnded = Nothing
} }
where where
compTime :: UTCTime compTime :: UTCTime
@ -253,35 +256,37 @@ instance Csv.DefaultOrdered LmsTableCsv where
instance CsvColumnsExplained LmsTableCsv where instance CsvColumnsExplained LmsTableCsv where
csvColumnsExplanations = genericCsvColumnsExplanations ltcOptions $ Map.fromList csvColumnsExplanations = genericCsvColumnsExplanations ltcOptions $ Map.fromList
[ ('ltcDisplayName, MsgLmsUser) [ ('ltcDisplayName , SomeMessage MsgLmsUser)
, ('ltcEmail , MsgTableLmsEmail) , ('ltcEmail , SomeMessage MsgTableLmsEmail)
, ('ltcValidUntil , MsgLmsQualificationValidUntil) , ('ltcCompany , SomeMessage MsgTableCompanies)
, ('ltcLastRefresh, MsgTableQualificationLastRefresh) , ('ltcCompanyNumbers , SomeMessage MsgTableCompanyNos)
, ('ltcFirstHeld , MsgTableQualificationFirstHeld) , ('ltcValidUntil , SomeMessage MsgLmsQualificationValidUntil)
, ('ltcLmsIdent , MsgTableLmsIdent) , ('ltcLastRefresh , SomeMessage MsgTableQualificationLastRefresh)
, ('ltcLmsStatus , MsgTableLmsStatus) , ('ltcFirstHeld , SomeMessage MsgTableQualificationFirstHeld)
, ('ltcLmsStarted , MsgTableLmsStarted) , ('ltcLmsIdent , SomeMessage MsgTableLmsIdent)
, ('ltcLmsDatePin , MsgTableLmsDatePin) , ('ltcLmsStatus , SomeMessage MsgTableLmsStatus)
, ('ltcLmsReceived, MsgTableLmsReceived) , ('ltcLmsStarted , SomeMessage MsgTableLmsStarted)
, ('ltcLmsEnded , MsgTableLmsEnded) , ('ltcLmsDatePin , SomeMessage MsgTableLmsDatePin)
, ('ltcLmsReceived , SomeMessage MsgTableLmsReceived)
, ('ltcLmsEnded , SomeMessage MsgTableLmsEnded)
] ]
type LmsTableExpr = ( E.SqlExpr (Entity QualificationUser) type LmsTableExpr = E.SqlExpr (Entity QualificationUser)
`E.InnerJoin` E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity User)
) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity LmsUser)) `E.InnerJoin` E.SqlExpr (Entity LmsUser)
queryQualUser :: LmsTableExpr -> E.SqlExpr (Entity QualificationUser) queryQualUser :: LmsTableExpr -> E.SqlExpr (Entity QualificationUser)
queryQualUser = $(sqlIJproj 2 1) . $(sqlLOJproj 2 1) queryQualUser = $(sqlIJproj 3 1)
queryUser :: LmsTableExpr -> E.SqlExpr (Entity User) queryUser :: LmsTableExpr -> E.SqlExpr (Entity User)
queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 2 1) queryUser = $(sqlIJproj 3 2)
queryLmsUser :: LmsTableExpr -> E.SqlExpr (Maybe (Entity LmsUser)) queryLmsUser :: LmsTableExpr -> E.SqlExpr (Entity LmsUser)
queryLmsUser = $(sqlLOJproj 2 2) queryLmsUser = $(sqlIJproj 3 3)
type LmsTableData = DBRow (Entity QualificationUser, Entity User, Maybe (Entity LmsUser), E.Value (Maybe [Maybe UTCTime])) type LmsTableData = DBRow (Entity QualificationUser, Entity User, Entity LmsUser, E.Value (Maybe [Maybe UTCTime]), [Entity UserCompany])
resultQualUser :: Lens' LmsTableData (Entity QualificationUser) resultQualUser :: Lens' LmsTableData (Entity QualificationUser)
resultQualUser = _dbrOutput . _1 resultQualUser = _dbrOutput . _1
@ -289,12 +294,15 @@ resultQualUser = _dbrOutput . _1
resultUser :: Lens' LmsTableData (Entity User) resultUser :: Lens' LmsTableData (Entity User)
resultUser = _dbrOutput . _2 resultUser = _dbrOutput . _2
resultLmsUser :: Traversal' LmsTableData (Entity LmsUser) resultLmsUser :: Lens' LmsTableData (Entity LmsUser)
resultLmsUser = _dbrOutput . _3 . _Just resultLmsUser = _dbrOutput . _3
resultPrintAck :: Traversal' LmsTableData [Maybe UTCTime] resultPrintAck :: Traversal' LmsTableData [Maybe UTCTime]
resultPrintAck = _dbrOutput . _4 . _unValue . _Just resultPrintAck = _dbrOutput . _4 . _unValue . _Just
resultCompanyUser :: Lens' LmsTableData [Entity UserCompany]
resultCompanyUser = _dbrOutput . _5
instance HasEntity LmsTableData User where instance HasEntity LmsTableData User where
hasEntity = resultUser hasEntity = resultUser
@ -330,71 +338,73 @@ isRenewPinAct LmsActRenewPinData = True
lmsTableQuery :: QualificationId -> LmsTableExpr lmsTableQuery :: QualificationId -> LmsTableExpr
-> E.SqlQuery ( E.SqlExpr (Entity QualificationUser) -> E.SqlQuery ( E.SqlExpr (Entity QualificationUser)
, E.SqlExpr (Entity User) , E.SqlExpr (Entity User)
, E.SqlExpr (Maybe (Entity LmsUser)) , E.SqlExpr (Entity LmsUser)
, E.SqlExpr (E.Value (Maybe [Maybe UTCTime])) -- outer maybe indicates, whether a printJob exists, inner maybe indicates all acknowledged printJobs , E.SqlExpr (E.Value (Maybe [Maybe UTCTime])) -- outer maybe indicates, whether a printJob exists, inner maybe indicates all acknowledged printJobs
) )
lmsTableQuery qid (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser) = do lmsTableQuery qid (qualUser `E.InnerJoin` user `E.InnerJoin` lmsUser) = do
-- RECALL: another outer join on PrintJob did not work out well, since -- RECALL: another outer join on PrintJob did not work out well, since
-- - E.distinctOn [E.don $ printJob E.?. PrintJobLmsUser] $ do -- types, but destroys the ability to sort interactively, since distinctOn requires sorting; -- - E.distinctOn [E.don $ printJob E.?. PrintJobLmsUser] $ do -- types, but destroys the ability to sort interactively, since distinctOn requires sorting;
-- - using noExsists on printJob join condition works, but only deliver single value; -- - using noExsists on printJob join condition works, but only deliver single value;
-- experiments with separate sub-query showed that we would need two subsqueries to learn whether the request was indeed the latest -- experiments with separate sub-query showed that we would need two subsqueries to learn whether the request was indeed the latest
E.on $ user E.^. UserId E.=?. lmsUser E.?. LmsUserUser E.on $ user E.^. UserId E.==. lmsUser E.^. LmsUserUser
E.&&. E.val qid E.=?. lmsUser E.?. LmsUserQualification -- NOTE: condition was once erroneously placed in where-clause, which does not work E.&&. E.val qid E.==. lmsUser E.^. LmsUserQualification -- NOTE: condition was once erroneously placed in where-clause, which does not work
E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser
E.where_ $ E.val qid E.==. qualUser E.^. QualificationUserQualification E.where_ $ E.val qid E.==. qualUser E.^. QualificationUserQualification
-- TODO: decide whether to use subSelect or LeftOuterJoin and delete the other! -- TODO: decide whether to use subSelect or LeftOuterJoin and delete the other!
-- Letztes Datum anzeigen, wenn mehrere, dann diese in klickbaren Tooltip verstecken! -- Letztes Datum anzeigen, wenn mehrere, dann diese in klickbaren Tooltip verstecken!
let printAcknowledged = E.subSelectMaybe . E.from $ \pj -> do let printAcknowledged = E.subSelectMaybe . E.from $ \pj -> do
E.where_ $ E.isJust (pj E.^. PrintJobLmsUser) E.where_ $ E.isJust (pj E.^. PrintJobLmsUser)
E.&&. ((lmsUser E.?. LmsUserIdent) E.==. (pj E.^. PrintJobLmsUser)) E.&&. ((lmsUser E.^. LmsUserIdent) E.=?. (pj E.^. PrintJobLmsUser))
let pjOrder = [E.desc $ pj E.^. PrintJobCreated, E.desc $ pj E.^. PrintJobAcknowledged] -- latest created comes first! This is assumed to be the case later on! let pjOrder = [E.desc $ pj E.^. PrintJobCreated, E.desc $ pj E.^. PrintJobAcknowledged] -- latest created comes first! This is assumed to be the case later on!
pure $ --(E.arrayAggWith E.AggModeAll (pj E.^. PrintJobCreated ) pjOrder, -- return two aggregates only works with select, the restricted typr of subSelect does not seem to support this! pure $ --(E.arrayAggWith E.AggModeAll (pj E.^. PrintJobCreated ) pjOrder, -- return two aggregates only works with select, the restricted typr of subSelect does not seem to support this!
E.arrayAggWith E.AggModeAll (pj E.^. PrintJobAcknowledged) pjOrder E.arrayAggWith E.AggModeAll (pj E.^. PrintJobAcknowledged) pjOrder
return (qualUser, user, lmsUser, printAcknowledged) return (qualUser, user, lmsUser, printAcknowledged)
mkLmsTable :: forall h p cols act act'. mkLmsTable :: ( Functor h, ToSortable h
( Functor h, ToSortable h , AsCornice h p LmsTableData (DBCell (MForm Handler) (FormResult (First LmsTableActionData, DBFormResult UserId Bool LmsTableData))) cols
, Ord act, PathPiece act, RenderMessage UniWorX act
, AsCornice h p LmsTableData (DBCell (MForm Handler) (FormResult (First act', DBFormResult UserId Bool LmsTableData))) cols
) )
=> Bool => Bool
-> Entity Qualification -> Entity Qualification
-> Map act (AForm Handler act') -> Map LmsTableAction (AForm Handler LmsTableActionData)
-> cols -> (Map CompanyId Company -> cols)
-> PSValidator (MForm Handler) (FormResult (First act', DBFormResult UserId Bool LmsTableData)) -> PSValidator (MForm Handler) (FormResult (First LmsTableActionData, DBFormResult UserId Bool LmsTableData))
-> DB (FormResult (act', Set UserId), Widget) -> DB (FormResult (LmsTableActionData, Set UserId), Widget)
mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
currentRoute <- fromMaybe (error "mkLmsAllTable called from 404-handler") <$> liftHandler getCurrentRoute -- we know the route here -- lookup all companies
cmpMap <- memcachedBy (Just . Right $ 5 * diffMinute) ("CompanyDictionary"::Text) $ do
cmps <- selectList [] [Asc CompanyId]
return $ Map.fromAscList $ fmap (\c -> (entityKey c, entityVal c)) cmps
let let
-- currentRoute = LmsR (qualificationSchool quali) (qualificationShorthand quali) -- bad idea as seen
nowaday = utctDay now nowaday = utctDay now
mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday -- mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday
csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName) csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName)
dbtIdent :: Text dbtIdent :: Text
dbtIdent = "qualification" dbtIdent = "qualification"
dbtSQLQuery q = lmsTableQuery qid q dbtSQLQuery = lmsTableQuery qid
dbtRowKey = queryUser >>> (E.^. UserId) dbtRowKey = queryUser >>> (E.^. UserId)
dbtProj = dbtProjId dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr, printAcks) -> do
cmpUsr <- selectList [UserCompanyUser ==. entityKey usr] [Asc UserCompanyCompany]
dbtColonnade = cols return (qualUsr, usr, lmsUsr, printAcks, cmpUsr)
dbtColonnade = cols cmpMap
dbtSorting = mconcat dbtSorting = mconcat
[ single $ sortUserNameLink queryUser [ single $ sortUserNameLink queryUser
, single $ sortUserEmail queryUser , single $ sortUserEmail queryUser
, single $ sortUserMatriclenr queryUser
, single ("valid-until" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserValidUntil)) , single ("valid-until" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserValidUntil))
, single ("last-refresh" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserLastRefresh)) , single ("last-refresh" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserLastRefresh))
, single ("first-held" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserFirstHeld)) , single ("first-held" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserFirstHeld))
, single ("blocked-due" , SortColumnNeverNull$ queryQualUser >>> (E.^. QualificationUserBlockedDue)) , single ("blocked-due" , SortColumnNeverNull$ queryQualUser >>> (E.^. QualificationUserBlockedDue))
, single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal)) , single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal))
, single ("lms-ident" , SortColumnNullsInv $ queryLmsUser >>> (E.?. LmsUserIdent)) , single ("lms-ident" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserIdent))
, single ("lms-pin" , SortColumnNullsInv $ queryLmsUser >>> (E.?. LmsUserPin)) , single ("lms-pin" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserPin))
, single ("lms-status" , SortColumnNullsInv $ views (to queryLmsUser) (E.?. LmsUserStatus)) , single ("lms-status" , SortColumnNullsInv $ views (to queryLmsUser) (E.^. LmsUserStatus))
, single ("lms-started" , SortColumnNullsInv $ queryLmsUser >>> (E.?. LmsUserStarted)) , single ("lms-started" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserStarted))
, single ("lms-datepin" , SortColumnNullsInv $ queryLmsUser >>> (E.?. LmsUserDatePin)) , single ("lms-datepin" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserDatePin))
, single ("lms-received" , SortColumnNullsInv $ queryLmsUser >>> (E.?. LmsUserReceived)) , single ("lms-received" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserReceived))
, single ("lms-notified" , SortColumnNullsInv $ queryLmsUser >>> (E.?. LmsUserNotified)) -- cannot include printJob acknowledge date , single ("lms-notified" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserNotified)) -- cannot include printJob acknowledge date
, single ("lms-ended" , SortColumnNullsInv $ queryLmsUser >>> (E.?. LmsUserEnded)) , single ("lms-ended" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserEnded))
, single ( "user-company" , SortColumn $ \row -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do , single ( "user-company" , SortColumn $ \row -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId
@ -404,17 +414,17 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
] ]
dbtFilter = mconcat dbtFilter = mconcat
[ single $ fltrUserNameEmail queryUser [ single $ fltrUserNameEmail queryUser
, single ("lms-ident" , FilterColumn . E.mkContainsFilterWith (Just . LmsIdent) $ views (to queryLmsUser) (E.?. LmsUserIdent)) , single ("lms-ident" , FilterColumn . E.mkContainsFilterWith LmsIdent $ views (to queryLmsUser) (E.^. LmsUserIdent))
-- , single ("lms-status" , FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) ((E.>=. E.val nowaday) . (E.^. LmsUserStatus))) -- LmsStatus cannot be filtered easily within the DB -- , single ("lms-status" , FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) ((E.>=. E.val nowaday) . (E.^. LmsUserStatus))) -- LmsStatus cannot be filtered easily within the DB
-- , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) ((E.>=. E.val nowaday) . (E.^. QualificationUserValidUntil))) -- , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) ((E.>=. E.val nowaday) . (E.^. QualificationUserValidUntil)))
, single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification nowaday)) , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification nowaday))
, single ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion -> -- , single ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion ->
if | Just renewal <- mbRenewal -- if | Just renewal <- mbRenewal
, Just True <- getLast criterion -> quser E.^. QualificationUserValidUntil E.<=. E.val renewal -- , Just True <- getLast criterion -> quser E.^. QualificationUserValidUntil E.<=. E.val renewal
E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday -- E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday
| otherwise -> E.true -- | otherwise -> E.true
) -- )
, single ("lms-notified", FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) (E.isJust . (E.?. LmsUserNotified))) , single ("lms-notified", FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) (E.isJust . (E.^. LmsUserNotified)))
, single ("avs-number" , FilterColumn . E.mkExistsFilter $ \row criterion -> , single ("avs-number" , FilterColumn . E.mkExistsFilter $ \row criterion ->
E.from $ \usrAvs -> -- do E.from $ \usrAvs -> -- do
E.where_ $ usrAvs E.^. UserAvsUser E.==. queryUser row E.^. UserId E.where_ $ usrAvs E.^. UserAvsUser E.==. queryUser row E.^. UserId
@ -429,17 +439,30 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId E.&&. testcrit E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId E.&&. testcrit
) )
, single ("avs-card" , FilterColumn $ \(queryUser -> user) (criterion :: Set.Set Text) -> case readAvsFullCardNo =<< Set.lookupMin criterion of
Nothing -> E.false
Just cardNo -> E.exists $ E.from $ \(avsCard `E.InnerJoin` usrAvs) -> do
E.on $ usrAvs E.^. UserAvsPersonId E.==. avsCard E.^. UserAvsCardPersonId
E.where_ $ usrAvs E.^. UserAvsUser E.==. user E.^. UserId
E.&&. (avsCard E.^. UserAvsCardCardNo E.==. E.val cardNo)
)
, single ("personal-number", FilterColumn $ \(queryUser -> user) (criteria :: Set.Set Text) -> if
| Set.null criteria -> E.true
| otherwise -> E.any (\c -> user E.^. UserCompanyPersonalNumber `E.hasInfix` E.val c) criteria
)
] ]
dbtFilterUI mPrev = mconcat 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) , fltrUserNameEmailHdrUI MsgLmsUser mPrev
-- , prismAForm (singletonFilter "lms-status" . maybePrism _PathPiece) mPrev $ aopt (selectField' (Just $ SomeMessage MsgTableNoFilter) $ return (optionsPairs [(MsgTableLmsSuccess,"success"::Text),(MsgTableLmsFailed,"blocked")])) (fslI MsgTableLmsStatus)
, prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo)
, prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany) , prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany)
, prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumber)
, prismAForm (singletonFilter "avs-card" ) mPrev $ aopt textField (fslI MsgAvsCardNo)
, prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo)
, 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) , prismAForm (singletonFilter "lms-notified" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsNotified)
, if isNothing mbRenewal then mempty -- , prismAForm (singletonFilter "lms-status" . maybePrism _PathPiece) mPrev $ aopt (selectField' (Just $ SomeMessage MsgTableNoFilter) $ return (optionsPairs [(MsgTableLmsSuccess,"success"::Text),(MsgTableLmsFailed,"blocked")])) (fslI MsgTableLmsStatus)
else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal) -- , if isNothing mbRenewal then mempty
-- else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal)
] ]
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
dbtCsvEncode = Just DBTCsvEncode dbtCsvEncode = Just DBTCsvEncode
@ -456,6 +479,8 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
doEncode' = LmsTableCsv doEncode' = LmsTableCsv
<$> view (resultUser . _entityVal . _userDisplayName) <$> view (resultUser . _entityVal . _userDisplayName)
<*> view (resultUser . _entityVal . _userDisplayEmail) <*> view (resultUser . _entityVal . _userDisplayEmail)
<*> (view resultCompanyUser >>= getCompanies)
<*> (view resultCompanyUser >>= getCompanyNos)
<*> view (resultQualUser . _entityVal . _qualificationUserValidUntil) <*> view (resultQualUser . _entityVal . _qualificationUserValidUntil)
<*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh) <*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh)
<*> view (resultQualUser . _entityVal . _qualificationUserFirstHeld) <*> view (resultQualUser . _entityVal . _qualificationUserFirstHeld)
@ -467,12 +492,17 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
<*> (join . preview (resultLmsUser . _entityVal . _lmsUserReceived)) <*> (join . preview (resultLmsUser . _entityVal . _lmsUserReceived))
<*> (join . preview (resultLmsUser . _entityVal . _lmsUserNotified)) -- TODO: only exports last email date / print job sending date, not print acknowledge <*> (join . preview (resultLmsUser . _entityVal . _lmsUserNotified)) -- TODO: only exports last email date / print job sending date, not print acknowledge
<*> (join . preview (resultLmsUser . _entityVal . _lmsUserEnded)) <*> (join . preview (resultLmsUser . _entityVal . _lmsUserEnded))
getCompanies cmps = case mapMaybe (flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) cmps of
[] -> pure Nothing
somecmps -> pure $ Just $ intercalate ", " $ fmap (view (_companyName . _CI)) somecmps
getCompanyNos = pure . CsvSemicolonList . mapMaybe (preview (_Just . _companyAvsId) . flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany))
dbtCsvDecode = Nothing dbtCsvDecode = Nothing
dbtExtraReps = [] dbtExtraReps = []
dbtParams = if not isAdmin then def {dbParamsFormAction = Nothing, dbParamsFormSubmit = FormNoSubmit} else dbtParams = if not isAdmin then def {dbParamsFormAction = Nothing, dbParamsFormSubmit = FormNoSubmit} else
DBParamsForm DBParamsForm
{ dbParamsFormMethod = POST { dbParamsFormMethod = POST
, dbParamsFormAction = Just $ SomeRoute currentRoute , dbParamsFormAction = Nothing -- Just $ SomeRoute currentRoute
, dbParamsFormAttrs = [] , dbParamsFormAttrs = []
, dbParamsFormSubmit = FormSubmit , dbParamsFormSubmit = FormSubmit
, dbParamsFormAdditional , dbParamsFormAdditional
@ -505,7 +535,6 @@ getLmsR, postLmsR :: SchoolId -> QualificationShorthand -> Handler Html
getLmsR = postLmsR getLmsR = postLmsR
postLmsR sid qsh = do postLmsR sid qsh = do
isAdmin <- hasReadAccessTo AdminR isAdmin <- hasReadAccessTo AdminR
currentRoute <- fromMaybe (error "correctionsR called from 404-handler") <$> getCurrentRoute -- This should never be called from a 404 handler
((lmsRes, lmsTable), Entity qid quali) <- runDB $ do ((lmsRes, lmsTable), Entity qid quali) <- runDB $ do
qent <- getBy404 $ SchoolQualificationShort sid qsh qent <- getBy404 $ SchoolQualificationShort sid qsh
let acts :: Map LmsTableAction (AForm Handler LmsTableActionData) let acts :: Map LmsTableAction (AForm Handler LmsTableActionData)
@ -515,20 +544,21 @@ postLmsR sid qsh = do
-- , singletonMap LmsActRenewPin $ pure LmsActRenewPinData -- , singletonMap LmsActRenewPin $ pure LmsActRenewPinData
] ]
-- lmsStatusLink = toMaybe isAdmin LmsUserR -- lmsStatusLink = toMaybe isAdmin LmsUserR
colChoices = mconcat colChoices cmpMap = mconcat
[ if not isAdmin then mempty else dbSelectIf (applying _2) id (return . view (resultUser . _entityKey)) (\r -> isJust $ r ^? resultLmsUser) -- TODO: refactor using function "is" [ if not isAdmin then mempty else dbSelectIf (applying _2) id (return . view (resultUser . _entityKey)) (\r -> isJust $ r ^? resultLmsUser) -- TODO: refactor using function "is"
, colUserNameModalHdr MsgLmsUser AdminUserR , colUserNameModalHdr MsgLmsUser AdminUserR
, colUserEmail , colUserEmail
, sortable (Just "user-company") (i18nCell MsgTableCompany) $ \( view $ resultUser . _entityKey -> uid) -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX" , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultCompanyUser -> cmps) ->
companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do let icnSuper = text2markup " " <> icon IconSupervisor
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId cs = [ (cmpName, cmpSpr)
E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid | Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps
E.orderBy [E.asc (comp E.^. CompanyName)] , let cmpEnt = Map.lookup cmpId cmpMap
return (comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor) , Just Company{companyName = cmpName} <- [cmpEnt]
let companies = intersperse (text2markup ", ") $ ]
(\(E.Value cmpName, E.Value cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> companies' companies = intercalate (text2markup ", ") $
icnSuper = text2markup " " <> icon IconSupervisor (\(cmpName, cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> cs
pure $ toWgt $ mconcat companies in wgtCell companies
, colUserMatriclenr
, sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \( view $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> dayCell d , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \( view $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> dayCell d
, sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d
, sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d , sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d
@ -536,22 +566,22 @@ postLmsR sid qsh = do
) $ \( view $ resultQualUser . _entityVal . _qualificationUserBlockedDue -> b) -> qualificationBlockedCell b ) $ \( view $ resultQualUser . _entityVal . _qualificationUserBlockedDue -> b) -> qualificationBlockedCell b
, sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip , sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip
) $ \( view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification ) $ \( view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification
, sortable (Just "lms-ident") (i18nCell MsgTableLmsIdent) $ \(preview $ resultLmsUser . _entityVal . _lmsUserIdent . _getLmsIdent -> lid) -> foldMap textCell lid , sortable (Just "lms-ident") (i18nCell MsgTableLmsIdent) $ \(view $ resultLmsUser . _entityVal . _lmsUserIdent . _getLmsIdent -> lid) -> textCell lid
, sortable (Just "lms-pin") (i18nCell MsgTableLmsPin & cellAttrs <>~ [("uw-hide-column-default-hidden",mempty)] , sortable (Just "lms-pin") (i18nCell MsgTableLmsPin & cellAttrs <>~ [("uw-hide-column-default-hidden",mempty)]
) $ \(preview $ resultLmsUser . _entityVal . _lmsUserPin -> pin) -> foldMap textCell pin ) $ \(view $ resultLmsUser . _entityVal . _lmsUserPin -> pin) -> textCell pin
, sortable (Just "lms-status") (i18nCell MsgTableLmsStatus) $ \(preview $ resultLmsUser . _entityVal . _lmsUserStatus -> status) -> foldMap lmsStatusCell $ join status , sortable (Just "lms-status") (i18nCell MsgTableLmsStatus) $ \(view $ resultLmsUser . _entityVal . _lmsUserStatus -> status) -> foldMap lmsStatusCell status
, sortable (Just "lms-started") (i18nLms MsgTableLmsStarted) $ \(preview $ resultLmsUser . _entityVal . _lmsUserStarted -> d) -> foldMap dateTimeCell d , sortable (Just "lms-started") (i18nLms MsgTableLmsStarted) $ \(view $ resultLmsUser . _entityVal . _lmsUserStarted -> d) -> dateTimeCell d
, sortable (Just "lms-datepin") (i18nLms MsgTableLmsDatePin) $ \(preview $ resultLmsUser . _entityVal . _lmsUserDatePin -> d) -> foldMap dateTimeCell d , sortable (Just "lms-datepin") (i18nLms MsgTableLmsDatePin) $ \(view $ resultLmsUser . _entityVal . _lmsUserDatePin -> d) -> dateTimeCell d
, sortable (Just "lms-received") (i18nLms MsgTableLmsReceived) $ \(preview $ resultLmsUser . _entityVal . _lmsUserReceived -> d) -> foldMap dateTimeCell $ join d , sortable (Just "lms-received") (i18nLms MsgTableLmsReceived) $ \(view $ resultLmsUser . _entityVal . _lmsUserReceived -> d) -> foldMap dateTimeCell d
--, sortable (Just "lms-notified") (i18nLms MsgTableLmsNotified) $ \(preview $ resultLmsUser . _entityVal . _lmsUserNotified -> d) -> foldMap dateTimeCell $ join d --, sortable (Just "lms-notified") (i18nLms MsgTableLmsNotified) $ \(view $ resultLmsUser . _entityVal . _lmsUserNotified -> d) -> foldMap dateTimeCell $ join d
, sortable (Just "lms-notified") (i18nLms MsgTableLmsNotified & cellTooltip MsgTableLmsNotifiedTooltip) $ \row -> , sortable (Just "lms-notified") (i18nLms MsgTableLmsNotified & cellTooltip MsgTableLmsNotifiedTooltip) $ \row ->
-- 4 Cases: -- 4 Cases:
-- - No notification: LmsUserNotified == Nothing -- - No notification: LmsUserNotified == Nothing
-- - Email sent : LmsUserNotified == Just _ && PrintJobId == Nothing -- - Email sent : LmsUserNotified == Just _ && PrintJobId == Nothing
-- - Letter printed : LmsUserNotified == Just _ && PrintJobId == Just _ -- - Letter printed : LmsUserNotified == Just _ && PrintJobId == Just _
-- - Letter sent : LmsUserNotified == Just _ && PrintJobId == Just _ && PrintJobAcknowledged == Just _ -- - Letter sent : LmsUserNotified == Just _ && PrintJobId == Just _ && PrintJobAcknowledged == Just _
let notifyDate = join $ row ^? resultLmsUser . _entityVal . _lmsUserNotified let notifyDate = row ^. resultLmsUser . _entityVal . _lmsUserNotified
lmsident = row ^? resultLmsUser . _entityVal . _lmsUserIdent lmsident = row ^. resultLmsUser . _entityVal . _lmsUserIdent
recipient = row ^. hasUser recipient = row ^. hasUser
letterDates = row ^? resultPrintAck letterDates = row ^? resultPrintAck
lastLetterDate = headDef Nothing =<< letterDates lastLetterDate = headDef Nothing =<< letterDates
@ -561,7 +591,7 @@ postLmsR sid qsh = do
cDate = if | not letterSent -> foldMap dateTimeCell notifyDate cDate = if | not letterSent -> foldMap dateTimeCell notifyDate
| Just d <- lastLetterDate -> dateTimeCell d | Just d <- lastLetterDate -> dateTimeCell d
| otherwise -> i18nCell MsgPrintJobUnacknowledged | otherwise -> i18nCell MsgPrintJobUnacknowledged
lprLink :: Maybe (Route UniWorX) = lmsident <&> (\lid -> urlRoute (PrintCenterR, [("print-job-lmsid", toPathPiece lid)])) lprLink :: Route UniWorX = lmsident & (\lid -> urlRoute (PrintCenterR, [("print-job-lmsid", toPathPiece lid)]))
cAckDates = case letterDates of cAckDates = case letterDates of
Just ackDates@(_:_:_) -> spacerCell <> modalCell [whamlet| Just ackDates@(_:_:_) -> spacerCell <> modalCell [whamlet|
<h1> <h1>
@ -574,10 +604,9 @@ postLmsR sid qsh = do
^{formatTimeW SelFormatDateTime ackdate} ^{formatTimeW SelFormatDateTime ackdate}
$nothing $nothing
_{MsgPrintJobUnacknowledged} _{MsgPrintJobUnacknowledged}
$maybe lu <- lprLink <p>
<p> <a href=@{lprLink}>
<a href=@{lu}> _{MsgPrintJobs}
_{MsgPrintJobs}
|] |]
-- (PrintCenterR, [("pj-lmsid", toPathPiece lu)]) -- (PrintCenterR, [("pj-lmsid", toPathPiece lu)])
_ -> mempty _ -> mempty
@ -586,7 +615,7 @@ postLmsR sid qsh = do
then mempty then mempty
else cIcon <> spacerCell <> cDate <> cAckDates else cIcon <> spacerCell <> cDate <> cAckDates
-- , sortable (Just "lms-notified-alternative") (i18nLms MsgTableLmsNotified) $ \(preview resultPrintAck -> d) -> textCell (show d) -- , sortable (Just "lms-notified-alternative") (i18nLms MsgTableLmsNotified) $ \(preview resultPrintAck -> d) -> textCell (show d)
, sortable (Just "lms-ended") (i18nLms MsgTableLmsEnded) $ \(preview $ resultLmsUser . _entityVal . _lmsUserEnded -> d) -> foldMap dateTimeCell $ join d , sortable (Just "lms-ended") (i18nLms MsgTableLmsEnded) $ \(view $ resultLmsUser . _entityVal . _lmsUserEnded -> d) -> foldMap dateTimeCell d
] ]
where where
-- i18nLms :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a -- i18nLms :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a
@ -613,7 +642,7 @@ postLmsR sid qsh = do
when (isRenewPinAct action) $ addMessageI Success $ MsgLmsPinRenewal numExaminees when (isRenewPinAct action) $ addMessageI Success $ MsgLmsPinRenewal numExaminees
when (isNotifyAct action) $ addMessageI Success $ MsgLmsNotificationSend numExaminees when (isNotifyAct action) $ addMessageI Success $ MsgLmsNotificationSend numExaminees
when (diffSelected /= 0) $ addMessageI Warning $ MsgLmsActionFailed diffSelected when (diffSelected /= 0) $ addMessageI Warning $ MsgLmsActionFailed diffSelected
redirect currentRoute reloadKeepGetParams $ LmsR sid qsh
let heading = citext2widget $ "LMS " <> qualificationName quali let heading = citext2widget $ "LMS " <> qualificationName quali
siteLayout heading $ do siteLayout heading $ do

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

@ -96,7 +96,7 @@ mkResultTable sid qsh qid = do
E.where_ $ lmsresult E.^. LmsResultQualification E.==. E.val qid E.where_ $ lmsresult E.^. LmsResultQualification E.==. E.val qid
return lmsresult return lmsresult
dbtRowKey = (E.^. LmsResultId) dbtRowKey = (E.^. LmsResultId)
dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference? dbtProj = dbtProjId
dbtColonnade = dbColonnade $ mconcat dbtColonnade = dbColonnade $ mconcat
[ sortable (Just csvLmsIdent) (i18nCell MsgTableLmsIdent) $ \(view $ _dbrOutput . _entityVal . _lmsResultIdent . _getLmsIdent -> ident) -> textCell ident [ sortable (Just csvLmsIdent) (i18nCell MsgTableLmsIdent) $ \(view $ _dbrOutput . _entityVal . _lmsResultIdent . _getLmsIdent -> ident) -> textCell ident
, sortable (Just csvLmsSuccess) (i18nCell MsgTableLmsSuccess) $ \(view $ _dbrOutput . _entityVal . _lmsResultSuccess -> success) -> dayCell success , sortable (Just csvLmsSuccess) (i18nCell MsgTableLmsSuccess) $ \(view $ _dbrOutput . _entityVal . _lmsResultSuccess -> success) -> dayCell success

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

@ -94,7 +94,7 @@ mkUserlistTable sid qsh qid = do
E.where_ $ lmslist E.^. LmsUserlistQualification E.==. E.val qid E.where_ $ lmslist E.^. LmsUserlistQualification E.==. E.val qid
return lmslist return lmslist
dbtRowKey = (E.^. LmsUserlistId) dbtRowKey = (E.^. LmsUserlistId)
dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference? dbtProj = dbtProjId
dbtColonnade = dbColonnade $ mconcat dbtColonnade = dbColonnade $ mconcat
[ sortable (Just csvLmsIdent) (i18nCell MsgTableLmsIdent) $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> textCell $ lmsUserlistIdent & getLmsIdent [ sortable (Just csvLmsIdent) (i18nCell MsgTableLmsIdent) $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> textCell $ lmsUserlistIdent & getLmsIdent
, sortable (Just csvLmsBlocked) (i18nCell MsgTableLmsFailed) $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> ifIconCell lmsUserlistFailed IconBlocked , sortable (Just csvLmsBlocked) (i18nCell MsgTableLmsFailed) $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> ifIconCell lmsUserlistFailed IconBlocked

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

@ -95,7 +95,7 @@ mkUserTable _sid qsh qid = do
E.&&. E.isNothing (lmsuser E.^. LmsUserEnded) E.&&. E.isNothing (lmsuser E.^. LmsUserEnded)
return lmsuser return lmsuser
dbtRowKey = (E.^. LmsUserId) dbtRowKey = (E.^. LmsUserId)
dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference? dbtProj = dbtProjId
dbtColonnade = dbColonnade $ mconcat dbtColonnade = dbColonnade $ mconcat
[ sortable (Just csvLmsIdent) (i18nCell MsgTableLmsIdent) $ \(view $ _dbrOutput . _entityVal . _lmsUserIdent . _getLmsIdent -> ident) -> textCell ident [ sortable (Just csvLmsIdent) (i18nCell MsgTableLmsIdent) $ \(view $ _dbrOutput . _entityVal . _lmsUserIdent . _getLmsIdent -> ident) -> textCell ident
, sortable (Just csvLmsPin) (i18nCell MsgTableLmsPin & cellAttrs <>~ [("uw-hide-column-default-hidden",mempty)] , sortable (Just csvLmsPin) (i18nCell MsgTableLmsPin & cellAttrs <>~ [("uw-hide-column-default-hidden",mempty)]
@ -177,7 +177,8 @@ getLmsUsersDirectR sid qsh = do
--csvRenderedHeader = lmsUserTableCsvHeader --csvRenderedHeader = lmsUserTableCsvHeader
--cvsRendered = CsvRendered {..} --cvsRendered = CsvRendered {..}
csvRendered = toCsvRendered lmsUserTableCsvHeader $ lmsUser2csv cutoff . entityVal <$> lms_users csvRendered = toCsvRendered lmsUserTableCsvHeader $ lmsUser2csv cutoff . entityVal <$> lms_users
fmtOpts = def { csvIncludeHeader = lmsDownloadHeader fmtOpts = (review csvPreset CsvPresetRFC)
{ csvIncludeHeader = lmsDownloadHeader
, csvDelimiter = lmsDownloadDelimiter , csvDelimiter = lmsDownloadDelimiter
, csvUseCrLf = lmsDownloadCrLf , csvUseCrLf = lmsDownloadCrLf
} }

63
src/Handler/PrintCenter.hs
View File

@ -2,7 +2,7 @@
-- --
-- SPDX-License-Identifier: AGPL-3.0-or-later -- SPDX-License-Identifier: AGPL-3.0-or-later
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications, ExistentialQuantification #-}
{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-orphans #-}
module Handler.PrintCenter module Handler.PrintCenter
@ -25,6 +25,8 @@ import qualified Database.Esqueleto.Utils as E
import Database.Esqueleto.Utils.TH import Database.Esqueleto.Utils.TH
import Utils.Print import Utils.Print
import Utils.Print.Letters (MDLetter)
-- import Data.Aeson (encode) -- import Data.Aeson (encode)
import qualified Data.Text as Text import qualified Data.Text as Text
-- import qualified Data.Set as Set -- import qualified Data.Set as Set
@ -37,20 +39,24 @@ import Handler.Utils
single :: (k,a) -> Map k a single :: (k,a) -> Map k a
single = uncurry Map.singleton single = uncurry Map.singleton
data SomeLetter = forall l . (MDLetter l) => SomeLetter l -- a record selector would be useless here due to the escaped type variable
data LRQF = LRQF data LRQF = LRQF
{ lrqfUser :: Either UserEmail UserId { lrqfLetter :: Text
, lrqfSuper :: Maybe (Either UserEmail UserId) , lrqfUser :: Either UserEmail UserId
, lrqfQuali :: Entity Qualification , lrqfSuper :: Maybe (Either UserEmail UserId)
, lrqfIdent :: LmsIdent , lrqfQuali :: Entity Qualification
, lrqfPin :: Text , lrqfIdent :: LmsIdent
, lrqfExpiry:: Day , lrqfPin :: Text
, lrqfExpiry :: Day
} deriving (Eq, Generic) } deriving (Eq, Generic)
makeRenewalForm :: Maybe LRQF -> Form LRQF makeRenewalForm :: Maybe LRQF -> Form LRQF
makeRenewalForm tmpl = identifyForm FIDLmsLetter . validateForm validateLetterRenewQualificationF $ \html -> do makeRenewalForm tmpl = identifyForm FIDLmsLetter . validateForm validateLetterRenewQualificationF $ \html -> do
-- now_day <- utctDay <$> liftIO getCurrentTime -- now_day <- utctDay <$> liftIO getCurrentTime
flip (renderAForm FormStandard) html $ LRQF flip (renderAForm FormStandard) html $ LRQF
<$> areq (userField False Nothing) (fslI MsgLmsUser) (lrqfUser <$> tmpl) <$> areq textField (fslI MsgLmsUser) (lrqfLetter <$> tmpl)
<*> areq (userField False Nothing) (fslI MsgLmsUser) (lrqfUser <$> tmpl)
<*> aopt (userField False Nothing) (fslI MsgTableSupervisor) (lrqfSuper <$> tmpl) <*> aopt (userField False Nothing) (fslI MsgTableSupervisor) (lrqfSuper <$> tmpl)
<*> areq qualificationFieldEnt (fslI MsgQualificationName) (lrqfQuali <$> tmpl) <*> areq qualificationFieldEnt (fslI MsgQualificationName) (lrqfQuali <$> tmpl)
<*> areq lmsField (fslI MsgTableLmsIdent) (lrqfIdent <$> tmpl) <*> areq lmsField (fslI MsgTableLmsIdent) (lrqfIdent <$> tmpl)
@ -64,8 +70,9 @@ validateLetterRenewQualificationF = -- do
-- LRQF{..} <- State.get -- LRQF{..} <- State.get
return () return ()
lrqf2letter :: LRQF -> DB (Entity User, LetterRenewQualificationF) lrqf2letter :: LRQF -> DB (Entity User, SomeLetter)
lrqf2letter LRQF{..} = do lrqf2letter LRQF{..}
| lrqfLetter == "r" = do
usr <- getUser lrqfUser usr <- getUser lrqfUser
rcvr <- mapM getUser lrqfSuper rcvr <- mapM getUser lrqfSuper
let letter = LetterRenewQualificationF let letter = LetterRenewQualificationF
@ -81,7 +88,24 @@ lrqf2letter LRQF{..} = do
, qualSchool = lrqfQuali ^. _qualificationSchool , qualSchool = lrqfQuali ^. _qualificationSchool
, qualDuration = lrqfQuali ^. _qualificationValidDuration , qualDuration = lrqfQuali ^. _qualificationValidDuration
} }
return (fromMaybe usr rcvr, letter) return (fromMaybe usr rcvr, SomeLetter letter)
| lrqfLetter == "e" = do
rcvr <- mapM getUser lrqfSuper
usr <- getUser lrqfUser
usrUuid <- encrypt $ entityKey usr
let letter = LetterExpireQualificationF
{ leqfHolderUUID = usrUuid
, leqfHolderID = usr ^. _entityKey
, leqfHolderDN = usr ^. _userDisplayName
, leqfHolderSN = usr ^. _userSurname
, leqfExpiry = lrqfExpiry
, leqfId = lrqfQuali ^. _entityKey
, leqfName = lrqfQuali ^. _qualificationName . _CI
, leqfShort = lrqfQuali ^. _qualificationShorthand . _CI
, leqfSchool = lrqfQuali ^. _qualificationSchool
}
return (fromMaybe usr rcvr, SomeLetter letter)
| otherwise = error "Unknown Letter Type encountered. Use 'e' or 'r' only."
where where
getUser :: Either UserEmail UserId -> DB (Entity User) getUser :: Either UserEmail UserId -> DB (Entity User)
getUser (Right uid) = getEntity404 uid getUser (Right uid) = getEntity404 uid
@ -158,11 +182,10 @@ pjTableQuery (printJob `E.LeftOuterJoin` recipient
mkPJTable :: DB (FormResult (PJTableActionData, Set PrintJobId), Widget) mkPJTable :: DB (FormResult (PJTableActionData, Set PrintJobId), Widget)
mkPJTable = do mkPJTable = do
currentRoute <- fromMaybe (error "mkPJTable called from 404-handler") <$> liftHandler getCurrentRoute -- albeit we do know the route here
let let
dbtSQLQuery = pjTableQuery dbtSQLQuery = pjTableQuery
dbtRowKey = queryPrintJob >>> (E.^. PrintJobId) dbtRowKey = queryPrintJob >>> (E.^. PrintJobId)
dbtProj = dbtProjFilteredPostId dbtProj = dbtProjId
dbtColonnade = mconcat dbtColonnade = mconcat
[ dbSelectIf (applying _2) id (return . view (resultPrintJob . _entityKey)) (\r -> isNothing $ r ^. resultPrintJob . _entityVal . _printJobAcknowledged) [ dbSelectIf (applying _2) id (return . view (resultPrintJob . _entityKey)) (\r -> isNothing $ r ^. resultPrintJob . _entityVal . _printJobAcknowledged)
, sortable (Just "created") (i18nCell MsgPrintJobCreated) $ \( view $ resultPrintJob . _entityVal . _printJobCreated -> t) -> dateTimeCell t , sortable (Just "created") (i18nCell MsgPrintJobCreated) $ \( view $ resultPrintJob . _entityVal . _printJobCreated -> t) -> dateTimeCell t
@ -176,7 +199,7 @@ mkPJTable = do
, sortable (Just "sender") (i18nCell MsgPrintSender) $ \(preview resultSender -> u) -> maybeCell u $ cellHasUserLink AdminUserR , sortable (Just "sender") (i18nCell MsgPrintSender) $ \(preview resultSender -> u) -> maybeCell u $ cellHasUserLink AdminUserR
, sortable (Just "course") (i18nCell MsgPrintCourse) $ \(preview $ resultCourse . _entityVal -> c) -> maybeCell c courseCell , sortable (Just "course") (i18nCell MsgPrintCourse) $ \(preview $ resultCourse . _entityVal -> c) -> maybeCell c courseCell
, sortable (Just "qualification")(i18nCell MsgPrintQualification) $ \(preview $ resultQualification . _entityVal -> q) -> maybeCell q qualificationCell , sortable (Just "qualification")(i18nCell MsgPrintQualification) $ \(preview $ resultQualification . _entityVal -> q) -> maybeCell q qualificationCell
, sortable (Just "lmsid") (i18nCell MsgPrintLmsUser) $ \( view $ resultPrintJob . _entityVal . _printJobLmsUser -> l) -> foldMap textCell (getLmsIdent <$> l) , sortable (Just "lmsid") (i18nCell MsgPrintLmsUser) $ \( view $ resultPrintJob . _entityVal . _printJobLmsUser -> l) -> foldMap (textCell . getLmsIdent) l
] ]
dbtSorting = mconcat dbtSorting = mconcat
[ single ("name" , SortColumn $ queryPrintJob >>> (E.^. PrintJobName)) [ single ("name" , SortColumn $ queryPrintJob >>> (E.^. PrintJobName))
@ -227,7 +250,7 @@ mkPJTable = do
dbtExtraReps = [] dbtExtraReps = []
dbtParams = DBParamsForm dbtParams = DBParamsForm
{ dbParamsFormMethod = POST { dbParamsFormMethod = POST
, dbParamsFormAction = Just $ SomeRoute currentRoute , dbParamsFormAction = Nothing -- Just $ SomeRoute currentRoute
, dbParamsFormAttrs = [] , dbParamsFormAttrs = []
, dbParamsFormSubmit = FormSubmit , dbParamsFormSubmit = FormSubmit
, dbParamsFormAdditional , dbParamsFormAdditional
@ -255,7 +278,6 @@ mkPJTable = do
getPrintCenterR, postPrintCenterR :: Handler Html getPrintCenterR, postPrintCenterR :: Handler Html
getPrintCenterR = postPrintCenterR getPrintCenterR = postPrintCenterR
postPrintCenterR = do postPrintCenterR = do
currentRoute <- fromMaybe (error "printCenterR called from 404-handler") <$> getCurrentRoute -- This should never be called from a 404 handler
(pjRes, pjTable) <- runDB mkPJTable (pjRes, pjTable) <- runDB mkPJTable
formResult pjRes $ \case formResult pjRes $ \case
@ -263,7 +285,7 @@ postPrintCenterR = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
num <- runDB $ updateWhereCount [PrintJobAcknowledged ==. Nothing, PrintJobId <-. pjIds] [PrintJobAcknowledged =. Just now] num <- runDB $ updateWhereCount [PrintJobAcknowledged ==. Nothing, PrintJobId <-. pjIds] [PrintJobAcknowledged =. Just now]
addMessageI Success $ MsgPrintJobAcknowledge num addMessageI Success $ MsgPrintJobAcknowledge num
redirect currentRoute reloadKeepGetParams PrintCenterR
siteLayoutMsg MsgMenuApc $ do siteLayoutMsg MsgMenuApc $ do
setTitleI MsgMenuApc setTitleI MsgMenuApc
@ -279,7 +301,8 @@ postPrintSendR = do
let nowaday = utctDay now let nowaday = utctDay now
uid = usr ^. _entityKey uid = usr ^. _entityKey
mkLetter qual = LRQF mkLetter qual = LRQF
{ lrqfUser = Right uid { lrqfLetter = "r"
, lrqfUser = Right uid
, lrqfSuper = Nothing , lrqfSuper = Nothing
, lrqfQuali = qual , lrqfQuali = qual
, lrqfIdent = LmsIdent "stuvwxyz" , lrqfIdent = LmsIdent "stuvwxyz"
@ -290,7 +313,9 @@ postPrintSendR = do
((sendResult, sendWidget), sendEnctype) <- runFormPost $ makeRenewalForm def_lrqf ((sendResult, sendWidget), sendEnctype) <- runFormPost $ makeRenewalForm def_lrqf
let procFormSend lrqf = do let procFormSend lrqf = do
ok <- (runDB (lrqf2letter lrqf) >>= printLetter (Just uid)) >>= \case ok <- (runDB (lrqf2letter lrqf) >>= \case
(entUsr, SomeLetter l) -> printLetter (Just uid) (entUsr, l)
) >>= \case
Left err -> do Left err -> do
let msg = "PDF printing failed with error: " <> err let msg = "PDF printing failed with error: " <> err
$logErrorS "LPR" msg $logErrorS "LPR" msg

222
src/Handler/Qualification.hs
View File

@ -1,9 +1,8 @@
-- SPDX-FileCopyrightText: 2022 Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de> -- SPDX-FileCopyrightText: 2022-23 Steffen Jost <S.Jost@fraport.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
-- --
-- SPDX-License-Identifier: AGPL-3.0-or-later -- SPDX-License-Identifier: AGPL-3.0-or-later
{-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances {-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances
{-# OPTIONS -Wno-unused-top-binds #-} -- TODO: remove me, for debugging only
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
module Handler.Qualification module Handler.Qualification
@ -17,7 +16,7 @@ import Import
-- import Jobs -- import Jobs
import Handler.Utils import Handler.Utils
-- import Handler.Utils.Csv import Handler.Utils.Users
import Handler.Utils.LMS import Handler.Utils.LMS
@ -46,9 +45,10 @@ getQualificationSchoolR :: SchoolId -> Handler Html
getQualificationSchoolR ssh = redirect (QualificationAllR, [("qualification-overview-school", toPathPiece ssh)]) getQualificationSchoolR ssh = redirect (QualificationAllR, [("qualification-overview-school", toPathPiece ssh)])
getQualificationAllR :: Handler Html getQualificationAllR :: Handler Html
getQualificationAllR = do -- TODO just a stub getQualificationAllR = do
isAdmin <- hasReadAccessTo AdminR
qualiTable <- runDB $ do qualiTable <- runDB $ do
view _2 <$> mkQualificationAllTable view _2 <$> mkQualificationAllTable isAdmin
siteLayoutMsg MsgMenuQualifications $ do siteLayoutMsg MsgMenuQualifications $ do
setTitleI MsgMenuQualifications setTitleI MsgMenuQualifications
$(widgetFile "qualification-all") $(widgetFile "qualification-all")
@ -63,15 +63,9 @@ resultAllQualificationActive = _dbrOutput . _2 . _unValue
resultAllQualificationTotal :: Lens' AllQualificationTableData Word64 resultAllQualificationTotal :: Lens' AllQualificationTableData Word64
resultAllQualificationTotal = _dbrOutput . _3 . _unValue resultAllQualificationTotal = _dbrOutput . _3 . _unValue
getSupervisees :: DB (Set UserId)
getSupervisees = do
uid <- requireAuthId
svs <- userSupervisorUser . entityVal <<$>> selectList [UserSupervisorSupervisor ==. uid] [Asc UserSupervisorUser]
return $ Set.insert uid $ Set.fromAscList svs
mkQualificationAllTable :: Bool -> DB (Any, Widget)
mkQualificationAllTable :: DB (Any, Widget) mkQualificationAllTable isAdmin = do
mkQualificationAllTable = do
svs <- getSupervisees svs <- getSupervisees
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
let let
@ -79,7 +73,7 @@ mkQualificationAllTable = do
where where
dbtSQLQuery quali = do dbtSQLQuery quali = do
let filterSvs quser = quser Ex.^. QualificationUserQualification Ex.==. quali Ex.^. QualificationId let filterSvs quser = quser Ex.^. QualificationUserQualification Ex.==. quali Ex.^. QualificationId
Ex.&&. quser Ex.^. QualificationUserUser `Ex.in_` E.vals svs Ex.&&. (E.val isAdmin E.||. quser Ex.^. QualificationUserUser `Ex.in_` E.vals svs)
cusers = Ex.subSelectCount $ do cusers = Ex.subSelectCount $ do
quser <- Ex.from $ Ex.table @QualificationUser quser <- Ex.from $ Ex.table @QualificationUser
Ex.where_ $ filterSvs quser Ex.where_ $ filterSvs quser
@ -88,7 +82,7 @@ mkQualificationAllTable = do
Ex.where_ $ filterSvs quser Ex.&&. validQualification (utctDay now) quser Ex.where_ $ filterSvs quser Ex.&&. validQualification (utctDay now) quser
return (quali, cactive, cusers) return (quali, cactive, cusers)
dbtRowKey = (Ex.^. QualificationId) dbtRowKey = (Ex.^. QualificationId)
dbtProj = dbtProjId -- TODO: or dbtProjSimple what is the difference? dbtProj = dbtProjId
dbtColonnade = dbColonnade $ mconcat dbtColonnade = dbColonnade $ mconcat
[ colSchool $ resultAllQualification . _qualificationSchool [ colSchool $ resultAllQualification . _qualificationSchool
, sortable (Just "qshort") (i18nCell MsgQualificationShort) $ \(view resultAllQualification -> quali) -> , sortable (Just "qshort") (i18nCell MsgQualificationShort) $ \(view resultAllQualification -> quali) ->
@ -151,26 +145,32 @@ mkQualificationAllTable = do
-- postQualificationEditR = error "TODO" -- postQualificationEditR = error "TODO"
data QualificationTableCsv = QualificationTableCsv -- Q..T..C.. -> qtc.. data QualificationTableCsv = QualificationTableCsv -- Q..T..C.. -> qtc..
{ qtcDisplayName :: UserDisplayName { qtcDisplayName :: UserDisplayName
, qtcEmail :: UserEmail , qtcEmail :: UserEmail
, qtcValidUntil :: Day , qtcCompany :: Maybe Text
, qtcLastRefresh :: Day , qtcCompanyNumbers :: CsvSemicolonList Int
, qtcBlocked :: Maybe Day , qtcValidUntil :: Day
, qtcLmsStatusTxt :: Maybe Text , qtcLastRefresh :: Day
, qtcLmsStatusDay :: Maybe Day , qtcBlocked :: Maybe Day
, qtcScheduleRenewal:: Bool
, qtcLmsStatusTxt :: Maybe Text
, qtcLmsStatusDay :: Maybe Day
} }
deriving Generic deriving Generic
makeLenses_ ''QualificationTableCsv makeLenses_ ''QualificationTableCsv
qtcExample :: QualificationTableCsv qtcExample :: QualificationTableCsv
qtcExample = QualificationTableCsv qtcExample = QualificationTableCsv
{ qtcDisplayName = "Max Mustermann" { qtcDisplayName = "Max Mustermann"
, qtcEmail = "m.mustermann@example.com" , qtcEmail = "m.mustermann@example.com"
, qtcValidUntil = compDay , qtcCompany = Just "Example Brothers LLC, SecondaryJobs Inc"
, qtcLastRefresh = compDay , qtcCompanyNumbers = CsvSemicolonList [27,69]
, qtcBlocked = Nothing , qtcValidUntil = compDay
, qtcLmsStatusTxt = Just "Success" , qtcLastRefresh = compDay
, qtcLmsStatusDay = Just compDay , qtcBlocked = Nothing
, qtcScheduleRenewal= True
, qtcLmsStatusTxt = Just "Success"
, qtcLmsStatusDay = Just compDay
} }
where where
compTime :: UTCTime compTime :: UTCTime
@ -185,7 +185,7 @@ qtcOptions = Csv.defaultOptions { Csv.fieldLabelModifier = renameLtc }
renameLtc other = replaceLtc $ camelToPathPiece' 1 other renameLtc other = replaceLtc $ camelToPathPiece' 1 other
replaceLtc ('l':'m':'s':'-':t) = prefixLms t replaceLtc ('l':'m':'s':'-':t) = prefixLms t
replaceLtc other = other replaceLtc other = other
prefixLms = ("e-learn-" <>) prefixLms = ("elearn-" <>)
instance Csv.ToNamedRecord QualificationTableCsv where instance Csv.ToNamedRecord QualificationTableCsv where
toNamedRecord = Csv.genericToNamedRecord qtcOptions toNamedRecord = Csv.genericToNamedRecord qtcOptions
@ -195,18 +195,21 @@ instance Csv.DefaultOrdered QualificationTableCsv where
instance CsvColumnsExplained QualificationTableCsv where instance CsvColumnsExplained QualificationTableCsv where
csvColumnsExplanations = genericCsvColumnsExplanations qtcOptions $ Map.fromList csvColumnsExplanations = genericCsvColumnsExplanations qtcOptions $ Map.fromList
[ ('qtcDisplayName, MsgLmsUser) [ ('qtcDisplayName , SomeMessage MsgLmsUser)
, ('qtcEmail , MsgTableLmsEmail) , ('qtcEmail , SomeMessage MsgTableLmsEmail)
, ('qtcValidUntil , MsgLmsQualificationValidUntil) , ('qtcCompany , SomeMessage MsgTableCompanies)
, ('qtcLastRefresh, MsgTableQualificationLastRefresh) , ('qtcCompanyNumbers , SomeMessage MsgTableCompanyNos)
, ('qtcLmsStatusTxt, MsgTableLmsStatus) , ('qtcValidUntil , SomeMessage MsgLmsQualificationValidUntil)
, ('qtcLmsStatusDay, MsgTableLmsStatusDay) , ('qtcLastRefresh , SomeMessage MsgTableQualificationLastRefresh)
, ('qtcScheduleRenewal, SomeMessage MsgQualificationScheduleRenewalTooltip)
, ('qtcLmsStatusTxt , SomeMessage MsgTableLmsStatus)
, ('qtcLmsStatusDay , SomeMessage MsgTableLmsStatusDay)
] ]
type QualificationTableExpr = ( E.SqlExpr (Entity QualificationUser) type QualificationTableExpr = ( E.SqlExpr (Entity QualificationUser)
`E.InnerJoin` E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity User)
) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity LmsUser)) ) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity LmsUser))
queryQualUser :: QualificationTableExpr -> E.SqlExpr (Entity QualificationUser) queryQualUser :: QualificationTableExpr -> E.SqlExpr (Entity QualificationUser)
queryQualUser = $(sqlIJproj 2 1) . $(sqlLOJproj 2 1) queryQualUser = $(sqlIJproj 2 1) . $(sqlLOJproj 2 1)
@ -218,7 +221,7 @@ queryLmsUser :: QualificationTableExpr -> E.SqlExpr (Maybe (Entity LmsUser))
queryLmsUser = $(sqlLOJproj 2 2) queryLmsUser = $(sqlLOJproj 2 2)
type QualificationTableData = DBRow (Entity QualificationUser, Entity User, Maybe (Entity LmsUser)) type QualificationTableData = DBRow (Entity QualificationUser, Entity User, Maybe (Entity LmsUser), [Entity UserCompany])
resultQualUser :: Lens' QualificationTableData (Entity QualificationUser) resultQualUser :: Lens' QualificationTableData (Entity QualificationUser)
resultQualUser = _dbrOutput . _1 resultQualUser = _dbrOutput . _1
@ -229,6 +232,9 @@ resultUser = _dbrOutput . _2
resultLmsUser :: Traversal' QualificationTableData (Entity LmsUser) resultLmsUser :: Traversal' QualificationTableData (Entity LmsUser)
resultLmsUser = _dbrOutput . _3 . _Just resultLmsUser = _dbrOutput . _3 . _Just
resultCompanyUser :: Lens' QualificationTableData [Entity UserCompany]
resultCompanyUser = _dbrOutput . _4
instance HasEntity QualificationTableData User where instance HasEntity QualificationTableData User where
hasEntity = resultUser hasEntity = resultUser
@ -242,6 +248,8 @@ data QualificationTableAction
| QualificationActBlockSupervisor | QualificationActBlockSupervisor
| QualificationActBlock | QualificationActBlock
| QualificationActUnblock | QualificationActUnblock
| QualificationActRenew
| QualificationActGrant
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
instance Universe QualificationTableAction instance Universe QualificationTableAction
@ -249,13 +257,22 @@ instance Finite QualificationTableAction
nullaryPathPiece ''QualificationTableAction $ camelToPathPiece' 2 nullaryPathPiece ''QualificationTableAction $ camelToPathPiece' 2
embedRenderMessage ''UniWorX ''QualificationTableAction id embedRenderMessage ''UniWorX ''QualificationTableAction id
-- Not yet needed, since there is no additional data for now: {-
isAdminAct :: QualificationTableAction -> Bool
isAdminAct QualificationActExpire = False
isAdminAct QualificationActUnexpire = False
isAdminAct QualificationActBlockSupervisor = False
isAdminAct _ = True
-}
data QualificationTableActionData data QualificationTableActionData
= QualificationActExpireData = QualificationActExpireData
| QualificationActUnexpireData | QualificationActUnexpireData
| QualificationActBlockSupervisorData | QualificationActBlockSupervisorData
| QualificationActBlockData { qualTableActBlockReason :: Text} | QualificationActBlockData { qualTableActBlockReason :: Text }
| QualificationActUnblockData | QualificationActUnblockData
| QualificationActRenewData
| QualificationActGrantData { qualTableActGrantUntil :: Day }
deriving (Eq, Ord, Read, Show, Generic) deriving (Eq, Ord, Read, Show, Generic)
isExpiryAct :: QualificationTableActionData -> Bool isExpiryAct :: QualificationTableActionData -> Bool
@ -284,18 +301,21 @@ qualificationTableQuery qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin`
mkQualificationTable :: mkQualificationTable ::
( Functor h, ToSortable h ( Functor h, ToSortable h
, AsCornice h p QualificationTableData (DBCell (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableData))) cols , AsCornice h p QualificationTableData (DBCell (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableData))) cols
) )
=> Bool => Bool
-> Entity Qualification -> Entity Qualification
-> Map QualificationTableAction (AForm Handler QualificationTableActionData) -> Map QualificationTableAction (AForm Handler QualificationTableActionData)
-> cols -> (Map CompanyId Company -> cols)
-> PSValidator (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableData)) -> PSValidator (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableData))
-> DB (FormResult (QualificationTableActionData, Set UserId), Widget) -> DB (FormResult (QualificationTableActionData, Set UserId), Widget)
mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
svs <- getSupervisees svs <- getSupervisees
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
currentRoute <- fromMaybe (error "mkQualificationTable called from 404-handler") <$> liftHandler getCurrentRoute -- lookup all companies
cmpMap <- memcachedBy (Just . Right $ 5 * diffMinute) ("CompanyDictionary"::Text) $ do
cmps <- selectList [] [Asc CompanyId]
return $ Map.fromAscList $ fmap (\c -> (entityKey c, entityVal c)) cmps
let let
nowaday = utctDay now nowaday = utctDay now
mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday
@ -303,13 +323,21 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
dbtIdent :: Text dbtIdent :: Text
dbtIdent = "qualification" dbtIdent = "qualification"
fltrSvs = if isAdmin then const E.true else \quser -> quser E.^. QualificationUserUser `Ex.in_` E.vals svs fltrSvs = if isAdmin then const E.true else \quser -> quser E.^. QualificationUserUser `Ex.in_` E.vals svs
dbtSQLQuery q = qualificationTableQuery qid fltrSvs q dbtSQLQuery = qualificationTableQuery qid fltrSvs
dbtRowKey = queryUser >>> (E.^. UserId) dbtRowKey = queryUser >>> (E.^. UserId)
dbtProj = dbtProjId -- FilteredPostId dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr) -> do
dbtColonnade = cols -- cmps <- E.select . E.from $ \(usrComp `E.InnerJoin` comp) -> do
-- E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
-- E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val (entityKey usr)
-- E.orderBy [E.asc (comp E.^. CompanyName)]
-- return (comp E.^. CompanyName, comp E.^. CompanyAvsId, usrComp E.^. UserCompanySupervisor)
cmpUsr <- selectList [UserCompanyUser ==. entityKey usr] [Asc UserCompanyCompany]
return (qualUsr, usr, lmsUsr, cmpUsr)
dbtColonnade = cols cmpMap
dbtSorting = mconcat dbtSorting = mconcat
[ single $ sortUserNameLink queryUser [ single $ sortUserNameLink queryUser
, single $ sortUserEmail queryUser , single $ sortUserEmail queryUser
, single $ sortUserMatriclenr queryUser
, single ("valid-until" , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil)) , single ("valid-until" , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil))
, single ("last-refresh" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh)) , single ("last-refresh" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh))
, single ("blocked-due" , SortColumnNeverNull $ queryQualUser >>> (E.^. QualificationUserBlockedDue)) , single ("blocked-due" , SortColumnNeverNull $ queryQualUser >>> (E.^. QualificationUserBlockedDue))
@ -332,6 +360,17 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
E.where_ $ usrAvs E.^. UserAvsUser E.==. queryUser row E.^. UserId E.where_ $ usrAvs E.^. UserAvsUser E.==. queryUser row E.^. UserId
E.&&. ((E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.==. E.&&. ((E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.==.
(E.explicitUnsafeCoerceSqlExprValue "citext" (usrAvs E.^. UserAvsNoPerson) :: E.SqlExpr (E.Value (CI Text))) )) (E.explicitUnsafeCoerceSqlExprValue "citext" (usrAvs E.^. UserAvsNoPerson) :: E.SqlExpr (E.Value (CI Text))) ))
, single ("avs-card" , FilterColumn $ \(queryUser -> user) (criterion :: Set.Set Text) -> case readAvsFullCardNo =<< Set.lookupMin criterion of
Nothing -> E.false
Just cardNo -> E.exists $ E.from $ \(avsCard `E.InnerJoin` usrAvs) -> do
E.on $ usrAvs E.^. UserAvsPersonId E.==. avsCard E.^. UserAvsCardPersonId
E.where_ $ usrAvs E.^. UserAvsUser E.==. user E.^. UserId
E.&&. (avsCard E.^. UserAvsCardCardNo E.==. E.val cardNo)
)
, single ("personal-number", FilterColumn $ \(queryUser -> user) (criteria :: Set.Set Text) -> if
| Set.null criteria -> E.true
| otherwise -> E.any (\c -> user E.^. UserCompanyPersonalNumber `E.hasInfix` E.val c) criteria
)
, single ("user-company", FilterColumn . E.mkExistsFilter $ \row criterion -> , single ("user-company", FilterColumn . E.mkExistsFilter $ \row criterion ->
E.from $ \(usrComp `E.InnerJoin` comp) -> do E.from $ \(usrComp `E.InnerJoin` comp) -> do
let testname = (E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf` let testname = (E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf`
@ -351,8 +390,10 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
] ]
dbtFilterUI mPrev = mconcat dbtFilterUI mPrev = mconcat
[ fltrUserNameEmailHdrUI MsgLmsUser mPrev [ fltrUserNameEmailHdrUI MsgLmsUser mPrev
, prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo) , prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany)
, prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany) , prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumber)
, prismAForm (singletonFilter "avs-card" ) mPrev $ aopt textField (fslI MsgAvsCardNo)
, prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo)
, 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)
, if isNothing mbRenewal then mempty , if isNothing mbRenewal then mempty
else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal) else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal)
@ -372,11 +413,19 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
doEncode' = QualificationTableCsv doEncode' = QualificationTableCsv
<$> view (resultUser . _entityVal . _userDisplayName) <$> view (resultUser . _entityVal . _userDisplayName)
<*> view (resultUser . _entityVal . _userDisplayEmail) <*> view (resultUser . _entityVal . _userDisplayEmail)
<*> (view resultCompanyUser >>= getCompanies)
<*> (view resultCompanyUser >>= getCompanyNos)
<*> view (resultQualUser . _entityVal . _qualificationUserValidUntil) <*> view (resultQualUser . _entityVal . _qualificationUserValidUntil)
<*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh) <*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh)
<*> preview (resultQualUser . _entityVal . _qualificationUserBlockedDue . _Just . _qualificationBlockedDay) <*> preview (resultQualUser . _entityVal . _qualificationUserBlockedDue . _Just . _qualificationBlockedDay)
<*> view (resultQualUser . _entityVal . _qualificationUserScheduleRenewal)
<*> getStatusPlusTxt <*> getStatusPlusTxt
<*> getStatusPlusDay <*> getStatusPlusDay
getCompanies cmps = case mapMaybe (flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) cmps of
[] -> pure Nothing
somecmps -> pure $ Just $ intercalate ", " $ fmap (view (_companyName . _CI)) somecmps
getCompanyNos = pure . CsvSemicolonList . mapMaybe (preview (_Just . _companyAvsId) . flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany))
getStatusPlusTxt = getStatusPlusTxt =
(join . preview (resultLmsUser . _entityVal . _lmsUserStatus)) >>= \case (join . preview (resultLmsUser . _entityVal . _lmsUserStatus)) >>= \case
Just LmsBlocked{} -> return $ Just "Failed" Just LmsBlocked{} -> return $ Just "Failed"
@ -393,7 +442,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
dbtExtraReps = [] dbtExtraReps = []
dbtParams = DBParamsForm dbtParams = DBParamsForm
{ dbParamsFormMethod = POST { dbParamsFormMethod = POST
, dbParamsFormAction = Just $ SomeRoute currentRoute , dbParamsFormAction = Nothing
, dbParamsFormAttrs = [] , dbParamsFormAttrs = []
, dbParamsFormSubmit = FormSubmit , dbParamsFormSubmit = FormSubmit
, dbParamsFormAdditional , dbParamsFormAdditional
@ -420,37 +469,47 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
getQualificationR, postQualificationR :: SchoolId -> QualificationShorthand -> Handler Html getQualificationR, postQualificationR :: SchoolId -> QualificationShorthand -> Handler Html
getQualificationR = postQualificationR getQualificationR = postQualificationR
postQualificationR sid qsh = do postQualificationR sid qsh = do
currentRoute <- fromMaybe (error "correctionsR called from 404-handler") <$> getCurrentRoute -- This should never be called from a 404 handler
isAdmin <- hasReadAccessTo AdminR isAdmin <- hasReadAccessTo AdminR
now <- liftIO getCurrentTime
let nowaday = utctDay now
((lmsRes, qualificationTable), Entity qid quali) <- runDB $ do ((lmsRes, qualificationTable), Entity qid quali) <- runDB $ do
qent@Entity{entityVal=Qualification{qualificationAuditDuration=auditMonths}} <- getBy404 $ SchoolQualificationShort sid qsh qent@Entity{entityVal=Qualification{
let acts :: Map QualificationTableAction (AForm Handler QualificationTableActionData) qualificationAuditDuration=auditMonths
, qualificationValidDuration=validMonths
}} <- getBy404 $ SchoolQualificationShort sid qsh
let dayExpiry = flip addGregorianDurationClip nowaday . fromMonths <$> validMonths
acts :: Map QualificationTableAction (AForm Handler QualificationTableActionData)
acts = mconcat $ acts = mconcat $
[ singletonMap QualificationActExpire $ pure QualificationActExpireData [ singletonMap QualificationActExpire $ pure QualificationActExpireData
, singletonMap QualificationActUnexpire $ pure QualificationActUnexpireData , singletonMap QualificationActUnexpire $ pure QualificationActUnexpireData
] ++ bool ] ++ bool
[ singletonMap QualificationActBlockSupervisor $ pure QualificationActBlockSupervisorData ] -- nonAdmin Supervisor [ singletonMap QualificationActBlockSupervisor $ pure QualificationActBlockSupervisorData ] -- nonAdmin actions, ie. Supervisor
[ singletonMap QualificationActUnblock $ pure QualificationActUnblockData [ singletonMap QualificationActUnblock $ pure QualificationActUnblockData -- Admin-only actions
, singletonMap QualificationActBlock $ QualificationActBlockData , singletonMap QualificationActBlock $ QualificationActBlockData
<$> apreq textField (fslI MsgQualificationBlockReason) Nothing <$> apreq textField (fslI MsgQualificationBlockReason) Nothing
, singletonMap QualificationActRenew $ pure QualificationActRenewData
, singletonMap QualificationActGrant
(QualificationActGrantData <$> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry)
] isAdmin ] isAdmin
linkLmsUser = toMaybe isAdmin LmsUserR linkLmsUser = toMaybe isAdmin LmsUserR
linkUserName = bool ForProfileR ForProfileDataR isAdmin linkUserName = bool ForProfileR ForProfileDataR isAdmin
blockedDueCell = bool qualificationBlockedCellNoReason qualificationBlockedCell isAdmin blockedDueCell = bool qualificationBlockedCellNoReason qualificationBlockedCell isAdmin
colChoices = mconcat colChoices cmpMap = mconcat
[ dbSelect (applying _2) id (return . view (resultUser . _entityKey)) [ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
, colUserNameModalHdr MsgLmsUser linkUserName , colUserNameModalHdr MsgLmsUser linkUserName
, colUserEmail , colUserEmail
, sortable (Just "user-company") (i18nCell MsgTableCompany) $ \( view $ resultUser . _entityKey -> uid) -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX" , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultCompanyUser -> cmps) ->
companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do let icnSuper = text2markup " " <> icon IconSupervisor
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId cs = [ (cmpName, cmpSpr)
E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid | Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps
E.orderBy [E.asc (comp E.^. CompanyName)] , let cmpEnt = Map.lookup cmpId cmpMap
return (comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor) , Just Company{companyName = cmpName} <- [cmpEnt]
let companies = intersperse (text2markup ", ") $ ]
(\(E.Value cmpName, E.Value cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> companies' companies = intercalate (text2markup ", ") $
icnSuper = text2markup " " <> icon IconSupervisor (\(cmpName, cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> cs
pure $ toWgt $ mconcat companies in wgtCell companies
, guardMonoid isAdmin colUserMatriclenr
, sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \( view $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> dayCell d , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \( view $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> dayCell d
, sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d
, sortable (Just "blocked-due") (i18nCell MsgTableQualificationBlockedDue & cellTooltip MsgTableQualificationBlockedTooltipSimple , sortable (Just "blocked-due") (i18nCell MsgTableQualificationBlockedDue & cellTooltip MsgTableQualificationBlockedTooltipSimple
@ -468,6 +527,14 @@ postQualificationR sid qsh = do
return (tbl, qent) return (tbl, qent)
formResult lmsRes $ \case formResult lmsRes $ \case
(QualificationActRenewData, selectedUsers) | isAdmin -> do
noks <- runDB $ renewValidQualificationUsers qid $ Set.toList selectedUsers
addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks
reloadKeepGetParams $ QualificationR sid qsh
(QualificationActGrantData grantValidday, selectedUsers) | isAdmin -> do
runDB . forM_ selectedUsers $ upsertQualificationUser qid nowaday grantValidday Nothing
addMessageI (if 0 < Set.size selectedUsers then Success else Warning) . MsgTutorialUserGrantedQualification $ Set.size selectedUsers
reloadKeepGetParams $ QualificationR sid qsh
(action, selectedUsers) | isExpiryAct action -> do (action, selectedUsers) | isExpiryAct action -> do
let isUnexpire = action == QualificationActUnexpireData let isUnexpire = action == QualificationActUnexpireData
upd <- runDB $ updateWhereCount upd <- runDB $ updateWhereCount
@ -476,10 +543,9 @@ postQualificationR sid qsh = do
let msgKind = if upd > 0 then Success else Warning let msgKind = if upd > 0 then Success else Warning
msgVal = upd & if isUnexpire then MsgQualificationSetUnexpire else MsgQualificationSetExpire msgVal = upd & if isUnexpire then MsgQualificationSetUnexpire else MsgQualificationSetExpire
addMessageI msgKind msgVal addMessageI msgKind msgVal
redirect currentRoute reloadKeepGetParams $ QualificationR sid qsh
(action, selectedUsers) | isBlockAct action && (isAdmin || action == QualificationActBlockSupervisorData) -> do (action, selectedUsers) | isBlockAct action && (isAdmin || action == QualificationActBlockSupervisorData) -> do
now <- liftIO getCurrentTime let selUserIds = Set.toList selectedUsers
let nowaday = utctDay now
qubr = case action of qubr = case action of
QualificationActUnblockData -> Nothing QualificationActUnblockData -> Nothing
QualificationActBlockSupervisorData -> Just $ mkQualificationBlocked QualificationBlockReturnedByCompany nowaday QualificationActBlockSupervisorData -> Just $ mkQualificationBlocked QualificationBlockReturnedByCompany nowaday
@ -488,7 +554,11 @@ postQualificationR sid qsh = do
, qualificationBlockedReason = qualTableActBlockReason , qualificationBlockedReason = qualTableActBlockReason
} }
_ -> error "Handle.Qualification.isBlockAct returned non-block action" _ -> error "Handle.Qualification.isBlockAct returned non-block action"
oks <- runDB $ qualificationUserBlocking qid (Set.toList selectedUsers) qubr
oks <- runDB $ do
deleteWhere [UserSupervisorUser <-. selUserIds]
deleteWhere [UserCompanyUser <-. selUserIds]
qualificationUserBlocking qid selUserIds qubr
let nrq = length selectedUsers let nrq = length selectedUsers
warnLevel = if warnLevel = if
| oks < 0 -> Error | oks < 0 -> Error
@ -498,8 +568,8 @@ postQualificationR sid qsh = do
| isNothing qubr -> MsgQualificationStatusUnblock | isNothing qubr -> MsgQualificationStatusUnblock
| otherwise -> MsgQualificationStatusBlock | otherwise -> MsgQualificationStatusBlock
addMessageI warnLevel $ fbmsg qsh oks nrq addMessageI warnLevel $ fbmsg qsh oks nrq
redirect currentRoute reloadKeepGetParams $ QualificationR sid qsh
_ -> addMessageI Error MsgUnauthorized _ -> addMessageI Error MsgInvalidFormAction
let heading = citext2widget $ qualificationName quali let heading = citext2widget $ qualificationName quali
siteLayout heading $ do siteLayout heading $ do

3
src/Handler/SAP.hs
View File

@ -97,7 +97,8 @@ getQualificationSAPDirectR = do
, qual Ex.^. QualificationSapId , qual Ex.^. QualificationSapId
) )
let csvRendered = toCsvRendered sapUserTableCsvHeader $ sapRes2csv qualUsers let csvRendered = toCsvRendered sapUserTableCsvHeader $ sapRes2csv qualUsers
fmtOpts = def { csvIncludeHeader = True fmtOpts = (review csvPreset CsvPresetRFC)
{ csvIncludeHeader = True
, csvDelimiter = ',' , csvDelimiter = ','
, csvUseCrLf = True , csvUseCrLf = True
} }

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

@ -66,7 +66,7 @@ postTUsersR tid ssh csh tutn = do
tutEnt@(Entity tutid _) <- fetchTutorial tid ssh csh tutn tutEnt@(Entity tutid _) <- fetchTutorial tid ssh csh tutn
qualifications <- getCourseQualifications cid qualifications <- getCourseQualifications cid
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
let minDur :: Maybe Int = minimumMaybe $ catMaybes (view _qualificationValidDuration <$> qualifications) -- no instance Ord CalendarDiffDays let minDur :: Maybe Int = minimumMaybe $ mapMaybe (view _qualificationValidDuration) qualifications -- no instance Ord CalendarDiffDays
dayExpiry = flip addGregorianDurationClip (utctDay now) . fromMonths <$> minDur dayExpiry = flip addGregorianDurationClip (utctDay now) . fromMonths <$> minDur
colChoices = mconcat $ catMaybes colChoices = mconcat $ catMaybes
[ pure $ dbSelect (applying _2) id (return . view (hasEntity . _entityKey)) [ pure $ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))

27
src/Handler/Users.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de> -- SPDX-FileCopyrightText: 2022-23 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
-- --
-- SPDX-License-Identifier: AGPL-3.0-or-later -- SPDX-License-Identifier: AGPL-3.0-or-later
@ -45,7 +45,7 @@ import Auth.Dummy (apDummy)
hijackUserForm :: Form () hijackUserForm :: Form ()
hijackUserForm csrf = do hijackUserForm = \csrf -> do
(btnResult, btnView) <- mopt (buttonField BtnHijack) "" Nothing (btnResult, btnView) <- mopt (buttonField BtnHijack) "" Nothing
return (btnResult >>= guard . is _Just, mconcat [toWidget csrf, fvWidget btnView]) return (btnResult >>= guard . is _Just, mconcat [toWidget csrf, fvWidget btnView])
@ -100,7 +100,7 @@ postUsersR = do
(AdminUserR <$> encrypt uid) (AdminUserR <$> encrypt uid)
(nameWidget userDisplayName userSurname) (nameWidget userDisplayName userSurname)
, sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \DBRow{ dbrOutput = entUsr } -> cellHasMatrikelnummerLinked entUsr , sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \DBRow{ dbrOutput = entUsr } -> cellHasMatrikelnummerLinked entUsr
, sortable (Just "user-company") (i18nCell MsgTableCompany) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX" , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX"
companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid
@ -334,7 +334,7 @@ postUsersR = do
, dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } , dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
, dbtParams = DBParamsForm , dbtParams = DBParamsForm
{ dbParamsFormMethod = POST { dbParamsFormMethod = POST
, dbParamsFormAction = Just $ SomeRoute UsersR , dbParamsFormAction = Nothing -- Just $ SomeRoute (UsersR, [("users-user-company","fraport")])
, dbParamsFormAttrs = [] , dbParamsFormAttrs = []
, dbParamsFormSubmit = FormSubmit , dbParamsFormSubmit = FormSubmit
, dbParamsFormAdditional , dbParamsFormAdditional
@ -351,21 +351,21 @@ postUsersR = do
, dbtExtraReps = [] , dbtExtraReps = []
} }
-- $logInfoS "UsersFormResult" $ tshow usersRes
formResult usersRes $ \case formResult usersRes $ \case
(act, usersSet) (act, usersSet)
| Set.null usersSet && isNotSetSupervisor act -> do | Set.null usersSet && isNotSetSupervisor act ->
addMessageI Info MsgActionNoUsersSelected addMessageI Info MsgActionNoUsersSelected
redirect UsersR
(UserLdapSyncData, userSet) -> do (UserLdapSyncData, userSet) -> do
runDBJobs . forM_ userSet $ \uid -> queueDBJob $ JobSynchroniseLdapUser uid runDBJobs . forM_ userSet $ \uid -> queueDBJob $ JobSynchroniseLdapUser uid
addMessageI Success . MsgSynchroniseLdapUserQueued $ Set.size userSet addMessageI Success . MsgSynchroniseLdapUserQueued $ Set.size userSet
redirect UsersR redirectKeepGetParams UsersR
(UserHijack, Set.minView -> Just (uid, _)) -> (UserHijack, Set.minView -> Just (uid, _)) ->
hijackUser uid >>= sendResponse hijackUser uid >>= sendResponse
(UserRemoveSupervisorData, userSet) -> do (UserRemoveSupervisorData, userSet) -> do
runDB $ deleteWhere [UserSupervisorUser <-. Set.toList userSet] runDB $ deleteWhere [UserSupervisorUser <-. Set.toList userSet]
addMessageI Success $ MsgUsersRemoveSupervisors $ Set.size userSet addMessageI Success $ MsgUsersRemoveSupervisors $ Set.size userSet
redirect UsersR redirectKeepGetParams UsersR
(act, usersSet) (act, usersSet)
| isActionSupervisor act -> do | isActionSupervisor act -> do
avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser $ getActionSupervisors act avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser $ getActionSupervisors act
@ -382,8 +382,8 @@ postUsersR = do
if nrSuperNotFound > 0 if nrSuperNotFound > 0
then addMessageI Warning $ MsgUsersChangeSupervisorsWarning (Set.size usersSet) (length supersFound) nrSuperNotFound then addMessageI Warning $ MsgUsersChangeSupervisorsWarning (Set.size usersSet) (length supersFound) nrSuperNotFound
else addMessageI Success $ MsgUsersChangeSupervisorsSuccess (Set.size usersSet) (length supersFound) else addMessageI Success $ MsgUsersChangeSupervisorsSuccess (Set.size usersSet) (length supersFound)
redirect UsersR redirectKeepGetParams UsersR
_other -> error "Should not be possible" _other -> addMessageI Error MsgInvalidFormAction
((allUsersRes, allUsersWgt), allUsersEnctype) <- runFormPost . identifyForm FIDAllUsersAction $ buttonForm ((allUsersRes, allUsersWgt), allUsersEnctype) <- runFormPost . identifyForm FIDAllUsersAction $ buttonForm
@ -563,8 +563,8 @@ postAdminUserR uuid = do
redirect $ AdminUserR uuid redirect $ AdminUserR uuid
let assimilateForm' = renderAForm FormStandard $ let assimilateForm' = renderAForm FormStandard $
areq (checkMap (first $ const MsgAssimilateUserNotFound) Right $ userField False Nothing) (fslI MsgUserAssimilateUser) Nothing areq (checkMap (first $ const MsgAssimilateUserNotFound) Right $ userField False Nothing) (fslI MsgUserAssimilateUser) Nothing
assimilateAction oldUserId = do assimilateAction newUserId = do
res <- try . runDB . setSerializable $ assimilateUser uid oldUserId res <- try . runDB . setSerializable $ assimilateUser newUserId uid
case res of case res of
Left (err :: UserAssimilateException) -> Left (err :: UserAssimilateException) ->
addMessageModal Error (i18n MsgAssimilateUserHaveError) $ Right addMessageModal Error (i18n MsgAssimilateUserHaveError) $ Right
@ -583,7 +583,8 @@ postAdminUserR uuid = do
#{tshow warning} #{tshow warning}
|] |]
addMessageI Success MsgAssimilateUserSuccess addMessageI Success MsgAssimilateUserSuccess
redirect $ AdminUserR uuid newUuid <- encrypt newUserId
redirect $ AdminUserR newUuid
((rightsResult, rightsFormWidget), rightsFormEnctype) <- runFormPost . identifyForm FIDUserRights $ userRightsForm ((rightsResult, rightsFormWidget), rightsFormEnctype) <- runFormPost . identifyForm FIDUserRights $ userRightsForm
((authResult, authFormWidget), authFormEnctype) <- runFormPost . identifyForm FIDUserAuthentication $ userAuthenticationForm ((authResult, authFormWidget), authFormEnctype) <- runFormPost . identifyForm FIDUserAuthentication $ userAuthenticationForm
((systemFunctionsResult, systemFunctionsWidget), systemFunctionsEnctype) <- runFormPost . identifyForm FIDUserSystemFunctions $ renderAForm FormStandard systemFunctionsForm' ((systemFunctionsResult, systemFunctionsWidget), systemFunctionsEnctype) <- runFormPost . identifyForm FIDUserSystemFunctions $ renderAForm FormStandard systemFunctionsForm'

21
src/Handler/Utils.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de> -- SPDX-FileCopyrightText: 2023 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
-- --
-- SPDX-License-Identifier: AGPL-3.0-or-later -- SPDX-License-Identifier: AGPL-3.0-or-later
@ -137,3 +137,22 @@ redirectAlternatives = go
Just xs' -> over _1 (x :) $ nunsnoc xs' Just xs' -> over _1 (x :) $ nunsnoc xs'
nsnoc [] x = x :| [] nsnoc [] x = x :| []
nsnoc (x' : xs) x = x' :| (xs ++ [x]) nsnoc (x' : xs) x = x' :| (xs ++ [x])
-- | redirect to currentRoute, if Just otherwise to given default
reload :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route (HandlerSite m) -> m a
reload r = getCurrentRoute >>= redirect . fromMaybe r
-- | like `reload`, preserving all GET parameters
reloadKeepGetParams :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route (HandlerSite m) -> m a
reloadKeepGetParams r = liftHandler $ do
getps <- reqGetParams <$> getRequest
route <- fromMaybe r <$> getCurrentRoute
-- addMessage Info $ toHtml (show getps) -- DEBUG ONLY
-- RECALL: redirect GET parameters are used like so: -- redirect (UsersR, [("users-user-company","fraport")])
redirect (route, getps)
-- | redirect preserving all GET parameters
redirectKeepGetParams :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route (HandlerSite m) -> m a
redirectKeepGetParams route = liftHandler $ do
getps <- reqGetParams <$> getRequest
redirect (route, getps)

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

@ -339,12 +339,16 @@ guessAvsUser (Text.splitAt 6 -> ("AVSNO:", avsnoTxt)) = ifMaybeM (readMay avsnoT
_ -> return Nothing _ -> return Nothing
guessAvsUser someid = do guessAvsUser someid = do
let maybeUpsertAvsUserByCard = maybeCatchAll . upsertAvsUserByCard let maybeUpsertAvsUserByCard = maybeCatchAll . upsertAvsUserByCard
extractUid (Entity _ UserAvs{userAvsUser=uid}) = return $ Just uid
extractUidCard (Entity _ UserAvsCard{userAvsCardPersonId=avid}) = getBy $ UniqueUserAvsId avid
case discernAvsCardPersonalNo someid of case discernAvsCardPersonalNo someid of
Just cid@(Left cardNo) -> Just cid@(Left _cardNo) -> maybeUpsertAvsUserByCard cid
maybeM (maybeUpsertAvsUserByCard cid) extractUid $ runDB $ -- NOTE: card validity might be outdated, so we must always check with avs
maybeM (return Nothing) extractUidCard $ getBy $ UniqueAvsCard cardNo -- maybeM (maybeUpsertAvsUserByCard cid) extractUid $ runDB $ do
-- let extractUid (Entity _ UserAvs{userAvsUser=uid}) = return $ Just uid
-- extractUidCard UserAvsCard{userAvsCardPersonId=avid} = getBy $ UniqueUserAvsId avid
-- cards <- selectList [UserAvsCardCardNo ==. cardNo] []
-- case [c | cent <- cards, let c = entityVal cent, avsDataValid (userAvsCardCard c)] of
-- [justOneCard] -> maybeM (return Nothing) extractUidCard (return $ Just justOneCard)
-- _ -> return Nothing
Just cid@(Right _wholeNumber) -> Just cid@(Right _wholeNumber) ->
maybeUpsertAvsUserByCard cid >>= \case maybeUpsertAvsUserByCard cid >>= \case
Nothing -> Nothing ->
@ -493,15 +497,16 @@ upsertAvsUserById api = do
[UserPinPassword =. userPin] [UserPinPassword =. userPin]
insert_ $ UserAvsCard api (getFullCardNo pCard) pCard now insert_ $ UserAvsCard api (getFullCardNo pCard) pCard now
upsertUserCompany uid mbCompany userFirmAddr upsertUserCompany uid mbCompany userFirmAddr
forM_ avsPersonPersonCards $ \aCard -> void $ upsert UserAvsCard forM_ avsPersonPersonCards $ \aCard -> do
let fcn = getFullCardNo aCard
-- probably not efficient, but fixes the problem that AvsCardNo is not unique as assumed before and may get reused
deleteWhere [UserAvsCardCardNo ==. fcn]
insert_ $ UserAvsCard
{ userAvsCardPersonId = api { userAvsCardPersonId = api
, userAvsCardCardNo = getFullCardNo aCard , userAvsCardCardNo = fcn
, userAvsCardCard = aCard , userAvsCardCard = aCard
, userAvsCardLastSynch = now , userAvsCardLastSynch = now
} }
[ UserAvsCardCard =. aCard
, UserAvsCardLastSynch =. now
]
return $ Just uid return $ Just uid

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

@ -8,7 +8,8 @@ module Handler.Utils.DateTime
( utcToLocalTime, utcToZonedTime ( utcToLocalTime, utcToZonedTime
, localTimeToUTC, TZ.LocalToUTCResult(..), localTimeToUTCSimple , localTimeToUTC, TZ.LocalToUTCResult(..), localTimeToUTCSimple
, toTimeOfDay , toTimeOfDay
, toMidnight, beforeMidnight, toMidday, toMorning, addHours , toMidnight, beforeMidnight, toMidday, toMorning
, toFullHour, roundDownToMinutes, addHours
, formatDiffDays, formatCalendarDiffDays , formatDiffDays, formatCalendarDiffDays
, formatTime' , formatTime'
, formatTime, formatTimeUser, formatTimeW, formatTimeMail , formatTime, formatTimeUser, formatTimeW, formatTimeMail
@ -68,6 +69,18 @@ toMidnight = toTimeOfDay 0 0 0
toMidday :: Day -> UTCTime toMidday :: Day -> UTCTime
toMidday = toTimeOfDay 12 0 0 toMidday = toTimeOfDay 12 0 0
-- | Round up to next full hour
toFullHour :: UTCTime -> UTCTime
toFullHour t = t{utctDayTime=rounded}
where
rounded = fromInteger $ 3600 * (1 + (truncate (utctDayTime t) `div` 3600))
roundDownToMinutes :: Integer -> UTCTime -> UTCTime
roundDownToMinutes f t = t{utctDayTime=rounded}
where
rounded = fromInteger $ factor * (truncate (utctDayTime t) `div` factor)
factor = 60 * f
-- | One second before the end of day -- | One second before the end of day
beforeMidnight :: Day -> UTCTime beforeMidnight :: Day -> UTCTime
beforeMidnight = toTimeOfDay 23 59 59 beforeMidnight = toTimeOfDay 23 59 59

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

@ -45,7 +45,8 @@ getLmsCsvDecoder :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m, From
getLmsCsvDecoder = do getLmsCsvDecoder = do
LmsConf{..} <- getsYesod $ view _appLmsConf LmsConf{..} <- getsYesod $ view _appLmsConf
if | Just upDelim <- lmsUploadDelimiter -> do if | Just upDelim <- lmsUploadDelimiter -> do
let fmtOpts = def { csvDelimiter = upDelim let fmtOpts = (review csvPreset CsvPresetRFC)
{ csvDelimiter = upDelim
, csvIncludeHeader = lmsUploadHeader , csvIncludeHeader = lmsUploadHeader
} }
csvOpts = def { csvFormat = fmtOpts } csvOpts = def { csvFormat = fmtOpts }

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

@ -138,3 +138,34 @@ qualificationUserBlocking qid uids qb = do
, transactionQualificationBlock = qb , transactionQualificationBlock = qb
} }
return $ fromIntegral oks return $ fromIntegral oks
qualificationUserUnblockByReason ::
( AuthId (HandlerSite m) ~ Key User
, IsPersistBackend (YesodPersistBackend (HandlerSite m))
, BaseBackend (YesodPersistBackend (HandlerSite m)) ~ SqlBackend
, BackendCompatible SqlBackend (YesodPersistBackend (HandlerSite m))
, PersistQueryWrite (YesodPersistBackend (HandlerSite m))
, PersistUniqueWrite (YesodPersistBackend (HandlerSite m))
, HasInstanceID (HandlerSite m) InstanceId
, YesodAuthPersist (HandlerSite m)
, HasAppSettings (HandlerSite m)
, MonadHandler m
, MonadCatch m
, Num n
) => QualificationId -> [UserId] -> Text -> ReaderT (YesodPersistBackend (HandlerSite m)) m n
qualificationUserUnblockByReason qid uids reason = do
blockedUsers <- selectList [ QualificationUserQualification ==. qid
, QualificationUserBlockedDue !=. Nothing
, QualificationUserUser <-. uids
] [Asc QualificationUserId]
let toUnblock = filter (\quent -> Just reason == quent ^? _entityVal . _qualificationUserBlockedDue . _Just . _qualificationBlockedReason) blockedUsers
oks <- updateWhereCount [ QualificationUserId <-. (view _entityKey <$> toUnblock) ]
[ QualificationUserBlockedDue =. Nothing ]
forM_ toUnblock $ \ubl -> do
audit TransactionQualificationUserBlocking
{ -- transactionQualificationUser = quid
transactionQualification = qid
, transactionUser = ubl ^. _entityVal . _qualificationUserUser
, transactionQualificationBlock = Nothing
}
return $ fromIntegral oks

4
src/Handler/Utils/Table/Columns.hs
View File

@ -718,7 +718,7 @@ fltrRelevantStudyFeaturesSemesterUI = fltrFeaturesSemesterUI
{- {-
-- colUserCompany :: (HandlerSite (DBCell m) ~ UniWorX, IsDBTable m c, HasEntity a User) => Colonnade Sortable a (DBCell m c) -- colUserCompany :: (HandlerSite (DBCell m) ~ UniWorX, IsDBTable m c, HasEntity a User) => Colonnade Sortable a (DBCell m c)
colUserCompany = sortable (Just "user-company") (i18nCell MsgTableCompany) $ \heu -> do colUserCompany = sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \heu -> do
let uid = heu ^. hasEntity . _entityKey let uid = heu ^. hasEntity . _entityKey
companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid
@ -732,7 +732,7 @@ colUserCompany = sortable (Just "user-company") (i18nCell MsgTableCompany) $ \he
-- PROBLEM: how to type sqlCell compatible with dbTable that as actions, i.e. MForm instead of YesodDB? -- PROBLEM: how to type sqlCell compatible with dbTable that as actions, i.e. MForm instead of YesodDB?
colUserCompany :: (IsDBTable (YesodDB UniWorX) c, HasEntity a User) => Colonnade Sortable a (DBCell (YesodDB UniWorX) c) colUserCompany :: (IsDBTable (YesodDB UniWorX) c, HasEntity a User) => Colonnade Sortable a (DBCell (YesodDB UniWorX) c)
colUserCompany = sortable (Just "user-company") (i18nCell MsgTableCompany) $ \heu -> colUserCompany = sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \heu ->
let uid = heu ^. hasEntity . _entityKey in let uid = heu ^. hasEntity . _entityKey in
sqlCell $ do sqlCell $ do
companies' <- E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do companies' <- E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do

7
src/Handler/Utils/Table/Pagination.hs
View File

@ -716,6 +716,7 @@ dbtProjId' :: forall fs r r'.
=> ReaderT (DBTProjCtx fs r) (MaybeT (ReaderT SqlBackend (HandlerFor UniWorX))) r' => ReaderT (DBTProjCtx fs r) (MaybeT (ReaderT SqlBackend (HandlerFor UniWorX))) r'
dbtProjId' = view _dbtProjRow dbtProjId' = view _dbtProjRow
-- | Reicht das Ergebnis der SQL-Abfrage direkt durch an colonnade und csv
dbtProjId :: forall fs r r'. dbtProjId :: forall fs r r'.
( fs ~ (), DBRow r ~ r' ) ( fs ~ (), DBRow r ~ r' )
=> ReaderT (DBTProjCtx fs r) (MaybeT (ReaderT SqlBackend (HandlerFor UniWorX))) r' => ReaderT (DBTProjCtx fs r) (MaybeT (ReaderT SqlBackend (HandlerFor UniWorX))) r'
@ -727,6 +728,7 @@ dbtProjSimple' :: forall fs r r' r''.
-> ReaderT (DBTProjCtx fs r) (MaybeT (ReaderT SqlBackend (HandlerFor UniWorX))) r' -> ReaderT (DBTProjCtx fs r) (MaybeT (ReaderT SqlBackend (HandlerFor UniWorX))) r'
dbtProjSimple' cont = (views _dbtProjRow . set _dbrOutput) <=< (hoist lift . magnify (_dbtProjRow . _dbrOutput)) $ lift . cont =<< ask dbtProjSimple' cont = (views _dbtProjRow . set _dbrOutput) <=< (hoist lift . magnify (_dbtProjRow . _dbrOutput)) $ lift . cont =<< ask
-- | Transformation des SQL Ergbnistyp vor dem Weiterreichen an colonnade oder csv durch eine einfache monadische Funktion
dbtProjSimple :: forall fs r r' r''. dbtProjSimple :: forall fs r r' r''.
( fs ~ (), DBRow r'' ~ r' ) ( fs ~ (), DBRow r'' ~ r' )
=> (r -> DB r'') => (r -> DB r'')
@ -743,11 +745,14 @@ withFilteredPost proj = do
guardM . lift . lift $ p r' guardM . lift . lift $ p r'
return r' return r'
-- | Wie `dbtProjId` plus zusätzliches Filtern der SQL-Abfrage in Haskell
-- Nur zu Verwenden, wenn Filter mit mkFilterProjectedPost verwendet werden; ein Typfehler weist daraufhin, wenn dies nötig ist!
dbtProjFilteredPostId :: forall fs r r'. dbtProjFilteredPostId :: forall fs r r'.
( fs ~ DBTProjFilterPost r', DBRow r ~ r' ) ( fs ~ DBTProjFilterPost r', DBRow r ~ r' )
=> ReaderT (DBTProjCtx fs r) (MaybeT (ReaderT SqlBackend (HandlerFor UniWorX))) r' => ReaderT (DBTProjCtx fs r) (MaybeT (ReaderT SqlBackend (HandlerFor UniWorX))) r'
dbtProjFilteredPostId = withFilteredPost dbtProjId' dbtProjFilteredPostId = withFilteredPost dbtProjId'
-- | Kombination aus `dbtProjFilteredPostId` und `dbtProjSimple`, d.h. Ergeniszeilen in Haskell transformieren und filtern
dbtProjFilteredPostSimple :: forall fs r r' r''. dbtProjFilteredPostSimple :: forall fs r r' r''.
( fs ~ DBTProjFilterPost r', DBRow r'' ~ r' ) ( fs ~ DBTProjFilterPost r', DBRow r'' ~ r' )
=> (r -> DB r'') => (r -> DB r'')
@ -964,7 +969,7 @@ instance Monoid' x => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) En
instance Default (DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) x) where instance Default (DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) x) where
def = DBParamsForm def = DBParamsForm
{ dbParamsFormMethod = POST { dbParamsFormMethod = POST
, dbParamsFormAction = Nothing , dbParamsFormAction = Nothing -- Recall: Nothing preserves GET Parameters
, dbParamsFormAttrs = [] , dbParamsFormAttrs = []
, dbParamsFormSubmit = FormSubmit , dbParamsFormSubmit = FormSubmit
, dbParamsFormAdditional = \_ -> return (pure (), mempty) , dbParamsFormAdditional = \_ -> return (pure (), mempty)

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

@ -18,6 +18,7 @@ module Handler.Utils.Users
, getPostalAddress, getPostalPreferenceAndAddress , getPostalAddress, getPostalPreferenceAndAddress
, abbrvName , abbrvName
, getReceivers , getReceivers
, getSupervisees
) where ) where
import Import import Import
@ -34,7 +35,7 @@ import qualified Data.Aeson as JSON
import qualified Data.Aeson.Types as JSON import qualified Data.Aeson.Types as JSON
import qualified Data.Set as Set import qualified Data.Set as Set
import qualified Data.List as List -- import qualified Data.List as List
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Legacy as E
@ -110,6 +111,13 @@ getReceivers uid = do
then directResult then directResult
else return (underling, receivers, uid `elem` (entityKey <$> receivers)) else return (underling, receivers, uid `elem` (entityKey <$> receivers))
-- | return underlings for currently logged in user
getSupervisees :: DB (Set UserId)
getSupervisees = do
uid <- requireAuthId
svs <- userSupervisorUser . entityVal <<$>> selectList [UserSupervisorSupervisor ==. uid] [Asc UserSupervisorUser]
return $ Set.insert uid $ Set.fromAscList svs
computeUserAuthenticationDigest :: AuthenticationMode -> Digest SHA3_256 computeUserAuthenticationDigest :: AuthenticationMode -> Digest SHA3_256
computeUserAuthenticationDigest = hashlazy . JSON.encode computeUserAuthenticationDigest = hashlazy . JSON.encode
@ -287,6 +295,16 @@ assimilateUser :: UserId -- ^ @newUserId@
-- --
-- Fatal errors are thrown, non-fatal warnings are returned -- Fatal errors are thrown, non-fatal warnings are returned
assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
-- retrieve user entities first, to ensure they both exist
(oldUserEnt, newUserEnt) <- do
oldUser <- getEntity oldUserId
newUser <- getEntity newUserId
case (oldUser, newUser) of
(Just old, Just new) -> return (old,new)
_ -> tellError UserAssimilateCouldNotDetermineUserIdents
let oldUser = oldUserEnt ^. _entityVal
newUser = newUserEnt ^. _entityVal
E.insertSelectWithConflict E.insertSelectWithConflict
UniqueCourseFavourite UniqueCourseFavourite
(E.from $ \courseFavourite -> do (E.from $ \courseFavourite -> do
@ -859,18 +877,56 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
(\current _excluded -> [ UserCompanySupervisor E.=. (current E.^. UserCompanySupervisor)] ) (\current _excluded -> [ UserCompanySupervisor E.=. (current E.^. UserCompanySupervisor)] )
deleteWhere [ UserCompanyUser ==. oldUserId] deleteWhere [ UserCompanyUser ==. oldUserId]
userIdents <- E.select . E.from $ \user -> do mbOldAvsId <- getBy $ UniqueUserAvsUser oldUserId
E.where_ $ user E.^. UserId `E.in_` E.valList [newUserId, oldUserId] mbNewAvsId <- getBy $ UniqueUserAvsUser newUserId
return ( user E.^. UserId case (mbOldAvsId,mbNewAvsId) of
, user E.^. UserIdent (Nothing, _)
) -> return ()
case (,) <$> List.lookup (E.Value oldUserId) userIdents <*> List.lookup (E.Value newUserId) userIdents of (Just Entity{entityVal=UserAvs{userAvsPersonId=oldAvsId}}, Just _)
Just (E.Value oldIdent, E.Value newIdent') -> deleteWhere [UserAvsCardPersonId ==. oldAvsId] >> deleteBy (UniqueUserAvsUser oldUserId)
| oldIdent /= newIdent' -> audit $ TransactionUserIdentChanged oldIdent newIdent' (Just Entity{entityVal=oldUserAvs}, Nothing)
| otherwise -> return () -> -- deleteBy $ UniqueUserAvsUser oldUserId -- maybe we need this due to double uniqueness?!
_other -> tellError UserAssimilateCouldNotDetermineUserIdents void $ upsertBy (UniqueUserAvsId (oldUserAvs ^. _userAvsPersonId)) oldUserAvs{userAvsUser=newUserId} [UserAvsUser =. newUserId]
-- merge some optional / incomplete user fields
let mergeBy :: forall a . PersistField a => (a -> a -> Bool) -> EntityField User a -> Maybe (Update User)
mergeBy cmp uf = let ufl = fieldLens uf
oldV = oldUserEnt ^. ufl
newV = newUserEnt ^. ufl
in toMaybe (cmp oldV newV) (uf =. oldV)
mergeMaybe :: forall b . PersistField b => EntityField User (Maybe b) -> Maybe (Update User)
mergeMaybe = mergeBy (\oldV newV -> isNothing newV && isJust oldV)
update newUserId $ catMaybes -- NOTE: persist does shortcircuit null updates as expected
[ mergeMaybe UserLdapPrimaryKey
, mergeBy (<) UserAuthentication
, mergeBy (>) UserLastAuthentication
, mergeBy (<) UserCreated
, toMaybe (not (validEmail' (newUser ^. _userEmail )) && validEmail' (oldUser ^. _userEmail))
(UserEmail =. oldUser ^. _userEmail)
, toMaybe (not (validEmail' (newUser ^. _userDisplayEmail)) && validEmail' (oldUser ^. _userDisplayEmail))
(UserDisplayEmail =. oldUser ^. _userDisplayEmail)
, mergeMaybe UserMatrikelnummer
, toMaybe (isNothing (newUser ^. _userPostAddress) && isJust (oldUser ^. _userPostAddress))
(UserPostAddress =. oldUser ^. _userPostAddress)
, toMaybe (isNothing (newUser ^. _userPostAddress) && isJust (oldUser ^. _userPostAddress))
(UserPostLastUpdate =. oldUser ^. _userPostLastUpdate)
, toMaybe ((isJust (newUser ^. _userPostAddress) || isJust (oldUser ^. _userPostAddress))
&& (newUser ^. _userPrefersPostal || oldUser ^. _userPrefersPostal))
(UserPrefersPostal =. True)
, mergeMaybe UserPinPassword
, mergeMaybe UserLanguages
, mergeMaybe UserSex
, mergeMaybe UserBirthday
, mergeMaybe UserTelephone
, mergeMaybe UserMobile
]
delete oldUserId delete oldUserId
let oldUsrIdent = oldUser ^. _userIdent
newUsrIdent = newUser ^. _userIdent
when (oldUsrIdent /= newUsrIdent) $ audit $ TransactionUserIdentChanged oldUsrIdent newUsrIdent
audit $ TransactionUserAssimilated newUserId oldUserId audit $ TransactionUserAssimilated newUserId oldUserId
where where
tellWarning :: UserAssimilateExceptionReason -> ReaderT SqlBackend (WriterT (Set UserAssimilateException) Handler) () tellWarning :: UserAssimilateExceptionReason -> ReaderT SqlBackend (WriterT (Set UserAssimilateException) Handler) ()

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

@ -217,7 +217,7 @@ dispatchJobLmsResults qid = JobHandlerAtomic act
return (quser, luser, lresult) return (quser, luser, lresult)
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
let locDay = localDay $ TZ.utcToLocalTimeTZ appTZ now let locDay = localDay $ TZ.utcToLocalTimeTZ appTZ now
forM_ results $ \(Entity _quid QualificationUser{..}, Entity luid LmsUser{..}, Entity lrid LmsResult{..}) -> do forM_ results $ \(Entity quid QualificationUser{..}, Entity luid LmsUser{..}, Entity lrid LmsResult{..}) -> do
-- three separate DB operations per result is not so nice. All within one transaction though. -- three separate DB operations per result is not so nice. All within one transaction though.
let lmsUserStartedDay = localDay $ TZ.utcToLocalTimeTZ appTZ lmsUserStarted let lmsUserStartedDay = localDay $ TZ.utcToLocalTimeTZ appTZ lmsUserStarted
saneDate = lmsResultSuccess `inBetween` (lmsUserStartedDay, min qualificationUserValidUntil locDay) saneDate = lmsResultSuccess `inBetween` (lmsUserStartedDay, min qualificationUserValidUntil locDay)
@ -226,15 +226,18 @@ dispatchJobLmsResults qid = JobHandlerAtomic act
-- newValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) qualificationUserValidUntil -- renew from old validUntil onwards -- newValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) qualificationUserValidUntil -- renew from old validUntil onwards
note <- if saneDate && replaceLmsStatus lmsUserStatus newStatus note <- if saneDate && replaceLmsStatus lmsUserStatus newStatus
then do then do
_ok <- renewValidQualificationUsers qid [qualificationUserUser] -- blocked remains unaffected _ok <- renewValidQualificationUsers qid [qualificationUserUser] -- ignores possible blocks
-- when (ok==1) $ update luid -- we end lms regardless of wether a regular renewal was successful, since BPol users may simultaneoysly have on-premise renewal courses and E-Learnings -- when (ok==1) $ update luid -- we end lms regardless of wether a regular renewal was successful, since BPol users may simultaneoysly have on-premise renewal courses and E-Learnings
-- WORKAROUND LMS-Bug [supposedly fixed now, but isnt]: sometimes we receive success and failure simultaneously; success is correct, hence we must unblock if the reason was e-learning
-- _ok <- qualificationUserUnblockByReason qid [qualificationUserUser] (qualificationBlockedReasonText QualificationBlockFailedELearning) -- affects audit log
when (Just (qualificationBlockedReasonText QualificationBlockFailedELearning) == qualificationUserBlockedDue ^? _Just . _qualificationBlockedReason) $
update quid [ QualificationUserBlockedDue =. Nothing ]
update luid update luid
[ LmsUserStatus =. newStatus [ LmsUserStatus =. newStatus
, LmsUserReceived =. Just lmsResultTimestamp , LmsUserReceived =. Just lmsResultTimestamp
] ]
-- WORKAROUND LMS-Bug [supposedly fixed now]: sometimes we receive success and failure simultaneously; success is correct, hence we must unblock if the reason was e-learning
-- when (Just (qualificationBlockedReasonText QualificationBlockFailedELearning) == qUsr ^? _qualificationUserBlockedDue . _Just . _qualificationBlockedReason) $
-- update quid [ QualificationUserBlockedDue =. Nothing ]
return Nothing return Nothing
else do else do
let errmsg = [st|LMS success with insane date #{tshow lmsResultSuccess} received for #{tshow lmsUserIdent}|] let errmsg = [st|LMS success with insane date #{tshow lmsResultSuccess} received for #{tshow lmsUserIdent}|]

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

@ -197,6 +197,7 @@ discernAvsCardPersonalNo _ = Nothing
newtype AvsPersonId = AvsPersonId { avsPersonId :: Int } -- untagged Int newtype AvsPersonId = AvsPersonId { avsPersonId :: Int } -- untagged Int
deriving (Eq, Ord, Generic) deriving (Eq, Ord, Generic)
deriving newtype (NFData, PathPiece, PersistField, PersistFieldSql, Csv.ToField, Csv.FromField, Hashable, Binary) deriving newtype (NFData, PathPiece, PersistField, PersistFieldSql, Csv.ToField, Csv.FromField, Hashable, Binary)
-- TODO: consider using "makeWrapped ''AvsPersonId"
instance E.SqlString AvsPersonId instance E.SqlString AvsPersonId
-- As opposed to AvsObjPersonId, AvsPersonId is an untagged Int with respect to FromJSON/ToJSON, as needed by AVS API; -- As opposed to AvsObjPersonId, AvsPersonId is an untagged Int with respect to FromJSON/ToJSON, as needed by AVS API;
instance FromJSON AvsPersonId where instance FromJSON AvsPersonId where
@ -590,6 +591,7 @@ deriveJSON defaultOptions
type AvsResponseStatus :: Type type AvsResponseStatus :: Type
newtype AvsResponseStatus = AvsResponseStatus (Set AvsStatusPerson) newtype AvsResponseStatus = AvsResponseStatus (Set AvsStatusPerson)
deriving (Eq, Ord, Show, Generic) deriving (Eq, Ord, Show, Generic)
makeWrapped ''AvsResponseStatus
deriveJSON defaultOptions deriveJSON defaultOptions
{ fieldLabelModifier = dropCamel 2 { fieldLabelModifier = dropCamel 2
, omitNothingFields = True , omitNothingFields = True
@ -601,6 +603,7 @@ instance Semigroup AvsResponseStatus where
newtype AvsResponsePerson = AvsResponsePerson (Set AvsDataPerson) newtype AvsResponsePerson = AvsResponsePerson (Set AvsDataPerson)
deriving (Eq, Ord, Show, Generic) deriving (Eq, Ord, Show, Generic)
-- makeWrapped ''AvsResponsePerson
deriveJSON defaultOptions deriveJSON defaultOptions
{ fieldLabelModifier = dropCamel 2 { fieldLabelModifier = dropCamel 2
, omitNothingFields = True , omitNothingFields = True
@ -610,6 +613,7 @@ deriveJSON defaultOptions
newtype AvsResponseContact = AvsResponseContact (Set AvsDataContact) newtype AvsResponseContact = AvsResponseContact (Set AvsDataContact)
deriving (Eq, Ord, Show, Generic) deriving (Eq, Ord, Show, Generic)
makeWrapped ''AvsResponseContact
deriveJSON defaultOptions deriveJSON defaultOptions
{ fieldLabelModifier = dropCamel 2 { fieldLabelModifier = dropCamel 2
, omitNothingFields = True , omitNothingFields = True
@ -666,10 +670,12 @@ deriveJSON defaultOptions
newtype AvsQueryStatus = AvsQueryStatus (Set AvsPersonId) newtype AvsQueryStatus = AvsQueryStatus (Set AvsPersonId)
deriving (Eq, Ord, Show, Generic) deriving (Eq, Ord, Show, Generic)
deriveJSON defaultOptions ''AvsQueryStatus deriveJSON defaultOptions ''AvsQueryStatus
makeWrapped ''AvsQueryStatus
newtype AvsQueryContact = AvsQueryContact (Set AvsObjPersonId) -- note the difference to AvsQueryStatus, which receives a list of id, whereas here we sent a list of single-field object newtype AvsQueryContact = AvsQueryContact (Set AvsObjPersonId) -- note the difference to AvsQueryStatus, which receives a list of id, whereas here we sent a list of single-field object
deriving (Eq, Ord, Show, Generic) deriving (Eq, Ord, Show, Generic)
deriveJSON defaultOptions ''AvsQueryContact deriveJSON defaultOptions ''AvsQueryContact
makeWrapped ''AvsQueryContact
newtype AvsQueryGetLicences = AvsQueryGetLicences AvsObjPersonId -- this should have been a set, but the specification was implemented differently newtype AvsQueryGetLicences = AvsQueryGetLicences AvsObjPersonId -- this should have been a set, but the specification was implemented differently
deriving (Eq, Ord, Show, Generic) deriving (Eq, Ord, Show, Generic)

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

@ -85,7 +85,8 @@ instance Default CsvOptions where
} }
instance Default CsvFormatOptions where instance Default CsvFormatOptions where
def = csvPreset # CsvPresetRFC def = csvPreset # CsvPresetRFC -- DO NOT CHANGE!
-- Changing the default to CsvPresetXlsx will cause internal server errors due to partial record selectors failing, like `csvIncludeHeader`
data CsvPreset = CsvPresetRFC data CsvPreset = CsvPresetRFC
| CsvPresetXlsx | CsvPresetXlsx

45
src/Utils/Avs.hs
View File

@ -32,10 +32,10 @@ type AVSGetRampLicences = "RampDrivingLicenceInfo" :> ReqBody '[JSON] AvsQueryG
type AVSSetRampLicences = "RampDrivingLicence" :> ReqBody '[JSON] AvsQuerySetLicences :> Post '[JSON] AvsResponseSetLicences type AVSSetRampLicences = "RampDrivingLicence" :> ReqBody '[JSON] AvsQuerySetLicences :> Post '[JSON] AvsResponseSetLicences
avsMaxSetLicenceAtOnce :: Int avsMaxSetLicenceAtOnce :: Int
avsMaxSetLicenceAtOnce = 90 -- maximum input set size for avsQuerySetLicences as enforced by AVS avsMaxSetLicenceAtOnce = 80 -- maximum input set size for avsQuerySetLicences as enforced by AVS
avsMaxGetStatusAtOnce :: Int avsMaxQueryAtOnce :: Int
avsMaxGetStatusAtOnce = 900 -- maximum input set size for avsQueryStatus as enforced by AVS avsMaxQueryAtOnce = 500 -- maximum input set size for avsQueryStatus as enforced by AVS
avsApi :: Proxy AVS avsApi :: Proxy AVS
@ -78,10 +78,10 @@ mkAvsQuery _ _ _ = AvsQuery
} }
#else #else
mkAvsQuery baseUrl basicAuth cliEnv = AvsQuery mkAvsQuery baseUrl basicAuth cliEnv = AvsQuery
{ avsQueryPerson = \q -> liftIO $ catch404toEmpty <$> runClientM (rawQueryPerson q) cliEnv { avsQueryPerson = \q -> liftIO $ catch404toEmpty <$> runClientM (rawQueryPerson q) cliEnv
, avsQueryStatus = \q -> liftIO $ runClientM (splitQueryStatus q) cliEnv , avsQueryStatus = \q -> liftIO $ runClientM (splitQuery rawQueryStatus q) cliEnv
, avsQueryContact = \q -> liftIO $ runClientM (rawQueryContact q) cliEnv , avsQueryContact = \q -> liftIO $ runClientM (splitQuery rawQueryContact q) cliEnv
, avsQuerySetLicences = \q -> liftIO $ runClientM (rawQuerySetLicences q) cliEnv , avsQuerySetLicences = \q -> liftIO $ runClientM (rawQuerySetLicences q) cliEnv -- TODO: currently uses setLicencesAvs for splitting to ensure return of correctly set licences
-- , avsQueryGetLicences = \q -> liftIO $ runClientM (rawQueryGetLicences q) cliEnv -- , avsQueryGetLicences = \q -> liftIO $ runClientM (rawQueryGetLicences q) cliEnv
, avsQueryGetAllLicences = liftIO $ runClientM (rawQueryGetLicences avsQueryAllLicences) cliEnv , avsQueryGetAllLicences = liftIO $ runClientM (rawQueryGetLicences avsQueryAllLicences) cliEnv
} }
@ -96,25 +96,18 @@ mkAvsQuery baseUrl basicAuth cliEnv = AvsQuery
| baseUrl == base = Right $ AvsResponsePerson mempty -- WORKAROUND: AVS server erroneously returns 404 if no matching person could be found in its database! | baseUrl == base = Right $ AvsResponsePerson mempty -- WORKAROUND: AVS server erroneously returns 404 if no matching person could be found in its database!
catch404toEmpty other = other catch404toEmpty other = other
-- TODO: make a generic implementation for this splitQuery :: (Wrapped a, Wrapped c, Unwrapped a ~ Set b, Semigroup (Unwrapped c))
splitQueryStatus :: AvsQueryStatus -> ClientM AvsResponseStatus => (a -> ClientM c) -> a -> ClientM c
splitQueryStatus q@(AvsQueryStatus avids) splitQuery rawQuery q
| Set.size avids <= avsMaxGetStatusAtOnce = rawQueryStatus q | avsMaxQueryAtOnce >= Set.size s = rawQuery q
| otherwise = do | otherwise = do
let (avid_1,avid_2) = Set.splitAt avsMaxGetStatusAtOnce avids -- $logInfoS "AVS" $ "Splitting large query for input Set " <> tshow (Set.size s) -- would require MonadLogger ClientM
res1 <- rawQueryStatus (AvsQueryStatus avid_1) let (avsid1, avsid2) = Set.splitAt avsMaxQueryAtOnce s
res2 <- splitQueryStatus (AvsQueryStatus avid_2) res1 <- rawQuery $ view _Unwrapped' avsid1
return $ res1 <> res2 res2 <- splitQuery rawQuery $ view _Unwrapped' avsid2
return $ view _Unwrapped' (res1 ^. _Wrapped' <> res2 ^. _Wrapped')
-- splitQuery :: (a -> Set b) -> (Set b -> a) -> (a -> ClientM c) -> a -> ClientM c where
-- splitQuery toSet fromSet rawQuery q s = view _Wrapped' q
-- | Set.size (toSet q) <= avsMaxGetStatusAtOnce = rawQueryStatus q
-- | otherwise = do
-- let (fromSet -> avid_1,fromSet -> avid_2) = Set.splitAt avsMaxGetStatusAtOnce (toSet q)
-- res1 <- rawQuery avid_1
-- res2 <- splitQuery toSet fromSet rawQuery avid_2
-- return $ fromSet (toSet res1 <> toSet res2)
#endif #endif
----------------------- -----------------------

4
src/Utils/Form.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Felix Hamann <felix.hamann@campus.lmu.de>,Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Wolfgang Witt <Wolfgang.Witt@campus.lmu.de> -- SPDX-FileCopyrightText: 2023 Felix Hamann <felix.hamann@campus.lmu.de>,Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Wolfgang Witt <Wolfgang.Witt@campus.lmu.de>
-- --
-- SPDX-License-Identifier: AGPL-3.0-or-later -- SPDX-License-Identifier: AGPL-3.0-or-later
@ -308,6 +308,7 @@ data FormIdentifier
| FIDAvsSetLicence | FIDAvsSetLicence
| FIDBtnAvsImportUnknown | FIDBtnAvsImportUnknown
| FIDBtnAvsRevokeUnknown | FIDBtnAvsRevokeUnknown
| FIDHijackUser
deriving (Eq, Ord, Read, Show) deriving (Eq, Ord, Read, Show)
instance PathPiece FormIdentifier where instance PathPiece FormIdentifier where
@ -1089,6 +1090,7 @@ wrapForm' :: Button site button => button -> WidgetT site IO () -> FormSettings
wrapForm' btn formWidget FormSettings{..} = do wrapForm' btn formWidget FormSettings{..} = do
formId <- maybe newIdent (return . toPathPiece) formAnchor formId <- maybe newIdent (return . toPathPiece) formAnchor
formActionUrl <- traverse toTextUrl formAction formActionUrl <- traverse toTextUrl formAction
let hasAction = isJust formActionUrl
$(widgetFile "widgets/form/form") $(widgetFile "widgets/form/form")

2
src/Utils/Lens.hs
View File

@ -128,7 +128,7 @@ makeClassyFor_ ''LmsResult
makeClassyFor_ ''UserAvs makeClassyFor_ ''UserAvs
makeClassyFor_ ''UserAvsCard makeClassyFor_ ''UserAvsCard
makeClassyFor_ ''UserCompany makeLenses_ ''UserCompany
makeLenses_ ''Company makeLenses_ ''Company
_entityKey :: Getter (Entity record) (Key record) _entityKey :: Getter (Entity record) (Key record)

38
src/Utils/Print.hs
View File

@ -17,7 +17,10 @@ module Utils.Print
, _Meta, addMeta , _Meta, addMeta
, toMeta, mbMeta -- single values , toMeta, mbMeta -- single values
, mkMeta, appMeta, applyMetas -- multiple values , mkMeta, appMeta, applyMetas -- multiple values
-- , MDMail
-- , MDLetter
, LetterRenewQualificationF(..) , LetterRenewQualificationF(..)
, LetterExpireQualificationF(..)
-- , LetterCourseCertificate() -- , LetterCourseCertificate()
, makeCourseCertificates , makeCourseCertificates
) where ) where
@ -42,6 +45,7 @@ import Text.Hamlet
import System.Exit import System.Exit
import System.Process.Typed -- for calling pdftk for pdf encryption import System.Process.Typed -- for calling pdftk for pdf encryption
import Handler.Utils.Memcached
import Handler.Utils.Users import Handler.Utils.Users
import Handler.Utils.DateTime import Handler.Utils.DateTime
import Handler.Utils.Mail import Handler.Utils.Mail
@ -49,8 +53,10 @@ import Handler.Utils.Widgets (nameHtml')
import Handler.Utils.Avs (updateReceivers) import Handler.Utils.Avs (updateReceivers)
import Jobs.Handler.SendNotification.Utils import Jobs.Handler.SendNotification.Utils
import Utils.Print.Instances ()
import Utils.Print.Letters import Utils.Print.Letters
import Utils.Print.RenewQualification import Utils.Print.RenewQualification
import Utils.Print.ExpireQualification
import Utils.Print.CourseCertificate import Utils.Print.CourseCertificate
@ -108,32 +114,35 @@ import Utils.Print.CourseCertificate
-- | read and writes markdown, applying it as its own template to apply meta -- | read and writes markdown, applying it as its own template to apply meta
mdTemplating :: Text -> P.Meta -> HandlerFor UniWorX (Either P.PandocError P.Pandoc) mdTemplating :: Text -> P.Meta -> HandlerFor UniWorX (Either Text P.Pandoc)
mdTemplating template meta = runExceptT $ do mdTemplating template meta = runExceptT $ do
let readerOpts = def { P.readerExtensions = P.pandocExtensions let readerOpts = def { P.readerExtensions = P.pandocExtensions
, P.readerStripComments = True , P.readerStripComments = True
} }
doc <- ExceptT $ $cachedHereBinary ("pandoc: \n" <> template) (pure . P.runPure $ P.readMarkdown readerOpts template) -- doc <- ExceptT (pure . over _Left P.renderError . P.runPure $ P.readMarkdown readerOpts template)
tmpl <- ExceptT $ $cachedHereBinary ("template: \n" <> template) (pure . P.runPure $ compileTemplate template) -- tmpl <- ExceptT (pure . over _Left P.renderError . P.runPure $ compileTemplate template)
doc <- ExceptT $ memcachedBy (Just . Right $ 6 * diffHour) ("pandoc-md: \n" <> template) (pure . over _Left P.renderError . P.runPure $ P.readMarkdown readerOpts template)
tmpl <- ExceptT $ memcachedBy (Just . Right $ 6 * diffHour) ("template-md: \n" <> template) (pure . over _Left P.renderError . P.runPure $ compileTemplate template)
let writerOpts = def { P.writerExtensions = P.pandocExtensions let writerOpts = def { P.writerExtensions = P.pandocExtensions
, P.writerTemplate = Just tmpl , P.writerTemplate = Just tmpl
} }
ExceptT . pure . P.runPure $ do ExceptT . pure . over _Left P.renderError . P.runPure $ do
md_txt <- P.writeMarkdown writerOpts $ appMeta setIsDeFromLang $ addMeta meta doc md_txt <- P.writeMarkdown writerOpts $ appMeta setIsDeFromLang $ addMeta meta doc
P.readMarkdown readerOpts md_txt addMeta meta <$> P.readMarkdown readerOpts md_txt -- NOTE: meta is lost along the way somehow, despite P.pandocExtensions containing Ext_yaml_metadata_block
-- | creates a PDF using a LaTeX template -- | creates a PDF using a LaTeX template
pdfLaTeX :: LetterKind -> P.Pandoc -> HandlerFor UniWorX (Either P.PandocError LBS.ByteString) pdfLaTeX :: LetterKind -> P.Pandoc -> HandlerFor UniWorX (Either Text LBS.ByteString)
pdfLaTeX lk doc = do pdfLaTeX lk doc = do
e_tmpl <- $cachedHereBinary ("LetterKind:" <> tshow lk) (liftIO . P.runIO $ compileTemplate $ templateLatex lk) -- e_tmpl <- fmap (over _Left P.renderError) . liftIO . P.runIO $ compileTemplate $ templateLatex lk
actRight e_tmpl $ \tmpl -> liftIO . P.runIO $ do e_tmpl <- memcachedBy (Just . Right $ 6 * diffHour) ("LetterKind-latex: \n" <> tshow lk) (fmap (over _Left P.renderError) . liftIO . P.runIO $ compileTemplate $ templateLatex lk)
actRight e_tmpl $ \tmpl -> fmap (over _Left P.renderError) . liftIO . P.runIO $ do
let writerOpts = def { P.writerExtensions = P.pandocExtensions let writerOpts = def { P.writerExtensions = P.pandocExtensions
, P.writerTemplate = Just tmpl } , P.writerTemplate = Just tmpl }
makePDF writerOpts $ appMeta setIsDeFromLang doc makePDF writerOpts $ appMeta setIsDeFromLang doc
renderLetter :: (MDLetter l) => Entity User -> l -> Text -> Handler (Either Text LBS.ByteString) renderLetter :: (MDLetter l) => Entity User -> l -> Text -> Handler (Either Text LBS.ByteString)
renderLetter rcvrEnt@Entity{entityVal=rcvr} mdl apcIdent = do renderLetter rcvrEnt@Entity{entityVal=rcvr} mdl apcIdent = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
@ -151,8 +160,8 @@ renderLetter rcvrEnt@Entity{entityVal=rcvr} mdl apcIdent = do
--, toMeta "rcvr-email" $ rcvr & userDisplayEmail -- note that some templates use "email" already otherwise --, toMeta "rcvr-email" $ rcvr & userDisplayEmail -- note that some templates use "email" already otherwise
] ]
e_md <- mdTemplating tmpl meta e_md <- mdTemplating tmpl meta
result <- actRight e_md $ pdfLaTeX kind actRight e_md $ pdfLaTeX kind
return $ over _Left P.renderError result
-- TODO: apcIdent does not make sense for multiple letters -- TODO: apcIdent does not make sense for multiple letters
renderLetters :: (MDLetter l, Foldable f) => Entity User -> f l -> Text -> Handler (Either Text LBS.ByteString) renderLetters :: (MDLetter l, Foldable f) => Entity User -> f l -> Text -> Handler (Either Text LBS.ByteString)
@ -180,8 +189,9 @@ renderLetters rcvrEnt@Entity{entityVal=rcvr} mdls apcIdent
Right doc2 -> pure $ Right $ doc1 <> doc2 Right doc2 -> pure $ Right $ doc1 <> doc2
doc <- foldrM templateCombine (Right mempty) mdls doc <- foldrM templateCombine (Right mempty) mdls
result <- actRight doc $ pdfLaTeX kind -- result <- actRight doc $ pdfLaTeX kind
return $ over _Left P.renderError result -- return $ over _Left P.renderError result
actRight doc $ pdfLaTeX kind
| otherwise = return $ Left "renderLetters received empty set of letters" | otherwise = return $ Left "renderLetters received empty set of letters"
@ -377,7 +387,7 @@ encryptPDF pw bs = over _Left (decodeUtf8 . LBS.toStrict) . exit2either <$> read
-- | Internal only, use `printLetter` instead -- | Internal only, use `printLetter` instead
lprPDF :: (MonadHandler m, HasAppSettings (HandlerSite m)) => FilePath -> LBS.ByteString -> m (Either Text Text) lprPDF :: (MonadHandler m, HasAppSettings (HandlerSite m)) => FilePath -> LBS.ByteString -> m (Either Text Text)
lprPDF (sanitizeCmdArg' -> jb) bs = do lprPDF (sanitizeCmdArg' -> jb) bs = do
mbLprServerArg <- $cachedHereBinary ("lprServer"::Text) getLprServerArg mbLprServerArg <- getLprServerArg
case mbLprServerArg of case mbLprServerArg of
Nothing -> return $ Right "Print command ignored due to setting 'mail-reroute-to' being set." Nothing -> return $ Right "Print command ignored due to setting 'mail-reroute-to' being set."
Just lprServerArg -> do Just lprServerArg -> do

84
src/Utils/Print/ExpireQualification.hs Normal file
View File

@ -0,0 +1,84 @@
-- SPDX-FileCopyrightText: 2023 Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
module Utils.Print.ExpireQualification where
import Import
import Text.Hamlet
-- import Data.Char as Char
-- import qualified Data.Text as Text
import qualified Data.CaseInsensitive as CI
import Data.FileEmbed (embedFile)
import Utils.Print.Letters
import Handler.Utils.Widgets (nameHtml) -- , nameHtml')
data LetterExpireQualificationF = LetterExpireQualificationF
{ leqfHolderUUID:: CryptoUUIDUser
, leqfHolderID :: UserId
, leqfHolderDN :: UserDisplayName
, leqfHolderSN :: UserSurname
, leqfExpiry :: Day
, leqfId :: QualificationId
, leqfName :: Text
, leqfShort :: Text
, leqfSchool :: SchoolId
}
deriving (Eq, Show)
-- TODO: use markdown to generate the Letter
instance MDMail LetterExpireQualificationF where
getMailSubject l = SomeMessage $ MsgMailSubjectQualificationExpired $ leqfShort l
getMailBody LetterExpireQualificationF{..} DateTimeFormatter{ format } =
let expiryDate = format SelFormatDate leqfExpiry
userDisplayName = leqfHolderDN
userSurname = leqfHolderSN
qualificationName = leqfName
qualificationShorthand = CI.mk leqfShort
qualificationSchool = leqfSchool
qname = qualificationName
ihamletSomeMessage _ _ _ = (mempty :: Html) -- TODO: use markdown for letter
editNotifications = () -- TODO: use markdown for letter
in $(ihamletFile "templates/mail/qualificationExpired.hamlet")
instance MDLetter LetterExpireQualificationF where
encrypPDFfor _ = NoPassword
getLetterKind _ = Din5008
getLetterEnvelope _ = 'e'
getTemplate _ = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/fraport_f_expiry.md")
letterMeta LetterExpireQualificationF{..} DateTimeFormatter{ format } lang Entity{entityKey=rcvrId, entityVal=User{userDisplayName}} =
let isSupervised = rcvrId /= leqfHolderID
in mkMeta $
guardMonoid isSupervised
[ toMeta "supervisor" userDisplayName
, toMeta "de-opening" ("Sehr geehrte Damen und Herren,"::Text)
, toMeta "en-opening" ("Dear Sir or Madam,"::Text)
] <>
[ toMeta "lang" lang
, toMeta "licenceholder" leqfHolderDN
, toMeta "expiry" (format SelFormatDate leqfExpiry)
]
getPJId LetterExpireQualificationF{..} =
PrintJobIdentification
{ pjiName = "Expiry"
, pjiApcAcknowledge = "exp-" <> tshow (ciphertext leqfHolderUUID)
, pjiRecipient = Nothing -- to be filled later
, pjiSender = Nothing
, pjiCourse = Nothing
, pjiQualification = Just leqfId
, pjiLmsUser = Nothing
, pjiFileName = "expire_" <> CI.original (unSchoolKey leqfSchool) <> "-" <> leqfShort <> "_" <> leqfHolderSN
-- let nameRecipient = abbrvName <$> recipient
-- nameSender = abbrvName <$> sender
-- nameCourse = CI.original . courseShorthand <$> course
-- nameQuali = CI.original . qualificationShorthand <$> quali
-- in .. = T.replace " " "-" (T.intercalate "_" . catMaybes $ [Just printJobName, nameQuali, nameCourse, nameSender, nameRecipient])
}

66
src/Utils/Print/Instances.hs Normal file
View File

@ -0,0 +1,66 @@
-- SPDX-FileCopyrightText: 2022-23 Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Utils.Print.Instances where
import Import.NoModel
-- import Import
import qualified Text.DocTemplates.Internal as D
import qualified Text.DocLayout as D
import qualified Text.Pandoc as P
-----------------------------
-- Pandoc Orphan Instances --
-----------------------------
-- deriving anyclass instance Generic IOException
-- deriving anyclass instance Binary IOException
-- deriving anyclass instance Binary HttpException
-- deriving anyclass instance Binary P.PandocError
-- required for memcaching compiled markdown and LaTeX templates
instance Binary P.RowHeadColumns
instance Binary P.RowSpan
instance Binary P.ColWidth
instance Binary P.ColSpan
instance Binary P.Alignment
instance Binary P.TableHead
instance Binary P.TableBody
instance Binary P.TableFoot
instance Binary P.MathType
instance Binary P.Cell
instance Binary P.Caption
instance Binary P.Citation
instance Binary P.CitationMode
instance Binary P.ListNumberStyle
instance Binary P.ListNumberDelim
instance Binary P.Format
instance Binary P.QuoteType
instance Binary P.Inline
instance Binary P.Row
instance Binary P.Block
instance Binary P.MetaValue
instance Binary P.Meta
instance Binary P.Pandoc
-- -- and for memchaching a LaTeX template
deriving instance Binary D.Border
deriving instance Binary D.Alignment
deriving instance Binary D.Pipe
deriving instance Binary D.Variable
deriving instance (Binary a) => Binary (D.Doc a)
deriving instance (Binary a) => Binary (P.Template a)
deriving instance NFData D.Border
deriving instance NFData D.Alignment
deriving instance NFData D.Pipe
deriving instance NFData D.Variable
deriving instance (NFData a) => NFData (D.Doc a)
deriving instance (NFData a) => NFData (P.Template a)
-- TODO: sadly this is not yet enough.

2
src/Utils/Print/Letters.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de> -- SPDX-FileCopyrightText: 2022-23 Steffen Jost <jost@tcs.ifi.lmu.de>
-- --
-- SPDX-License-Identifier: AGPL-3.0-or-later -- SPDX-License-Identifier: AGPL-3.0-or-later

6
src/Utils/Print/RenewQualification.hs
View File

@ -9,8 +9,8 @@ module Utils.Print.RenewQualification where
import Import import Import
import Text.Hamlet import Text.Hamlet
import Data.Char as Char -- import Data.Char as Char
import qualified Data.Text as Text -- import qualified Data.Text as Text
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
import Data.FileEmbed (embedFile) import Data.FileEmbed (embedFile)
@ -55,7 +55,7 @@ instance MDMail LetterRenewQualificationF where
instance MDLetter LetterRenewQualificationF where instance MDLetter LetterRenewQualificationF where
encrypPDFfor _ = PasswordUnderling encrypPDFfor _ = PasswordUnderling
getLetterKind _ = PinLetter getLetterKind _ = PinLetter
getLetterEnvelope l = maybe 'q' (Char.toLower . fst) $ Text.uncons (qualShort l) getLetterEnvelope _ = 'f' -- maybe 'q' (Char.toLower . fst) $ Text.uncons (qualShort l)
getTemplate _ = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/fraport_renewal.md") getTemplate _ = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/fraport_renewal.md")
letterMeta l@LetterRenewQualificationF{..} DateTimeFormatter{ format } lang Entity{entityKey=rcvrId, entityVal=User{userDisplayName}} = letterMeta l@LetterRenewQualificationF{..} DateTimeFormatter{ format } lang Entity{entityKey=rcvrId, entityVal=User{userDisplayName}} =

2
src/Utils/Users.hs
View File

@ -73,7 +73,7 @@ addNewUser AddUserData{..} = do
, userExamOfficeGetLabels = userDefaultExamOfficeGetLabels , userExamOfficeGetLabels = userDefaultExamOfficeGetLabels
, userNotificationSettings = def , userNotificationSettings = def
, userLanguages = Nothing , userLanguages = Nothing
, userCsvOptions = def , userCsvOptions = def { csvFormat = review csvPreset CsvPresetXlsx }
, userTokensIssuedAfter = Nothing , userTokensIssuedAfter = Nothing
, userCreated = now , userCreated = now
, userLastLdapSynchronisation = Nothing , userLastLdapSynchronisation = Nothing

10
stack.yaml
View File

@ -7,8 +7,12 @@ flags:
cffi: true cffi: true
rebuild-ghc-options: true rebuild-ghc-options: true
ghc-options: #ghc-options:
"$everything": -fno-prof-auto # "$everything": -fno-prof-auto
build:
library-profiling: true
executable-profiling: true
nix: nix:
packages: [] packages: []
@ -67,7 +71,7 @@ extra-deps:
commit: 843683d024f767de236f74d24a3348f69181a720 commit: 843683d024f767de236f74d24a3348f69181a720
- git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git - git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 # <- references debug with traceStack; master ref: cb75191e0c5490246ae2cbcc2a00e7985cf2aadb
subdirs: subdirs:
- yesod-core - yesod-core
- yesod-static - yesod-static

58
stack.yaml.lock
View File

@ -240,12 +240,12 @@ packages:
git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
pantry-tree: pantry-tree:
size: 5954 size: 5954
sha256: bca827b8f5b4b649ef6d8f0e06fc5ae9b825f9def16fb472173d2fbf12fb5dc2 sha256: 08c8da10b32c8d9f784238fd87232bf90b752e82f81ef2c52c62210f9aadda9a
commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
original: original:
subdir: yesod-core subdir: yesod-core
git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
- completed: - completed:
subdir: yesod-static subdir: yesod-static
name: yesod-static name: yesod-static
@ -254,11 +254,11 @@ packages:
pantry-tree: pantry-tree:
size: 2949 size: 2949
sha256: 32c1608243a5309005ce11e2aa379ac1d6f8c380c529785eb510770118f3da06 sha256: 32c1608243a5309005ce11e2aa379ac1d6f8c380c529785eb510770118f3da06
commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
original: original:
subdir: yesod-static subdir: yesod-static
git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
- completed: - completed:
subdir: yesod-persistent subdir: yesod-persistent
name: yesod-persistent name: yesod-persistent
@ -267,11 +267,11 @@ packages:
pantry-tree: pantry-tree:
size: 497 size: 497
sha256: 3778ef2964e1a3890afc22cc9124eacb40e64b62bed4983a85d3b99897f54c5c sha256: 3778ef2964e1a3890afc22cc9124eacb40e64b62bed4983a85d3b99897f54c5c
commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
original: original:
subdir: yesod-persistent subdir: yesod-persistent
git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
- completed: - completed:
subdir: yesod-newsfeed subdir: yesod-newsfeed
name: yesod-newsfeed name: yesod-newsfeed
@ -280,11 +280,11 @@ packages:
pantry-tree: pantry-tree:
size: 488 size: 488
sha256: 53ebad62655863a657dcf749ffd3de46f6af90dd71f55bc4d50805ac48ddb099 sha256: 53ebad62655863a657dcf749ffd3de46f6af90dd71f55bc4d50805ac48ddb099
commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
original: original:
subdir: yesod-newsfeed subdir: yesod-newsfeed
git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
- completed: - completed:
subdir: yesod-form subdir: yesod-form
name: yesod-form name: yesod-form
@ -293,11 +293,11 @@ packages:
pantry-tree: pantry-tree:
size: 1914 size: 1914
sha256: 260b7f16a8e1d58da137eb91aeed3a11ccbe59ba3e614457a635b9dc3e71426f sha256: 260b7f16a8e1d58da137eb91aeed3a11ccbe59ba3e614457a635b9dc3e71426f
commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
original: original:
subdir: yesod-form subdir: yesod-form
git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
- completed: - completed:
subdir: yesod-form-multi subdir: yesod-form-multi
name: yesod-form-multi name: yesod-form-multi
@ -306,11 +306,11 @@ packages:
pantry-tree: pantry-tree:
size: 328 size: 328
sha256: b21fc50db43733dfe6e285345856610ba4feb83329e9cf953bf8047ba18ecbd6 sha256: b21fc50db43733dfe6e285345856610ba4feb83329e9cf953bf8047ba18ecbd6
commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
original: original:
subdir: yesod-form-multi subdir: yesod-form-multi
git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
- completed: - completed:
subdir: yesod-auth subdir: yesod-auth
name: yesod-auth name: yesod-auth
@ -319,11 +319,11 @@ packages:
pantry-tree: pantry-tree:
size: 1212 size: 1212
sha256: d335b940a207f8155f421b7146746a72d20db6ad54412154f2c829a59bf21e08 sha256: d335b940a207f8155f421b7146746a72d20db6ad54412154f2c829a59bf21e08
commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
original: original:
subdir: yesod-auth subdir: yesod-auth
git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
- completed: - completed:
subdir: yesod-auth-oauth subdir: yesod-auth-oauth
name: yesod-auth-oauth name: yesod-auth-oauth
@ -332,11 +332,11 @@ packages:
pantry-tree: pantry-tree:
size: 321 size: 321
sha256: 39d2f7d5d1abb3a2953858c5f23880e60ecfcdad0549ddc2570204f9c47649f4 sha256: 39d2f7d5d1abb3a2953858c5f23880e60ecfcdad0549ddc2570204f9c47649f4
commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
original: original:
subdir: yesod-auth-oauth subdir: yesod-auth-oauth
git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
- completed: - completed:
subdir: yesod-sitemap subdir: yesod-sitemap
name: yesod-sitemap name: yesod-sitemap
@ -345,11 +345,11 @@ packages:
pantry-tree: pantry-tree:
size: 314 size: 314
sha256: 971f48af7011ff7816872d067e5de9cadafdd371bdf209170b77df36001abd27 sha256: 971f48af7011ff7816872d067e5de9cadafdd371bdf209170b77df36001abd27
commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
original: original:
subdir: yesod-sitemap subdir: yesod-sitemap
git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
- completed: - completed:
subdir: yesod-test subdir: yesod-test
name: yesod-test name: yesod-test
@ -358,11 +358,11 @@ packages:
pantry-tree: pantry-tree:
size: 563 size: 563
sha256: 3d5022e8e3f8e77abcf075c42cf49efaa26f4951159bbb5ab50b69fdfeacb7c1 sha256: 3d5022e8e3f8e77abcf075c42cf49efaa26f4951159bbb5ab50b69fdfeacb7c1
commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
original: original:
subdir: yesod-test subdir: yesod-test
git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
- completed: - completed:
subdir: yesod-bin subdir: yesod-bin
name: yesod-bin name: yesod-bin
@ -371,11 +371,11 @@ packages:
pantry-tree: pantry-tree:
size: 1295 size: 1295
sha256: 422d7816965b79826c6c24582d76dadbacd1bfb3e9a8f31208867cd788f2a5b8 sha256: 422d7816965b79826c6c24582d76dadbacd1bfb3e9a8f31208867cd788f2a5b8
commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
original: original:
subdir: yesod-bin subdir: yesod-bin
git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
- completed: - completed:
subdir: yesod subdir: yesod
name: yesod name: yesod
@ -384,11 +384,11 @@ packages:
pantry-tree: pantry-tree:
size: 666 size: 666
sha256: cb53ef3f2036185d2b4752d6fbc5d78470b4504e646e7eb4dd2397f2599daf42 sha256: cb53ef3f2036185d2b4752d6fbc5d78470b4504e646e7eb4dd2397f2599daf42
commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
original: original:
subdir: yesod subdir: yesod
git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
- completed: - completed:
subdir: yesod-eventsource subdir: yesod-eventsource
name: yesod-eventsource name: yesod-eventsource
@ -397,11 +397,11 @@ packages:
pantry-tree: pantry-tree:
size: 324 size: 324
sha256: 6d393201852cd024e377159ba836398e24d191563e08165430113d3c1384aff2 sha256: 6d393201852cd024e377159ba836398e24d191563e08165430113d3c1384aff2
commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
original: original:
subdir: yesod-eventsource subdir: yesod-eventsource
git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
- completed: - completed:
subdir: yesod-websockets subdir: yesod-websockets
name: yesod-websockets name: yesod-websockets
@ -410,11 +410,11 @@ packages:
pantry-tree: pantry-tree:
size: 485 size: 485
sha256: 02df6117e9b74a77879ea750130ba2d8ad8d3c99e14ca678320cb578984301e5 sha256: 02df6117e9b74a77879ea750130ba2d8ad8d3c99e14ca678320cb578984301e5
commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
original: original:
subdir: yesod-websockets subdir: yesod-websockets
git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git
commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7
- completed: - completed:
name: cryptonite name: cryptonite
version: '0.29' version: '0.29'

1
templates/letter/din5008.latex
View File

@ -67,6 +67,7 @@ $endif$
\usepackage{fontspec} \usepackage{fontspec}
\setmonofont{DejaVu Sans Mono} \setmonofont{DejaVu Sans Mono}
\fi \fi
\renewcommand{\familydefault}{\sfdefault}
$if(mathspec)$ $if(mathspec)$
\ifXeTeX \ifXeTeX

1
templates/letter/din5008with_pin.latex
View File

@ -67,6 +67,7 @@ $endif$
\usepackage{fontspec} \usepackage{fontspec}
\setmonofont{DejaVu Sans Mono} \setmonofont{DejaVu Sans Mono}
\fi \fi
\renewcommand{\familydefault}{\sfdefault}
$if(mathspec)$ $if(mathspec)$
\ifXeTeX \ifXeTeX

130
templates/letter/fraport_f_expiry.md Normal file
View File

@ -0,0 +1,130 @@
---
### Metadaten, welche hier eingestellt werden:
# Absender
de-subject: 'Entzug "F" (Vorfeldführerschein)'
en-subject: Revocation of apron driving license
author: Fraport AG - Fahrerausbildung (AVN-AR)
phone: +49 69 690-28467
email: fahrerausbildung@fraport.de
place: Frankfurt am Main
return-address:
- 60547 Frankfurt
de-opening: Liebe Fahrberechtigungsinhaber,
en-opening: Dear driver,
de-closing: |
Mit freundlichen Grüßen,
Ihre Fraport Fahrerausbildung
en-closing: |
With kind regards,
Your Fraport Driver Training
encludes:
hyperrefoptions: hidelinks
### Metadaten, welche automatisch ersetzt werden:
date: 11.11.1111
expiry: 00.00.0000
lang: de-de
is-de: true
# Emfpänger
licenceholder: P. Rüfling
address:
- E. M. Pfänger
- Musterfirma GmbH
- Musterstraße 11
- 12345 Musterstadt
...
$if(titleblock)$
$titleblock$
$endif$
$for(header-includes)$
$header-includes$
$endfor$
$for(include-before)$
$include-before$
$endfor$
$if(is-de)$
<!-- deutsche Version des Briefes -->
$if(supervisor)$
leider hat $licenceholder$
$else$
leider haben Sie
$endif$
den Wissenstest im Rahmen des Recurrent Trainings Vorfeldführerschein nicht bestanden
oder die Ablauffrist nicht eingehalten.
Die Qualifikation „Vorfeldführerschein“ ist somit nicht mehr gültig.
$if(supervisor)$
**$licenceholder$** darf
$else$
Sie dürfen
$endif$
ab sofort keine Fahrzeuge mehr eigenständig auf dem Vorfeld des Frankfurter Flughafens führen.
Um die Fahrberechtigung wiederzuerlangen, ist die Teilnahme an einem Grundkurs Vorfeldführerschein erforderlich.
$if(supervisor)$
Hierfür wenden Sie sich bitte an die Fahrerausbildung der Fraport AG unter:
Telefon
: $phone$
Email
: $email$
$else$
Hierfür wenden Sie sich bitte an Ihren Arbeitgeber.
$endif$
$else$
<!-- englische Version des Briefes -->
we regret to inform you that
$if(supervisor)$
**$licenceholder$**
$else$
you
$endif$
did not pass the required knowledge test within the alotted time
for the renewal of the apron driving licence.
The qualification „Vorfeldführerschein“ (apron driving lincence) is therefore invalid now.
$if(supervisor)$
$licenceholder$
$else$
You
$endif$
may no longer drive a vehicle on the apron of Frankfurt airport, effective immediately.
In order to regain this apron driving licence, a full participation in a
basic training course is required.
$if(supervisor)$
Please contact the Fraport driving school team, if you want to book a course:
Phone
: $phone$
Email
: $email$
$else$
Please contact you employer to book a course for you.
$endif$
$endif$

78
templates/letter/fraport_qualification.md
View File

@ -5,18 +5,19 @@
lang: de-de lang: de-de
is-de: true is-de: true
date: 11.11.1111 date: 11.11.1111
test1: this **is really** a test
test2: 'this **is another** test'
test3: |
<h1>First</h1>
<p>Here is some text with <em>emphasis</em> to see.
... ...
\renewcommand{\familydefault}{\sfdefault} \renewcommand{\familydefault}{\sfdefault}
\vspace*{2cm}
\begin{huge}\sffamily\textbf{%
$if(is-de)$ $if(is-de)$
Teilnahmebescheinigung
\medskip $else$
Certificate of attendance
\begin{huge}\sffamily\textbf{Teilnahmebescheinigung}\end{huge} $endif$
}\end{huge}
\vspace{\fill} \vspace{\fill}
@ -27,23 +28,46 @@ $endif$
$if(company)$ $if(company)$
## $company$ {-} ## $company$ {-}
$endif$ $endif$
$if(is-de)$
hat hat
$if(course-begin)$ $if(course-begin)$
$if(course-end)$ $if(course-end)$
von $course-begin$ bis $course-end$ vom $course-begin$ bis zum $course-end$
$else$ $else$
am $course-begin$ am $course-begin$
$endif$ $endif$
$endif$ $endif$
an der Veranstaltung an der Veranstaltung
\centerline{\sffamily\LARGE{$course-name$}} $else$
der Fahrerausbildung der Fraport AG teilgenommen. attended
$if(course-begin)$
$if(course-end)$
from $course-begin$ to $course-end$
$else$
on $course-begin$
$endif$
$endif$
the course
$endif$
\vspace*{1.2EX}
\textbf{\LARGE $course-name$}
\vspace*{1.1EX}
$if(is-de)$
der Fahrerausbildung der Fraport AG teilgenommen.
$else$
taught by Fahrerausbildung of Fraport AG.
$endif$
\vspace{\fill}
\vspace{\fill} \vspace{\fill}
$if(course-content)$ $if(course-content)$
## Inhalte: {-} $if(is-de)$
## Inhalte {-}
$else$
## Course content {-}
$endif$
%%%course-content%%% %%%course-content%%%
@ -51,11 +75,20 @@ $if(course-content)$
$endif$ $endif$
\vspace{\fill}
\vspace{\fill} \vspace{\fill}
$if(is-de)$
Mit Aushändigung der Teilnahmebescheinigung wird der erfolgreiche Abschluss des Kurses bestätigt. Mit Aushändigung der Teilnahmebescheinigung wird der erfolgreiche Abschluss des Kurses bestätigt.
Dieses Zertifikat wurde maschinell erstellt. Dieses Zertifikat wurde maschinell erstellt.
$else$
The successful completion of the course is confirmed
by handing out this certificate.
This is machine generated certificate requires no signature.
$endif$
\medskip \medskip
@ -65,20 +98,5 @@ Fraport College
\vspace{\fill} \vspace{\fill}
\vspace{\fill} \vspace{\fill}
\vspace{\fill} \vspace{\fill}
\vspace{\fill}
\vspace{\fill}
<!-- deutsche version -->
$else$
<!-- english version -->
# Certificate of attendance
**English version is not yet implemened.**
TODO
$endif$
\clearpage \clearpage

4
templates/letter/fraport_renewal.md
View File

@ -13,7 +13,7 @@ de-opening: Liebe Fahrberechtigungsinhaber,
en-opening: Dear driver, en-opening: Dear driver,
de-closing: | de-closing: |
Mit freundlichen Grüßen, Mit freundlichen Grüßen,
Ihre Fahrerausbildung Ihre Fraport Fahrerausbildung
en-closing: | en-closing: |
With kind regards, With kind regards,
Your Fraport Driver Training Your Fraport Driver Training
@ -133,7 +133,7 @@ $if(supervisor)$
to regain the apron driving licence. to regain the apron driving licence.
$else$ $else$
you have to participate in a basic training course again to regain you have to participate in a basic training course again to regain
your apron driving licnece. your apron driving licence.
$endif$ $endif$

10
templates/letter/plain_article.latex
View File

@ -51,15 +51,19 @@ $endif$
\fi \fi
\ifPDFTeX \ifPDFTeX
\usepackage{helvet}
\usepackage[$if(fontenc)$$fontenc$$else$T1$endif$]{fontenc} \usepackage[$if(fontenc)$$fontenc$$else$T1$endif$]{fontenc}
\usepackage[utf8]{inputenc} \usepackage[utf8]{inputenc}
\usepackage{textcomp} % provide euro and other symbols \usepackage{textcomp}% provide euro and other symbols
\usepackage{DejaVuSansMono} % better monofont \usepackage{DejaVuSansMono}% better monofont
\renewcommand{\familydefault}{\sfdefault}
\else \else
% if luatex or xetex % if luatex or xetex
\usepackage{fontspec} \usepackage{fontspec}
%\setmainfont{TeXGyreHeros}%could not install the package somehow tex-gyre in default.nix/shell.nix did not work
\setmainfont{DejaVu Sans}
\setmonofont{DejaVu Sans Mono} \setmonofont{DejaVu Sans Mono}
%\renewcommand{\familydefault}{\sfdefault} \renewcommand{\familydefault}{\sfdefault}
\fi \fi
$if(mathspec)$ $if(mathspec)$

2
templates/mail/qualificationExpired.hamlet
View File

@ -29,7 +29,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
#{qualificationName} #{qualificationName}
<dt>_{SomeMessage MsgLmsUser} <dt>_{SomeMessage MsgLmsUser}
<dd>#{nameHtml userDisplayName userSurname} <dd>#{nameHtml userDisplayName userSurname}
<dt>_{SomeMessage MsgLmsQualificationValidUntil} <dt>_{SomeMessage MsgQualificationExpired}
<dd>#{expiryDate} <dd>#{expiryDate}

2
templates/widgets/form/form.hamlet
View File

@ -5,7 +5,7 @@ $#
$# SPDX-License-Identifier: AGPL-3.0-or-later $# SPDX-License-Identifier: AGPL-3.0-or-later
$# Wrapper for all kinds of forms $# Wrapper for all kinds of forms
<form ##{formId} method=#{decodeUtf8 (renderStdMethod formMethod)} action=#{fromMaybe "" formActionUrl} enctype=#{formEncoding} *{formAttrs}> <form ##{formId} method=#{decodeUtf8 (renderStdMethod formMethod)} :hasAction:action=#{fromMaybe "" formActionUrl} enctype=#{formEncoding} *{formAttrs}>
$# Distinguish different falvours of submit button layouts here: $# Distinguish different falvours of submit button layouts here:
$case formSubmit $case formSubmit
$of FormNoSubmit $of FormNoSubmit

8
test/Database/Fill.hs
View File

@ -163,7 +163,7 @@ fillDb = do
, userAuthentication = pwSimple , userAuthentication = pwSimple
, userLastAuthentication = Nothing , userLastAuthentication = Nothing
, userTokensIssuedAfter = Nothing , userTokensIssuedAfter = Nothing
, userMatrikelnummer = Just "94094094094" , userMatrikelnummer = Just "12345678"
, userEmail = "S.Jost@Fraport.de" , userEmail = "S.Jost@Fraport.de"
, userDisplayEmail = "jost@tcs.ifi.lmu.de" , userDisplayEmail = "jost@tcs.ifi.lmu.de"
, userDisplayName = "Steffen Jost" , userDisplayName = "Steffen Jost"
@ -680,6 +680,10 @@ fillDb = do
void . insert' $ UserAvs (AvsPersonId 4) sbarth 4 void . insert' $ UserAvs (AvsPersonId 4) sbarth 4
void . insert' $ UserAvs (AvsPersonId 5) fhamann 5 void . insert' $ UserAvs (AvsPersonId 5) fhamann 5
void . insert' $ UserAvs (AvsPersonId 77) tinaTester 77 void . insert' $ UserAvs (AvsPersonId 77) tinaTester 77
insert_ $ UserAvsCard (AvsPersonId 12345678) (AvsFullCardNo (AvsCardNo "1234") "4") (AvsDataPersonCard True Nothing Nothing AvsCardColorGelb (Set.fromList ['F']) Nothing Nothing Nothing Nothing (AvsCardNo "1234") "4") now
insert_ $ UserAvsCard (AvsPersonId 2) (AvsFullCardNo (AvsCardNo "3344") "1") (AvsDataPersonCard True Nothing Nothing AvsCardColorRot (Set.fromList ['F','R']) Nothing Nothing Nothing Nothing (AvsCardNo "3344") "1") now
insert_ $ UserAvsCard (AvsPersonId 3) (AvsFullCardNo (AvsCardNo "7788") "1") (AvsDataPersonCard False Nothing Nothing AvsCardColorRot (Set.fromList ['F','R']) Nothing Nothing Nothing Nothing (AvsCardNo "7788") "1") now
insert_ $ UserAvsCard (AvsPersonId 4) (AvsFullCardNo (AvsCardNo "9999") "4") (AvsDataPersonCard True Nothing Nothing AvsCardColorGelb (Set.fromList ['F']) Nothing Nothing Nothing Nothing (AvsCardNo "9999") "4") now
let f_descr = Just $ htmlToStoredMarkup [shamlet|<p>Berechtigung zum Führen eines Fahrzeuges auf den Fahrstrassen des Vorfeldes.|] let f_descr = Just $ htmlToStoredMarkup [shamlet|<p>Berechtigung zum Führen eines Fahrzeuges auf den Fahrstrassen des Vorfeldes.|]
let r_descr = Just $ htmlToStoredMarkup [shamlet|<p>Berechtigung zum Führen eines Fahrzeuges auf dem gesamten Rollfeld.|] let r_descr = Just $ htmlToStoredMarkup [shamlet|<p>Berechtigung zum Führen eines Fahrzeuges auf dem gesamten Rollfeld.|]
@ -932,7 +936,7 @@ fillDb = do
<section> <section>
<h3>Benötigte Unterlagen <h3>Benötigte Unterlagen
<ul> <ul>
<li>Sehtest, <li>Sehtest, #
<i>bitte vorab hochladen! <i>bitte vorab hochladen!
<li>Regulärer Führerschein, <li>Regulärer Führerschein,
<i>Bitte mitbringen. <i>Bitte mitbringen.