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 fradrive/driving-course-participants

Browse Source
This commit is contained in:
Sarah Vaupel 2022-12-13 22:23:19 +01:00
commit 5a2d2247ad
337 changed files with 1338 additions and 2268 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
CHANGELOG.md
View File

@ -2,6 +2,28 @@
All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines. All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines.
## [26.6.6](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v26.6.5...v26.6.6) (2022-12-12)
## [26.6.5](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v26.6.4...v26.6.5) (2022-12-05)
## [26.6.4](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v26.6.3...v26.6.4) (2022-12-02)
## [26.6.3](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v26.6.2...v26.6.3) (2022-11-30)
### Bug Fixes
* **avs:** normalize internal personal numbers between LDAP and AVS ([b20008d](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/b20008d3bcb730ff76a76ce2928364e6ce9e7c35))
## [26.6.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v26.6.1...v26.6.2) (2022-11-29)
## [26.6.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v26.6.0...v26.6.1) (2022-11-28)
### Bug Fixes
* **lms:** filtering qualifications by supervisor works properly now ([15f7a75](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/15f7a7576ab48a362a479f43034510b4e80bb1b2))
## [26.6.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v26.5.14...v26.6.0) (2022-11-18) ## [26.6.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v26.5.14...v26.6.0) (2022-11-18)

1
config/settings.yml
View File

@ -276,6 +276,7 @@ user-defaults:
show-sex: false show-sex: false
exam-office-get-synced: true exam-office-get-synced: true
exam-office-get-labels: true exam-office-get-labels: true
prefers-postal: true
instance-id: "_env:INSTANCE_ID:instance" instance-id: "_env:INSTANCE_ID:instance"

21
messages/uniworx/categories/admin/de-de-formal.msg
View File

@ -79,7 +79,7 @@ StudyFeatureInferenceNoNameConflicts: Keine Konflikte beobachtet
StudyFeatureInferenceNameConflictsHeading: Studiengangseinträge mit beobachteten Konflikten StudyFeatureInferenceNameConflictsHeading: Studiengangseinträge mit beobachteten Konflikten
AdminHeading !ident-ok: Administration AdminHeading !ident-ok: Administration
AdminPageEmpty: Diese Seite soll eine Übersichtsseite für Administrator:innen werden. Aktuell finden sich hier nur Links zu wichtigen Administrator-Funktionalitäten.
BearerTokenImpersonate: Auftreten als BearerTokenImpersonate: Auftreten als
BearerTokenImpersonateNone: Keine Änderung BearerTokenImpersonateNone: Keine Änderung
BearerTokenImpersonateSingle: Einzelner Benutzer/Einzelne Benutzerin BearerTokenImpersonateSingle: Einzelner Benutzer/Einzelne Benutzerin
@ -94,3 +94,22 @@ BearerTokenArchiveName !ident-ok: tokens.zip
TestDownloadDirect: Direkte Generierung TestDownloadDirect: Direkte Generierung
TestDownloadInTransaction: Generierung während Datenbank-Transaktion TestDownloadInTransaction: Generierung während Datenbank-Transaktion
TestDownloadFromDatabase: Generierung während Download aus Datenbank TestDownloadFromDatabase: Generierung während Download aus Datenbank
ProblemsHeading: Problemübersicht
ProblemsHeadingDrivers: Fahrberechtigungen
ProblemsAvsProblem: Synchronisation mit AVS/MoBaKo komplett fehlgeschlagen
ProblemsDriverSynch n@Int: #{tshow n} Diskrepanzen zwischen AVS und FRADrive
ProblemsDriverSynch0: Alle Sperrungen von Fahrberechtigungen sind im AVS eingetragen
ProblemsDriverSynch1: Alle gültigen Vorfeld-Fahrberechtigungen 'F' sind im AVS eingetragen
ProblemsDriverSynch2: Alle gültigen Rollfeld-Fahrberechtigungen 'R' sind im AVS eingetragen
ProblemsRDriversHaveFs: Alle Inhaber einer Rollfeld-Fahrberechtigung besitzen auch eine gültige Vorfeld-Fahrberechtigung
ProblemsDriversHaveAvsIds: Alle Inhaber einer Fahrberechtigung konnten einer AVS Identifikationsnummer zugeordnet werden
ProblemsHeadingUsers: Allgemein
ProblemsUsersAreReachable: Für alle Benutzer ist eine E-Mail oder postalische Adresse bekannt
ProblemsNoStalePrintJobs n@Integer: Alle Briefversandaufträge der vergangenen #{show n} Tage wurden von der Druckerei bestätigt
ProblemsUnreachableHeading: Unerreichbare Benutzer
ProblemsUnreachableBody: Benutzer ohne E-Mail oder Postadresse, welche z.B. bei ablaufenden Berechtigungen nicht benachrichtigt werden können:
ProblemsRWithoutFHeading: Fahrer mit R ohne F
ProblemsRWithoutFBody: Diese Fahrer sind wegen einer ungültigen Vorfeld-Fahrberechtigung komplett gesperrt, obwohl eine gültige Rollfeld-Fahrberechtigung besteht:
ProblemsNoAvsIdHeading: Fahrer ohne AVS-Id
ProblemsNoAvsIdBody: Fahrer mit gültiger Fahrberechtigung in FRADrive, welche trotzdem nicht fahren dürfen, da die Fahrberechtigung aufgrund einer unbekannten AVS Id nicht an die Ausweisstelle übermittelt werden konnte:

20
messages/uniworx/categories/admin/en-eu.msg
View File

@ -79,7 +79,6 @@ StudyFeatureInferenceNoNameConflicts: No observed conflicts
StudyFeatureInferenceNameConflictsHeading: Fields of study with observed conflicts StudyFeatureInferenceNameConflictsHeading: Fields of study with observed conflicts
AdminHeading: Administration AdminHeading: Administration
AdminPageEmpty: This page shall provide an overview for administrators in the future. For now there are only links to important administrator-functions.
BearerTokenImpersonate: Impersonate BearerTokenImpersonate: Impersonate
BearerTokenImpersonateNone: No one BearerTokenImpersonateNone: No one
@ -95,3 +94,22 @@ BearerTokenArchiveName: tokens.zip
TestDownloadDirect: Direct generation TestDownloadDirect: Direct generation
TestDownloadInTransaction: Generate during database transaction TestDownloadInTransaction: Generate during database transaction
TestDownloadFromDatabase: Generate while streaming from database TestDownloadFromDatabase: Generate while streaming from database
ProblemsHeading: Overview Problems
ProblemsHeadingDrivers: Driving Licences
ProblemsAvsProblem: Synchronisation with AVS/MoBaKo failed entirely
ProblemsDriverSynch n: #{tshow n} mismatches between AVS and FRADrive
ProblemsDriverSynch0: All revocations of driving licences were successfully registered with AVS
ProblemsDriverSynch1: All valid apron driving licences 'F' were successfully registered with AVS
ProblemsDriverSynch2: All valid maneuvering area driving licences 'R' were successfully registered with AVS
ProblemsRDriversHaveFs: All driving licence 'R' holders also have a valid 'F' licence
ProblemsDriversHaveAvsIds: All driving licence holder could be matched with their AVS id
ProblemsHeadingUsers: Miscellaneous
ProblemsUsersAreReachable: Either Email or postal address is known for all users
ProblemsNoStalePrintJobs n: All requests for letter mailing within the last #{show n} days were acknowledged as printed by the airport printing center
ProblemsUnreachableHeading: Unreachable Users
ProblemsUnreachableBody: Users without Email nor postal address, who thus cannot be notified about expiring qualifications:
ProblemsRWithoutFHeading: Drivers having 'R' but not 'F'
ProblemsRWithoutFBody: Drivers without apron driving licence are prohibited from driving, even if they own a valid maneuvering driving licence:
ProblemsNoAvsIdHeading: Drivers without AVS id
ProblemsNoAvsIdBody: Drivers having a valid apron driving licence within FRADrive only, but who may not drive since a missing AVS id prevents communication of the driving licence to AVS:

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

@ -28,7 +28,6 @@ UnauthorizedExamExamOffice: Es existieren keine Prüfungsergebnisse für Nutzer:
UnauthorizedSchoolExamOffice: Sie sind nicht mit Prüfungsverwaltung für dieses Institut beauftragt. UnauthorizedSchoolExamOffice: Sie sind nicht mit Prüfungsverwaltung für dieses Institut beauftragt.
UnauthorizedSystemExamOffice: Sie sind nicht mit systemweiter Prüfungsverwaltung beauftragt. UnauthorizedSystemExamOffice: Sie sind nicht mit systemweiter Prüfungsverwaltung beauftragt.
UnauthorizedSystemPrinter: Sie sind nicht mit systemweitem Druck und Briefversand beauftragt. UnauthorizedSystemPrinter: Sie sind nicht mit systemweitem Druck und Briefversand beauftragt.
UnauthorizedSystemSap: Sie sind nicht mit der systemweitem SAP Schnittstellenverwaltung beauftragt.
UnauthorizedExternalExamExamOffice: Es existieren keine Prüfungsergebnisse für Nutzer:innen, für die Sie mit der Prüfungsverwaltung beauftragt sind. UnauthorizedExternalExamExamOffice: Es existieren keine Prüfungsergebnisse für Nutzer:innen, für die Sie mit der Prüfungsverwaltung beauftragt sind.
UnauthorizedEvaluation: Sie sind nicht mit der Kursumfragenverwaltung beauftragt. UnauthorizedEvaluation: Sie sind nicht mit der Kursumfragenverwaltung beauftragt.
UnauthorizedSchoolLecturer: Sie sind nicht als Veranstalter:in für dieses Institut eingetragen. UnauthorizedSchoolLecturer: Sie sind nicht als Veranstalter:in für dieses Institut eingetragen.

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

@ -29,7 +29,6 @@ UnauthorizedExamExamOffice: You are not part of the appropriate exam office for
UnauthorizedSchoolExamOffice: You are not part of an exam office for this school. UnauthorizedSchoolExamOffice: You are not part of an exam office for this school.
UnauthorizedSystemExamOffice: You are not charged with system wide exam administration. UnauthorizedSystemExamOffice: You are not charged with system wide exam administration.
UnauthorizedSystemPrinter: You are not charged with system wide letter printing. UnauthorizedSystemPrinter: You are not charged with system wide letter printing.
UnauthorizedSystemSap: You are not charged with system wide SAP administration.
UnauthorizedExternalExamExamOffice: You are not part of the appropriate exam office for any of the participants of this exam. UnauthorizedExternalExamExamOffice: You are not part of the appropriate exam office for any of the participants of this exam.
UnauthorizedSchoolLecturer: You are no lecturer for this department. UnauthorizedSchoolLecturer: You are no lecturer for this department.
UnauthorizedLecturer: You are no administrator for this course. UnauthorizedLecturer: You are no administrator for this course.

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

@ -10,4 +10,6 @@ AvsLastName: Nachname
AvsInternalPersonalNo: Personalnummer (nur Fraport AG) AvsInternalPersonalNo: Personalnummer (nur Fraport AG)
AvsVersionNo: Versionsnummer AvsVersionNo: Versionsnummer
AvsQueryEmpty: Bitte mindestens ein Anfragefeld ausfüllen! AvsQueryEmpty: Bitte mindestens ein Anfragefeld ausfüllen!
AvsQueryStatusInvalid t@Text: Nur numerische IDs eingeben, durch Komma getrennt! Erhalten: #{show t} AvsQueryStatusInvalid t@Text: Nur numerische IDs eingeben, durch Komma getrennt! Erhalten: #{show t}
AvsLicence: Fahrberechtigung
AvsPersonNoNotId: AVS Personennummer dient zur menschlichen Kommunikation mit der Ausweisstelle und darf nicht verwechselt werden mit der maschinell verwendeten AVS Personen Id

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

@ -10,4 +10,6 @@ AvsLastName: Last name
AvsInternalPersonalNo: Personnel number (Fraport AG only) AvsInternalPersonalNo: Personnel number (Fraport AG only)
AvsVersionNo: Version number AvsVersionNo: Version number
AvsQueryEmpty: At least one query field must be filled! AvsQueryEmpty: At least one query field must be filled!
AvsQueryStatusInvalid t: Numeric IDs only, comma seperated! #{show t} AvsQueryStatusInvalid t: Numeric IDs only, comma seperated! #{show t}
AvsLicence: Driving Licence
AvsPersonNoNotId: AVS person number is used in human communication only and must not be mistaken for the AVS personen id used in machine communications

3
messages/uniworx/categories/model_types/de-de-formal.msg
View File

@ -18,5 +18,4 @@ BothSubmissions: Abgabe direkt in Uni2work oder extern mit Pseudonym
SystemExamOffice: Prüfungsverwaltung SystemExamOffice: Prüfungsverwaltung
SystemFaculty: Fakultätsmitglied SystemFaculty: Fakultätsmitglied
SystemStudent: Student:in SystemStudent: Student:in
SystemPrinter: Drucker:in SystemPrinter: Drucker:in
SystemSap: SAP Verwalter:in

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

@ -18,5 +18,4 @@ BothSubmissions: Submission either directly in Uni2work or externally via pseudo
SystemExamOffice: Exam office SystemExamOffice: Exam office
SystemFaculty: Faculty member SystemFaculty: Faculty member
SystemStudent: Student SystemStudent: Student
SystemPrinter: Printing staff SystemPrinter: Printing staff
SystemSap: SAP Administrator

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

@ -14,9 +14,9 @@ TableQualificationCountActive: Active
TableQualificationCountActiveTooltip: Number of currently valid qualification holders TableQualificationCountActiveTooltip: Number of currently valid qualification holders
TableQualificationCountTotal: Total TableQualificationCountTotal: Total
TableQualificationIsAvsLicence: AVS Driving License TableQualificationIsAvsLicence: AVS Driving License
TableQualificationIsAvsLicenceTooltip: Is this Qualification synchronized with AVS? Only applies to qualification holders having an AVS PersonID. TableQualificationIsAvsLicenceTooltip: Under which name is this qualification synchronized with AVS, if any? Only applies to qualification holders having an AVS PersonID.
TableQualificationSapExport: Sent to SAP TableQualificationSapExport: Sent to SAP
TableQualificationSapExportTooltip: Is this Qualification transmitted to SAP? Only applies to qualification holder having a Fraport Personnelnumber. TableQualificationSapExportTooltip: Is this qualification transmitted to SAP? Only applies to qualification holder having a Fraport AG personnel number.
LmsQualificationValidUntil: Valid until LmsQualificationValidUntil: Valid until
TableQualificationLastRefresh: Last renewed TableQualificationLastRefresh: Last renewed
TableQualificationFirstHeld: First held TableQualificationFirstHeld: First held

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

@ -14,7 +14,6 @@ AuthTagAdmin: Nutzer:in ist Administrator:in
AuthTagExamOffice: Nutzer:in ist mit Prüfungsverwaltung beauftragt AuthTagExamOffice: Nutzer:in ist mit Prüfungsverwaltung beauftragt
AuthTagSystemExamOffice: Nutzer:in ist mit systemweiter Prüfungsverwaltung beauftragt AuthTagSystemExamOffice: Nutzer:in ist mit systemweiter Prüfungsverwaltung beauftragt
AuthTagSystemPrinter: Nutzer:in ist mit systemweiten Druck von Briefen beauftragt AuthTagSystemPrinter: Nutzer:in ist mit systemweiten Druck von Briefen beauftragt
AuthTagSystemSap: Nutzer:in ist mit systemweiter SAP Schnittstellen-Administration beauftragt
AuthTagEvaluation: Nutzer:in ist mit Kursumfragenverwaltung beauftragt AuthTagEvaluation: Nutzer:in ist mit Kursumfragenverwaltung beauftragt
AuthTagToken: Nutzer:in präsentiert Authorisierungs-Token AuthTagToken: Nutzer:in präsentiert Authorisierungs-Token
AuthTagNoEscalation: Nutzer-Rechte werden nicht auf fremde Institute ausgeweitet AuthTagNoEscalation: Nutzer-Rechte werden nicht auf fremde Institute ausgeweitet

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

@ -14,7 +14,6 @@ AuthTagAdmin: User is administrator
AuthTagExamOffice: User is part of an exam office AuthTagExamOffice: User is part of an exam office
AuthTagSystemExamOffice: User is charged with system wide exam administration AuthTagSystemExamOffice: User is charged with system wide exam administration
AuthTagSystemPrinter: User is responsible for system wide letter printing AuthTagSystemPrinter: User is responsible for system wide letter printing
AuthTagSystemSap: User is responsible for system wide SAP interface administration
AuthTagEvaluation: User is charged with course evaluation AuthTagEvaluation: User is charged with course evaluation
AuthTagToken: User is presenting an authorisation-token AuthTagToken: User is presenting an authorisation-token
AuthTagNoEscalation: User permissions are not being expanded to other departments AuthTagNoEscalation: User permissions are not being expanded to other departments

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

@ -27,7 +27,11 @@ ProfileCorrectorRemark: Die oberhalb angezeigte Tabelle zeigt nur prinzipielle E
ProfileCorrections: Auflistung aller zugewiesenen Korrekturen ProfileCorrections: Auflistung aller zugewiesenen Korrekturen
Remarks: Hinweise Remarks: Hinweise
ProfileSupervisor: Übergeordnete Ansprechpartner
ProfileSupervisee: Ist Ansprechpartner für
UserTelephone: Telefon UserTelephone: Telefon
UserMobile: Mobiltelefon UserMobile: Mobiltelefon
Company: Firmenzugehörigkeit
CompanyPersonalNumber: Personalnummer (nur Fraport AG) CompanyPersonalNumber: Personalnummer (nur Fraport AG)
CompanyDepartment: Abteilung CompanyDepartment: Abteilung

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

@ -27,7 +27,11 @@ ProfileCorrectorRemark: The table above only shows registration as a corrector i
ProfileCorrections: List of all assigned corrections ProfileCorrections: List of all assigned corrections
Remarks: Remarks Remarks: Remarks
ProfileSupervisor: Supervised by
ProfileSupervisee: Supervises
UserTelephone: Phone UserTelephone: Phone
UserMobile: Mobile UserMobile: Mobile
Company: Company affilitaion
CompanyPersonalNumber: Personnel number (Fraport AG only) CompanyPersonalNumber: Personnel number (Fraport AG only)
CompanyDepartment: Department CompanyDepartment: Department

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

@ -28,7 +28,7 @@ TermLectureStartTooltip: Muss am oder nach dem Beginn liegen
TermLectureEndTooltip: Muss am oder vor dem Ende liegen TermLectureEndTooltip: Muss am oder vor dem Ende liegen
TermActive: Aktiv TermActive: Aktiv
TermActiveTooltip: Zeitraum in dem Lehrende Kurse anlegen dürfen; kann auf angegebene Lehrende eingeschränkt werden TermActiveTooltip: Zeitraum in dem Lehrende Kurse anlegen dürfen; kann auf angegebene Lehrende eingeschränkt werden
TermActiveForPlaceholder: Email (optional) TermActiveForPlaceholder: E-Mail (optional)
NumCourses num@Int64: #{num} #{pluralDE num "Kurs" "Kurse"} NumCourses num@Int64: #{num} #{pluralDE num "Kurs" "Kurse"}
TermsHeading: Semesterübersicht TermsHeading: Semesterübersicht
TermEditHeading: Semester editieren/anlegen TermEditHeading: Semester editieren/anlegen

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

@ -28,7 +28,7 @@ TermLectureStartTooltip: Must be on or after starting day
TermLectureEndTooltip: Must be before or on ending day TermLectureEndTooltip: Must be before or on ending day
TermActive: Active TermActive: Active
TermActiveTooltip: Timeframe when lecturers may add courses; maybe restricted for specified lecturers TermActiveTooltip: Timeframe when lecturers may add courses; maybe restricted for specified lecturers
TermActiveForPlaceholder: E-Mail (optional) TermActiveForPlaceholder: Email (optional)
NumCourses num: #{num} #{pluralEN num "course" "courses"} NumCourses num: #{num} #{pluralEN num "course" "courses"}
TermsHeading: Semesters TermsHeading: Semesters
TermEditHeading: Edit semester TermEditHeading: Edit semester

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

@ -13,7 +13,7 @@ AdminUserAuth: Authentifizierung
AdminUserMatriculation: Matrikelnummer AdminUserMatriculation: Matrikelnummer
AdminUserSex: Geschlecht AdminUserSex: Geschlecht
AdminUserTelephone: Telefonnummer AdminUserTelephone: Telefonnummer
AdminUserMobile: Mobiltelefonmummer AdminUserMobile: Mobiltelefonnummer
AdminUserFPersonalNumber: Personalnummer (nur Fraport AG) AdminUserFPersonalNumber: Personalnummer (nur Fraport AG)
AdminUserFDepartment: Abteilung AdminUserFDepartment: Abteilung
AdminUserPostAddress: Postalische Anschrift AdminUserPostAddress: Postalische Anschrift

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

@ -72,3 +72,5 @@ TableExamOfficeLabel: Label-Name
TableExamOfficeLabelStatus: Label-Farbe TableExamOfficeLabelStatus: Label-Farbe
TableExamOfficeLabelPriority: Label-Priorität TableExamOfficeLabelPriority: Label-Priorität
TableQualifications: Qualifikationen TableQualifications: Qualifikationen
TableCompany: Firma
TableSupervisor: Ansprechpartner

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

@ -72,3 +72,5 @@ TableExamOfficeLabel: Label name
TableExamOfficeLabelStatus: Label colour TableExamOfficeLabelStatus: Label colour
TableExamOfficeLabelPriority: Label priority TableExamOfficeLabelPriority: Label priority
TableQualifications: Qualifications TableQualifications: Qualifications
TableCompany: Company
TableSupervisor: Supervisor

3
models/avs.model
View File

@ -14,8 +14,9 @@
UserAvs UserAvs
personId AvsPersonId -- unique identifier for user throughout avs personId AvsPersonId -- unique identifier for user throughout avs; newtype for Int
user UserId user UserId
noPerson Int default=0 -- only needed for manual communication with personnel from Ausweisverwaltungsstelle
UniqueUserAvsUser user UniqueUserAvsUser user
UniqueUserAvsId personId UniqueUserAvsId personId
deriving Generic deriving Generic

4
models/lms.model
View File

@ -15,8 +15,8 @@ Qualification
-- elearningOnly Bool -- successful E-learing automatically increases validity. NO! -- elearningOnly Bool -- successful E-learing automatically increases validity. NO!
-- refreshInvitation StoredMarkup -- hard-coded I18N-MSGs used instead, but displayed on qualification page NO! -- refreshInvitation StoredMarkup -- hard-coded I18N-MSGs used instead, but displayed on qualification page NO!
-- expiryNotification StoredMarkup Maybe -- configurable user-profile-notifcations are used instead NO! -- expiryNotification StoredMarkup Maybe -- configurable user-profile-notifcations are used instead NO!
avsLicence AvsLicence Maybe -- if set, is synchronized to Avs as a driving licence avsLicence AvsLicence Maybe -- if set, valid QualificationUsers are synchronized to AVS as a driving licence
sapId Text Maybe -- if set, all QualificationUsers with userCompanyPersonalNumber are transmitted via SAP interface under this id sapId Text Maybe -- if set, valid QualificationUsers with userCompanyPersonalNumber are transmitted via SAP interface under this id
SchoolQualificationShort school shorthand -- must be unique per school and shorthand SchoolQualificationShort school shorthand -- must be unique per school and shorthand
SchoolQualificationName school name -- must be unique per school and name SchoolQualificationName school name -- must be unique per school and name
-- across all schools, only one qualification may be a driving licence: -- across all schools, only one qualification may be a driving licence:

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

@ -1,3 +1,3 @@
{ {
"version": "26.6.0" "version": "26.6.6"
} }

2
nix/docker/version.json
View File

@ -1,3 +1,3 @@
{ {
"version": "26.6.0" "version": "26.6.6"
} }

2
package-lock.json generated
View File

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

2
package.json
View File

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

2
package.yaml
View File

@ -1,5 +1,5 @@
name: uniworx name: uniworx
version: 26.6.0 version: 26.6.6
dependencies: dependencies:
- base - base
- yesod - yesod

BIN
resources/FAG_UKM-MI_Pictogram-Library-Manual_RZ.pdf Normal file
View File

Binary file not shown.

BIN
resources/FraportIcons.zip Normal file
View File

Binary file not shown.

BIN
resources/fraport_icons_übersicht_2018-11-15.pdf Normal file
View File

Binary file not shown.

13
routes
View File

@ -68,6 +68,9 @@
/admin/crontab AdminCrontabR GET /admin/crontab AdminCrontabR GET
/admin/avs AdminAvsR GET POST /admin/avs AdminAvsR GET POST
/admin/ldap AdminLdapR GET POST /admin/ldap AdminLdapR GET POST
/admin/problems/no-contact ProblemUnreachableR GET
/admin/problems/no-avs-id ProblemWithoutAvsId GET
/admin/problems/r-without-f ProblemFbutNoR GET
/print PrintCenterR GET POST !system-printer /print PrintCenterR GET POST !system-printer
/print/acknowledge/#Day/#Int/#Int PrintAckR GET POST !system-printer /print/acknowledge/#Day/#Int/#Int PrintAckR GET POST !system-printer
@ -102,8 +105,8 @@
/user/lang LangR POST !free /user/lang LangR POST !free
/user/storage-key StorageKeyR POST !free /user/storage-key StorageKeyR POST !free
/for/#CryptoUUIDUser/user ForProfileR GET POST !supervisor /for/#CryptoUUIDUser/user ForProfileR GET POST !supervisor !self
/for/#CryptoUUIDUser/user/profile ForProfileDataR GET !supervisor /for/#CryptoUUIDUser/user/profile ForProfileDataR GET !supervisor !self
/exam-office ExamOfficeR !exam-office: /exam-office ExamOfficeR !exam-office:
@ -254,12 +257,12 @@
-- !/*{CI FilePath} CryptoFileNameDispatchR GET !free -- Disabled until preliminary check for valid cID exists -- !/*{CI FilePath} CryptoFileNameDispatchR GET !free -- Disabled until preliminary check for valid cID exists
-- for users -- for users
/qualification QualificationAllR GET !free -- TODO repurpose /qualification QualificationAllR GET -- TODO repurpose
/qualification/#SchoolId QualificationSchoolR GET !free -- TODO repurpose /qualification/#SchoolId QualificationSchoolR GET -- TODO repurpose
/qualification/#SchoolId/#QualificationShorthand QualificationR GET -- TODO repurpose /qualification/#SchoolId/#QualificationShorthand QualificationR GET -- TODO repurpose
-- SAP export -- SAP export
/qualifications/sap/direct QualificationSAPDirectR GET !system-sap /qualifications/sap/direct QualificationSAPDirectR GET !token
-- OSIS CSV Export Demo -- OSIS CSV Export Demo
/lms LmsAllR GET POST !free -- TODO verify that this is ok /lms LmsAllR GET POST !free -- TODO verify that this is ok
/lms/#SchoolId LmsSchoolR GET !free -- TODO verify that this is ok /lms/#SchoolId LmsSchoolR GET !free -- TODO verify that this is ok

2
src/Auth/LDAP.hs
View File

@ -146,7 +146,7 @@ campusUserReTest' :: (MonadMask m, MonadLogger m, MonadUnliftIO m) => Failover (
campusUserReTest' pool doTest mode User{userIdent} campusUserReTest' pool doTest mode User{userIdent}
= runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ campusUserReTest pool doTest mode (Creds apLdap (CI.original userIdent) []) = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ campusUserReTest pool doTest mode (Creds apLdap (CI.original userIdent) [])
campusUser :: (MonadUnliftIO m, MonadMask m, MonadLogger m) => Failover (LdapConf, LdapPool) -> FailoverMode -> Creds site -> m (Ldap.AttrList []) campusUser :: (MonadMask m, MonadUnliftIO m, MonadLogger m) => Failover (LdapConf, LdapPool) -> FailoverMode -> Creds site -> m (Ldap.AttrList [])
campusUser pool mode creds = throwLeft =<< campusUserWith withLdapFailover pool mode creds campusUser pool mode creds = throwLeft =<< campusUserWith withLdapFailover pool mode creds
campusUser' :: (MonadMask m, MonadUnliftIO m, MonadLogger m) => Failover (LdapConf, LdapPool) -> FailoverMode -> User -> m (Maybe (Ldap.AttrList [])) campusUser' :: (MonadMask m, MonadUnliftIO m, MonadLogger m) => Failover (LdapConf, LdapPool) -> FailoverMode -> User -> m (Maybe (Ldap.AttrList []))

2
src/Data/Time/Clock/Instances.hs
View File

@ -99,7 +99,7 @@ instance PersistField CalendarDiffDays where
coerceICcd :: Integer -> CDDdb coerceICcd :: Integer -> CDDdb
coerceICcd = fromIntegral coerceICcd = fromIntegral
-- placement in Utils impossivle due to cyclic dependencies -- placement in Utils impossible due to cyclic dependencies
-- Data.Tuple.Extra is not yet a dependency -- Data.Tuple.Extra is not yet a dependency
-- both = join (***) is still too cryptic for me -- both = join (***) is still too cryptic for me
both :: (a -> b) -> (a, a) -> (b, b) both :: (a -> b) -> (a, a) -> (b, b)

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

@ -7,7 +7,7 @@
module Database.Esqueleto.Utils module Database.Esqueleto.Utils
( true, false ( true, false
, justVal, justValList , justVal, justValList, toValues
, isJust, alt , isJust, alt
, isInfixOf, hasInfix , isInfixOf, hasInfix
, strConcat, substring , strConcat, substring
@ -50,7 +50,9 @@ import Data.Universe
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.Foldable as F import qualified Data.Foldable as F
import Data.List.NonEmpty (NonEmpty(..))
import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Legacy as E
import qualified Database.Esqueleto.Experimental as Ex
import qualified Database.Esqueleto.PostgreSQL as E import qualified Database.Esqueleto.PostgreSQL as E
import qualified Database.Esqueleto.Internal.Internal as E import qualified Database.Esqueleto.Internal.Internal as E
import Database.Esqueleto.Utils.TH import Database.Esqueleto.Utils.TH
@ -97,10 +99,15 @@ false = E.val False
-- infinity = unsafeSqlValue "'infinity'" -- infinity = unsafeSqlValue "'infinity'"
justVal :: PersistField typ => typ -> E.SqlExpr (E.Value (Maybe typ)) justVal :: PersistField typ => typ -> E.SqlExpr (E.Value (Maybe typ))
justVal = E.val . Just -- justVal = E.val . Just
justVal = E.just . E.val
justValList :: PersistField typ => [typ] -> E.SqlExpr (E.ValueList (Maybe typ)) justValList :: PersistField typ => [typ] -> E.SqlExpr (E.ValueList (Maybe typ))
justValList = E.valList . map Just -- justValList = E.valList . map Just
justValList = E.justList . E.valList
toValues :: PersistField typ => NonEmpty typ -> Ex.From (Ex.SqlExpr (Ex.Value typ)) -- E.From invalid here, requires Esqueleto.Experimental
toValues = E.values . fmap Ex.val
infixl 4 =?. infixl 4 =?.
(=?.) :: PersistField typ => E.SqlExpr (E.Value typ) -> E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value Bool) (=?.) :: PersistField typ => E.SqlExpr (E.Value typ) -> E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value Bool)

11
src/Foundation/Authorization.hs
View File

@ -568,15 +568,6 @@ tagAccessPredicate AuthSystemPrinter = cacheAPSystemFunction SystemPrinter (Just
isPrinter <- lift $ exists [UserSystemFunctionUser ==. authId, UserSystemFunctionFunction ==. SystemPrinter, UserSystemFunctionIsOptOut ==. False] isPrinter <- lift $ exists [UserSystemFunctionUser ==. authId, UserSystemFunctionFunction ==. SystemPrinter, UserSystemFunctionIsOptOut ==. False]
guardMExceptT isPrinter $ unauthorizedI MsgUnauthorizedSystemPrinter guardMExceptT isPrinter $ unauthorizedI MsgUnauthorizedSystemPrinter
return Authorized return Authorized
tagAccessPredicate AuthSystemSap = cacheAPSystemFunction SystemSap (Just $ Right diffHour) $ \mAuthId' _ _ sapList -> if
| maybe True (`Set.notMember` sapList) mAuthId' -> Right $ if
| is _Nothing mAuthId' -> return AuthenticationRequired
| otherwise -> unauthorizedI MsgUnauthorizedSystemSap
| otherwise -> Left $ APDB $ \_ _ mAuthId _ _ -> $cachedHereBinary mAuthId . exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
isPrinter <- lift $ exists [UserSystemFunctionUser ==. authId, UserSystemFunctionFunction ==. SystemSap, UserSystemFunctionIsOptOut ==. False]
guardMExceptT isPrinter $ unauthorizedI MsgUnauthorizedSystemSap
return Authorized
tagAccessPredicate AuthStudent = cacheAPSystemFunction SystemStudent (Just $ Right diffHour) $ \mAuthId' _ _ studentList -> if tagAccessPredicate AuthStudent = cacheAPSystemFunction SystemStudent (Just $ Right diffHour) $ \mAuthId' _ _ studentList -> if
| maybe True (`Set.notMember` studentList) mAuthId' -> Right $ if | maybe True (`Set.notMember` studentList) mAuthId' -> Right $ if
| is _Nothing mAuthId' -> return AuthenticationRequired | is _Nothing mAuthId' -> return AuthenticationRequired
@ -1505,6 +1496,8 @@ tagAccessPredicate AuthSelf = APDB $ \_ _ mAuthId route _ -> exceptT return retu
UserNotificationR cID -> return $ Left cID UserNotificationR cID -> return $ Left cID
UserPasswordR cID -> return $ Left cID UserPasswordR cID -> return $ Left cID
CourseR _ _ _ (CUserR cID) -> return $ Left cID CourseR _ _ _ (CUserR cID) -> return $ Left cID
ForProfileR cID -> return $ Left cID
ForProfileDataR cID -> return $ Left cID
_other -> throwError =<< $unsupportedAuthPredicate AuthSelf route _other -> throwError =<< $unsupportedAuthPredicate AuthSelf route
referencedUser <- case referencedUser' of referencedUser <- case referencedUser' of
Right uid -> return uid Right uid -> return uid

27
src/Foundation/Navigation.hs
View File

@ -106,14 +106,17 @@ breadcrumb (UserPasswordR cID) = useRunDB $ do
breadcrumb AdminNewFunctionaryInviteR = i18nCrumb MsgMenuLecturerInvite $ Just UsersR breadcrumb AdminNewFunctionaryInviteR = i18nCrumb MsgMenuLecturerInvite $ Just UsersR
breadcrumb AdminFunctionaryInviteR = i18nCrumb MsgBreadcrumbFunctionaryInvite Nothing breadcrumb AdminFunctionaryInviteR = i18nCrumb MsgBreadcrumbFunctionaryInvite Nothing
breadcrumb AdminR = i18nCrumb MsgAdminHeading Nothing breadcrumb AdminR = i18nCrumb MsgAdminHeading Nothing
breadcrumb AdminTestR = i18nCrumb MsgMenuAdminTest $ Just AdminR breadcrumb AdminTestR = i18nCrumb MsgMenuAdminTest $ Just AdminR
breadcrumb AdminTestPdfR = i18nCrumb MsgMenuAdminTest $ Just AdminTestR breadcrumb AdminTestPdfR = i18nCrumb MsgMenuAdminTest $ Just AdminTestR
breadcrumb AdminErrMsgR = i18nCrumb MsgMenuAdminErrMsg $ Just AdminR breadcrumb AdminErrMsgR = i18nCrumb MsgMenuAdminErrMsg $ Just AdminR
breadcrumb AdminTokensR = i18nCrumb MsgMenuAdminTokens $ Just AdminR breadcrumb AdminTokensR = i18nCrumb MsgMenuAdminTokens $ Just AdminR
breadcrumb AdminCrontabR = i18nCrumb MsgBreadcrumbAdminCrontab $ Just AdminR breadcrumb AdminCrontabR = i18nCrumb MsgBreadcrumbAdminCrontab $ Just AdminR
breadcrumb AdminAvsR = i18nCrumb MsgMenuAvs $ Just AdminR breadcrumb AdminAvsR = i18nCrumb MsgMenuAvs $ Just AdminR
breadcrumb AdminLdapR = i18nCrumb MsgMenuLdap $ Just AdminR breadcrumb AdminLdapR = i18nCrumb MsgMenuLdap $ Just AdminR
breadcrumb ProblemUnreachableR = i18nCrumb MsgProblemsUnreachableHeading $Just AdminR
breadcrumb ProblemWithoutAvsId = i18nCrumb MsgProblemsNoAvsIdHeading $ Just AdminR
breadcrumb ProblemFbutNoR = i18nCrumb MsgProblemsRWithoutFHeading $ Just AdminR
breadcrumb PrintCenterR = i18nCrumb MsgMenuApc Nothing breadcrumb PrintCenterR = i18nCrumb MsgMenuApc Nothing
breadcrumb PrintSendR = i18nCrumb MsgMenuPrintSend $ Just PrintCenterR breadcrumb PrintSendR = i18nCrumb MsgMenuPrintSend $ Just PrintCenterR
@ -732,6 +735,14 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the
, navIcon = IconMenuAdmin , navIcon = IconMenuAdmin
, navChildren = , navChildren =
[ NavLink [ NavLink
{ navLabel = MsgProblemsHeading
, navRoute = AdminR
, navAccess' = NavAccessTrue
, navType = NavTypeLink { navModal = False }
, navQuick' = mempty
, navForceActive = False
}
, NavLink
{ navLabel = MsgMenuUsers { navLabel = MsgMenuUsers
, navRoute = UsersR , navRoute = UsersR
, navAccess' = NavAccessTrue , navAccess' = NavAccessTrue

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

@ -4,7 +4,8 @@
module Foundation.Yesod.Auth module Foundation.Yesod.Auth
( authenticate ( authenticate
, upsertCampusUser, upsertCampusUserByCn , ldapLookupAndUpsert
, upsertCampusUser
, decodeUserTest , decodeUserTest
, CampusUserConversionException(..) , CampusUserConversionException(..)
, campusUserFailoverMode, updateUserLanguage , campusUserFailoverMode, updateUserLanguage
@ -106,10 +107,10 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend
| not isDummy -> res <$ update uid [ UserLastAuthentication =. Just now ] | not isDummy -> res <$ update uid [ UserLastAuthentication =. Just now ]
_other -> return res _other -> return res
$logDebugS "auth" $ tshow Creds{..} $logDebugS "auth" $ tshow Creds{..}
UniWorX{..} <- getYesod ldapPool' <- getsYesod $ view _appLdapPool
flip catches excHandlers $ case appLdapPool of flip catches excHandlers $ case ldapPool' of
Just ldapPool Just ldapPool
| Just upsertMode' <- upsertMode -> do | Just upsertMode' <- upsertMode -> do
ldapData <- campusUser ldapPool campusUserFailoverMode Creds{..} ldapData <- campusUser ldapPool campusUserFailoverMode Creds{..}
@ -152,14 +153,25 @@ _upsertCampusUserMode mMode cs@Creds{..}
defaultOther = apHash defaultOther = apHash
ldapLookupAndUpsert :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX, MonadMask m, MonadUnliftIO m) => Text -> SqlPersistT m (Entity User)
ldapLookupAndUpsert ident =
getsYesod (view _appLdapPool) >>= \case
Nothing -> throwM $ CampusUserLdapError $ LdapHostNotResolved "No LDAP configuration in Foundation."
Just ldapPool ->
campusUser'' ldapPool campusUserFailoverMode ident >>= \case
Nothing -> throwM CampusUserNoResult
Just ldapResponse -> upsertCampusUser UpsertCampusUserGuessUser ldapResponse
{- THIS FUNCION JUST DECODES, BUT IT DOES NOT QUERY LDAP!
upsertCampusUserByCn :: forall m. upsertCampusUserByCn :: forall m.
( MonadHandler m, HandlerSite m ~ UniWorX ( MonadHandler m, HandlerSite m ~ UniWorX
, MonadThrow m , MonadThrow m
) )
=> Text -> SqlPersistT m (Entity User) => Text -> SqlPersistT m (Entity User)
upsertCampusUserByCn persNo = upsertCampusUser UpsertCampusUserGuessUser [(ldapPrimaryKey,[Text.encodeUtf8 persNo])] upsertCampusUserByCn persNo = upsertCampusUser UpsertCampusUserGuessUser [(ldapPrimaryKey,[Text.encodeUtf8 persNo])]
-}
-- | Upsert User DB according to given LDAP data (does not query LDAP itself)
upsertCampusUser :: forall m. upsertCampusUser :: forall m.
( MonadHandler m, HandlerSite m ~ UniWorX ( MonadHandler m, HandlerSite m ~ UniWorX
, MonadThrow m , MonadThrow m
@ -208,7 +220,7 @@ decodeUserTest mbIdent ldapData = do
decodeUser :: (MonadThrow m) => UTCTime -> UserDefaultConf -> UpsertCampusUserMode -> Ldap.AttrList [] -> m (User,_) decodeUser :: (MonadThrow m) => UTCTime -> UserDefaultConf -> UpsertCampusUserMode -> Ldap.AttrList [] -> m (User,_)
decodeUser now UserDefaultConf{..} upsertMode ldapData = do decodeUser now UserDefaultConf{..} upsertMode ldapData = do
let let
userTelephone = decodeLdap ldapUserTelephone userTelephone = decodeLdap ldapUserTelephone
userMobile = decodeLdap ldapUserMobile userMobile = decodeLdap ldapUserMobile
@ -279,7 +291,7 @@ decodeUser now UserDefaultConf{..} upsertMode ldapData = do
, userMatrikelnummer = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO , userMatrikelnummer = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO
, userPostAddress = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO , userPostAddress = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO
, userPinPassword = Nothing -- must be derived via AVS , userPinPassword = Nothing -- must be derived via AVS
, userPrefersPostal = False , userPrefersPostal = userDefaultPrefersPostal
, .. , ..
} }
userUpdate = [ userUpdate = [

204
src/Handler/Admin.hs
View File

@ -8,6 +8,22 @@ module Handler.Admin
import Import import Import
-- import Data.Either
import qualified Data.Set as Set
-- import qualified Data.Text.Lazy.Encoding as LBS
-- import qualified Control.Monad.Catch as Catch
-- import Servant.Client (ClientError(..), ResponseF(..))
-- import Text.Blaze.Html (preEscapedToHtml)
import Database.Esqueleto.Experimental ((:&)(..))
import qualified Database.Esqueleto.Experimental as E
import qualified Database.Esqueleto.Utils as E
import Handler.Utils.DateTime
import Handler.Utils.Avs
import Handler.Utils.Widgets
import Handler.Admin.Test as Handler.Admin import Handler.Admin.Test as Handler.Admin
import Handler.Admin.ErrorMessage as Handler.Admin import Handler.Admin.ErrorMessage as Handler.Admin
import Handler.Admin.Tokens as Handler.Admin import Handler.Admin.Tokens as Handler.Admin
@ -15,8 +31,188 @@ import Handler.Admin.Crontab as Handler.Admin
import Handler.Admin.Avs as Handler.Admin import Handler.Admin.Avs as Handler.Admin
import Handler.Admin.Ldap as Handler.Admin import Handler.Admin.Ldap as Handler.Admin
getAdminR :: Handler Html getAdminR :: Handler Html
getAdminR = getAdminR = do
siteLayoutMsg MsgAdminHeading $ do now <- liftIO getCurrentTime
setTitleI MsgAdminHeading let nowaday = utctDay now
i18n MsgAdminPageEmpty cutOffPrintDays = 7
cutOffPrintJob = addLocalDays (-cutOffPrintDays) now
(usersAreReachable, driversHaveAvsIds, rDriversHaveFs, noStalePrintJobs) <- runDB $ (,,,)
<$> areAllUsersReachable
<*> allDriversHaveAvsId nowaday
<*> allRDriversHaveFs nowaday
<*> (not <$> exists [PrintJobAcknowledged ==. Nothing, PrintJobCreated <=. cutOffPrintJob])
diffLics <- try retrieveDifferingLicences <&> \case
-- (Left (UnsupportedContentType "text/html" resp)) -> Left $ text2widget "Html received"
(Left e) -> Left $ text2widget $ tshow (e :: SomeException)
(Right (to0, to1, to2)) -> Right (Set.size to0, Set.size to1, Set.size to2)
-- let procDiffLics (to0, to1, to2) = Right (Set.size to0, Set.size to1, Set.size to2)
-- diffLics <- (procDiffLics <$> retrieveDifferingLicences) `catches`
-- [ Catch.Handler (\case (UnsupportedContentType "text/html;charset=utf-8" Response{responseBody})
-- -> return $ Left $ toWidget $ preEscapedToHtml $ fromRight "Response UTF8-decoding error" $ LBS.decodeUtf8' responseBody
-- ex -> return $ Left $ text2widget $ tshow ex)
-- , Catch.Handler (\(ex::SomeException) -> return $ Left $ text2widget $ tshow ex)
-- ]
-- we abuse messageTooltip for colored icons here
msgSuccessTooltip <- messageI Success MsgMessageSuccess
msgWarningTooltip <- messageI Warning MsgMessageWarning
msgErrorTooltip <- messageI Error MsgMessageError
let flagError = messageTooltip . bool msgErrorTooltip msgSuccessTooltip
flagWarning = messageTooltip . bool msgWarningTooltip msgSuccessTooltip
flagNonZero :: Int -> Widget
flagNonZero n | n <= 0 = flagError True
| otherwise = messageTooltip =<< handlerToWidget (messageI Error (MsgProblemsDriverSynch n))
siteLayoutMsg MsgProblemsHeading $ do
setTitleI MsgProblemsHeading
$(widgetFile "admin-problems")
getProblemUnreachableR :: Handler Html
getProblemUnreachableR = do
unreachables <- runDB $ E.select retrieveUnreachableUsers
siteLayoutMsg MsgProblemsUnreachableHeading $ do
setTitleI MsgProblemsUnreachableHeading
[whamlet|
<section>
_{MsgProblemsUnreachableBody}
<ul>
$forall usr <- unreachables
<li>
^{linkUserWidget ForProfileR usr}
|]
getProblemFbutNoR :: Handler Html
getProblemFbutNoR = do
now <- liftIO getCurrentTime
let nowaday = utctDay now
rnofs <- runDB $ E.select $ retrieveDriversRWithoutF nowaday
siteLayoutMsg MsgProblemsRWithoutFHeading $ do
setTitleI MsgProblemsRWithoutFHeading
[whamlet|
<section>
_{MsgProblemsRWithoutFBody}
<ul>
$forall usr <- rnofs
<li>
^{linkUserWidget AdminUserR usr}
|]
getProblemWithoutAvsId :: Handler Html
getProblemWithoutAvsId = do
now <- liftIO getCurrentTime
let nowaday = utctDay now
rnofs <- runDB $ E.select $ retrieveDriversWithoutAvsId nowaday
siteLayoutMsg MsgProblemsNoAvsIdHeading $ do
setTitleI MsgProblemsNoAvsIdHeading
[whamlet|
<section>
_{MsgProblemsNoAvsIdBody}
<ul>
$forall usr <- rnofs
<li>
^{linkUserWidget AdminUserR usr}
|]
{-
mkUnreachableUsersTable = do
let dbtSQLQuery user -> do
E.where_ $ E.isNothing (user E.^. UserPostAddress)
E.&&. E.not_ ((user E.^. UserEmail) `E.like` E.val "%@%.%")
pure user
dbtRowKey = (E.^. UserId)
dbtProj = dbtProjFilteredPostId -- TODO: still don't understand the choices here
dbtColonnade =
-}
areAllUsersReachable :: DB Bool
-- areAllUsersReachable = isNothing <$> E.selectOne retrieveUnreachableUsers
areAllUsersReachable = E.selectNotExists retrieveUnreachableUsers
retrieveUnreachableUsers :: E.SqlQuery (E.SqlExpr (Entity User))
retrieveUnreachableUsers = do
user <- E.from $ E.table @User
E.where_ $ E.isNothing (user E.^. UserPostAddress)
E.&&. E.not_ ((user E.^. UserEmail) `E.like` E.val "%@%.%")
return user
allDriversHaveAvsId :: Day -> DB Bool
-- allDriversHaveAvsId = fmap isNothing . E.selectOne . retrieveDriversWithoutAvsId
allDriversHaveAvsId = E.selectNotExists . retrieveDriversWithoutAvsId
qIsValid :: E.SqlExpr (Entity QualificationUser) -> Day -> E.SqlExpr (E.Value Bool)
qIsValid qualUsr nowaday =
E.isNothing (qualUsr E.^. QualificationUserBlockedDue) -- not blocked
E.&&. -- currently valid
(E.val nowaday `E.between`
( qualUsr E.^. QualificationUserFirstHeld
, qualUsr E.^. QualificationUserValidUntil))
{-
-- | Returns users more than once if they own multiple avs-related valid licences, but no AvsID is known
retrieveDriversWithoutAvsId' :: Day -> E.SqlQuery (E.SqlExpr (Entity User))
retrieveDriversWithoutAvsId' nowaday = do
(usr :& qualUsr :& qual) <- E.from $ E.table @User
`E.innerJoin` E.table @QualificationUser
`E.on` (\(usr :& qualUsr) -> usr E.^. UserId E.==. qualUsr E.^. QualificationUserUser)
`E.innerJoin` E.table @Qualification
`E.on` (\(_usr :& qualUsr :& qual) -> qual E.^. QualificationId E.==. qualUsr E.^. QualificationUserQualification)
E.where_ $ -- is avs licence
E.isJust (qual E.^. QualificationAvsLicence)
E.&&. (qualUsr `qIsValid` nowaday)
E.&&. -- AvsId is unknown
E.notExists (do
avsUsr <- E.from $ E.table @UserAvs
E.where_ $ avsUsr E.^. UserAvsUser E.==. usr E.^. UserId
)
return usr
-}
-- | Returns users at most once, even if they own multiple avs-related licences, but no AvsID is known
retrieveDriversWithoutAvsId :: Day -> E.SqlQuery (E.SqlExpr (Entity User))
retrieveDriversWithoutAvsId nowaday = do
usr <- E.from $ E.table @User
E.where_ $
E.exists (do -- a valid avs licence
(qual :& qualUsr) <- E.from (E.table @Qualification
`E.innerJoin` E.table @QualificationUser
`E.on` (\(qual :& qualUsr) -> qual E.^. QualificationId E.==. qualUsr E.^. QualificationUserQualification))
E.where_ $ -- is avs licence
E.isJust (qual E.^. QualificationAvsLicence)
E.&&. (qualUsr `qIsValid` nowaday) -- currently valid
E.&&. -- matches user
(qualUsr E.^. QualificationUserUser E.==. usr E.^. UserId)
)
E.&&.
E.notExists (do -- a known AvsId
avsUsr <- E.from $ E.table @UserAvs
E.where_ $ avsUsr E.^. UserAvsUser E.==. usr E.^. UserId
)
return usr
allRDriversHaveFs :: Day -> DB Bool
-- allRDriversHaveFs = fmap isNothing . E.selectOne . retrieveDriversRWithoutF
allRDriversHaveFs = E.selectNotExists . retrieveDriversRWithoutF
-- | Returns users at most once, even if they own multiple avs-related licences, but no AvsID is known
retrieveDriversRWithoutF :: Day -> E.SqlQuery (E.SqlExpr (Entity User))
retrieveDriversRWithoutF nowaday = do
usr <- E.from $ E.table @User
let hasValidQual lic = do
(qual :& qualUsr) <- E.from (E.table @Qualification
`E.innerJoin` E.table @QualificationUser
`E.on` (\(qual :& qualUsr) -> qual E.^. QualificationId E.==. qualUsr E.^. QualificationUserQualification))
E.where_ $ (qual E.^. QualificationAvsLicence E.==. E.justVal lic) -- matches licence
E.&&. (qualUsr E.^. QualificationUserUser E.==. usr E.^. UserId) -- matches user
E.&&. (qualUsr `qIsValid` nowaday) -- currently valid
E.where_ $ E.exists (hasValidQual AvsLicenceRollfeld)
E.&&. E.notExists (hasValidQual AvsLicenceVorfeld)
return usr
{-
getAdjustLicences :: SchoolId -> QualificationShortand -> Handler Html
-}

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

@ -4,7 +4,7 @@
module Handler.Admin.Avs module Handler.Admin.Avs
( getAdminAvsR ( getAdminAvsR
, postAdminAvsR , postAdminAvsR
) where ) where
import Import import Import
@ -14,23 +14,45 @@ import qualified Data.Text as Text
import qualified Data.Set as Set import qualified Data.Set as Set
import Handler.Utils import Handler.Utils
import Handler.Utils.Avs
import Utils.Avs import Utils.Avs
-- Button needed only here
data ButtonAvsTest = BtnCheckLicences | BtnSynchLicences
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
instance Universe ButtonAvsTest
instance Finite ButtonAvsTest
nullaryPathPiece ''ButtonAvsTest camelToPathPiece
instance Button UniWorX ButtonAvsTest where
btnLabel BtnCheckLicences = "Check all licences" -- could be msg
btnLabel BtnSynchLicences = "Synchronize all licences" -- could be msg
btnClasses BtnCheckLicences = [BCIsButton, BCPrimary]
btnClasses BtnSynchLicences = [BCIsButton, BCDanger]
-- END Button
avsCardNoField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m AvsCardNo avsCardNoField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m AvsCardNo
avsCardNoField = convertField AvsCardNo avsCardNo textField avsCardNoField = convertField AvsCardNo avsCardNo textField
avsInternalPersonalNoField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m AvsInternalPersonalNo
avsInternalPersonalNoField = convertField mkAvsInternalPersonalNo avsInternalPersonalNo textField
makeAvsPersonForm :: Maybe AvsQueryPerson -> Form AvsQueryPerson makeAvsPersonForm :: Maybe AvsQueryPerson -> Form AvsQueryPerson
makeAvsPersonForm tmpl = identifyForm FIDAvsQueryPerson . validateForm validateAvsQueryPerson $ \html -> makeAvsPersonForm tmpl = identifyForm FIDAvsQueryPerson . validateForm validateAvsQueryPerson $ \html ->
flip (renderAForm FormStandard) html $ AvsQueryPerson flip (renderAForm FormStandard) html $ AvsQueryPerson
<$> aopt avsCardNoField (fslI MsgAvsCardNo) (avsPersonQueryCardNo <$> tmpl) <$> aopt avsCardNoField (fslI MsgAvsCardNo) (avsPersonQueryCardNo <$> tmpl)
<*> aopt textField (fslI MsgAvsVersionNo) (avsPersonQueryVersionNo <$> tmpl)
<*> aopt textField (fslI MsgAvsFirstName) (avsPersonQueryFirstName <$> tmpl) <*> aopt textField (fslI MsgAvsFirstName) (avsPersonQueryFirstName <$> tmpl)
<*> aopt textField (fslI MsgAvsLastName) (avsPersonQueryLastName <$> tmpl) <*> aopt textField (fslI MsgAvsLastName) (avsPersonQueryLastName <$> tmpl)
<*> aopt textField (fslI MsgAvsInternalPersonalNo) (avsPersonQueryInternalPersonalNo <$> tmpl) <*> aopt avsInternalPersonalNoField
<*> aopt textField (fslI MsgAvsVersionNo) (avsPersonQueryVersionNo <$> tmpl) (fslI MsgAvsInternalPersonalNo) (avsPersonQueryInternalPersonalNo <$> tmpl)
validateAvsQueryPerson :: FormValidator AvsQueryPerson Handler () validateAvsQueryPerson :: FormValidator AvsQueryPerson Handler ()
validateAvsQueryPerson = do validateAvsQueryPerson = do
AvsQueryPerson{..} <- State.get AvsQueryPerson{..} <- State.get
guardValidation MsgAvsQueryEmpty $ guardValidation MsgAvsQueryEmpty $
is _Just avsPersonQueryCardNo || is _Just avsPersonQueryCardNo ||
@ -40,23 +62,34 @@ validateAvsQueryPerson = do
is _Just avsPersonQueryVersionNo is _Just avsPersonQueryVersionNo
makeAvsStatusForm :: Maybe AvsQueryStatus -> Form AvsQueryStatus makeAvsStatusForm :: Maybe AvsQueryStatus -> Form AvsQueryStatus
makeAvsStatusForm tmpl = identifyForm FIDAvsQueryStatus . validateForm validateAvsQueryStatus $ \html -> makeAvsStatusForm tmpl = identifyForm FIDAvsQueryStatus . validateForm validateAvsQueryStatus $ \html ->
flip (renderAForm FormStandard) html $ flip (renderAForm FormStandard) html $
parseAvsIds <$> areq textField (fslI MsgAvsPersonId) (unparseAvsIds <$> tmpl) parseAvsIds <$> areq textField (fslI MsgAvsPersonId) (unparseAvsIds <$> tmpl)
where where
parseAvsIds :: Text -> AvsQueryStatus parseAvsIds :: Text -> AvsQueryStatus
parseAvsIds txt = AvsQueryStatus $ Set.fromList ids parseAvsIds txt = AvsQueryStatus $ Set.fromList ids
where where
nonemptys = filter (not . Text.null) $ Text.strip <$> Text.split (==',') txt nonemptys = filter (not . Text.null) $ Text.strip <$> Text.split (==',') txt
ids = catMaybes $ readMay <$> nonemptys ids = catMaybes $ readMay <$> nonemptys
unparseAvsIds :: AvsQueryStatus -> Text unparseAvsIds :: AvsQueryStatus -> Text
unparseAvsIds (AvsQueryStatus ids) = Text.intercalate ", " $ tshow <$> Set.toAscList ids unparseAvsIds (AvsQueryStatus ids) = Text.intercalate ", " $ tshow <$> Set.toAscList ids
validateAvsQueryStatus :: FormValidator AvsQueryStatus Handler () validateAvsQueryStatus :: FormValidator AvsQueryStatus Handler ()
validateAvsQueryStatus = do validateAvsQueryStatus = do
AvsQueryStatus ids <- State.get AvsQueryStatus ids <- State.get
guardValidation (MsgAvsQueryStatusInvalid $ tshow ids) $ not (null ids) guardValidation (MsgAvsQueryStatusInvalid $ tshow ids) $ not (null ids)
avsLicenceOptions :: OptionList AvsLicence
avsLicenceOptions = mkOptionList
[ Option
{ optionDisplay = Text.singleton $ licence2char l
, optionInternalValue = l
, optionExternalValue = toJsonText l
}
| l <- universeF
]
getAdminAvsR, postAdminAvsR :: Handler Html getAdminAvsR, postAdminAvsR :: Handler Html
getAdminAvsR = postAdminAvsR getAdminAvsR = postAdminAvsR
postAdminAvsR = do postAdminAvsR = do
@ -66,31 +99,136 @@ postAdminAvsR = do
Just AvsQuery{..} -> do Just AvsQuery{..} -> do
((presult, pwidget), penctype) <- runFormPost $ makeAvsPersonForm Nothing ((presult, pwidget), penctype) <- runFormPost $ makeAvsPersonForm Nothing
let procFormPerson fr = do let procFormPerson fr = do
addMessage Info $ text2Html $ "Query: " <> tshow (toJSON fr)
res <- avsQueryPerson fr res <- avsQueryPerson fr
case res of case res of
Left err -> return . Just $ tshow err Left err -> return . Just $ tshow err
Right jsn -> return . Just $ tshow jsn Right jsn -> return . Just $ Text.replace "},Avs" "},\n Avs" $ tshow jsn
mbPerson <- formResultMaybe presult procFormPerson mbPerson <- formResultMaybe presult procFormPerson
((sresult, swidget), senctype) <- runFormPost $ makeAvsStatusForm Nothing ((sresult, swidget), senctype) <- runFormPost $ makeAvsStatusForm Nothing
let procFormStatus fr = do let procFormStatus fr = do
addMessage Info $ text2Html $ "Query: " <> tshow (toJSON fr)
res <- avsQueryStatus fr res <- avsQueryStatus fr
case res of case res of
Left err -> return . Just $ tshow err Left err -> return . Just $ tshow err
Right jsn -> return . Just $ tshow jsn Right jsn -> return . Just $ Text.replace "},Avs" "},\n Avs" $ tshow jsn
mbStatus <- formResultMaybe sresult procFormStatus mbStatus <- formResultMaybe sresult procFormStatus
((crUsrRes, crUsrWgt), crUsrEnctype) <- runFormPost $ identifyForm FIDAvsCreateUser $ \html ->
flip (renderAForm FormStandard) html $ areq textField (fslI MsgAvsCardNo) Nothing
let procFormCrUsr fr = do
-- addMessage Info $ text2Html $ "Query: " <> tshow (toJSON fr)
res <- try $ upsertAvsUser fr
case res of
(Right (Just uid)) -> do
uuid :: CryptoUUIDUser <- encrypt uid
return $ Just [whamlet|<h2>Success:</h2> <a href=@{ForProfileR uuid}>User created or updated.|]
(Right Nothing) ->
return $ Just [whamlet|<h2>Warning:</h2> No user found.|]
(Left e) -> do
let msg = tshow (e :: SomeException)
return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
mbCrUser <- formResultMaybe crUsrRes procFormCrUsr
((getLicRes, getLicWgt), getLicEnctype) <- runFormPost $ identifyForm FIDAvsQueryLicence $ \html ->
flip (renderAForm FormStandard) html $ (,,) <$> aopt intField (fslI $ text2message "Min AvsPersonId") Nothing
<*> aopt intField (fslI $ text2message "Max AvsPersonId") Nothing
<*> aopt (selectField $ return avsLicenceOptions) (fslI MsgAvsLicence) Nothing
let procFormGetLic fr = do
res <- avsQueryGetAllLicences
case res of
(Right (AvsResponseGetLicences lics)) -> do
let flics = Set.toList $ Set.filter lfltr lics
lfltr = case fr of -- not pretty, but it'll do
(Just idmin, Just idmax, Just lic) -> \AvsPersonLicence{..} -> (avsLicenceRampLicence == lic) && (avsLicencePersonID `inBetween` (AvsPersonId idmin, AvsPersonId idmax))
(Just idmin, Nothing, Just lic) -> \AvsPersonLicence{..} -> (avsLicenceRampLicence == lic) && (avsLicencePersonID == AvsPersonId idmin)
(Nothing , Just idmax, Just lic) -> \AvsPersonLicence{..} -> (avsLicenceRampLicence == lic) && (avsLicencePersonID == AvsPersonId idmax)
(Nothing , Nothing, Just lic) -> \AvsPersonLicence{..} -> avsLicenceRampLicence == lic
(Just idmin, Just idmax, Nothing ) -> (`inBetween` (AvsPersonId idmin, AvsPersonId idmax)) . avsLicencePersonID
(Just idmin, Nothing, Nothing ) -> (== AvsPersonId idmin) . avsLicencePersonID
(Nothing , Just idmax, Nothing ) -> (== AvsPersonId idmax) . avsLicencePersonID
(Nothing , Nothing, Nothing ) -> const True
addMessage Info $ text2Html $ "Query returned " <> tshow (length flics) <> " licences."
return $ Just [whamlet|
<h2>Success:</h2>
<ul>
$forall AvsPersonLicence{..} <- flics
<li> #{tshow avsLicencePersonID}: #{licence2char avsLicenceRampLicence}
|]
(Left err) -> do
let msg = tshow err
return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
mbGetLic <- formResultMaybe getLicRes procFormGetLic
((setLicRes, setLicWgt), setLicEnctype) <- runFormPost $ identifyForm FIDAvsSetLicence $ \html ->
flip (renderAForm FormStandard) html $ (,) <$> areq intField (fslI MsgAvsPersonId) Nothing
<*> areq (selectField $ return avsLicenceOptions) (fslI MsgAvsLicence) (Just AvsLicenceVorfeld)
let procFormSetLic (aid, lic) = do
let req = Set.singleton $ AvsPersonLicence { avsLicenceRampLicence = lic, avsLicencePersonID = AvsPersonId aid }
addMessage Info $ text2Html $ "See log for detailed errors. Query: " <> tshow (toJSON $ AvsQuerySetLicences req)
res <- try $ setLicencesAvs req
case res of
(Right True) ->
return $ Just [whamlet|<h2>Success:</h2> Licence #{tshow (licence2char lic)} set for #{tshow aid}.|]
(Right False) ->
return $ Just [whamlet|<h2>Error:</h2> Licence could not be set for #{tshow aid}.|]
(Left e) -> do
let msg = tshow (e :: SomeException)
return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
mbSetLic <- formResultMaybe setLicRes procFormSetLic
((qryLicRes, qryLicWgt), qryLicEnctype) <- runFormPost $ identifyForm FIDAvsQueryLicenceDiffs (buttonForm :: Form ButtonAvsTest)
let procFormQryLic btn = case btn of
BtnCheckLicences -> do
res <- try $ do
allLicences <- throwLeftM avsQueryGetAllLicences
computeDifferingLicences allLicences
case res of
(Right diffs) -> do
let showLics l = Text.intercalate ", " $ fmap (tshow . avsLicencePersonID) $ Set.toList $ Set.filter ((l ==) . avsLicenceRampLicence) diffs
r_grant = showLics AvsLicenceRollfeld
f_set = showLics AvsLicenceVorfeld
revoke = showLics AvsNoLicence
return $ Just [whamlet|
<h2>Licence check differences:
<h3>Grant R:
<p>
#{r_grant}
<h3>Set to F:
<p>
#{f_set}
<h3>Revoke licence:
<p>
#{revoke}
|]
(Left e) -> do
let msg = tshow (e :: SomeException)
return $ Just [whamlet|<h2>Licence check error:</h2> #{msg}|]
BtnSynchLicences -> do
res <- try synchAvsLicences
case res of
(Right True) ->
return $ Just [whamlet|<h2>Success:</h2> Licences sychronized.|]
(Right False) ->
return $ Just [whamlet|<h2>Error:</h2> Licences could not be synchronized, see error log.|]
(Left e) -> do
let msg = tshow (e :: SomeException)
return $ Just [whamlet|<h2>Licence synchronisation error:</h2> #{msg}|]
mbQryLic <- formResultMaybe qryLicRes procFormQryLic
actionUrl <- fromMaybe AdminAvsR <$> getCurrentRoute actionUrl <- fromMaybe AdminAvsR <$> getCurrentRoute
siteLayoutMsg MsgMenuAvs $ do siteLayoutMsg MsgMenuAvs $ do
setTitleI MsgMenuAvs setTitleI MsgMenuAvs
let personForm = wrapForm pwidget def let wrapFormHere fw fe = wrapForm fw def { formAction = Just $ SomeRoute actionUrl, formEncoding = fe }
{ formAction = Just $ SomeRoute actionUrl personForm = wrapFormHere pwidget penctype
, formEncoding = penctype statusForm = wrapFormHere swidget senctype
} crUsrForm = wrapFormHere crUsrWgt crUsrEnctype
statusForm = wrapForm swidget def getLicForm = wrapFormHere getLicWgt getLicEnctype
{ formAction = Just $ SomeRoute actionUrl setLicForm = wrapFormHere setLicWgt setLicEnctype
, formEncoding = senctype qryLicForm = wrapForm qryLicWgt def { formAction = Just $ SomeRoute actionUrl, formEncoding = qryLicEnctype, formSubmit = FormNoSubmit }
}
-- TODO: use i18nWidgetFile instead if this is to become permanent -- TODO: use i18nWidgetFile instead if this is to become permanent
$(widgetFile "avs") $(widgetFile "avs")

70
src/Handler/Admin/Ldap.hs
View File

@ -10,67 +10,46 @@ module Handler.Admin.Ldap
) where ) where
import Import import Import
import qualified Control.Monad.State.Class as State -- import qualified Control.Monad.State.Class as State
-- import Data.Aeson (encode) -- import Data.Aeson (encode)
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
import qualified Data.Text as Text import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text import qualified Data.Text.Encoding as Text
-- import qualified Data.Set as Set -- import qualified Data.Set as Set
import Foundation.Yesod.Auth (decodeUserTest) import Foundation.Yesod.Auth (decodeUserTest,ldapLookupAndUpsert,campusUserFailoverMode,CampusUserConversionException())
import Handler.Utils import Handler.Utils
import qualified Ldap.Client as Ldap import qualified Ldap.Client as Ldap
import Auth.LDAP import Auth.LDAP
data LdapQueryPerson = LdapQueryPerson
{ ldapQueryIdent :: Maybe Text
-- , ldapQueryName :: Maybe Text
, ldapQueryPNum :: Maybe Text
}
deriving (Eq, Ord, Read, Show, Generic, Typeable)
makeLdapPersonForm :: Maybe LdapQueryPerson -> Form LdapQueryPerson
makeLdapPersonForm tmpl = validateForm validateLdapQueryPerson $ \html ->
flip (renderAForm FormStandard) html $ LdapQueryPerson
<$> aopt textField (fslI MsgAdminUserIdent) (ldapQueryIdent <$> tmpl)
-- <*> aopt textField (fslI MsgAdminUserSurname) (ldapQueryName <$> tmpl)
<*> aopt textField (fslI MsgAdminUserFPersonalNumber) (ldapQueryPNum <$> tmpl)
validateLdapQueryPerson :: FormValidator LdapQueryPerson Handler ()
validateLdapQueryPerson = do
LdapQueryPerson{..} <- State.get
guardValidation MsgAvsQueryEmpty $
is _Just ldapQueryIdent ||
-- is _Just ldapQueryName ||
is _Just ldapQueryPNum
getAdminLdapR, postAdminLdapR :: Handler Html getAdminLdapR, postAdminLdapR :: Handler Html
getAdminLdapR = postAdminLdapR getAdminLdapR = postAdminLdapR
postAdminLdapR = do postAdminLdapR = do
((presult, pwidget), penctype) <- runFormPost $ makeLdapPersonForm Nothing ((presult, pwidget), penctype) <- runFormPost $ identifyForm ("adminLdapLookup"::Text) $ \html ->
flip (renderAForm FormStandard) html $ areq textField (fslI MsgAdminUserIdent) Nothing
let procFormPerson :: LdapQueryPerson -> Handler (Maybe (Ldap.AttrList []))
procFormPerson LdapQueryPerson{..} = do
ldapPool' <- getsYesod $ view _appLdapPool
if isNothing ldapPool'
then addMessage Warning $ text2Html "LDAP Configuration missing."
else addMessage Info $ text2Html "Input for LDAP test received."
fmap join . for ldapPool' $ \ldapPool -> do
ldapData <- if | Just lqi <- ldapQueryIdent -> campusUser'' ldapPool FailoverUnlimited lqi
| Just lqn <- ldapQueryPNum -> campusUserMatr' ldapPool FailoverUnlimited lqn
| otherwise -> addMessageI Error MsgAvsQueryEmpty >> pure Nothing
decodedErr <- decodeUserTest (CI.mk <$> ldapQueryIdent) $ concat ldapData
whenIsLeft decodedErr $ addMessageI Error
return ldapData
let procFormPerson :: Text -> Handler (Maybe (Ldap.AttrList []))
procFormPerson lid = do
ldapPool' <- getsYesod $ view _appLdapPool
case ldapPool' of
Nothing -> addMessage Error (text2Html "LDAP Configuration missing.") >> return Nothing
Just ldapPool -> do
addMessage Info $ text2Html "Input for LDAP test received."
ldapData <- campusUser'' ldapPool campusUserFailoverMode lid
decodedErr <- decodeUserTest (pure $ CI.mk lid) $ concat ldapData
whenIsLeft decodedErr $ addMessageI Error
return ldapData
mbLdapData <- formResultMaybe presult procFormPerson mbLdapData <- formResultMaybe presult procFormPerson
((uresult, uwidget), uenctype) <- runFormPost $ identifyForm ("adminLdapUpsert"::Text) $ \html ->
flip (renderAForm FormStandard) html $ areq textField (fslI MsgAdminUserIdent) Nothing
let procFormUpsert :: Text -> Handler (Maybe (Either CampusUserConversionException (Entity User)))
procFormUpsert lid = pure <$> runDB (try $ ldapLookupAndUpsert lid)
mbLdapUpsert <- formResultMaybe uresult procFormUpsert
actionUrl <- fromMaybe AdminLdapR <$> getCurrentRoute actionUrl <- fromMaybe AdminLdapR <$> getCurrentRoute
siteLayoutMsg MsgMenuLdap $ do siteLayoutMsg MsgMenuLdap $ do
setTitleI MsgMenuLdap setTitleI MsgMenuLdap
@ -78,7 +57,10 @@ postAdminLdapR = do
{ formAction = Just $ SomeRoute actionUrl { formAction = Just $ SomeRoute actionUrl
, formEncoding = penctype , formEncoding = penctype
} }
upsertForm = wrapForm uwidget def
{ formAction = Just $ SomeRoute actionUrl
, formEncoding = uenctype
}
presentUtf8 lv = Text.intercalate ", " (either tshow id . Text.decodeUtf8' <$> lv) presentUtf8 lv = Text.intercalate ", " (either tshow id . Text.decodeUtf8' <$> lv)
presentLatin1 lv = Text.intercalate ", " ( Text.decodeLatin1 <$> lv) presentLatin1 lv = Text.intercalate ", " ( Text.decodeLatin1 <$> lv)

17
src/Handler/LMS.hs
View File

@ -83,8 +83,9 @@ postLmsAllR = do
FormMissing -> return () FormMissing -> return ()
_other -> addMessage Warning "Kein korrekter LMS Knopf erkannt" _other -> addMessage Warning "Kein korrekter LMS Knopf erkannt"
isAdmin <- hasReadAccessTo AdminR
lmsTable <- runDB $ do lmsTable <- runDB $ do
view _2 <$> mkLmsAllTable view _2 <$> mkLmsAllTable isAdmin
siteLayoutMsg MsgMenuQualifications $ do siteLayoutMsg MsgMenuQualifications $ do
setTitleI MsgMenuQualifications setTitleI MsgMenuQualifications
$(widgetFile "lms-all") $(widgetFile "lms-all")
@ -100,9 +101,10 @@ resultAllQualificationTotal :: Lens' AllQualificationTableData Word64
resultAllQualificationTotal = _dbrOutput . _3 . _unValue resultAllQualificationTotal = _dbrOutput . _3 . _unValue
mkLmsAllTable :: DB (Any, Widget) mkLmsAllTable :: Bool -> DB (Any, Widget)
mkLmsAllTable = do mkLmsAllTable isAdmin = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
let let
resultDBTable = DBTable{..} resultDBTable = DBTable{..}
where where
@ -139,7 +141,12 @@ mkLmsAllTable = do
, sortable Nothing (i18nCell MsgTableQualificationIsAvsLicence & cellTooltip MsgTableQualificationIsAvsLicenceTooltip) , sortable Nothing (i18nCell MsgTableQualificationIsAvsLicence & cellTooltip MsgTableQualificationIsAvsLicenceTooltip)
$ \(view (resultAllQualification . _qualificationAvsLicence) -> licence) -> maybeCell licence $ textCell . T.singleton . licence2char $ \(view (resultAllQualification . _qualificationAvsLicence) -> licence) -> maybeCell licence $ textCell . T.singleton . licence2char
, sortable Nothing (i18nCell MsgTableQualificationSapExport & cellTooltip MsgTableQualificationSapExportTooltip) , sortable Nothing (i18nCell MsgTableQualificationSapExport & cellTooltip MsgTableQualificationSapExportTooltip)
$ \(view (resultAllQualification . _qualificationSapId) -> sapid) -> tickmarkCell $ isJust sapid $ \(view (resultAllQualification . _qualificationSapId) -> mbSapId) ->
let icn = IconOK -- change icon here, if desired
in case mbSapId of
Nothing -> mempty
Just sapId | isAdmin -> cellTooltipIcon (Just icn) (text2message sapId) mempty
Just _ -> iconCell icn
, sortable Nothing (i18nCell MsgTableQualificationCountActive & cellTooltip MsgTableQualificationCountActiveTooltip) , sortable Nothing (i18nCell MsgTableQualificationCountActive & cellTooltip MsgTableQualificationCountActiveTooltip)
$ \(view resultAllQualificationActive -> n) -> wgtCell $ word2widget n $ \(view resultAllQualificationActive -> n) -> wgtCell $ word2widget n
, sortable Nothing (i18nCell MsgTableQualificationCountTotal) $ wgtCell . word2widget . view resultAllQualificationTotal , sortable Nothing (i18nCell MsgTableQualificationCountTotal) $ wgtCell . word2widget . view resultAllQualificationTotal
@ -553,7 +560,7 @@ postLmsR sid qsh = do
where where
-- i18nLms :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a -- i18nLms :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a
i18nLms msg = cell [whamlet|LMS #|] <> i18nCell msg i18nLms msg = cell [whamlet|LMS #|] <> i18nCell msg
psValidator = def -- TODO: hier einen Filter für Schützlinge einbauen psValidator = def & forceFilter "may-access" (Any True)
tbl <- mkLmsTable qent acts (const E.true) colChoices psValidator tbl <- mkLmsTable qent acts (const E.true) colChoices psValidator
return (tbl, qent) return (tbl, qent)

33
src/Handler/Profile.hs
View File

@ -559,17 +559,42 @@ getForProfileDataR cID = do
makeProfileData :: Entity User -> DB Widget makeProfileData :: Entity User -> DB Widget
makeProfileData (Entity uid User{..}) = do makeProfileData (Entity uid User{..}) = do
avsId <- entityVal <<$>> getBy (UniqueUserAvsUser uid)
-- avsCards <- maybe (pure mempty) (\a -> selectList [UserAvsCardPersonId ==. userAvsPersonId a] []) avsId
functions <- Map.fromListWith Set.union . map (\(Entity _ UserFunction{..}) -> (userFunctionFunction, Set.singleton userFunctionSchool)) <$> selectList [UserFunctionUser ==. uid] [] functions <- Map.fromListWith Set.union . map (\(Entity _ UserFunction{..}) -> (userFunctionFunction, Set.singleton userFunctionSchool)) <$> selectList [UserFunctionUser ==. uid] []
lecture_corrector <- E.select $ E.distinct $ E.from $ \(sheet `E.InnerJoin` corrector `E.InnerJoin` course) -> do lecture_corrector <- E.select $ E.distinct $ E.from $ \(sheet `E.InnerJoin` corrector `E.InnerJoin` course) -> do
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet
E.where_ $ corrector E.^. SheetCorrectorUser E.==. E.val uid E.where_ $ corrector E.^. SheetCorrectorUser E.==. E.val uid
return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand) return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand)
studies <- E.select $ E.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do studies <- E.select $ E.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do
E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid
E.on $ studyfeat E.^. StudyFeaturesField E.==. studyterms E.^. StudyTermsId E.on $ studyfeat E.^. StudyFeaturesField E.==. studyterms E.^. StudyTermsId
E.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId E.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId
E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid
return (studyfeat, studydegree, studyterms) return (studyfeat, studydegree, studyterms)
companies' <- E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid
E.orderBy [E.asc (comp E.^. CompanyName)] -- E.desc (usrComp E.^. UserCompanySupervisor),
return (comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor)
let companies = intersperse (text2markup ", ") $
(\(E.Value cmpName, E.Value cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> companies'
icnSuper = text2markup " " <> icon IconSupervisor
supervisors' <- E.select $ E.from $ \(spvr `E.InnerJoin` usrSpvr) -> do
E.on $ spvr E.^. UserSupervisorSupervisor E.==. usrSpvr E.^. UserId
E.where_ $ spvr E.^. UserSupervisorUser E.==. E.val uid
E.orderBy [E.asc (usrSpvr E.^. UserDisplayName)]
return (usrSpvr, spvr E.^. UserSupervisorRerouteNotifications)
let supervisors = intersperse (text2widget ", ") $
(\(usr, E.Value reroutCom) -> linkUserWidget ForProfileDataR usr <> bool mempty icnReroute reroutCom) <$> supervisors'
icnReroute = text2widget " " <> toWgt (icon IconLetter)
supervisees' <- E.select $ E.from $ \(spvr `E.InnerJoin` usrSpvr) -> do
E.on $ spvr E.^. UserSupervisorUser E.==. usrSpvr E.^. UserId
E.where_ $ spvr E.^. UserSupervisorSupervisor E.==. E.val uid
return (usrSpvr, spvr E.^. UserSupervisorRerouteNotifications)
let supervisees = intersperse (text2widget ", ") $
(\(usr, E.Value reroutCom) -> linkUserWidget ForProfileDataR usr <> bool mempty icnReroute reroutCom) <$> supervisees'
-- icnReroute = text2widget " " <> toWgt (icon IconLetter)
--Tables --Tables
(hasRows, ownedCoursesTable) <- mkOwnedCoursesTable uid -- Tabelle mit eigenen Kursen (hasRows, ownedCoursesTable) <- mkOwnedCoursesTable uid -- Tabelle mit eigenen Kursen
enrolledCoursesTable <- mkEnrolledCoursesTable uid -- Tabelle mit allen Teilnehmer: Kurs (link), Datum enrolledCoursesTable <- mkEnrolledCoursesTable uid -- Tabelle mit allen Teilnehmer: Kurs (link), Datum
@ -584,7 +609,8 @@ makeProfileData (Entity uid User{..}) = do
cID <- encrypt uid cID <- encrypt uid
mCRoute <- getCurrentRoute mCRoute <- getCurrentRoute
showAdminInfo <- pure (mCRoute == Just (AdminUserR cID)) `or2M` hasReadAccessTo (AdminUserR cID) showAdminInfo <- pure (mCRoute == Just (AdminUserR cID)) `or2M` hasReadAccessTo (AdminUserR cID)
tooltipAvsPersNo <- messageI Info MsgAvsPersonNoNotId
let profileRemarks = $(i18nWidgetFile "profile-remarks") let profileRemarks = $(i18nWidgetFile "profile-remarks")
return $(widgetFile "profileData") return $(widgetFile "profileData")
@ -908,7 +934,6 @@ mkCorrectionsTable =
in dbTableWidget' validator DBTable{..} in dbTableWidget' validator DBTable{..}
-- | Table listing all qualifications that the given user is enrolled in -- | Table listing all qualifications that the given user is enrolled in
mkQualificationsTable :: UserId -> DB Widget mkQualificationsTable :: UserId -> DB Widget
mkQualificationsTable = mkQualificationsTable =

7
src/Handler/SAP.hs
View File

@ -16,6 +16,7 @@ import Handler.Utils.Csv
-- import qualified Data.CaseInsensitive as CI -- import qualified Data.CaseInsensitive as CI
import qualified Data.Csv as Csv import qualified Data.Csv as Csv
import Database.Esqueleto.Experimental ((:&)(..))
import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma
-- import qualified Database.Esqueleto.Legacy as E -- import qualified Database.Esqueleto.Legacy as E
import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Utils as E
@ -69,12 +70,12 @@ sapRes2csv l = [ res | (Ex.Value (Just persNo), Ex.Value firstHeld, Ex.Value val
getQualificationSAPDirectR :: Handler TypedContent getQualificationSAPDirectR :: Handler TypedContent
getQualificationSAPDirectR = do getQualificationSAPDirectR = do
qualUsers <- runDB $ Ex.select $ do qualUsers <- runDB $ Ex.select $ do
(qual Ex.:& qualUser Ex.:& user) <- (qual :& qualUser :& user) <-
Ex.from $ Ex.table @Qualification Ex.from $ Ex.table @Qualification
`Ex.innerJoin` Ex.table @QualificationUser `Ex.innerJoin` Ex.table @QualificationUser
`Ex.on` (\(qual Ex.:& qualUser) -> qual Ex.^. QualificationId Ex.==. qualUser Ex.^. QualificationUserQualification) `Ex.on` (\(qual :& qualUser) -> qual Ex.^. QualificationId Ex.==. qualUser Ex.^. QualificationUserQualification)
`Ex.innerJoin` Ex.table @User `Ex.innerJoin` Ex.table @User
`Ex.on` (\(_ Ex.:& qualUser Ex.:& user) -> qualUser Ex.^. QualificationUserUser Ex.==. user Ex.^. UserId) `Ex.on` (\(_ :& qualUser :& user) -> qualUser Ex.^. QualificationUserUser Ex.==. user Ex.^. UserId)
Ex.where_ $ E.isJust (qual Ex.^. QualificationSapId) Ex.where_ $ E.isJust (qual Ex.^. QualificationSapId)
Ex.&&. E.isJust (user Ex.^. UserCompanyPersonalNumber) Ex.&&. E.isJust (user Ex.^. UserCompanyPersonalNumber)
return return

62
src/Handler/Users.hs
View File

@ -85,6 +85,16 @@ postUsersR = do
-- , sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM -- , sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM
-- (AdminUserR <$> encrypt uid) -- (AdminUserR <$> encrypt uid)
-- (toWgt userMatrikelnummer) -- (toWgt userMatrikelnummer)
, 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"
companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid
E.orderBy [E.asc (comp E.^. CompanyName)]
return (comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor)
let companies = intersperse (text2markup ", ") $
(\(E.Value cmpName, E.Value cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> companies'
icnSuper = text2markup " " <> icon IconSupervisor
pure $ toWgt $ mconcat companies
, sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM , sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM
(AdminUserR <$> encrypt uid) (AdminUserR <$> encrypt uid)
(toWgt userCompanyPersonalNumber) (toWgt userCompanyPersonalNumber)
@ -92,6 +102,16 @@ postUsersR = do
-- , sortable (Just "last-name") (i18nCell MsgName) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM -- , sortable (Just "last-name") (i18nCell MsgName) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM
-- (AdminUserR <$> encrypt uid) -- (AdminUserR <$> encrypt uid)
-- (toWidget . display $ last $ impureNonNull $ words $ userDisplayName) -- (toWidget . display $ last $ impureNonNull $ words $ userDisplayName)
, sortable (Just "user-supervisor") (i18nCell MsgTableSupervisor) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do
supervisors' <- liftHandler . runDB . E.select $ E.from $ \(spvr `E.InnerJoin` usrSpvr) -> do
E.on $ spvr E.^. UserSupervisorSupervisor E.==. usrSpvr E.^. UserId
E.where_ $ spvr E.^. UserSupervisorUser E.==. E.val uid
E.orderBy [E.asc (usrSpvr E.^. UserDisplayName)]
return (usrSpvr, spvr E.^. UserSupervisorRerouteNotifications)
let supervisors = intersperse (text2widget ", ") $
(\(usr, E.Value reroutCom) -> linkUserWidget ForProfileDataR usr <> bool mempty icnReroute reroutCom) <$> supervisors'
icnReroute = text2widget " " <> toWgt (icon IconLetter)
pure $ mconcat supervisors
, sortable (Just "auth-ldap") (i18nCell MsgAuthMode) $ \DBRow{ dbrOutput = Entity _ User{..} } -> i18nCell userAuthentication , sortable (Just "auth-ldap") (i18nCell MsgAuthMode) $ \DBRow{ dbrOutput = Entity _ User{..} } -> i18nCell userAuthentication
, sortable (Just "ldap-sync") (i18nCell MsgLdapSynced) $ \DBRow{ dbrOutput = Entity _ User{..} } -> maybe mempty dateTimeCell userLastLdapSynchronisation , sortable (Just "ldap-sync") (i18nCell MsgLdapSynced) $ \DBRow{ dbrOutput = Entity _ User{..} } -> maybe mempty dateTimeCell userLastLdapSynchronisation
, flip foldMap universeF $ \function -> , flip foldMap universeF $ \function ->
@ -171,6 +191,20 @@ postUsersR = do
, ( "ldap-sync" , ( "ldap-sync"
, SortColumn $ \user -> user E.^. UserLastLdapSynchronisation , SortColumn $ \user -> user E.^. UserLastLdapSynchronisation
) )
, ( "user-company"
, SortColumn $ \user -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
E.where_ $ usrComp E.^. UserCompanyUser E.==. user E.^. UserId
E.orderBy [E.asc (comp E.^. CompanyName)]
return (comp E.^. CompanyName)
)
, ( "user-supervisor"
, SortColumn $ \user -> E.subSelect $ E.from $ \(spvr `E.InnerJoin` usrSpvr) -> do
E.on $ spvr E.^. UserSupervisorSupervisor E.==. usrSpvr E.^. UserId
E.where_ $ spvr E.^. UserSupervisorUser E.==. user E.^. UserId
E.orderBy [E.asc (usrSpvr E.^. UserDisplayName)]
return (usrSpvr E.^. UserDisplayName)
)
] ]
, dbtFilter = Map.fromList -- OverloadedLists does not work with the templates , dbtFilter = Map.fromList -- OverloadedLists does not work with the templates
[ ( "user-search", FilterColumn $ \user (criteria :: Set.Set Text) -> [ ( "user-search", FilterColumn $ \user (criteria :: Set.Set Text) ->
@ -185,7 +219,7 @@ postUsersR = do
, ( "user-email", FilterColumn $ \user criterion -> case getLast (criterion :: Last Text) of , ( "user-email", FilterColumn $ \user criterion -> case getLast (criterion :: Last Text) of
Nothing -> E.val True :: E.SqlExpr (E.Value Bool) Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
Just needle -> (E.castString (user E.^. UserEmail) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%)) Just needle -> (E.castString (user E.^. UserEmail) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
E.||. (E.castString (user E.^. UserDisplayEmail) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%)) E.||. (E.castString (user E.^. UserDisplayEmail) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
) )
-- , ( "matriculation", FilterColumn $ \user (criteria :: Set.Set Text) -> if -- , ( "matriculation", FilterColumn $ \user (criteria :: Set.Set Text) -> if
-- | Set.null criteria -> E.true -- TODO: why can this be eFalse and work still? -- | Set.null criteria -> E.true -- TODO: why can this be eFalse and work still?
@ -217,14 +251,32 @@ postUsersR = do
in E.maybe E.true (E.<=. E.val minTime) $ user E.^. UserLastLdapSynchronisation in E.maybe E.true (E.<=. E.val minTime) $ user E.^. UserLastLdapSynchronisation
| otherwise -> E.val True :: E.SqlExpr (E.Value Bool) | otherwise -> E.val True :: E.SqlExpr (E.Value Bool)
) )
, ( "user-company", FilterColumn $ \user criteria -> if
| Set.null (criteria :: Set.Set Text) -> E.val True :: E.SqlExpr (E.Value Bool)
| otherwise ->
E.exists . E.from $ \(ucomp `E.InnerJoin` comp) -> do
E.on $ ucomp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
E.where_ $ (ucomp E.^. UserCompanyUser E.==. user E.^.UserId)
E.&&. E.any (E.hasInfix (comp E.^. CompanyName)) (E.val <$> Set.toList criteria)
)
, ( "user-supervisor", FilterColumn $ \user criteria -> if
| Set.null (criteria :: Set.Set Text) -> E.val True :: E.SqlExpr (E.Value Bool)
| otherwise ->
E.exists . E.from $ \(spvr `E.InnerJoin` usrSpvr) -> do
E.on $ spvr E.^. UserSupervisorSupervisor E.==. usrSpvr E.^. UserId
E.where_ $ (spvr E.^. UserSupervisorUser E.==. user E.^.UserId)
E.&&. E.any (E.hasInfix (usrSpvr E.^. UserDisplayName)) (E.val <$> Set.toList criteria)
)
] ]
, dbtFilterUI = \mPrev -> mconcat , dbtFilterUI = \mPrev -> mconcat
[ prismAForm (singletonFilter "user-search") mPrev $ aopt textField (fslI MsgName) [ prismAForm (singletonFilter "user-search") mPrev $ aopt textField (fslI MsgName)
, prismAForm (singletonFilter "user-ident") mPrev $ aopt textField (fslI MsgAdminUserIdent) , prismAForm (singletonFilter "user-ident") mPrev $ aopt textField (fslI MsgAdminUserIdent)
, prismAForm (singletonFilter "user-email") mPrev $ aopt textField (fslI MsgAdminUserEmail) , prismAForm (singletonFilter "user-email") mPrev $ aopt textField (fslI MsgAdminUserEmail)
-- , prismAForm (singletonFilter "matriculation") mPrev $ aopt matriculationField (fslI MsgTableMatrikelNr) -- , prismAForm (singletonFilter "matriculation") mPrev $ aopt matriculationField (fslI MsgTableMatrikelNr)
, prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumber) , prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumber)
, prismAForm (singletonFilter "company-department" ) mPrev $ aopt textField (fslI MsgCompanyDepartment) , prismAForm (singletonFilter "company-department" ) mPrev $ aopt textField (fslI MsgCompanyDepartment)
, prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany)
, prismAForm (singletonFilter "user-supervisor") mPrev $ aopt textField (fslI MsgTableSupervisor)
, prismAForm (singletonFilter "auth-ldap" . maybePrism _PathPiece) mPrev $ aopt (lift `hoistField` selectFieldList [(MsgAuthPWHash "", False), (MsgAuthLDAP, True)]) (fslI MsgAuthMode) , prismAForm (singletonFilter "auth-ldap" . maybePrism _PathPiece) mPrev $ aopt (lift `hoistField` selectFieldList [(MsgAuthPWHash "", False), (MsgAuthLDAP, True)]) (fslI MsgAuthMode)
, prismAForm (singletonFilter "school") mPrev $ aopt (lift `hoistField` selectFieldList schoolOptions) (fslI MsgCourseSchool) , prismAForm (singletonFilter "school") mPrev $ aopt (lift `hoistField` selectFieldList schoolOptions) (fslI MsgCourseSchool)
, prismAForm (singletonFilter "ldap-sync" . maybePrism _PathPiece) mPrev $ aopt utcTimeField (fslI MsgLdapSyncedBefore) , prismAForm (singletonFilter "ldap-sync" . maybePrism _PathPiece) mPrev $ aopt utcTimeField (fslI MsgLdapSyncedBefore)
@ -317,7 +369,7 @@ nullaryPathPiece ''UserAssimilateButton $ camelToPathPiece' 2
embedRenderMessage ''UniWorX ''UserAssimilateButton id embedRenderMessage ''UniWorX ''UserAssimilateButton id
getAdminUserR, postAdminUserR :: CryptoUUIDUser -> Handler Html getAdminUserR, postAdminUserR :: CryptoUUIDUser -> Handler Html
getAdminUserR = postAdminUserR getAdminUserR = postAdminUserR
@ -337,7 +389,7 @@ postAdminUserR uuid = do
return (school, userFunction E.?. UserFunctionFunction, isAdmin) return (school, userFunction E.?. UserFunctionFunction, isAdmin)
systemFunctionsF <- Set.fromList . map (userSystemFunctionFunction . entityVal) <$> selectList [UserSystemFunctionUser ==. uid, UserSystemFunctionIsOptOut ==. False] [] systemFunctionsF <- Set.fromList . map (userSystemFunctionFunction . entityVal) <$> selectList [UserSystemFunctionUser ==. uid, UserSystemFunctionIsOptOut ==. False] []
let systemFunctions = (`Set.member` systemFunctionsF) let systemFunctions = (`Set.member` systemFunctionsF)
return ( user return ( user
, setOf (folded . filtered (view $ _3 . _Value) . _1 . _entityKey) schools , setOf (folded . filtered (view $ _3 . _Value) . _1 . _entityKey) schools

6
src/Handler/Users/Add.hs
View File

@ -36,9 +36,9 @@ data AdminUserForm = AdminUserForm
} }
data AuthenticationKind = AuthKindLDAP | AuthKindPWHash | AuthKindNoLogin data AuthenticationKind = AuthKindLDAP | AuthKindPWHash | AuthKindNoLogin
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable, Universe, Finite)
instance Universe AuthenticationKind --instance Universe AuthenticationKind
instance Finite AuthenticationKind --instance Finite AuthenticationKind
embedRenderMessage ''UniWorX ''AuthenticationKind id embedRenderMessage ''UniWorX ''AuthenticationKind id
nullaryPathPiece ''AuthenticationKind $ camelToPathPiece' 2 nullaryPathPiece ''AuthenticationKind $ camelToPathPiece' 2

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

@ -4,14 +4,16 @@
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-unused-imports #-}
module Handler.Utils.Avs module Handler.Utils.Avs
( upsertAvsUser, upsertAvsUserById, upsertAvsUserByCard ( upsertAvsUser, upsertAvsUserById, upsertAvsUserByCard
, getLicence, getLicenceDB -- , getLicence, getLicenceDB, getLicenceByAvsId -- not supported by interface
, setLicence, setLicenceAvs, setLicencesAvs , setLicence, setLicenceAvs, setLicencesAvs
, checkLicences , retrieveDifferingLicences, computeDifferingLicences
, synchAvsLicences
, lookupAvsUser, lookupAvsUsers , lookupAvsUser, lookupAvsUsers
, AvsException(..)
, updateReceivers
) where ) where
import Import import Import
@ -26,14 +28,14 @@ import qualified Data.Map as Map
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
-- import Auth.LDAP (ldapUserPrincipalName) -- import Auth.LDAP (ldapUserPrincipalName)
import Foundation.Yesod.Auth (upsertCampusUserByCn,CampusUserConversionException()) import Foundation.Yesod.Auth (ldapLookupAndUpsert, CampusUserConversionException())
import Handler.Utils.Company import Handler.Utils.Company
import Handler.Users.Add import Handler.Users.Add
import Database.Esqueleto.Experimental ((:&)) import Database.Esqueleto.Experimental ((:&)(..))
import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Utils as E
-------------------- --------------------
@ -43,7 +45,7 @@ import qualified Database.Esqueleto.Utils as E
data AvsException data AvsException
= AvsInterfaceUnavailable -- Interface to AVS was not configured at startup or does not respond = AvsInterfaceUnavailable -- Interface to AVS was not configured at startup or does not respond
| AvsUserUnassociated UserId -- Manipulating AVS Data for a user that is not linked to AVS yet | AvsUserUnassociated UserId -- Manipulating AVS Data for a user that is not linked to AVS yet
| AvsUserUnknownByAvs AvsPersonId -- AvsPersionId not (or no longer) found in AVS DB | AvsUserUnknownByAvs AvsPersonId -- AvsPersonId not (or no longer) found in AVS DB
| AvsUserAmbiguous -- Multiple matching existing users found in our DB | AvsUserAmbiguous -- Multiple matching existing users found in our DB
| AvsPersonSearchEmpty -- AvsPersonSearch returned empty result | AvsPersonSearchEmpty -- AvsPersonSearch returned empty result
| AvsPersonSearchAmbiguous -- AvsPersonSearch returned more than one result | AvsPersonSearchAmbiguous -- AvsPersonSearch returned more than one result
@ -68,6 +70,7 @@ instance Exception AvsException
-} -}
{- AVS interface only allows collecting all licences at once, thus getLicence should be avoided, see getLicenceByAvsId including a workaround
-- Do we need this? -- Do we need this?
-- getLicence :: UserId -> Handler (Maybe AvsLicence) -- with runDB -- getLicence :: UserId -> Handler (Maybe AvsLicence) -- with runDB
getLicence :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, WithRunDB SqlReadBackend (HandlerFor UniWorX) m ) => UserId -> m (Maybe AvsLicence) getLicence :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, WithRunDB SqlReadBackend (HandlerFor UniWorX) m ) => UserId -> m (Maybe AvsLicence)
@ -86,96 +89,169 @@ getLicenceDB uid = do
let ulicence = Set.lookupMax $ Set.filter ((userAvsPersonId ==) . avsLicencePersonID) licences let ulicence = Set.lookupMax $ Set.filter ((userAvsPersonId ==) . avsLicencePersonID) licences
return (avsLicenceRampLicence <$> ulicence) return (avsLicenceRampLicence <$> ulicence)
setLicence :: UserId -> AvsLicence -> DB ()
-- | Should be avoided, since all licences must be requested at once.
getLicenceByAvsId :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) =>
Set AvsPersonId -> m (Set AvsPersonLicence)
getLicenceByAvsId aids = do
AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ liftHandler $ getsYesod $ view _appAvsQuery
AvsResponseGetLicences licences <- throwLeftM avsQueryGetAllLicences
return $ Set.filter (\x -> avsLicencePersonID x `Set.member` aids) licences
-}
-- setLicence :: (MonadHandler m, MonadThrow m, HandlerSite m ~ UniWorX) => UserId -> AvsLicence -> m Bool
setLicence :: (PersistUniqueRead backend, MonadThrow m,
MonadHandler m, HandlerSite m ~ UniWorX,
BaseBackend backend ~ SqlBackend) =>
UserId -> AvsLicence -> ReaderT backend m Bool
setLicence uid lic = do setLicence uid lic = do
Entity _ UserAvs{..} <- maybeThrowM (AvsUserUnassociated uid) $ getBy $ UniqueUserAvsUser uid Entity _ UserAvs{..} <- maybeThrowM (AvsUserUnassociated uid) $ getBy $ UniqueUserAvsUser uid
setLicenceAvs userAvsPersonId lic setLicenceAvs userAvsPersonId lic
setLicenceAvs :: AvsPersonId -> AvsLicence -> DB () setLicenceAvs :: (MonadHandler m, MonadThrow m, HandlerSite m ~ UniWorX) =>
AvsPersonId -> AvsLicence -> m Bool
setLicenceAvs apid lic = do setLicenceAvs apid lic = do
let req = Set.singleton $ AvsPersonLicence { avsLicenceRampLicence = lic, avsLicencePersonID = apid } let req = Set.singleton $ AvsPersonLicence { avsLicenceRampLicence = lic, avsLicencePersonID = apid }
setLicencesAvs req setLicencesAvs req
-- setLicencesAvs :: Set AvsPersonLicence -> DB ()
--setLicencesAvs :: Set AvsPersonLicence -> Handler Bool
setLicencesAvs :: (MonadHandler m, MonadThrow m, HandlerSite m ~ UniWorX) => setLicencesAvs :: (MonadHandler m, MonadThrow m, HandlerSite m ~ UniWorX) =>
Set AvsPersonLicence -> m () Set AvsPersonLicence -> m Bool
setLicencesAvs pls = do setLicencesAvs persLics = do
AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery AvsQuery{avsQuerySetLicences=aqsl} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery
response <- throwLeftM . avsQuerySetLicences $ AvsQuerySetLicences pls aux aqsl True persLics
case response of where
AvsResponseSetLicencesError{..} -> do aux aqsl batch0_ok pls
let msg = "Set licence failed completely: " <> avsResponseSetLicencesStatus <> ". Details: " <> avsResponseSetLicencesMessage | Set.null pls = return batch0_ok
$logErrorS "AVS" msg | otherwise = do
throwM $ AvsSetLicencesFailed avsResponseSetLicencesStatus let (batch1, batch2) = Set.splitAt avsMaxSetLicenceAtOnce pls
AvsResponseSetLicences responses -> response <- throwLeftM $ aqsl $ AvsQuerySetLicences batch1
forM_ responses $ \AvsLicenceResponse{..} -> case response of
unless (sloppyBool avsResponseSuccess) $ do AvsResponseSetLicencesError{..} -> do
-- TODO: create an Admin Problems overview page let msg = "Set AVS licences failed utterly: " <> avsResponseSetLicencesStatus <> ". Details: " <> cropText avsResponseSetLicencesMessage
$logErrorS "AVS" $ "Set licence failed for " <> tshow avsResponsePersonID <> " due to " <> cropText avsResponseMessage $logErrorS "AVS" msg
throwM $ AvsSetLicencesFailed avsResponseSetLicencesStatus
AvsResponseSetLicences msgs -> do
let (ok,bad') = Set.partition (sloppyBool . avsResponseSuccess) msgs
ok_ids = Set.map avsResponsePersonID ok
bad = Map.withoutKeys (setToMap avsResponsePersonID bad') ok_ids -- it is possible to receive an id multiple times, with only one success, but this is sufficient
batch1_ok = length ok == length batch1
forM_ bad $ \AvsLicenceResponse { avsResponsePersonID=api, avsResponseMessage=msg} ->
$logErrorS "AVS" $ "Set AVS Licence failed for " <> tshow api <> " due to " <> cropText msg
-- TODO: Admin Error page
aux aqsl (batch0_ok && batch1_ok) batch2 -- yay for tail recursion (TODO: maybe refactor?)
-- | Retrieve all currently valid driving licences and check against our database -- | Retrieve all currently valid driving licences and check against our database
-- Only react to changes as compared to last seen status in avs.model -- Only react to changes as compared to last seen status in avs.model
-- TODO: turn into a job, once the interface is actually available -- TODO: run in a background job, once the interface is actually available
checkLicences :: Handler () synchAvsLicences :: Handler Bool
checkLicences = do synchAvsLicences = do
{- AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery
AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery allLicences <- throwLeftM avsQueryGetAllLicences
AvsResponseGetLicences licences <- throwLeftM avsQueryGetAllLicences deltaLicences <- computeDifferingLicences allLicences
setResponse <- setLicencesAvs deltaLicences
if setResponse
then $logInfoS "AVS" "FRADrive Licences written to AVS successfully."
else $logWarnS "AVS" "Writing FRADrive Licences to AVS incomplete."
return setResponse
computeDifferingLicences :: AvsResponseGetLicences -> Handler (Set AvsPersonLicence)
computeDifferingLicences argl = do
(setTo0, setTo1, setTo2) <- getDifferingLicences argl
return $ Set.map (AvsPersonLicence AvsNoLicence) setTo0
<> Set.map (AvsPersonLicence AvsLicenceVorfeld) setTo1
<> Set.map (AvsPersonLicence AvsLicenceRollfeld) setTo2
retrieveDifferingLicences :: Handler (Set AvsPersonId, Set AvsPersonId, Set AvsPersonId)
retrieveDifferingLicences = do
AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery
allLicences <- throwLeftM avsQueryGetAllLicences
getDifferingLicences allLicences
getDifferingLicences :: AvsResponseGetLicences -> Handler (Set AvsPersonId, Set AvsPersonId, Set AvsPersonId)
getDifferingLicences (AvsResponseGetLicences licences) = do
now <- liftIO getCurrentTime
--let (vorfeld, nonvorfeld) = Set.partition (`avsPersonLicenceIs` AvsLicenceVorfeld) licences --let (vorfeld, nonvorfeld) = Set.partition (`avsPersonLicenceIs` AvsLicenceVorfeld) licences
-- rollfeld = Set.filter (`avsPersonLicenceIs` AvsLicenceRollfeld) nonvorfeld -- rollfeld = Set.filter (`avsPersonLicenceIs` AvsLicenceRollfeld) nonvorfeld
let (noOrVorfeld, rollfeld) = Set.spanAntitone (`avsPersonLicenceIsLEQ` AvsLicenceVorfeld) licences -- Note: FRADrive users with 'R' also own 'F' qualification, but AvsGetResponseGetLicences yields only either
(_nolicence , vorfeld) = Set.spanAntitone (`avsPersonLicenceIsLEQ` AvsNoLicence) noOrVorfeld let nowaday = utctDay now
idsRollfeld = avsLicencePersonId <$> Set.toList rollfeld noOne = AvsPersonId 0
idsVorfeld = avsLicencePersonId <$> Set.toList vorfeld vorORrollfeld' = Set.dropWhileAntitone (`avsPersonLicenceIsLEQ` AvsNoLicence) licences
rollfeld' = Set.dropWhileAntitone (`avsPersonLicenceIsLEQ` AvsLicenceVorfeld) vorORrollfeld'
vorORrollfeld = Set.map avsLicencePersonID vorORrollfeld'
rollfeld = Set.map avsLicencePersonID rollfeld'
-- let licenceMap Map.map avsLicencePersonID $ avsMap.fromSet avsLicenceRampLicence licences antijoinAvsLicences :: AvsLicence -> Set AvsPersonId -> DB (Set AvsPersonId,Set AvsPersonId)
-- idsRollfeld = concat $ Map.lookup AvsLicenceRollfeld licenceMap antijoinAvsLicences lic avsLics = fmap unwrapIds $
-- idsVorfeld = concat $ Map.lookup AvsLicenceVorfeld E.select $ do
((_qauli :& _qualUser :& usrAvs) :& excl) <-
E.from $ ( E.table @Qualification
`E.innerJoin` E.table @QualificationUser
`E.on` ( \(quali :& qualUser) ->
(quali E.^. QualificationId E.==. qualUser E.^. QualificationUserQualification)
-- NOTE: filters on the innerJoin must be part of ON-condition in order for anti-join to work!
E.&&. (quali E.^. QualificationAvsLicence E.==. E.justVal lic) -- correct type of licence
E.&&. (E.val nowaday `E.between` (qualUser E.^. QualificationUserFirstHeld
,qualUser E.^. QualificationUserValidUntil)) -- currently valid
E.&&. E.isNothing (qualUser E.^. QualificationUserBlockedDue) -- not blocked
)
`E.innerJoin` E.table @UserAvs
`E.on` (\(_ :& qualUser :& usrAvs) -> qualUser E.^. QualificationUserUser E.==. usrAvs E.^. UserAvsUser)
) `E.fullOuterJoin` E.toValues (set2NonEmpty noOne avsLics) -- left-hand side produces all currently valid matching qualifications
`E.on` (\((_ :& _ :& usrAvs) :& excl) -> usrAvs E.?. UserAvsPersonId E.==. excl)
E.where_ $ E.isNothing excl E.||. E.isNothing (usrAvs E.?. UserAvsPersonId) -- anti join
return (usrAvs E.?. UserAvsPersonId, excl)
now <- liftIO getCurrentTime unwrapIds :: [(E.Value (Maybe AvsPersonId), E.Value (Maybe AvsPersonId))] -> (Set AvsPersonId, Set AvsPersonId)
unwrapIds = mapBoth (Set.delete noOne) . foldr aux mempty
where
aux (_, E.Value(Just api)) (l,r) = (l, Set.insert api r) -- we may assume here that each pair contains precisely one Just constructor
aux (E.Value(Just api), _) (l,r) = (Set.insert api l, r)
aux _ acc = acc -- should never occur
((vorfGrant, vorfRevoke), (rollGrant, rollRevoke)) <- runDB $ (,)
<$> antijoinAvsLicences AvsLicenceVorfeld vorORrollfeld
<*> antijoinAvsLicences AvsLicenceRollfeld rollfeld
let setTo0 = vorfRevoke -- ready to use with SET 0
setTo1 = (vorfGrant Set.\\ rollGrant ) `Set.union` (rollRevoke Set.\\ vorfRevoke)
setTo2 = (rollGrant Set.\\ vorfRevoke) `Set.intersection` (vorfGrant `Set.union` vorORrollfeld)
return (setTo0, setTo1, setTo2)
{- Cases to consider (AVS_Licence,has_valid_F, has_valid_R) -> (vorfeld@(toset,unset), rollfeld@(toset,unset)) :
A (0,0,0) -> ((_,_),(_,_)) : nop; avs_id not returned from queries, no problem
B (0,0,1) -> ((_,_),(x,_)) : nop; do nothing -- CHECK since id is returned by roll-query
C (0,1,0) -> ((x,_),(_,_)) : set F for id
D (0,1,1) -> ((x,_),(x,_)) : set R for id
E (1,0,0) -> ((_,x),(_,_)) : set 0 for id
F (1,0,1) -> ((_,x),(x,_)) : set 0 for id
G (1,1,0) -> ((_,_),(_,_)) : nop
H (1,1,1) -> ((_,_),(x,_)) : set R for id
I (2,0,0) -> ((_,x),(_,x)) : set 0 for id
J (2,0,1) -> ((_,x),(_,_)) : set 0 for id
K (2,1,0) -> ((_,_),(_,x)) : set F for id
L (2,1,1) -> ((_,_),(_,_)) : nop
PROBLEM: B & H in conflict! (Note that nop is automatic except for case B)
Results:
set to 0: determined by vorfeld-unset -- zuerst
set to 1: vorfeld-set && nicht in rollfeld-set || rollfeld-unset && nicht in vorfeld-unset
set to 2: rollfeld-set && nicht in vorfeld-unset && (in vorfeld-set || AVS_Licence>0 == vorORrollfeld)
-}
runDB $ do -- | Always update AVS Data
E.select $ do upsertAvsUser :: Text -> Handler (Maybe UserId) -- TODO: change to Entity
(qauli E.:& qualUser E.:& usrAvs) <- upsertAvsUser (discernAvsCardPersonalNo -> Just someid) = upsertAvsUserByCard someid -- Note: Right case is a number, it could be AvsCardNumber or AvsInternalPersonalNumber; we cannot know, but the latter is much more likely and useful to users!
E.from $ E.table @Qualification upsertAvsUser otherId = -- attempt LDAP lookup to find by eMail
`E.innerJoin` E.table @QualificationUser try (runDB $ ldapLookupAndUpsert otherId) >>= \case
`E.on` (\(quali E.:& qualUser) -> qual E.^. QualificationId E.==. qualUser E.^. QualificationUserQualification) Right Entity{entityVal=User{userCompanyPersonalNumber=Just persNo}} -> upsertAvsUserByCard (Right $ mkAvsInternalPersonalNo persNo)
`E.innerJoin` E.table @UserAvs Left (_err::SomeException) -> return Nothing -- TODO: ; merely for convenience, not necessary right now
`E.on` (\(_ E.:& qualUser E.:& usrAvs) -> qualUser E.^. QualificationUserUser E.==. usrAvs E.^. UserAvsUser) _ -> return Nothing
E.where_ $ E.isJust (quali E.^. QualificationAvsLicence)
E.&&. (usrAvs E.^. QualificationAvsLicence `E.notIn` E.valList
-- WAS WILL ICH HIER WIRKLICH:
-- Liefere alle avsIds, welche die falsche Qualifikation zugewiesen bekommen haben?
-- Wie erhalte ich alle IDs, welche es KEINE Qualifikation haben? FROM valList scheint es nicht zu geben!
return
( userAvs E.^. UserAvsPersonId
, quali E.^. QualificationAvsLicence
)
--TODO this must be chunked into separate jobs/tasks
--forM licences $ \AvsPersonLicence{..} -> do
-}
error "CONTINUE HERE" -- TODO STUB
upsertAvsUser :: Text -> Handler (Maybe UserId) -- | Given CardNo or internal Number, retrieve UserId. Create non-existing users, if possible. Always update.
upsertAvsUser (discernAvsCardPersonalNo -> Just someid) = upsertAvsUserByCard someid -- Note: Right case is a number, it could be AvsPersonId or AvsInternalPersonalNumber; we cannot know, but the latter is much more likely and useful to users!
upsertAvsUser _other = return Nothing -- TODO: attempt LDAP lookup to find by eMail; merely for convenience, not necessary right now
{- maybe this code helps?
upsRes :: Either CampusUserConversionException (Entity User)
<- try $ upsertCampusUserByOther persNo
case upsRes of
Right Entity{entityKey=uid} -> insertUniqueEntity $ UserAvs api uid
_other -> return mbuid -- ==Nothing -- user could not be created somehow
-}
-- | Given CardNo or internal Number, retrieve UserId. Create non-existing users, if possible.
-- Throws errors if the avsInterface in unavailable or the user is non-unique within external AVS DB. -- Throws errors if the avsInterface in unavailable or the user is non-unique within external AVS DB.
upsertAvsUserByCard :: Either AvsFullCardNo AvsInternalPersonalNo -> Handler (Maybe UserId) -- Idee: Eingabe ohne Punkt is AvsInternalPersonalNo mit Punkt is Ausweisnummer?! upsertAvsUserByCard :: Either AvsFullCardNo AvsInternalPersonalNo -> Handler (Maybe UserId) -- Idee: Eingabe ohne Punkt is AvsInternalPersonalNo mit Punkt is Ausweisnummer?!
upsertAvsUserByCard persNo = do upsertAvsUserByCard persNo = do
@ -187,11 +263,12 @@ upsertAvsUserByCard persNo = do
case Set.elems adps of case Set.elems adps of
[] -> throwM AvsPersonSearchEmpty [] -> throwM AvsPersonSearchEmpty
(_:_:_) -> throwM AvsPersonSearchAmbiguous (_:_:_) -> throwM AvsPersonSearchAmbiguous
[AvsDataPerson{avsPersonPersonID=appi}] -> do [AvsDataPerson{avsPersonPersonID=api}] -> upsertAvsUserById api -- always trigger an update
mbuid <- runDB $ getBy $ UniqueUserAvsId appi -- do
case mbuid of -- mbuid <- runDB $ getBy $ UniqueUserAvsId api
(Just (Entity _ UserAvs{userAvsUser=uau})) -> return $ Just uau -- case mbuid of
Nothing -> upsertAvsUserById appi -- (Just (Entity _ UserAvs{userAvsUser=uau})) -> return $ Just uau
-- Nothing -> upsertAvsUserById api
@ -204,16 +281,18 @@ upsertAvsUserById api = do
mbuid <- getBy (UniqueUserAvsId api) mbuid <- getBy (UniqueUserAvsId api)
case (mbuid, mbapd) of case (mbuid, mbapd) of
(Nothing, Just AvsDataPerson{..}) -- FRADriver User does not exist yet, but found in AVS and has Internal Personal Number (Nothing, Just AvsDataPerson{..}) -- FRADriver User does not exist yet, but found in AVS and has Internal Personal Number
| Just persNo <- avsPersonInternalPersonalNo -> do | Just (avsInternalPersonalNo -> persNo) <- canonical avsPersonInternalPersonalNo -> do
candidates <- selectKeysList [UserCompanyPersonalNumber ==. avsPersonInternalPersonalNo] [] $logInfoS "AVS" $ "Creating new user with avsInternalPersonalNo " <> tshow persNo
candidates <- selectKeysList [UserCompanyPersonalNumber ==. Just persNo] []
case candidates of case candidates of
[uid] -> insertUniqueEntity $ UserAvs api uid [uid] -> $logInfoS "AVS" "Matching user found, linking." >> insertUniqueEntity (UserAvs api uid avsPersonPersonNo)
(_:_) -> throwM AvsUserAmbiguous (_:_) -> throwM AvsUserAmbiguous
[] -> do [] -> do
upsRes :: Either CampusUserConversionException (Entity User) upsRes :: Either CampusUserConversionException (Entity User)
<- try $ upsertCampusUserByCn persNo <- try $ ldapLookupAndUpsert persNo
$logInfoS "AVS" $ "No matching existing user found. Attempted LDAP upsert returned: " <> tshow upsRes
case upsRes of case upsRes of
Right Entity{entityKey=uid} -> insertUniqueEntity $ UserAvs api uid -- pin/addr are updated in next step anyway Right Entity{entityKey=uid} -> insertUniqueEntity $ UserAvs api uid avsPersonPersonNo -- pin/addr are updated in next step anyway
_other -> return mbuid -- ==Nothing -- user could not be created somehow _other -> return mbuid -- ==Nothing -- user could not be created somehow
_other -> return mbuid _other -> return mbuid
case (mbuid, mbapd) of case (mbuid, mbapd) of
@ -222,10 +301,10 @@ upsertAvsUserById api = do
let firmAddress = guessLicenceAddress avsPersonPersonCards let firmAddress = guessLicenceAddress avsPersonPersonCards
mbCompany = firmAddress ^? _Just . _1 . _Just mbCompany = firmAddress ^? _Just . _1 . _Just
userFirmAddr= plaintextToStoredMarkup . mergeCompanyAddress <$> firmAddress userFirmAddr= plaintextToStoredMarkup . mergeCompanyAddress <$> firmAddress
addrCard = firmAddress ^? _Just . _3
pinCard = Set.lookupMax avsPersonPersonCards pinCard = Set.lookupMax avsPersonPersonCards
userPin = tshowAvsFullCardNo . getFullCardNo <$> pinCard userPin = tshowAvsFullCardNo . getFullCardNo <$> pinCard
fakeIdent = CI.mk $ "AVSID:" <> tshow api fakeIdent = CI.mk $ "AVSID:" <> tshow api
fakeNo = CI.mk $ "AVSNO:" <> tshow avsPersonPersonNo
newUsr = AdminUserForm newUsr = AdminUserForm
{ aufTitle = Nothing { aufTitle = Nothing
, aufFirstName = avsPersonFirstName , aufFirstName = avsPersonFirstName
@ -236,65 +315,58 @@ upsertAvsUserById api = do
, aufSex = Nothing , aufSex = Nothing
, aufMobile = Nothing , aufMobile = Nothing
, aufTelephone = Nothing , aufTelephone = Nothing
, aufFPersonalNumber = avsPersonInternalPersonalNo , aufFPersonalNumber = avsInternalPersonalNo <$> canonical avsPersonInternalPersonalNo
, aufFDepartment = Nothing , aufFDepartment = Nothing
, aufPostAddress = userFirmAddr , aufPostAddress = userFirmAddr
, aufPrefersPostal = isJust firmAddress , aufPrefersPostal = True
, aufPinPassword = userPin , aufPinPassword = userPin
, aufEmail = fakeIdent -- Email is unknown in this version of the avs query, to be updated later (FUTURE TODO) , aufEmail = fakeNo -- Email is unknown in this version of the avs query, to be updated later (FUTURE TODO)
, aufIdent = fakeIdent -- use AvsPersonId instead , aufIdent = fakeIdent -- use AvsPersonId instead
, aufAuth = maybe AuthKindNoLogin (const AuthKindLDAP) avsPersonInternalPersonalNo -- FUTURE TODO: if email is known, use AuthKinfPWHash for email invite, if no internal personal number is known , aufAuth = maybe AuthKindNoLogin (const AuthKindLDAP) avsPersonInternalPersonalNo -- FUTURE TODO: if email is known, use AuthKinfPWHash for email invite, if no internal personal number is known
} }
mbUid <- addNewUser newUsr -- triggers JobSynchroniseLdapUser, JobSendPasswordReset and NotificationUserAutoModeUpdate -- TODO: check if these are failsafe mbUid <- addNewUser newUsr -- triggers JobSynchroniseLdapUser, JobSendPasswordReset and NotificationUserAutoModeUpdate -- TODO: check if these are failsafe
whenIsJust mbUid $ \uid -> runDB $ do whenIsJust mbUid $ \uid -> runDB $ do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
insert_ $ UserAvs avsPersonPersonID uid insert_ $ UserAvs avsPersonPersonID uid avsPersonPersonNo
-- forM_ avsPersonPersonCards $ -- save all cards for later forM_ avsPersonPersonCards $ -- save all cards for later
let cs :: Set AvsDataPersonCard = Set.fromList $ catMaybes [pinCard, addrCard] -- let cs :: Set AvsDataPersonCard = Set.fromList $ catMaybes [pinCard, addrCard]
forM_ cs $ -- only save used cards for the postal address update detection -- forM_ cs $ -- only save used cards for the postal address update detection
\avsCard -> insert_ $ UserAvsCard avsPersonPersonID (avsDataCardNo avsCard) avsCard now \avsCard -> insert_ $ UserAvsCard avsPersonPersonID (avsDataCardNo avsCard) avsCard now
upsertUserCompany uid mbCompany upsertUserCompany uid mbCompany
return mbUid return mbUid
(Just (Entity _ UserAvs{userAvsUser=uid}), Just AvsDataPerson{avsPersonPersonCards}) -> do -- known user, update address and pinPassword (Just (Entity _ UserAvs{userAvsUser=uid}), Just AvsDataPerson{avsPersonPersonCards}) -> do -- known user, update address and pinPassword
let firmAddress = guessLicenceAddress avsPersonPersonCards let firmAddress = guessLicenceAddress avsPersonPersonCards
mbCompany = firmAddress ^? _Just . _1 . _Just mbCompany = firmAddress ^? _Just . _1 . _Just
userFirmAddr= plaintextToStoredMarkup . mergeCompanyAddress <$> firmAddress mbCoFirmAddr= mergeCompanyAddress <$> firmAddress
addrCard = firmAddress ^? _Just . _3 userFirmAddr= plaintextToStoredMarkup <$> mbCoFirmAddr
pinCard = Set.lookupMax avsPersonPersonCards pinCard = Set.lookupMax avsPersonPersonCards
userPin = tshowAvsFullCardNo . getFullCardNo <$> pinCard userPin = tshowAvsFullCardNo . getFullCardNo <$> pinCard
runDB $ do runDB $ do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
upsertUserCompany uid mbCompany oldCards <- selectList [UserAvsCardPersonId ==. api] []
whenIsJust addrCard $ \aCard -> let oldAddrs = Set.fromList $ mapMaybe (maybeCompanyAddress . userAvsCardCard . entityVal) oldCards
getBy (UniqueAvsCard $ avsDataCardNo aCard) >>= \case unless (maybe True (`Set.member` oldAddrs) mbCoFirmAddr) $ do -- update postal address, unless the exact address had been seen before
(Just (Entity uac UserAvsCard{..})) | aCard == userAvsCardCard -> -- address seen before, no change updateWhere [UserId ==. uid] [UserPostAddress =. userFirmAddr]
update uac [UserAvsCardLastSynch =. now] whenIsJust pinCard $ \pCard -> -- update pin, but only if it was unset or set to the value of an old card
_ -> do -- possibly new address data unlessM (exists [UserAvsCardCardNo ==. avsDataCardNo pCard]) $ do
void $ upsert UserAvsCard
{ userAvsCardPersonId = api
, userAvsCardCardNo = avsDataCardNo aCard
, userAvsCardCard = aCard
, userAvsCardLastSynch= now
}
[ UserAvsCardCard =. aCard
, UserAvsCardLastSynch =. now
]
when (isJust userFirmAddr) $ updateWhere [UserId ==. uid] [UserPostAddress =. userFirmAddr]
whenIsJust pinCard $ \pCard ->
unlessM (exists [UserAvsCardCardNo ==. avsDataCardNo pCard]) $ do
-- update pin, but only if it was unset or set to the value of an old card
oldCards <- selectList [UserAvsCardPersonId ==. api] []
let oldPins = Just . tshowAvsFullCardNo . getFullCardNo . userAvsCardCard . entityVal <$> oldCards let oldPins = Just . tshowAvsFullCardNo . getFullCardNo . userAvsCardCard . entityVal <$> oldCards
updateWhere [UserId ==. uid, UserPinPassword !=. userPin, UserPinPassword <-. Nothing:oldPins] updateWhere [UserId ==. uid, UserPinPassword !=. userPin, UserPinPassword <-. Nothing:oldPins]
[UserPinPassword =. userPin] [UserPinPassword =. userPin]
insert_ $ UserAvsCard api (avsDataCardNo pCard) pCard now insert_ $ UserAvsCard api (avsDataCardNo pCard) pCard now
upsertUserCompany uid mbCompany
forM_ avsPersonPersonCards $ \aCard -> void $ upsert UserAvsCard
{ userAvsCardPersonId = api
, userAvsCardCardNo = avsDataCardNo aCard
, userAvsCardCard = aCard
, userAvsCardLastSynch = now
}
[ UserAvsCardCard =. aCard
, UserAvsCardLastSynch =. now
]
return $ Just uid return $ Just uid
lookupAvsUser :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) => lookupAvsUser :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) =>
AvsPersonId -> m (Maybe AvsDataPerson) AvsPersonId -> m (Maybe AvsDataPerson)
lookupAvsUser api = Map.lookup api <$> lookupAvsUsers (Set.singleton api) lookupAvsUser api = Map.lookup api <$> lookupAvsUsers (Set.singleton api)
@ -317,3 +389,26 @@ lookupAvsUsers apis = do
AvsResponsePerson adps <- throwLeftM . avsQueryPerson $ def{avsPersonQueryCardNo = Just avsDataCardNo, avsPersonQueryVersionNo = Just avsDataVersionNo} AvsResponsePerson adps <- throwLeftM . avsQueryPerson $ def{avsPersonQueryCardNo = Just avsDataCardNo, avsPersonQueryVersionNo = Just avsDataVersionNo}
return $ mergeByPersonId adps acc2 return $ mergeByPersonId adps acc2
-- | Like `Handler.Utils.getReceivers`, but calls upsertAvsUserById on each user to ensure that postal address is up-to-date
updateReceivers :: UserId -> Handler (Entity User, [Entity User], Bool)
updateReceivers uid = do
(underling :: Entity User, avsUnderling :: Maybe (Entity UserAvs), avsSupers :: [Entity UserAvs]) <- runDB $ (,,)
<$> getJustEntity uid
<*> getBy (UniqueUserAvsUser uid)
<*> (E.select $ do
(usrSuper :& usrAvs) <-
E.from $ E.table @UserSupervisor
`E.innerJoin` E.table @UserAvs
`E.on` (\(usrSuper :& userAvs) ->usrSuper E.^. UserSupervisorSupervisor E.==. userAvs E.^. UserAvsUser)
E.where_ $ (usrSuper E.^. UserSupervisorUser E.==. E.val uid)
E.&&. (usrSuper E.^. UserSupervisorRerouteNotifications)
pure usrAvs
)
let toUpdate = Set.fromList (userAvsPersonId . entityVal <$> mcons avsUnderling avsSupers)
forM_ toUpdate (void . upsertAvsUserById) -- update postaddress from AVS
let receiverIDs :: [UserId] = userAvsUser . entityVal <$> avsSupers
receivers <- runDB (catMaybes <$> mapM getEntity receiverIDs)
return $ if null receivers
then (underling, pure underling, True)
else (underling, receivers, underling `elem` receivers)

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

@ -18,4 +18,3 @@ determineSystemFunctions ldapFuncs = \case
-- SJ: not sure this LDAP-specific key belongs here? -- SJ: not sure this LDAP-specific key belongs here?
SystemStudent -> False -- "student" `Set.member` ldapFuncs -- no such key identified at FraPort SystemStudent -> False -- "student" `Set.member` ldapFuncs -- no such key identified at FraPort
SystemPrinter -> False -- "department=IFM-IS2" zu viele Mitglieder SystemPrinter -> False -- "department=IFM-IS2" zu viele Mitglieder
SystemSap -> False

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

@ -11,6 +11,9 @@ import Import hiding (link)
import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Legacy as E
import qualified Database.Esqueleto.Utils as E hiding ((->.)) import qualified Database.Esqueleto.Utils as E hiding ((->.))
import Database.Esqueleto.Utils (mkExactFilter, mkExactFilterWith, mkContainsFilter, mkContainsFilterWith, anyFilter) import Database.Esqueleto.Utils (mkExactFilter, mkExactFilterWith, mkContainsFilter, mkContainsFilterWith, anyFilter)
--import Database.Esqueleto.Experimental ((:&)(..))
--import qualified Database.Esqueleto.Experimental as Ex
import Handler.Utils.Table.Cells import Handler.Utils.Table.Cells
import Handler.Utils.Table.Pagination import Handler.Utils.Table.Pagination
@ -705,6 +708,39 @@ fltrRelevantStudyFeaturesSemesterUI :: DBFilterUI
fltrRelevantStudyFeaturesSemesterUI = fltrFeaturesSemesterUI fltrRelevantStudyFeaturesSemesterUI = fltrFeaturesSemesterUI
---------------
-- Companies --
---------------
{-
-- 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
let uid = heu ^. hasEntity . _entityKey
companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
return (comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor)
let companies = intersperse (text2markup ", ") $
(\(E.Value cmpName, E.Value cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> companies'
icnSuper = text2markup " " <> icon IconSupervisor
cell $ toWgt $ mconcat companies
-}
colUserCompany' :: (IsDBTable (YesodDB UniWorX) c, HasEntity a User) => Colonnade Sortable a (DBCell (YesodDB UniWorX) c)
colUserCompany' = sortable (Just "user-company") (i18nCell MsgTableCompany) $ \heu ->
let uid = heu ^. hasEntity . _entityKey in
sqlCell $ do
companies' <- E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
return (comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor)
let companies = intersperse (text2markup ", ") $
(\(E.Value cmpName, E.Value cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> companies'
icnSuper = text2markup " " <> icon IconSupervisor
pure $ toWgt $ mconcat companies
---------------------------- ----------------------------
-- Colonnade manipulation -- -- Colonnade manipulation --
---------------------------- ----------------------------

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

@ -48,7 +48,7 @@ module Handler.Utils.Table.Pagination
, linkEitherCell, linkEitherCellM, linkEitherCellM' , linkEitherCell, linkEitherCellM, linkEitherCellM'
, maybeAnchorCellM, maybeAnchorCellM', maybeLinkEitherCellM' , maybeAnchorCellM, maybeAnchorCellM', maybeLinkEitherCellM'
, anchorCellC, anchorCellCM, anchorCellCM', linkEitherCellCM', maybeLinkEitherCellCM' , anchorCellC, anchorCellCM, anchorCellCM', linkEitherCellCM', maybeLinkEitherCellCM'
, cellTooltip , cellTooltip, cellTooltipIcon
, listCell, listCell', listCellOf, listCellOf' , listCell, listCell', listCellOf, listCellOf'
, ilistCell, ilistCell', ilistCellOf, ilistCellOf' , ilistCell, ilistCell', ilistCellOf, ilistCellOf'
, formCell, DBFormResult(..), getDBFormResult , formCell, DBFormResult(..), getDBFormResult
@ -1689,10 +1689,13 @@ i18nCell msg = cell $ do
toWidget $ mr msg toWidget $ mr msg
cellTooltip :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a -> DBCell m a cellTooltip :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a -> DBCell m a
cellTooltip msg = cellContents.mapped %~ (<> tipWdgt) cellTooltip = cellTooltipIcon Nothing
cellTooltipIcon :: (RenderMessage UniWorX msg, IsDBTable m a) => Maybe Icon -> msg -> DBCell m a -> DBCell m a
cellTooltipIcon icn msg = cellContents.mapped %~ (<> tipWdgt)
where where
tipWdgt = iconTooltip (msg2widget msg) Nothing True tipWdgt = iconTooltip (msg2widget msg) icn True
-- | Always display widget; maybe a link if user is Authorized. -- | Always display widget; maybe a link if user is Authorized.
-- Also see variant `linkEmptyCell` -- Also see variant `linkEmptyCell`
anchorCell :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a) => url -> wgt -> DBCell m a anchorCell :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a) => url -> wgt -> DBCell m a

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

@ -47,14 +47,13 @@ import qualified Data.Text as Text
import Jobs.Types(Job, JobChildren) import Jobs.Types(Job, JobChildren)
abbrvName :: User -> Text abbrvName :: User -> Text
abbrvName User{userDisplayName, userFirstName, userSurname} = abbrvName User{userDisplayName, userFirstName, userSurname} =
if | (lastDisplayName : tsrif) <- reverse nameParts if | (lastDisplayName : tsrif) <- reverse nameParts
-> assemble $ reverse $ lastDisplayName : abbreviate tsrif -> assemble $ reverse $ lastDisplayName : abbreviate tsrif
| otherwise | otherwise
-> assemble $ abbreviate (Text.words userFirstName) <> [userSurname] -> assemble $ abbreviate (Text.words userFirstName) <> [userSurname]
where where
nameParts = Text.words userDisplayName nameParts = Text.words userDisplayName
abbreviate = fmap (Text.take 1) abbreviate = fmap (Text.take 1)
assemble = Text.intercalate "." assemble = Text.intercalate "."
@ -72,11 +71,11 @@ userPrefersEmail = not . userPrefersLetter
getPostalPreferenceAndAddress :: User -> (Bool, Maybe [Text]) getPostalPreferenceAndAddress :: User -> (Bool, Maybe [Text])
getPostalPreferenceAndAddress usr@User{..} = getPostalPreferenceAndAddress usr@User{..} =
(((userPrefersPostal || isNothing userPinPassword) && postPossible) || emailImpossible, pa) (((userPrefersPostal || isNothing userPinPassword) && postPossible) || emailImpossible, pa)
where where
orgEmail = CI.original userEmail orgEmail = CI.original userEmail
emailImpossible = not ('@' `textElem` orgEmail && '.' `textElem` orgEmail) emailImpossible = not ('@' `textElem` orgEmail && '.' `textElem` orgEmail)
postPossible = isJust pa postPossible = isJust pa
pa = getPostalAddress usr pa = getPostalAddress usr
getPostalAddress :: User -> Maybe [Text] getPostalAddress :: User -> Maybe [Text]
getPostalAddress User{..} getPostalAddress User{..}
@ -85,22 +84,23 @@ getPostalAddress User{..}
| Just abt <- userCompanyDepartment | Just abt <- userCompanyDepartment
= Just $ if | "BVD" `isPrefixOf` abt -> [userDisplayName, abt, "Bodenverkehrsdienste"] = Just $ if | "BVD" `isPrefixOf` abt -> [userDisplayName, abt, "Bodenverkehrsdienste"]
| otherwise -> [userDisplayName, abt, "Hausbriefkasten" ] | otherwise -> [userDisplayName, abt, "Hausbriefkasten" ]
| otherwise | otherwise
= Nothing = Nothing
-- | Return Entity User and all Supervisors with rerouteNotifications as well as -- | DEPRECATED, use Handler.Utis.Avs. updateReceivers instead
-- Return Entity User and all Supervisors with rerouteNotifications as well as
-- a boolean indicating if the user is own supervisor with rerouteNotifications -- a boolean indicating if the user is own supervisor with rerouteNotifications
getReceivers :: UserId -> DB (Entity User, [Entity User], Bool) getReceivers :: UserId -> DB (Entity User, [Entity User], Bool)
getReceivers uid = do getReceivers uid = do
underling <- getJustEntity uid underling <- getJustEntity uid
superVs <- selectList [UserSupervisorUser ==. uid, UserSupervisorRerouteNotifications ==. True] [] superVs <- selectList [UserSupervisorUser ==. uid, UserSupervisorRerouteNotifications ==. True] []
let superIds = userSupervisorSupervisor . entityVal <$> superVs let superIds = userSupervisorSupervisor . entityVal <$> superVs
if null superIds if null superIds
then return (underling, [underling], True) then return (underling, [underling], True)
else do else do
supers <- selectList [UserId <-. superIds] [] supers <- selectList [UserId <-. superIds] []
if null supers then return (underling, [underling], True) if null supers then return (underling, [underling], True)
else else
return (underling, supers, uid `elem` (entityKey <$> supers)) return (underling, supers, uid `elem` (entityKey <$> supers))
@ -152,7 +152,7 @@ matchesName (repack -> haystack) (repack -> needle)
guessUser :: PredDNF GuessUserInfo -- ^ guessing criteria guessUser :: PredDNF GuessUserInfo -- ^ guessing criteria
-> Maybe Int64 -- ^ Should the query be limited to a maximum number of results? -> Maybe Int64 -- ^ Should the query be limited to a maximum number of results?
-> DB (Maybe (Either (NonEmpty (Entity User)) (Entity User))) -- ^ Just (Left _) in case of multiple results, -> DB (Maybe (Either (NonEmpty (Entity User)) (Entity User))) -- ^ Just (Left _) in case of multiple results,
-- Just (Right _) in case of single result, and -- Just (Right _) in case of single result, and
-- Nothing in case of no result -- Nothing in case of no result
guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria) mQueryLimit = $cachedHereBinary criteria $ go False guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria) mQueryLimit = $cachedHereBinary criteria $ go False
@ -161,7 +161,7 @@ guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria)
asWords = filter (not . Text.null) . Text.words . Text.strip asWords = filter (not . Text.null) . Text.words . Text.strip
containsAsSet x y = E.and . map (\y' -> x `E.hasInfix` E.val y') $ asWords y containsAsSet x y = E.and . map (\y' -> x `E.hasInfix` E.val y') $ asWords y
toSql user pl = bool id E.not_ (is _PLNegated pl) $ case pl ^. _plVar of toSql user pl = bool id E.not_ (is _PLNegated pl) $ case pl ^. _plVar of
GuessUserMatrikelnummer userMatriculation' -> user E.^. UserMatrikelnummer E.==. E.val (Just userMatriculation') GuessUserMatrikelnummer userMatriculation' -> user E.^. UserMatrikelnummer E.==. E.val (Just userMatriculation')
GuessUserEduPersonPrincipalName userEPPN' -> user E.^. UserLdapPrimaryKey E.==. E.val (Just userEPPN') GuessUserEduPersonPrincipalName userEPPN' -> user E.^. UserLdapPrimaryKey E.==. E.val (Just userEPPN')
@ -184,7 +184,7 @@ guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria)
$ criteria ^.. folded) $ criteria ^.. folded)
closeness :: Entity User -> Entity User -> Ordering closeness :: Entity User -> Entity User -> Ordering
closeness ul ur = maximum $ impureNonNull $ criteria <&> \term -> closeness ul ur = maximum $ impureNonNull $ criteria <&> \term ->
let let
matches userField name = _entityVal . userField . to (`matchesName` name) matches userField name = _entityVal . userField . to (`matchesName` name)
comp True userField guess = (term ^.. folded . _PLVariable . guess) <&> \name -> comp True userField guess = (term ^.. folded . _PLVariable . guess) <&> \name ->
@ -203,7 +203,7 @@ guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria)
] ]
, b <- [True,False] , b <- [True,False]
] ]
-- Assuming the input list is sorted in descending order by closeness: -- Assuming the input list is sorted in descending order by closeness:
takeClosest [] = [] takeClosest [] = []
takeClosest [x] = [x] takeClosest [x] = [x]
@ -235,7 +235,7 @@ guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria)
convertLdapResults [] = Nothing convertLdapResults [] = Nothing
convertLdapResults [x] = Just $ Right x convertLdapResults [x] = Just $ Right x
convertLdapResults xs = Just $ Left $ NonEmpty.fromList xs convertLdapResults xs = Just $ Left $ NonEmpty.fromList xs
if if
| [x] <- users' | [x] <- users'
, Just True == matchesMatriculation x || didLdap , Just True == matchesMatriculation x || didLdap
@ -279,9 +279,9 @@ assimilateUser :: UserId -- ^ @newUserId@
-- ^ Move all relevant properties (submissions, corrections, grades, ...) from @oldUserId@ to @newUserId@ -- ^ Move all relevant properties (submissions, corrections, grades, ...) from @oldUserId@ to @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
E.insertSelectWithConflict E.insertSelectWithConflict
UniqueCourseFavourite UniqueCourseFavourite
(E.from $ \courseFavourite -> do (E.from $ \courseFavourite -> do
E.where_ $ courseFavourite E.^. CourseFavouriteUser E.==. E.val oldUserId E.where_ $ courseFavourite E.^. CourseFavouriteUser E.==. E.val oldUserId
return $ CourseFavourite return $ CourseFavourite
@ -398,7 +398,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
) )
(\_current _excluded -> []) (\_current _excluded -> [])
deleteWhere [ SubmissionUserUser ==. oldUserId ] deleteWhere [ SubmissionUserUser ==. oldUserId ]
do do
collisions <- E.select . E.from $ \((submissionGroupUserA `E.InnerJoin` submissionGroupA) `E.InnerJoin` (submissionGroupUserB `E.InnerJoin` submissionGroupB)) -> do collisions <- E.select . E.from $ \((submissionGroupUserA `E.InnerJoin` submissionGroupA) `E.InnerJoin` (submissionGroupUserB `E.InnerJoin` submissionGroupB)) -> do
E.on $ submissionGroupB E.^. SubmissionGroupId E.==. submissionGroupUserB E.^. SubmissionGroupUserSubmissionGroup E.on $ submissionGroupB E.^. SubmissionGroupId E.==. submissionGroupUserB E.^. SubmissionGroupUserSubmissionGroup
@ -587,7 +587,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
) )
(\current excluded -> [ ExamPartResultLastChanged E.=. E.max (current E.^. ExamPartResultLastChanged) (excluded E.^. ExamPartResultLastChanged) ]) (\current excluded -> [ ExamPartResultLastChanged E.=. E.max (current E.^. ExamPartResultLastChanged) (excluded E.^. ExamPartResultLastChanged) ])
deleteWhere [ ExamPartResultUser ==. oldUserId ] deleteWhere [ ExamPartResultUser ==. oldUserId ]
do do
collision <- E.selectMaybe . E.from $ \(examBonusA `E.InnerJoin` examBonusB) -> do collision <- E.selectMaybe . E.from $ \(examBonusA `E.InnerJoin` examBonusB) -> do
E.on $ examBonusA E.^. ExamBonusExam E.==. examBonusB E.^. ExamBonusExam E.on $ examBonusA E.^. ExamBonusExam E.==. examBonusB E.^. ExamBonusExam
@ -609,7 +609,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
) )
(\current excluded -> [ ExamBonusLastChanged E.=. E.max (current E.^. ExamBonusLastChanged) (excluded E.^. ExamBonusLastChanged) ]) (\current excluded -> [ ExamBonusLastChanged E.=. E.max (current E.^. ExamBonusLastChanged) (excluded E.^. ExamBonusLastChanged) ])
deleteWhere [ ExamBonusUser ==. oldUserId ] deleteWhere [ ExamBonusUser ==. oldUserId ]
let getExamResults = selectSource [ ExamResultUser ==. oldUserId ] [] let getExamResults = selectSource [ ExamResultUser ==. oldUserId ] []
upsertExamResult oldEREnt@(Entity oldERId oldER) = do upsertExamResult oldEREnt@(Entity oldERId oldER) = do
newER' <- getBy $ UniqueExamResult (examResultExam oldER) newUserId newER' <- getBy $ UniqueExamResult (examResultExam oldER) newUserId
@ -775,19 +775,19 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
delete oldSFId delete oldSFId
in runConduit $ getStudyFeatures .| C.mapM_ upsertStudyFeatures in runConduit $ getStudyFeatures .| C.mapM_ upsertStudyFeatures
-- Qualifications and ongoing LMS -- Qualifications and ongoing LMS
-- LmsUser: insertSelectWithConflict impossible due to 2 simultaneous uniqueness constraints; UniqueLmsIdent requires proper update, prohibits insert and then delete -- LmsUser: insertSelectWithConflict impossible due to 2 simultaneous uniqueness constraints; UniqueLmsIdent requires proper update, prohibits insert and then delete
-- updateWhere [ LmsUserUser ==. oldUserId ] [ LmsUserUser =. newUserId ] -- might fail due to UniqueLmsQualficationUuser -- updateWhere [ LmsUserUser ==. oldUserId ] [ LmsUserUser =. newUserId ] -- might fail due to UniqueLmsQualficationUuser
oldLms <- selectList [ LmsUserUser ==. oldUserId ] [ Asc LmsUserQualification ] oldLms <- selectList [ LmsUserUser ==. oldUserId ] [ Asc LmsUserQualification ]
newLms <- selectList [ LmsUserUser ==. newUserId ] [ Asc LmsUserQualification ] newLms <- selectList [ LmsUserUser ==. newUserId ] [ Asc LmsUserQualification ]
let projQ = lmsUserQualification . entityVal let projQ = lmsUserQualification . entityVal
oldQs = Set.fromList (projQ <$> oldLms) oldQs = Set.fromList (projQ <$> oldLms)
newQs = Set.fromList (projQ <$> newLms) newQs = Set.fromList (projQ <$> newLms)
qConflicts = oldQs `Set.intersection` newQs qConflicts = oldQs `Set.intersection` newQs
qResolvable = Set.fromList [ lmsUserQualification | Entity _ LmsUser{..} <- oldLms, isJust lmsUserEnded, lmsUserQualification `Set.member` qConflicts ] qResolvable = Set.fromList [ lmsUserQualification | Entity _ LmsUser{..} <- oldLms, isJust lmsUserEnded, lmsUserQualification `Set.member` qConflicts ]
qProblems = qConflicts `Set.difference` qResolvable qProblems = qConflicts `Set.difference` qResolvable
unless (Set.null qProblems) $ tellError $ UserAssimilateConflictingLmsQualifications qProblems unless (Set.null qProblems) $ tellError $ UserAssimilateConflictingLmsQualifications qProblems
unless (Set.null qResolvable) $ deleteWhere [ LmsUserUser ==. oldUserId, LmsUserQualification <-. Set.toList qResolvable ] -- delete conflicting and finished LMS, which are still within auditDuration unless (Set.null qResolvable) $ deleteWhere [ LmsUserUser ==. oldUserId, LmsUserQualification <-. Set.toList qResolvable ] -- delete conflicting and finished LMS, which are still within auditDuration
updateWhere [ LmsUserUser ==. oldUserId ] [ LmsUserUser =. newUserId ] updateWhere [ LmsUserUser ==. oldUserId ] [ LmsUserUser =. newUserId ]
updateWhere [ QualificationEditUser ==. oldUserId ] [ QualificationEditUser =. newUserId ] updateWhere [ QualificationEditUser ==. oldUserId ] [ QualificationEditUser =. newUserId ]
E.insertSelectWithConflict E.insertSelectWithConflict
@ -802,19 +802,19 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
E.<&> (qualificationUser E.^. QualificationUserFirstHeld) E.<&> (qualificationUser E.^. QualificationUserFirstHeld)
E.<&> (qualificationUser E.^. QualificationUserBlockedDue) E.<&> (qualificationUser E.^. QualificationUserBlockedDue)
) )
(\current excluded -> (\current excluded ->
[ QualificationUserValidUntil E.=. combineWith current excluded E.greatest QualificationUserValidUntil [ QualificationUserValidUntil E.=. combineWith current excluded E.greatest QualificationUserValidUntil
, QualificationUserLastRefresh E.=. combineWith current excluded E.greatest QualificationUserLastRefresh , QualificationUserLastRefresh E.=. combineWith current excluded E.greatest QualificationUserLastRefresh
, QualificationUserFirstHeld E.=. combineWith current excluded E.least QualificationUserFirstHeld , QualificationUserFirstHeld E.=. combineWith current excluded E.least QualificationUserFirstHeld
, QualificationUserBlockedDue E.=. combineWith current excluded E.greatest QualificationUserBlockedDue -- Tested: PostgreSQL GREATEST/LEAST ignores NULL values , QualificationUserBlockedDue E.=. combineWith current excluded E.greatest QualificationUserBlockedDue -- Tested: PostgreSQL GREATEST/LEAST ignores NULL values
] ]
) )
deleteWhere [ QualificationUserUser ==. oldUserId ] deleteWhere [ QualificationUserUser ==. oldUserId ]
-- Supervision is fully merged -- Supervision is fully merged
E.insertSelectWithConflict E.insertSelectWithConflict
UniqueUserSupervisor UniqueUserSupervisor
(E.from $ \userSupervisor -> do (E.from $ \userSupervisor -> do
E.where_ $ userSupervisor E.^. UserSupervisorSupervisor E.==. E.val oldUserId E.where_ $ userSupervisor E.^. UserSupervisorSupervisor E.==. E.val oldUserId
return $ UserSupervisor return $ UserSupervisor
E.<# E.val newUserId E.<# E.val newUserId
@ -822,11 +822,11 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
E.<&> (userSupervisor E.^. UserSupervisorRerouteNotifications) E.<&> (userSupervisor E.^. UserSupervisorRerouteNotifications)
) )
(\current excluded -> [ UserSupervisorRerouteNotifications E.=. (current E.^. UserSupervisorRerouteNotifications E.||. excluded E.^. UserSupervisorRerouteNotifications) ] ) (\current excluded -> [ UserSupervisorRerouteNotifications E.=. (current E.^. UserSupervisorRerouteNotifications E.||. excluded E.^. UserSupervisorRerouteNotifications) ] )
deleteWhere [ UserSupervisorSupervisor ==. oldUserId] deleteWhere [ UserSupervisorSupervisor ==. oldUserId]
E.insertSelectWithConflict E.insertSelectWithConflict
UniqueUserSupervisor UniqueUserSupervisor
(E.from $ \userSupervisor -> do (E.from $ \userSupervisor -> do
E.where_ $ userSupervisor E.^. UserSupervisorUser E.==. E.val oldUserId E.where_ $ userSupervisor E.^. UserSupervisorUser E.==. E.val oldUserId
return $ UserSupervisor return $ UserSupervisor
E.<# (userSupervisor E.^. UserSupervisorSupervisor) E.<# (userSupervisor E.^. UserSupervisorSupervisor)
@ -834,14 +834,14 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
E.<&> (userSupervisor E.^. UserSupervisorRerouteNotifications) E.<&> (userSupervisor E.^. UserSupervisorRerouteNotifications)
) )
(\current excluded -> [ UserSupervisorRerouteNotifications E.=. (current E.^. UserSupervisorRerouteNotifications E.||. excluded E.^. UserSupervisorRerouteNotifications) ] ) (\current excluded -> [ UserSupervisorRerouteNotifications E.=. (current E.^. UserSupervisorRerouteNotifications E.||. excluded E.^. UserSupervisorRerouteNotifications) ] )
deleteWhere [ UserSupervisorUser ==. oldUserId] deleteWhere [ UserSupervisorUser ==. oldUserId]
-- Companies, in conflict, keep the newUser-Company as is -- Companies, in conflict, keep the newUser-Company as is
E.insertSelectWithConflict E.insertSelectWithConflict
UniqueUserCompany UniqueUserCompany
(E.from $ \userCompany -> do (E.from $ \userCompany -> do
E.where_ $ userCompany E.^. UserCompanyUser E.==. E.val oldUserId E.where_ $ userCompany E.^. UserCompanyUser E.==. E.val oldUserId
return $ UserCompany return $ UserCompany
E.<# E.val newUserId E.<# E.val newUserId
E.<&> (userCompany E.^. UserCompanyCompany) E.<&> (userCompany E.^. UserCompanyCompany)
E.<&> (userCompany E.^. UserCompanySupervisor) E.<&> (userCompany E.^. UserCompanySupervisor)
@ -877,4 +877,4 @@ combineWith :: (PersistEntity val, PersistField typ1) =>
-> (E.SqlExpr (E.Value typ1) -> E.SqlExpr (E.Value typ1) -> E.SqlExpr (E.Value typ2)) -> (E.SqlExpr (E.Value typ1) -> E.SqlExpr (E.Value typ1) -> E.SqlExpr (E.Value typ2))
-> EntityField val typ1 -> EntityField val typ1
-> E.SqlExpr (E.Value typ2) -> E.SqlExpr (E.Value typ2)
combineWith x y f pj = f (x E.^. pj) (y E.^. pj) combineWith x y f pj = f (x E.^. pj) (y E.^. pj)

5
src/Handler/Utils/Widgets.hs
View File

@ -59,6 +59,11 @@ nameWidget displayName surname = toWidget $ nameHtml displayName surname
userWidget :: HasUser c => c -> Widget userWidget :: HasUser c => c -> Widget
userWidget x = nameWidget (x ^. _userDisplayName) (x ^._userSurname) userWidget x = nameWidget (x ^. _userDisplayName) (x ^._userSurname)
linkUserWidget :: HasRoute UniWorX url => (CryptoUUIDUser -> url) -> Entity User -> Widget
linkUserWidget lnk (Entity uid usr) = do
uuid <- encrypt uid
simpleLink (userWidget usr) (lnk uuid)
-- | toWidget-Version of @nameEmailHtml@, for convenience -- | toWidget-Version of @nameEmailHtml@, for convenience
nameEmailWidget :: UserEmail -- ^ userEmail nameEmailWidget :: UserEmail -- ^ userEmail
-> Text -- ^ userDisplayName -> Text -- ^ userDisplayName

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

@ -17,6 +17,7 @@ import Import
import Jobs.Queue import Jobs.Queue
-- import Jobs.Handler.Intervals.Utils -- import Jobs.Handler.Intervals.Utils
import Database.Esqueleto.Experimental ((:&)(..))
import qualified Database.Esqueleto.Experimental as E import qualified Database.Esqueleto.Experimental as E
--import qualified Database.Esqueleto.Legacy as E --import qualified Database.Esqueleto.Legacy as E
-- import qualified Database.Esqueleto.PostgreSQL as E -- for insertSelect variant -- import qualified Database.Esqueleto.PostgreSQL as E -- for insertSelect variant
@ -180,14 +181,14 @@ dispatchJobLmsResults qid = JobHandlerAtomic act
-- otherwise there is nothing to do: we cannot renew s qualification without a specified validDuration -- otherwise there is nothing to do: we cannot renew s qualification without a specified validDuration
-- result :: [(Entity QualificationUser, Entity LmsUser, Entity LmsResult)] -- result :: [(Entity QualificationUser, Entity LmsUser, Entity LmsResult)]
results <- E.select $ do results <- E.select $ do
(quser E.:& luser E.:& lresult) <- E.from $ (quser :& luser :& lresult) <- E.from $
E.table @QualificationUser -- table not needed if renewal from lms completion day is used TODO: decide! E.table @QualificationUser -- table not needed if renewal from lms completion day is used TODO: decide!
`E.innerJoin` E.table @LmsUser `E.innerJoin` E.table @LmsUser
`E.on` (\(quser E.:& luser) -> `E.on` (\(quser :& luser) ->
luser E.^. LmsUserUser E.==. quser E.^. QualificationUserUser luser E.^. LmsUserUser E.==. quser E.^. QualificationUserUser
E.&&. luser E.^. LmsUserQualification E.==. quser E.^. QualificationUserQualification) E.&&. luser E.^. LmsUserQualification E.==. quser E.^. QualificationUserQualification)
`E.innerJoin` E.table @LmsResult `E.innerJoin` E.table @LmsResult
`E.on` (\(_ E.:& luser E.:& lresult) -> `E.on` (\(_ :& luser :& lresult) ->
luser E.^. LmsUserIdent E.==. lresult E.^. LmsResultIdent luser E.^. LmsUserIdent E.==. lresult E.^. LmsResultIdent
E.&&. luser E.^. LmsUserQualification E.==. lresult E.^. LmsResultQualification) E.&&. luser E.^. LmsUserQualification E.==. lresult E.^. LmsResultQualification)
E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid
@ -239,9 +240,9 @@ dispatchJobLmsUserlist qid = JobHandlerAtomic act
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
-- result :: [(Entity LmsUser, Entity LmsUserlist)] -- result :: [(Entity LmsUser, Entity LmsUserlist)]
results <- E.select $ do results <- E.select $ do
(luser E.:& lulist) <- E.from $ (luser :& lulist) <- E.from $
E.table @LmsUser `E.leftJoin` E.table @LmsUserlist E.table @LmsUser `E.leftJoin` E.table @LmsUserlist
`E.on` (\(luser E.:& lulist) -> luser E.^. LmsUserIdent E.=?. lulist E.?. LmsUserlistIdent `E.on` (\(luser :& lulist) -> luser E.^. LmsUserIdent E.=?. lulist E.?. LmsUserlistIdent
E.&&. luser E.^. LmsUserQualification E.=?. lulist E.?. LmsUserlistQualification) E.&&. luser E.^. LmsUserQualification E.=?. lulist E.?. LmsUserlistQualification)
E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid
E.&&. E.isNothing (luser E.^. LmsUserEnded) -- do not process closed learners E.&&. E.isNothing (luser E.^. LmsUserEnded) -- do not process closed learners

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

@ -45,7 +45,7 @@ o .:?~ key = o .: key <|> maybe empty parseJSON go
-- Like (.:?) but maps Just null to Nothing, ie. Nothing instead of Just "" -- Like (.:?) but maps Just null to Nothing, ie. Nothing instead of Just ""
(.:?!) :: (MonoFoldable a, FromJSON a) => Object -> Text -> Parser (Maybe a) (.:?!) :: (MonoFoldable a, FromJSON a) => Object -> Text -> Parser (Maybe a)
(.:?!) o k = null2nothing <$> (o .:? k) (.:?!) o k = canonical <$> (o .:? k)
-- | `SloppyBool` successfully parses different variations of true/false -- | `SloppyBool` successfully parses different variations of true/false
@ -81,7 +81,58 @@ instance FromJSON SloppyBool where
-- AVS Datatypes -- -- AVS Datatypes --
------------------- -------------------
type AvsInternalPersonalNo = Text -- ought to be all digits, type synonym for clarity/documentation within types newtype AvsInternalPersonalNo = AvsInternalPersonalNo { avsInternalPersonalNo :: Text } -- ought to be all digits
deriving (Eq, Ord, Show, Generic, Typeable)
deriving newtype (NFData, PathPiece, PersistField, PersistFieldSql, Csv.ToField, Csv.FromField)
instance E.SqlString AvsInternalPersonalNo
-- AvsInternalPersonalNo is an untagged Text with respect to FromJSON/ToJSON, as needed by AVS API
normalizeAvsInternalPersonalNo :: Text -> Text
normalizeAvsInternalPersonalNo = Text.dropWhile (\c -> '0' == c || Char.isSpace c)
mkAvsInternalPersonalNo :: Text -> AvsInternalPersonalNo
mkAvsInternalPersonalNo = AvsInternalPersonalNo . normalizeAvsInternalPersonalNo
instance Canonical AvsInternalPersonalNo where
canonical (AvsInternalPersonalNo ipn) = AvsInternalPersonalNo $ Text.dropWhile (\c -> '0' == c || Char.isSpace c) ipn
instance FromJSON AvsInternalPersonalNo where
parseJSON x = AvsInternalPersonalNo . normalizeAvsInternalPersonalNo <$> parseJSON x
instance ToJSON AvsInternalPersonalNo where
toJSON (AvsInternalPersonalNo ipn) = toJSON $ normalizeAvsInternalPersonalNo ipn
type instance Element AvsInternalPersonalNo = Char
instance MonoFoldable AvsInternalPersonalNo where
ofoldMap f = ofoldr (mappend . f) mempty . avsInternalPersonalNo
ofoldr x y = Text.foldr x y . avsInternalPersonalNo
ofoldl' x y = Text.foldl' x y . avsInternalPersonalNo
otoList = Text.unpack . avsInternalPersonalNo
oall x = Text.all x . avsInternalPersonalNo
oany x = Text.any x . avsInternalPersonalNo
onull = Text.null . avsInternalPersonalNo
olength = Text.length . avsInternalPersonalNo
ofoldr1Ex x = Text.foldr1 x . avsInternalPersonalNo
ofoldl1Ex' x = Text.foldl1' x . avsInternalPersonalNo
headEx = Text.head . avsInternalPersonalNo
lastEx = Text.last . avsInternalPersonalNo
{-# INLINE ofoldMap #-}
{-# INLINE ofoldr #-}
{-# INLINE ofoldl' #-}
{-# INLINE otoList #-}
{-# INLINE oall #-}
{-# INLINE oany #-}
{-# INLINE onull #-}
{-# INLINE olength #-}
{-# INLINE ofoldr1Ex #-}
{-# INLINE ofoldl1Ex' #-}
{-# INLINE headEx #-}
{-# INLINE lastEx #-}
{-
instance {-# OVERLAPS #-} Canonical (Maybe AvsInternalPersonalNo) where
canonical (Just aipn) | ipn@(AvsInternalPersonalNo pn) <- canonical aipn, not (null pn) = Just ipn
canonical _ = Nothing
-}
-- CompleteCardNo = xxxxxxxx.y -- CompleteCardNo = xxxxxxxx.y
-- where x is an 8 digit AvsCardNo prefixed by zeros, see normalizeAvsCardNo -- where x is an 8 digit AvsCardNo prefixed by zeros, see normalizeAvsCardNo
@ -99,6 +150,11 @@ instance ToJSON AvsCardNo where
normalizeAvsCardNo :: Text -> Text normalizeAvsCardNo :: Text -> Text
normalizeAvsCardNo = Text.justifyRight 8 '0' normalizeAvsCardNo = Text.justifyRight 8 '0'
instance Canonical AvsCardNo where
canonical AvsCardNo{..} = AvsCardNo $ normalizeAvsCardNo avsCardNo
-- canonical = AvsCardNo . normalizeAvsCardNo . avsCardNo
data AvsFullCardNo = AvsFullCardNo { avsFullCardNo :: AvsCardNo, avsFullCardVersion :: AvsVersionNo } data AvsFullCardNo = AvsFullCardNo { avsFullCardNo :: AvsCardNo, avsFullCardVersion :: AvsVersionNo }
deriving (Eq, Ord, Generic, Typeable) deriving (Eq, Ord, Generic, Typeable)
@ -117,7 +173,7 @@ readAvsFullCardNo _ = Nothing
discernAvsCardPersonalNo :: Text -> Maybe (Either AvsFullCardNo AvsInternalPersonalNo) -- Just implies it is a whole number or decimal with one digit after the point discernAvsCardPersonalNo :: Text -> Maybe (Either AvsFullCardNo AvsInternalPersonalNo) -- Just implies it is a whole number or decimal with one digit after the point
discernAvsCardPersonalNo (Text.span Char.isDigit -> (c, pv)) discernAvsCardPersonalNo (Text.span Char.isDigit -> (c, pv))
| Text.null pv | Text.null pv
= Just $ Right c = Just $ Right $ mkAvsInternalPersonalNo c
| not $ Text.null c | not $ Text.null c
, Just ('.', v) <- Text.uncons pv , Just ('.', v) <- Text.uncons pv
, Just (Char.isDigit -> True, "") <- Text.uncons v , Just (Char.isDigit -> True, "") <- Text.uncons v
@ -256,18 +312,19 @@ instance Ord AvsDataPersonCard where
makeLenses_ ''AvsDataPersonCard makeLenses_ ''AvsDataPersonCard
{- {-
instance Canonical AvsDataPersonCard where instance Canonical AvsDataPersonCard where
canonical proto = proto { avsDataStreet = null2nothing $ avsDataStreet proto canonical proto = proto { avsDataStreet = canonical $ avsDataStreet proto
, avsDataPostalCode = null2nothing $ avsDataPostalCode proto , avsDataPostalCode = canonical $ avsDataPostalCode proto
, avsDataCity = null2nothing $ avsDataCity proto , avsDataCity = canonical $ avsDataCity proto
, avsDataFirm = null2nothing $ avsDataFirm proto , avsDataFirm = canonical $ avsDataFirm proto
} }
-} -}
instance Canonical AvsDataPersonCard where instance Canonical AvsDataPersonCard where
canonical proto = canonical proto =
proto & _avsDataStreet %~ null2nothing proto & _avsDataStreet %~ canonical
& _avsDataPostalCode %~ null2nothing & _avsDataPostalCode %~ canonical
& _avsDataCity %~ null2nothing & _avsDataCity %~ canonical
& _avsDataFirm %~ null2nothing & _avsDataFirm %~ canonical
& _avsDataCardNo %~ canonical
-- TODO: use canonical in FromJSON/ToJSON instances for consistency -- TODO: use canonical in FromJSON/ToJSON instances for consistency
instance FromJSON AvsDataPersonCard where instance FromJSON AvsDataPersonCard where
@ -281,7 +338,7 @@ instance FromJSON AvsDataPersonCard where
<*> v .:?! "PostalCode" <*> v .:?! "PostalCode"
<*> v .:?! "City" <*> v .:?! "City"
<*> v .:?! "Firm" <*> v .:?! "Firm"
<*> v .: "CardNo" <*> ((v .: "CardNo") <&> canonical)
<*> v .: "VersionNo" <*> v .: "VersionNo"
instance ToJSON AvsDataPersonCard where instance ToJSON AvsDataPersonCard where
@ -289,16 +346,16 @@ instance ToJSON AvsDataPersonCard where
catMaybes catMaybes
[ ("ValidTo" .=) <$> avsDataValidTo [ ("ValidTo" .=) <$> avsDataValidTo
, ("IssueDate" .=) <$> avsDataIssueDate , ("IssueDate" .=) <$> avsDataIssueDate
, ("Street" .=) <$> (avsDataStreet & null2nothing) , ("Street" .=) <$> (avsDataStreet & canonical)
, ("PostalCode" .=) <$> (avsDataPostalCode & null2nothing) , ("PostalCode" .=) <$> (avsDataPostalCode & canonical)
, ("City" .=) <$> (avsDataCity & null2nothing) , ("City" .=) <$> (avsDataCity & canonical)
, ("Firm" .=) <$> (avsDataFirm & null2nothing) , ("Firm" .=) <$> (avsDataFirm & canonical)
] ]
<> <>
[ "Valid" .= show avsDataValid [ "Valid" .= show avsDataValid
, "CardColor" .= avsDataCardColor , "CardColor" .= avsDataCardColor
, "CardAreas" .= Set.foldl Text.snoc Text.empty avsDataCardAreas , "CardAreas" .= Set.foldl Text.snoc Text.empty avsDataCardAreas
, "CardNo" .= avsDataCardNo , "CardNo" .= (avsDataCardNo & canonical)
, "VersionNo" .= avsDataVersionNo , "VersionNo" .= avsDataVersionNo
] ]
derivePersistFieldJSON ''AvsDataPersonCard derivePersistFieldJSON ''AvsDataPersonCard
@ -332,7 +389,7 @@ data AvsDataPerson = AvsDataPerson
makeLenses_ ''AvsDataPerson makeLenses_ ''AvsDataPerson
instance Canonical AvsDataPerson where instance Canonical AvsDataPerson where
canonical = over _avsPersonInternalPersonalNo null2nothing canonical = over _avsPersonInternalPersonalNo canonical
. over _avsPersonPersonCards canonical . over _avsPersonPersonCards canonical
@ -347,7 +404,7 @@ instance FromJSON AvsDataPerson where
instance ToJSON AvsDataPerson where instance ToJSON AvsDataPerson where
toJSON AvsDataPerson{..} = object $ toJSON AvsDataPerson{..} = object $
catMaybes [ ("InternalPersonalNo" .=) <$> (avsPersonInternalPersonalNo & null2nothing) ] catMaybes [ ("InternalPersonalNo" .=) <$> (avsPersonInternalPersonalNo & canonical) ]
<> <>
[ "FirstName" .= avsPersonFirstName [ "FirstName" .= avsPersonFirstName
, "LastName" .= avsPersonLastName , "LastName" .= avsPersonLastName
@ -470,7 +527,7 @@ newtype AvsQueryStatus = AvsQueryStatus (Set AvsPersonId)
deriving (Eq, Ord, Show, Generic, Typeable) deriving (Eq, Ord, Show, Generic, Typeable)
deriveJSON defaultOptions ''AvsQueryStatus deriveJSON defaultOptions ''AvsQueryStatus
newtype AvsQueryGetLicences = AvsQueryGetLicences (Set AvsObjPersonId) newtype AvsQueryGetLicences = AvsQueryGetLicences AvsObjPersonId -- this should have been a set, but the specification was implemented differently
deriving (Eq, Ord, Show, Generic, Typeable) deriving (Eq, Ord, Show, Generic, Typeable)
deriveJSON defaultOptions ''AvsQueryGetLicences deriveJSON defaultOptions ''AvsQueryGetLicences

26
src/Model/Types/Changelog.hs
View File

@ -16,6 +16,18 @@ import Model.Types.TH.PathPiece
import qualified Data.Map as Map import qualified Data.Map as Map
{-
How to add a changelog item:
* pick a constructor name for the feature, e.g. MyGoodFeature
* add hamlet files in kebab-case for each langugage, e.g. /templates/i18n/changelog/my-good-feature.de-de-formal.hamlet
and /templates/i18n/changelog/my-good-feature.en-eu.hamlet
* if it is a bugfix, classify it in `classifyChangelogItem` below
* add list item (MyGoodFeature, date) to `changelogItemDays` below
Es können mehrere Changes an einem Tag stattfinden, aber jeder Change kann nur an einem Tag stattfinden.
Changes werden in die Datenbank eingetragen, d.h. sie müssen auch in der DB gelöscht werden, wenn diese nicht mehr angezeigt werden sollen!
-}
mkI18nWidgetEnum "Changelog" "changelog" mkI18nWidgetEnum "Changelog" "changelog"
derivePersistFieldPathPiece ''ChangelogItem derivePersistFieldPathPiece ''ChangelogItem
@ -31,6 +43,19 @@ data ChangelogItemKind
makePrisms ''ChangelogItemKind makePrisms ''ChangelogItemKind
classifyChangelogItem :: ChangelogItem -> ChangelogItemKind
classifyChangelogItem = \case
--ChangelogBlaBla -> ChangelogItemBugfix
--ChangelogFradriveInitialRelease -> ChangelogItemFeature -- remove me once we have a bugfix
_other -> ChangelogItemFeature
changelogItemDays :: Map ChangelogItem Day
changelogItemDays = Map.fromListWithKey (\k d1 d2 -> bool (error $ "Duplicate changelog days for " <> show k) d1 $ d1 /= d2)
[ (ChangelogFradriveInitialRelease, [day|2022-12-12|])
]
{- FOR REFERENCE, PREVIOUS CHANGELOG (delete in the future, along with all translation files):
classifyChangelogItem :: ChangelogItem -> ChangelogItemKind classifyChangelogItem :: ChangelogItem -> ChangelogItemKind
classifyChangelogItem = \case classifyChangelogItem = \case
ChangelogHaskellCampusLogin -> ChangelogItemBugfix ChangelogHaskellCampusLogin -> ChangelogItemBugfix
@ -150,3 +175,4 @@ changelogItemDays = Map.fromListWithKey (\k d1 d2 -> bool (error $ "Duplicate ch
, (ChangelogMaterialsVideoStreaming, [day|2020-11-10|]) , (ChangelogMaterialsVideoStreaming, [day|2020-11-10|])
, (ChangelogFixPersonalisedSheetFilesKeep, [day|2020-11-10|]) , (ChangelogFixPersonalisedSheetFilesKeep, [day|2020-11-10|])
] ]
-}

1
src/Model/Types/Security.hs
View File

@ -81,7 +81,6 @@ data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prä
| AuthExamOffice | AuthExamOffice
| AuthSystemExamOffice | AuthSystemExamOffice
| AuthSystemPrinter | AuthSystemPrinter
| AuthSystemSap
| AuthEvaluation | AuthEvaluation
| AuthCourseRegistered | AuthCourseRegistered
| AuthTutorialRegistered | AuthTutorialRegistered

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

@ -15,8 +15,7 @@ data SystemFunction
= SystemExamOffice = SystemExamOffice
| SystemFaculty | SystemFaculty
| SystemStudent | SystemStudent
| SystemPrinter | SystemPrinter
| SystemSap
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
deriving anyclass (Universe, Finite, Hashable, NFData) deriving anyclass (Universe, Finite, Hashable, NFData)

1
src/Settings.hs
View File

@ -278,6 +278,7 @@ data UserDefaultConf = UserDefaultConf
, userDefaultShowSex :: Bool , userDefaultShowSex :: Bool
, userDefaultExamOfficeGetSynced :: Bool , userDefaultExamOfficeGetSynced :: Bool
, userDefaultExamOfficeGetLabels :: Bool , userDefaultExamOfficeGetLabels :: Bool
, userDefaultPrefersPostal :: Bool
} deriving (Show) } deriving (Show)
data PWHashConf = PWHashConf data PWHashConf = PWHashConf

42
src/Utils.hs
View File

@ -363,6 +363,9 @@ toWgt :: ToMarkup a
toWgt = toWidget . toHtml toWgt = toWidget . toHtml
-- Convenience Functions to avoid type signatures: -- Convenience Functions to avoid type signatures:
text2markup :: Text -> Markup
text2markup t = [shamlet|#{t}|]
text2widget :: Text -> WidgetFor site () text2widget :: Text -> WidgetFor site ()
text2widget t = [whamlet|#{t}|] text2widget t = [whamlet|#{t}|]
@ -619,6 +622,10 @@ trd3 (_,_,z) = z
mTuple :: Applicative f => f a -> f b -> f (a, b) mTuple :: Applicative f => f a -> f b -> f (a, b)
mTuple = liftA2 (,) mTuple = liftA2 (,)
-- From Data.Tuple.Extra
mapBoth :: (a -> b) -> (a,a) -> (b,b)
mapBoth f ~(a,b) = (f a, f b)
----------- -----------
-- Lists -- -- Lists --
----------- -----------
@ -781,6 +788,9 @@ partitionKeysEither = over _2 (Map.mapKeysMonotonic . view $ singular _Right) .
mapFromSetM :: Applicative m => (k -> m v) -> Set k -> m (Map k v) mapFromSetM :: Applicative m => (k -> m v) -> Set k -> m (Map k v)
mapFromSetM = (sequenceA .) . Map.fromSet mapFromSetM = (sequenceA .) . Map.fromSet
setToMap :: (Ord k) => (v -> k) -> Set v -> Map k v
setToMap mkKey = Map.fromList . fmap (\x -> (mkKey x, x)) . Set.toList
mapFM :: (Applicative m, Ord k, Finite k) => (k -> m v) -> m (Map k v) mapFM :: (Applicative m, Ord k, Finite k) => (k -> m v) -> m (Map k v)
mapFM = sequenceA . mapF mapFM = sequenceA . mapF
@ -816,10 +826,10 @@ toNothing = const Nothing
toNothingS :: String -> Maybe b toNothingS :: String -> Maybe b
toNothingS = const Nothing toNothingS = const Nothing
-- a more general formulation probably possible -- replaced by a more general formulation, see canonical
null2nothing :: MonoFoldable a => Maybe a -> Maybe a -- null2nothing :: MonoFoldable a => Maybe a -> Maybe a
null2nothing (Just x) | null x = Nothing -- null2nothing (Just x) | null x = Nothing
null2nothing other = other -- null2nothing other = other
-- | Swap 'Nothing' for 'Just' and vice versa -- | Swap 'Nothing' for 'Just' and vice versa
-- This belongs into Module 'Utils' but we have a weird cyclic -- This belongs into Module 'Utils' but we have a weird cyclic
@ -1047,6 +1057,16 @@ throwExceptT = exceptT throwM return
generalFinally :: MonadMask m => m a -> (ExitCase a -> m b) -> m a generalFinally :: MonadMask m => m a -> (ExitCase a -> m b) -> m a
generalFinally action finalizer = view _1 <$> generalBracket (return ()) (const finalizer) (const action) generalFinally action finalizer = view _1 <$> generalBracket (return ()) (const finalizer) (const action)
-------------
-- Functor --
-------------
infixl 4 <<$>>
(<<$>>) :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b)
(<<$>>) f x = fmap f <$> x
------------ ------------
-- Monads -- -- Monads --
------------ ------------
@ -1872,5 +1892,19 @@ makePrisms ''ExitCase
class Canonical a where class Canonical a where
canonical :: a -> a canonical :: a -> a
instance {-# OVERLAPPABLE #-} MonoFoldable mono => Canonical (Maybe mono) where
canonical (Just t) | null t = Nothing
canonical other = other
{-
instance {-# OVERLAPPABLE #-} (Canonical mono, MonoFoldable mono, Eq mono) => Canonical (Maybe mono) where
canonical r@(Just t) = let c = canonical t
in if null c then Nothing else
if t==c then r else Just c
canonical other = other
-}
-- this instance is more of a convenient abuse of the class (expand to Foldable)
instance (Ord a, Canonical a) => Canonical (Set a) where instance (Ord a, Canonical a) => Canonical (Set a) where
canonical = Set.map canonical canonical = Set.map canonical

35
src/Utils/Avs.hs
View File

@ -27,6 +27,8 @@ type AVSPersonStatus = "PersonStatus" :> ReqBody '[JSON] AvsQueryStatus :> Po
type AVSGetRampLicences = "RampDrivingLicenceInfo" :> ReqBody '[JSON] AvsQueryGetLicences :> Post '[JSON] AvsResponseGetLicences type AVSGetRampLicences = "RampDrivingLicenceInfo" :> ReqBody '[JSON] AvsQueryGetLicences :> Post '[JSON] AvsResponseGetLicences
type AVSSetRampLicences = "RampDrivingLicence" :> ReqBody '[JSON] AvsQuerySetLicences :> Post '[JSON] AvsResponseSetLicences type AVSSetRampLicences = "RampDrivingLicence" :> ReqBody '[JSON] AvsQuerySetLicences :> Post '[JSON] AvsResponseSetLicences
avsMaxSetLicenceAtOnce :: Int
avsMaxSetLicenceAtOnce = 99 -- maximum input set size for avsQuerySetLicences as enforced by AVS
avsApi :: Proxy AVS avsApi :: Proxy AVS
avsApi = Proxy avsApi = Proxy
@ -45,15 +47,15 @@ data AvsQuery = AvsQuery
{ avsQueryPerson :: forall m. MonadIO m => AvsQueryPerson -> m (Either ClientError AvsResponsePerson) { avsQueryPerson :: forall m. MonadIO m => AvsQueryPerson -> m (Either ClientError AvsResponsePerson)
, avsQueryStatus :: forall m. MonadIO m => AvsQueryStatus -> m (Either ClientError AvsResponseStatus) , avsQueryStatus :: forall m. MonadIO m => AvsQueryStatus -> m (Either ClientError AvsResponseStatus)
, avsQuerySetLicences :: forall m. MonadIO m => AvsQuerySetLicences -> m (Either ClientError AvsResponseSetLicences) , avsQuerySetLicences :: forall m. MonadIO m => AvsQuerySetLicences -> m (Either ClientError AvsResponseSetLicences)
, avsQueryGetLicences :: forall m. MonadIO m => AvsQueryGetLicences -> m (Either ClientError AvsResponseGetLicences) -- , avsQueryGetLicences :: forall m. MonadIO m => AvsQueryGetLicences -> m (Either ClientError AvsResponseGetLicences) -- not supported by VSM
, avsQueryGetAllLicences :: forall m. MonadIO m => m (Either ClientError AvsResponseGetLicences) , avsQueryGetAllLicences :: forall m. MonadIO m => m (Either ClientError AvsResponseGetLicences)
} }
makeLenses_ ''AvsQuery makeLenses_ ''AvsQuery
-- | To query all active licences, a special argument must be prepared -- | To query all active licences, a special constant argument must be prepared
avsQueryAllLicences :: AvsQueryGetLicences avsQueryAllLicences :: AvsQueryGetLicences
avsQueryAllLicences = AvsQueryGetLicences $ Set.singleton $ AvsObjPersonId $ AvsPersonId 0 avsQueryAllLicences = AvsQueryGetLicences $ AvsObjPersonId $ AvsPersonId 0
mkAvsQuery :: BaseUrl -> BasicAuthData -> ClientEnv -> AvsQuery mkAvsQuery :: BaseUrl -> BasicAuthData -> ClientEnv -> AvsQuery
@ -61,7 +63,7 @@ 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 (rawQueryStatus q) cliEnv , avsQueryStatus = \q -> liftIO $ runClientM (rawQueryStatus q) cliEnv
, avsQuerySetLicences = \q -> liftIO $ runClientM (rawQuerySetLicences q) cliEnv , avsQuerySetLicences = \q -> liftIO $ runClientM (rawQuerySetLicences q) cliEnv
, 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
} }
where where
@ -87,21 +89,32 @@ getValidLicence cutoff licence' cards = Set.lookupMax validLicenceCards
cardMatch AvsDataPersonCard{..} = cardMatch AvsDataPersonCard{..} =
avsDataValid && (avsDataValidTo >= cutoff) && (licence `Set.member` avsDataCardAreas) avsDataValid && (avsDataValidTo >= cutoff) && (licence `Set.member` avsDataCardAreas)
guessLicenceAddress :: Set AvsDataPersonCard -> Maybe (Maybe Text, Text, AvsDataPersonCard)
guessLicenceAddress cards getCompanyAddress :: AvsDataPersonCard -> Maybe (Maybe Text, Text, AvsDataPersonCard)
| Just c <- Set.lookupMax cards getCompanyAddress card@AvsDataPersonCard{..}
, card@AvsDataPersonCard{..} <- Set.foldr pickLicenceAddress c cards | Just street <- avsDataStreet
, Just street <- avsDataStreet
, Just pcode <- avsDataPostalCode , Just pcode <- avsDataPostalCode
, Just city <- avsDataCity , Just city <- avsDataCity
= Just (avsDataFirm, Text.unlines [street, Text.unwords [pcode, city]], card) = Just (avsDataFirm, Text.unlines [street, Text.unwords [pcode, city]], card)
| otherwise = Nothing | otherwise = Nothing
-- | Helper for guessLicenceAddress -- | From a set of card, choose the one with the most complete postal address.
-- Returns company, postal address and the associated card where the address was taken from
guessLicenceAddress :: Set AvsDataPersonCard -> Maybe (Maybe Text, Text, AvsDataPersonCard)
guessLicenceAddress cards
| Just c <- Set.lookupMax cards
, card <- Set.foldr pickLicenceAddress c cards
= getCompanyAddress card
| otherwise = Nothing
-- | Helper for guessLicenceAddress or getCompanyAddress
mergeCompanyAddress :: (Maybe Text, Text, a) -> Text mergeCompanyAddress :: (Maybe Text, Text, a) -> Text
mergeCompanyAddress (Nothing , addr, _) = addr mergeCompanyAddress (Nothing , addr, _) = addr
mergeCompanyAddress (Just firm, addr, _) = firm <> Text.cons '\n' addr mergeCompanyAddress (Just firm, addr, _) = firm <> Text.cons '\n' addr
maybeCompanyAddress :: AvsDataPersonCard -> Maybe Text
maybeCompanyAddress = fmap mergeCompanyAddress . getCompanyAddress
hasAddress :: AvsDataPersonCard -> Bool hasAddress :: AvsDataPersonCard -> Bool
hasAddress AvsDataPersonCard{..} = isJust avsDataStreet && isJust avsDataCity && isJust avsDataPostalCode hasAddress AvsDataPersonCard{..} = isJust avsDataStreet && isJust avsDataCity && isJust avsDataPostalCode
@ -157,7 +170,7 @@ mergeAvsDataPerson = Map.unionWithKey merger
in AvsDataPerson in AvsDataPerson
{ avsPersonFirstName = pickBy' Text.length avsPersonFirstName { avsPersonFirstName = pickBy' Text.length avsPersonFirstName
, avsPersonLastName = pickBy' Text.length avsPersonLastName , avsPersonLastName = pickBy' Text.length avsPersonLastName
, avsPersonInternalPersonalNo = pickBy' (Text.length . fromMaybe mempty) avsPersonInternalPersonalNo , avsPersonInternalPersonalNo = pickBy' (maybe 0 length) avsPersonInternalPersonalNo
, avsPersonPersonNo = pickBy' id avsPersonPersonNo , avsPersonPersonNo = pickBy' id avsPersonPersonNo
, avsPersonPersonID = api -- keys must be identical due to call with insertWithKey , avsPersonPersonID = api -- keys must be identical due to call with insertWithKey
, avsPersonPersonCards = (Set.union `on` avsPersonPersonCards) pa pb , avsPersonPersonCards = (Set.union `on` avsPersonPersonCards) pa pb

6
src/Utils/Form.hs
View File

@ -299,7 +299,11 @@ data FormIdentifier
| FIDExamAutoOccurrenceCalculate | FIDExamAutoOccurrenceConfirm | FIDExamAutoOccurrenceNudge UUID | FIDExamAutoOccurrenceIgnoreRoom UUID | FIDExamAutoOccurrenceCalculate | FIDExamAutoOccurrenceConfirm | FIDExamAutoOccurrenceNudge UUID | FIDExamAutoOccurrenceIgnoreRoom UUID
| FIDTestDownload | FIDTestDownload
| FIDAvsQueryPerson | FIDAvsQueryPerson
| FIDAvsQueryStatus | FIDAvsQueryStatus
| FIDAvsCreateUser
| FIDAvsQueryLicenceDiffs
| FIDAvsQueryLicence
| FIDAvsSetLicence
| FIDLmsLetter | FIDLmsLetter
deriving (Eq, Ord, Read, Show) deriving (Eq, Ord, Read, Show)

4
src/Utils/Icon.hs
View File

@ -104,6 +104,7 @@ data Icon
| IconPrintCenter | IconPrintCenter
| IconLetter | IconLetter
| IconAt | IconAt
| IconSupervisor
deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic, Typeable) deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic, Typeable)
deriving anyclass (Universe, Finite, NFData) deriving anyclass (Universe, Finite, NFData)
@ -186,6 +187,7 @@ iconText = \case
IconPrintCenter -> "mail-bulk" -- From fontawesome v6 onwards: "envelope-bulk" IconPrintCenter -> "mail-bulk" -- From fontawesome v6 onwards: "envelope-bulk"
IconLetter -> "mail-bulk" -- Problem "envelope" already used for email as well IconLetter -> "mail-bulk" -- Problem "envelope" already used for email as well
IconAt -> "at" IconAt -> "at"
IconSupervisor -> "head-side" -- must be notably different to user
nullaryPathPiece ''Icon $ camelToPathPiece' 1 nullaryPathPiece ''Icon $ camelToPathPiece' 1
deriveLift ''Icon deriveLift ''Icon
@ -218,7 +220,7 @@ iconStacked ic0 ic1
<i .fas .fa-stack-2x .fa-#{iconText ic1}> <i .fas .fa-stack-2x .fa-#{iconText ic1}>
|] |]
-- Create an icon (defaults to "?") with a specified tooltip -- Create an icon (defaults to "?") with a specified tooltip; inline-bool just affects the size of the icon
iconTooltip :: forall site. WidgetFor site () -> Maybe Icon -> Bool -> WidgetFor site () iconTooltip :: forall site. WidgetFor site () -> Maybe Icon -> Bool -> WidgetFor site ()
iconTooltip tooltip mIcon isInlineTooltip = let iconTooltip tooltip mIcon isInlineTooltip = let
ic = iconText $ fromMaybe IconTooltipDefault mIcon ic = iconText $ fromMaybe IconTooltipDefault mIcon

2
src/Utils/Lens.hs
View File

@ -125,6 +125,8 @@ makeClassyFor_ ''QualificationUser
makeClassyFor_ ''LmsUser makeClassyFor_ ''LmsUser
makeClassyFor_ ''LmsUserlist makeClassyFor_ ''LmsUserlist
makeClassyFor_ ''LmsResult makeClassyFor_ ''LmsResult
makeClassyFor_ ''UserAvs
makeClassyFor_ ''UserAvsCard
_entityKey :: Getter (Entity record) (Key record) _entityKey :: Getter (Entity record) (Key record)
-- ^ Not a `Lens'` for safety -- ^ Not a `Lens'` for safety

14
src/Utils/Print.hs
View File

@ -42,7 +42,7 @@ import System.Process.Typed -- for calling pdftk for pdf encryption
import Handler.Utils.Users import Handler.Utils.Users
import Handler.Utils.DateTime import Handler.Utils.DateTime
import Handler.Utils.Mail import Handler.Utils.Mail
import Handler.Utils.Widgets (nameHtml') import Handler.Utils.Widgets (nameHtml')
import Jobs.Handler.SendNotification.Utils import Jobs.Handler.SendNotification.Utils
-- import Model.Types.Markup -- TODO-QSV: should this module be moved accordingly? -- import Model.Types.Markup -- TODO-QSV: should this module be moved accordingly?
@ -119,8 +119,8 @@ appMeta f (P.Pandoc m bs) = P.Pandoc (f m) bs
applyMetas :: (P.HasMeta p, Foldable t, P.ToMetaValue a) => t (Text, Maybe a) -> p -> p applyMetas :: (P.HasMeta p, Foldable t, P.ToMetaValue a) => t (Text, Maybe a) -> p -> p
applyMetas metas doc = Fold.foldr act doc metas applyMetas metas doc = Fold.foldr act doc metas
where where
act (_, Nothing) acc = acc act (k, Just v) acc | notNull k = P.setMeta k v acc
act (k, Just v ) acc = P.setMeta k v acc act _ acc = acc
-- | Add meta to pandoc. Existing variables will be overwritten. -- | Add meta to pandoc. Existing variables will be overwritten.
@ -377,7 +377,7 @@ data LetterRenewQualificationF = LetterRenewQualificationF
, lmsPin :: Text , lmsPin :: Text
, qualHolder :: UserDisplayName , qualHolder :: UserDisplayName
, qualExpiry :: Day , qualExpiry :: Day
, qualId :: QualificationId , qualId :: QualificationId
, qualName :: Text , qualName :: Text
, qualShort :: Text , qualShort :: Text
, qualDuration :: Maybe Int , qualDuration :: Maybe Int
@ -386,8 +386,8 @@ data LetterRenewQualificationF = LetterRenewQualificationF
instance MDLetter LetterRenewQualificationF where instance MDLetter LetterRenewQualificationF where
getTemplate _ = templateRenewal getTemplate _ = templateRenewal
getMailSubject l = SomeMessage $ MsgMailSubjectQualificationRenewal $ qualShort l getMailSubject l = SomeMessage $ MsgMailSubjectQualificationRenewal $ qualShort l
getMailBody l = SomeMessage $ MsgMailBodyQualificationRenewal $ qualName l getMailBody l = SomeMessage $ MsgMailBodyQualificationRenewal $ qualName l
letterMeta LetterRenewQualificationF{..} _lang DateTimeFormatter{ format } = mkMeta letterMeta LetterRenewQualificationF{..} _lang DateTimeFormatter{ format } = mkMeta
[ toMeta "login" lmsIdent [ toMeta "login" lmsIdent
, toMeta "pin" lmsPin , toMeta "pin" lmsPin
@ -413,7 +413,7 @@ instance MDLetter LetterRenewQualificationF where
sendEmailOrLetter :: (MDLetter l) => UserId -> l -> Handler Bool sendEmailOrLetter :: (MDLetter l) => UserId -> l -> Handler Bool
sendEmailOrLetter recipient letter = do sendEmailOrLetter recipient letter = do
(underling, receivers, undercopy) <- liftHandler . runDB $ getReceivers recipient (underling, receivers, undercopy) <- runDB $ getReceivers recipient
let tmpl = getTemplate $ pure letter let tmpl = getTemplate $ pure letter
pjid = getPJId letter pjid = getPJId letter
-- Below are only needed if sent by email -- Below are only needed if sent by email

10
src/Utils/Set.hs
View File

@ -11,8 +11,10 @@ module Utils.Set
, setPartitionEithers , setPartitionEithers
, setFromFunc , setFromFunc
, mapIntersectNotOne , mapIntersectNotOne
, set2NonEmpty
) where ) where
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Set as Set import qualified Data.Set as Set
import qualified Data.Map.Strict() import qualified Data.Map.Strict()
import qualified Data.Map as Map import qualified Data.Map as Map
@ -65,4 +67,10 @@ setPartitionEithers :: (Ord a, Ord b) => Set (Either a b) -> (Set a, Set b)
setPartitionEithers = (,) <$> setMapMaybe (preview _Left) <*> setMapMaybe (preview _Right) setPartitionEithers = (,) <$> setMapMaybe (preview _Left) <*> setMapMaybe (preview _Right)
setFromFunc :: (Finite k, Ord k) => (k -> Bool) -> Set k setFromFunc :: (Finite k, Ord k) => (k -> Bool) -> Set k
setFromFunc = Set.fromList . flip filter universeF setFromFunc = Set.fromList . flip filter universeF
-- | convert a Set to NonEmpty, inserting a default value if necessary
set2NonEmpty :: a -> Set a -> NonEmpty.NonEmpty a
set2NonEmpty _ (Set.toList -> h:t) = h NonEmpty.:| t
set2NonEmpty d _ = d NonEmpty.:| []

43
templates/admin-problems.hamlet Normal file
View File

@ -0,0 +1,43 @@
$newline never
$# SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
$#
$# SPDX-License-Identifier: AGPL-3.0-or-later
<section>
<h2>
_{MsgProblemsHeadingDrivers}
<dl .deflist>
<dt .deflist__dt>^{flagError driversHaveAvsIds}
<dd .deflist__dd>^{simpleLinkI MsgProblemsDriversHaveAvsIds ProblemWithoutAvsId}
$case diffLics
$of Left err
<dt .deflist__dt>^{flagError False}
<dd .deflist__dd>^{modal (i18n MsgProblemsAvsProblem) (Right err)}
$of Right (ok0,ok1,ok2)
<dt .deflist__dt>^{flagNonZero ok2}
<dd .deflist__dd>_{MsgProblemsDriverSynch2}
<dt .deflist__dt>^{flagNonZero ok1}
<dd .deflist__dd>_{MsgProblemsDriverSynch1}
<dt .deflist__dt>^{flagNonZero ok0}
<dd .deflist__dd>_{MsgProblemsDriverSynch0}
<dt .deflist__dt>^{flagWarning rDriversHaveFs}
<dd .deflist__dd>^{simpleLinkI MsgProblemsRDriversHaveFs ProblemFbutNoR}
<section>
<h2>
_{MsgProblemsHeadingUsers}
<dl .deflist>
<dt .deflist__dt>^{flagError usersAreReachable}
<dd .deflist__dd>^{simpleLinkI MsgProblemsUsersAreReachable ProblemUnreachableR}
<dt .deflist__dt>^{flagError noStalePrintJobs}
<dd .deflist__dd>^{simpleLinkI (MsgProblemsNoStalePrintJobs cutOffPrintDays) PrintCenterR}

36
templates/avs.hamlet
View File

@ -6,7 +6,39 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
<section> <section>
<p> <p>
Person Search: Upsert User by CardNo or Fraport Personnel Number:
^{crUsrForm}
$maybe answer <- mbCrUser
<p>
^{answer}
<section>
<p>
Get Licence by AVS Person ID:
^{getLicForm}
$maybe answer <- mbGetLic
<p>
^{answer}
<section>
<p>
Set Licence by AVS Person ID:
^{setLicForm}
$maybe answer <- mbSetLic
<p>
^{answer}
<section>
<p>
Synchronize licences with AVS.
^{qryLicForm}
$maybe answer <- mbQryLic
<p>
^{answer}
<section>
<p>
Person search:
^{personForm} ^{personForm}
$maybe answer <- mbPerson $maybe answer <- mbPerson
<p> <p>
@ -15,7 +47,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
<section> <section>
<p> <p>
Person Status: Person status:
^{statusForm} ^{statusForm}
$maybe answer <- mbStatus $maybe answer <- mbStatus
<p> <p>

1
templates/i18n/admin-test/de-de-formal.hamlet
View File

@ -15,6 +15,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
<p> <p>
^{iconTooltip testTooltipMsg Nothing False} ^{iconTooltip testTooltipMsg Nothing False}
$# ^{iconTooltip testTooltipMsg Nothing True} -- just a different size
^{messageTooltip msgInfoTooltip} ^{messageTooltip msgInfoTooltip}
^{messageTooltip msgSuccessTooltip} ^{messageTooltip msgSuccessTooltip}
^{messageTooltip msgWarningTooltip} ^{messageTooltip msgWarningTooltip}

9
templates/i18n/changelog/abolish-course-associated-study-features.de-de-formal.hamlet
View File

@ -1,9 +0,0 @@
$newline never
$# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
$#
$# SPDX-License-Identifier: AGPL-3.0-or-later
Kursassoziierte Studienfächer wurden abgeschafft.
<br>
Es werden nun an allen kursbezogenen Stellen jene Studiendaten angezeigt, die während des entsprechenden Semesters aktuell waren.

9
templates/i18n/changelog/abolish-course-associated-study-features.en-eu.hamlet
View File

@ -1,9 +0,0 @@
$newline never
$# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
$#
$# SPDX-License-Identifier: AGPL-3.0-or-later
Abolished course-associated features of study.
<br>
In course-related contexts now all study features which were up to date during the relevant term are displayed.

7
templates/i18n/changelog/account-deletion-during-testing.de-de-formal.hamlet
View File

@ -1,7 +0,0 @@
$newline never
$# SPDX-FileCopyrightText: 2022 Winnie Ros <winnie.ros@campus.lmu.de>
$#
$# SPDX-License-Identifier: AGPL-3.0-or-later
Benutzer:innen können sich in der Testphase komplett selbst löschen

7
templates/i18n/changelog/account-deletion-during-testing.en-eu.hamlet
View File

@ -1,7 +0,0 @@
$newline never
$# SPDX-FileCopyrightText: 2022 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>
$#
$# SPDX-License-Identifier: AGPL-3.0-or-later
During testing users may completely delete their accounts.

7
templates/i18n/changelog/additional-datetime-formats.de-de-formal.hamlet
View File

@ -1,7 +0,0 @@
$newline never
$# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
$#
$# SPDX-License-Identifier: AGPL-3.0-or-later
Zusätzliche Uhrzeit- und Datumsformate

7
templates/i18n/changelog/additional-datetime-formats.en-eu.hamlet
View File

@ -1,7 +0,0 @@
$newline never
$# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
$#
$# SPDX-License-Identifier: AGPL-3.0-or-later
Additional date and time formats

7
templates/i18n/changelog/additional-sheet-notifications.de-de-formal.hamlet
View File

@ -1,7 +0,0 @@
$newline never
$# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
$#
$# SPDX-License-Identifier: AGPL-3.0-or-later
Zusätzliche Benachrichtigungen für Übungsblätter

7
templates/i18n/changelog/additional-sheet-notifications.en-eu.hamlet
View File

@ -1,7 +0,0 @@
$newline never
$# SPDX-FileCopyrightText: 2022 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>
$#
$# SPDX-License-Identifier: AGPL-3.0-or-later
Additional notifications for exercise sheets.

7
templates/i18n/changelog/allocation-applications.de-de-formal.hamlet
View File

@ -1,7 +0,0 @@
$newline never
$# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
$#
$# SPDX-License-Identifier: AGPL-3.0-or-later
Bewerbungen für Zentralanmeldungen

7
templates/i18n/changelog/allocation-applications.en-eu.hamlet
View File

@ -1,7 +0,0 @@
$newline never
$# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
$#
$# SPDX-License-Identifier: AGPL-3.0-or-later
Applications for central allocations

7
templates/i18n/changelog/allocation-course-accept-substitutes-fixed.de-de-formal.hamlet
View File

@ -1,7 +0,0 @@
$newline never
$# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
$#
$# SPDX-License-Identifier: AGPL-3.0-or-later
Das Eintragen von Fristen bis zu denen Nachrücker aus Zentralanmeldungen akzeptiert werden ist nun möglich

7
templates/i18n/changelog/allocation-course-accept-substitutes-fixed.en-eu.hamlet
View File

@ -1,7 +0,0 @@
$newline never
$# SPDX-FileCopyrightText: 2022 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>
$#
$# SPDX-License-Identifier: AGPL-3.0-or-later
It is now possible to specify deadlines up to which substitute registrations from central allocations are accepted.

7
templates/i18n/changelog/allocation-course-accept-substitutes.de-de-formal.hamlet
View File

@ -1,7 +0,0 @@
$newline never
$# SPDX-FileCopyrightText: 2022 Winnie Ros <winnie.ros@campus.lmu.de>
$#
$# SPDX-License-Identifier: AGPL-3.0-or-later
Kurse, die an Zentralanmeldungen teilnehmen, können nun angeben bis zu welcher Frist sie Nachrücker:innen akzeptieren können

7
templates/i18n/changelog/allocation-course-accept-substitutes.en-eu.hamlet
View File

@ -1,7 +0,0 @@
$newline never
$# SPDX-FileCopyrightText: 2022 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>
$#
$# SPDX-License-Identifier: AGPL-3.0-or-later
Courses which participate in a central allocation may now specify a deadline up to which they are able to accept substitute registrations.

7
templates/i18n/changelog/allocation-course-registration.de-de-formal.hamlet
View File

@ -1,7 +0,0 @@
$newline never
$# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
$#
$# SPDX-License-Identifier: AGPL-3.0-or-later
Kurse zu Zentralanmeldungen eintragen

7
templates/i18n/changelog/allocation-course-registration.en-eu.hamlet
View File

@ -1,7 +0,0 @@
$newline never
$# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
$#
$# SPDX-License-Identifier: AGPL-3.0-or-later
Registration of courses for central allocation

7
templates/i18n/changelog/allocation-new-course-notification.de-de-formal.hamlet
View File

@ -1,7 +0,0 @@
$newline never
$# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
$#
$# SPDX-License-Identifier: AGPL-3.0-or-later
Benachrichtigungen, wenn neue Kurse zu Zentralanmeldungen hinzugefügt werden

7
templates/i18n/changelog/allocation-new-course-notification.en-eu.hamlet
View File

@ -1,7 +0,0 @@
$newline never
$# SPDX-FileCopyrightText: 2022 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>
$#
$# SPDX-License-Identifier: AGPL-3.0-or-later
Notifications for new courses being added to central allocations.

7
templates/i18n/changelog/allocations-notifications.de-de-formal.hamlet
View File

@ -1,7 +0,0 @@
$newline never
$# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
$#
$# SPDX-License-Identifier: AGPL-3.0-or-later
Benachrichtigungen für Zentralanmeldungen

7
templates/i18n/changelog/allocations-notifications.en-eu.hamlet
View File

@ -1,7 +0,0 @@
$newline never
$# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
$#
$# SPDX-License-Identifier: AGPL-3.0-or-later
Notifications for central allocations

7
templates/i18n/changelog/asidenav.de-de-formal.hamlet
View File

@ -1,7 +0,0 @@
$newline never
$# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
$#
$# SPDX-License-Identifier: AGPL-3.0-or-later
Designänderungen

7
templates/i18n/changelog/asidenav.en-eu.hamlet
View File

@ -1,7 +0,0 @@
$newline never
$# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
$#
$# SPDX-License-Identifier: AGPL-3.0-or-later
Design changes

7
templates/i18n/changelog/assigned-corrections-filters.de-de-formal.hamlet
View File

@ -1,7 +0,0 @@
$newline never
$# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
$#
$# SPDX-License-Identifier: AGPL-3.0-or-later
Liste zugewiesener Abgaben lassen sich nun filtern

7
templates/i18n/changelog/assigned-corrections-filters.en-eu.hamlet
View File

@ -1,7 +0,0 @@
$newline never
$# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
$#
$# SPDX-License-Identifier: AGPL-3.0-or-later
Filters for list of assigned corrections

7
templates/i18n/changelog/authorship-statements.de-de-formal.hamlet
View File

@ -1,7 +0,0 @@
$newline never
$# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
$#
$# SPDX-License-Identifier: AGPL-3.0-or-later
Es kann die Abgabe einer Eigenständigkeitserklärung bei Anlegen einer Übungsblattabgabe gefordert werden.

7
templates/i18n/changelog/authorship-statements.en-eu.hamlet
View File

@ -1,7 +0,0 @@
$newline never
$# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
$#
$# SPDX-License-Identifier: AGPL-3.0-or-later
Submittors can be required to make a Statement of Authorship when creating their submission for an exercise sheet.

7
templates/i18n/changelog/automatically-accept-course-applications.de-de-formal.hamlet
View File

@ -1,7 +0,0 @@
$newline never
$# SPDX-FileCopyrightText: 2022 Winnie Ros <winnie.ros@campus.lmu.de>
$#
$# SPDX-License-Identifier: AGPL-3.0-or-later
Automatische Anmeldung von Bewerber:innen in Kursen, die nicht an einer Zentralanmeldung teilnehmen (nach Bewertung der Bewerbung)

7
templates/i18n/changelog/automatically-accept-course-applications.en-eu.hamlet
View File

@ -1,7 +0,0 @@
$newline never
$# SPDX-FileCopyrightText: 2022 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>
$#
$# SPDX-License-Identifier: AGPL-3.0-or-later
Option to automatically accept applications for courses outside of central allocations.

7
templates/i18n/changelog/better-course-communication-tutorials.de-de-formal.hamlet
View File

@ -1,7 +0,0 @@
$newline never
$# SPDX-FileCopyrightText: 2022 Winnie Ros <winnie.ros@campus.lmu.de>
$#
$# SPDX-License-Identifier: AGPL-3.0-or-later
Besseres Verschicken von Kursmitteilungen an Tutoriumsteilnehmer:innen

7
templates/i18n/changelog/better-course-communication-tutorials.en-eu.hamlet
View File

@ -1,7 +0,0 @@
$newline never
$# SPDX-FileCopyrightText: 2022 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>
$#
$# SPDX-License-Identifier: AGPL-3.0-or-later
Better sending of course communications to tutorial participants.

7
templates/i18n/changelog/better-course-participant-detail-page.de-de-formal.hamlet
View File

@ -1,7 +0,0 @@
$newline never
$# SPDX-FileCopyrightText: 2022 Winnie Ros <winnie.ros@campus.lmu.de>
$#
$# SPDX-License-Identifier: AGPL-3.0-or-later
Anzeige von Abgaben, Tutorien und Klausuren auf der Seite für einzelne Kursteilnehmer:innen

7
templates/i18n/changelog/better-course-participant-detail-page.en-eu.hamlet
View File

@ -1,7 +0,0 @@
$newline never
$# SPDX-FileCopyrightText: 2022 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>
$#
$# SPDX-License-Identifier: AGPL-3.0-or-later
Submissions, tutorials, and exams are now shown on the detail page for course participants.

7
templates/i18n/changelog/better-csv-import.de-de-formal.hamlet
View File

@ -1,7 +0,0 @@
$newline never
$# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
$#
$# SPDX-License-Identifier: AGPL-3.0-or-later
Verbesserter Workflow & Fehlerbehandlung für CSV-Import

Some files were not shown because too many files have changed in this diff Show More