Merge branch 'master' into fradrive/driving-course-participants
This commit is contained in:
Sarah Vaupel
commit
5a2d2247ad
22
CHANGELOG.md
22
CHANGELOG.md
@ -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.
|
||||
|
||||
## [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)
|
||||
|
||||
|
||||
|
||||
@ -276,6 +276,7 @@ user-defaults:
|
||||
show-sex: false
|
||||
exam-office-get-synced: true
|
||||
exam-office-get-labels: true
|
||||
prefers-postal: true
|
||||
|
||||
|
||||
instance-id: "_env:INSTANCE_ID:instance"
|
||||
|
||||
@ -79,7 +79,7 @@ StudyFeatureInferenceNoNameConflicts: Keine Konflikte beobachtet
|
||||
StudyFeatureInferenceNameConflictsHeading: Studiengangseinträge mit beobachteten Konflikten
|
||||
|
||||
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
|
||||
BearerTokenImpersonateNone: Keine Änderung
|
||||
BearerTokenImpersonateSingle: Einzelner Benutzer/Einzelne Benutzerin
|
||||
@ -94,3 +94,22 @@ BearerTokenArchiveName !ident-ok: tokens.zip
|
||||
TestDownloadDirect: Direkte Generierung
|
||||
TestDownloadInTransaction: Generierung während Datenbank-Transaktion
|
||||
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:
|
||||
@ -79,7 +79,6 @@ StudyFeatureInferenceNoNameConflicts: No observed conflicts
|
||||
StudyFeatureInferenceNameConflictsHeading: Fields of study with observed conflicts
|
||||
|
||||
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
|
||||
BearerTokenImpersonateNone: No one
|
||||
@ -95,3 +94,22 @@ BearerTokenArchiveName: tokens.zip
|
||||
TestDownloadDirect: Direct generation
|
||||
TestDownloadInTransaction: Generate during database transaction
|
||||
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:
|
||||
@ -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.
|
||||
UnauthorizedSystemExamOffice: Sie sind nicht mit systemweiter Prüfungsverwaltung 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.
|
||||
UnauthorizedEvaluation: Sie sind nicht mit der Kursumfragenverwaltung beauftragt.
|
||||
UnauthorizedSchoolLecturer: Sie sind nicht als Veranstalter:in für dieses Institut eingetragen.
|
||||
|
||||
@ -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.
|
||||
UnauthorizedSystemExamOffice: You are not charged with system wide exam administration.
|
||||
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.
|
||||
UnauthorizedSchoolLecturer: You are no lecturer for this department.
|
||||
UnauthorizedLecturer: You are no administrator for this course.
|
||||
|
||||
@ -10,4 +10,6 @@ AvsLastName: Nachname
|
||||
AvsInternalPersonalNo: Personalnummer (nur Fraport AG)
|
||||
AvsVersionNo: Versionsnummer
|
||||
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
|
||||
@ -10,4 +10,6 @@ AvsLastName: Last name
|
||||
AvsInternalPersonalNo: Personnel number (Fraport AG only)
|
||||
AvsVersionNo: Version number
|
||||
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
|
||||
@ -18,5 +18,4 @@ BothSubmissions: Abgabe direkt in Uni2work oder extern mit Pseudonym
|
||||
SystemExamOffice: Prüfungsverwaltung
|
||||
SystemFaculty: Fakultätsmitglied
|
||||
SystemStudent: Student:in
|
||||
SystemPrinter: Drucker:in
|
||||
SystemSap: SAP Verwalter:in
|
||||
SystemPrinter: Drucker:in
|
||||
@ -18,5 +18,4 @@ BothSubmissions: Submission either directly in Uni2work or externally via pseudo
|
||||
SystemExamOffice: Exam office
|
||||
SystemFaculty: Faculty member
|
||||
SystemStudent: Student
|
||||
SystemPrinter: Printing staff
|
||||
SystemSap: SAP Administrator
|
||||
SystemPrinter: Printing staff
|
||||
@ -14,9 +14,9 @@ TableQualificationCountActive: Active
|
||||
TableQualificationCountActiveTooltip: Number of currently valid qualification holders
|
||||
TableQualificationCountTotal: Total
|
||||
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
|
||||
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
|
||||
TableQualificationLastRefresh: Last renewed
|
||||
TableQualificationFirstHeld: First held
|
||||
|
||||
@ -14,7 +14,6 @@ AuthTagAdmin: Nutzer:in ist Administrator:in
|
||||
AuthTagExamOffice: Nutzer:in ist mit Prüfungsverwaltung beauftragt
|
||||
AuthTagSystemExamOffice: Nutzer:in ist mit systemweiter Prüfungsverwaltung 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
|
||||
AuthTagToken: Nutzer:in präsentiert Authorisierungs-Token
|
||||
AuthTagNoEscalation: Nutzer-Rechte werden nicht auf fremde Institute ausgeweitet
|
||||
|
||||
@ -14,7 +14,6 @@ AuthTagAdmin: User is administrator
|
||||
AuthTagExamOffice: User is part of an exam office
|
||||
AuthTagSystemExamOffice: User is charged with system wide exam administration
|
||||
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
|
||||
AuthTagToken: User is presenting an authorisation-token
|
||||
AuthTagNoEscalation: User permissions are not being expanded to other departments
|
||||
|
||||
@ -27,7 +27,11 @@ ProfileCorrectorRemark: Die oberhalb angezeigte Tabelle zeigt nur prinzipielle E
|
||||
ProfileCorrections: Auflistung aller zugewiesenen Korrekturen
|
||||
Remarks: Hinweise
|
||||
|
||||
ProfileSupervisor: Übergeordnete Ansprechpartner
|
||||
ProfileSupervisee: Ist Ansprechpartner für
|
||||
|
||||
UserTelephone: Telefon
|
||||
UserMobile: Mobiltelefon
|
||||
Company: Firmenzugehörigkeit
|
||||
CompanyPersonalNumber: Personalnummer (nur Fraport AG)
|
||||
CompanyDepartment: Abteilung
|
||||
@ -27,7 +27,11 @@ ProfileCorrectorRemark: The table above only shows registration as a corrector i
|
||||
ProfileCorrections: List of all assigned corrections
|
||||
Remarks: Remarks
|
||||
|
||||
ProfileSupervisor: Supervised by
|
||||
ProfileSupervisee: Supervises
|
||||
|
||||
UserTelephone: Phone
|
||||
UserMobile: Mobile
|
||||
Company: Company affilitaion
|
||||
CompanyPersonalNumber: Personnel number (Fraport AG only)
|
||||
CompanyDepartment: Department
|
||||
@ -28,7 +28,7 @@ TermLectureStartTooltip: Muss am oder nach dem Beginn liegen
|
||||
TermLectureEndTooltip: Muss am oder vor dem Ende liegen
|
||||
TermActive: Aktiv
|
||||
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"}
|
||||
TermsHeading: Semesterübersicht
|
||||
TermEditHeading: Semester editieren/anlegen
|
||||
|
||||
@ -28,7 +28,7 @@ TermLectureStartTooltip: Must be on or after starting day
|
||||
TermLectureEndTooltip: Must be before or on ending day
|
||||
TermActive: Active
|
||||
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"}
|
||||
TermsHeading: Semesters
|
||||
TermEditHeading: Edit semester
|
||||
|
||||
@ -13,7 +13,7 @@ AdminUserAuth: Authentifizierung
|
||||
AdminUserMatriculation: Matrikelnummer
|
||||
AdminUserSex: Geschlecht
|
||||
AdminUserTelephone: Telefonnummer
|
||||
AdminUserMobile: Mobiltelefonmummer
|
||||
AdminUserMobile: Mobiltelefonnummer
|
||||
AdminUserFPersonalNumber: Personalnummer (nur Fraport AG)
|
||||
AdminUserFDepartment: Abteilung
|
||||
AdminUserPostAddress: Postalische Anschrift
|
||||
|
||||
@ -72,3 +72,5 @@ TableExamOfficeLabel: Label-Name
|
||||
TableExamOfficeLabelStatus: Label-Farbe
|
||||
TableExamOfficeLabelPriority: Label-Priorität
|
||||
TableQualifications: Qualifikationen
|
||||
TableCompany: Firma
|
||||
TableSupervisor: Ansprechpartner
|
||||
|
||||
@ -72,3 +72,5 @@ TableExamOfficeLabel: Label name
|
||||
TableExamOfficeLabelStatus: Label colour
|
||||
TableExamOfficeLabelPriority: Label priority
|
||||
TableQualifications: Qualifications
|
||||
TableCompany: Company
|
||||
TableSupervisor: Supervisor
|
||||
|
||||
@ -14,8 +14,9 @@
|
||||
|
||||
|
||||
UserAvs
|
||||
personId AvsPersonId -- unique identifier for user throughout avs
|
||||
personId AvsPersonId -- unique identifier for user throughout avs; newtype for Int
|
||||
user UserId
|
||||
noPerson Int default=0 -- only needed for manual communication with personnel from Ausweisverwaltungsstelle
|
||||
UniqueUserAvsUser user
|
||||
UniqueUserAvsId personId
|
||||
deriving Generic
|
||||
|
||||
@ -15,8 +15,8 @@ Qualification
|
||||
-- elearningOnly Bool -- successful E-learing automatically increases validity. 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!
|
||||
avsLicence AvsLicence Maybe -- if set, is synchronized to Avs as a driving licence
|
||||
sapId Text Maybe -- if set, all QualificationUsers with userCompanyPersonalNumber are transmitted via SAP interface under this id
|
||||
avsLicence AvsLicence Maybe -- if set, valid QualificationUsers are synchronized to AVS as a driving licence
|
||||
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
|
||||
SchoolQualificationName school name -- must be unique per school and name
|
||||
-- across all schools, only one qualification may be a driving licence:
|
||||
|
||||
@ -1,3 +1,3 @@
|
||||
{
|
||||
"version": "26.6.0"
|
||||
"version": "26.6.6"
|
||||
}
|
||||
|
||||
@ -1,3 +1,3 @@
|
||||
{
|
||||
"version": "26.6.0"
|
||||
"version": "26.6.6"
|
||||
}
|
||||
|
||||
2
package-lock.json
generated
2
package-lock.json
generated
@ -1,6 +1,6 @@
|
||||
{
|
||||
"name": "uni2work",
|
||||
"version": "26.6.0",
|
||||
"version": "26.6.6",
|
||||
"lockfileVersion": 1,
|
||||
"requires": true,
|
||||
"dependencies": {
|
||||
|
||||
@ -1,6 +1,6 @@
|
||||
{
|
||||
"name": "uni2work",
|
||||
"version": "26.6.0",
|
||||
"version": "26.6.6",
|
||||
"description": "",
|
||||
"keywords": [],
|
||||
"author": "",
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: uniworx
|
||||
version: 26.6.0
|
||||
version: 26.6.6
|
||||
dependencies:
|
||||
- base
|
||||
- yesod
|
||||
|
||||
BIN
resources/FAG_UKM-MI_Pictogram-Library-Manual_RZ.pdf
Normal file
BIN
resources/FAG_UKM-MI_Pictogram-Library-Manual_RZ.pdf
Normal file
Binary file not shown.
BIN
resources/FraportIcons.zip
Normal file
BIN
resources/FraportIcons.zip
Normal file
Binary file not shown.
BIN
resources/fraport_icons_übersicht_2018-11-15.pdf
Normal file
BIN
resources/fraport_icons_übersicht_2018-11-15.pdf
Normal file
Binary file not shown.
13
routes
13
routes
@ -68,6 +68,9 @@
|
||||
/admin/crontab AdminCrontabR GET
|
||||
/admin/avs AdminAvsR 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/acknowledge/#Day/#Int/#Int PrintAckR GET POST !system-printer
|
||||
@ -102,8 +105,8 @@
|
||||
/user/lang LangR POST !free
|
||||
/user/storage-key StorageKeyR POST !free
|
||||
|
||||
/for/#CryptoUUIDUser/user ForProfileR GET POST !supervisor
|
||||
/for/#CryptoUUIDUser/user/profile ForProfileDataR GET !supervisor
|
||||
/for/#CryptoUUIDUser/user ForProfileR GET POST !supervisor !self
|
||||
/for/#CryptoUUIDUser/user/profile ForProfileDataR GET !supervisor !self
|
||||
|
||||
|
||||
/exam-office ExamOfficeR !exam-office:
|
||||
@ -254,12 +257,12 @@
|
||||
-- !/*{CI FilePath} CryptoFileNameDispatchR GET !free -- Disabled until preliminary check for valid cID exists
|
||||
|
||||
-- for users
|
||||
/qualification QualificationAllR GET !free -- TODO repurpose
|
||||
/qualification/#SchoolId QualificationSchoolR GET !free -- TODO repurpose
|
||||
/qualification QualificationAllR GET -- TODO repurpose
|
||||
/qualification/#SchoolId QualificationSchoolR GET -- TODO repurpose
|
||||
/qualification/#SchoolId/#QualificationShorthand QualificationR GET -- TODO repurpose
|
||||
|
||||
-- SAP export
|
||||
/qualifications/sap/direct QualificationSAPDirectR GET !system-sap
|
||||
/qualifications/sap/direct QualificationSAPDirectR GET !token
|
||||
-- OSIS CSV Export Demo
|
||||
/lms LmsAllR GET POST !free -- TODO verify that this is ok
|
||||
/lms/#SchoolId LmsSchoolR GET !free -- TODO verify that this is ok
|
||||
|
||||
@ -146,7 +146,7 @@ campusUserReTest' :: (MonadMask m, MonadLogger m, MonadUnliftIO m) => Failover (
|
||||
campusUserReTest' pool doTest mode User{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' :: (MonadMask m, MonadUnliftIO m, MonadLogger m) => Failover (LdapConf, LdapPool) -> FailoverMode -> User -> m (Maybe (Ldap.AttrList []))
|
||||
|
||||
@ -99,7 +99,7 @@ instance PersistField CalendarDiffDays where
|
||||
coerceICcd :: Integer -> CDDdb
|
||||
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
|
||||
-- both = join (***) is still too cryptic for me
|
||||
both :: (a -> b) -> (a, a) -> (b, b)
|
||||
|
||||
@ -7,7 +7,7 @@
|
||||
|
||||
module Database.Esqueleto.Utils
|
||||
( true, false
|
||||
, justVal, justValList
|
||||
, justVal, justValList, toValues
|
||||
, isJust, alt
|
||||
, isInfixOf, hasInfix
|
||||
, strConcat, substring
|
||||
@ -50,7 +50,9 @@ import Data.Universe
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.List as List
|
||||
import qualified Data.Foldable as F
|
||||
import Data.List.NonEmpty (NonEmpty(..))
|
||||
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.Internal.Internal as E
|
||||
import Database.Esqueleto.Utils.TH
|
||||
@ -97,10 +99,15 @@ false = E.val False
|
||||
-- infinity = unsafeSqlValue "'infinity'"
|
||||
|
||||
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 = 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 =?.
|
||||
(=?.) :: PersistField typ => E.SqlExpr (E.Value typ) -> E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value Bool)
|
||||
|
||||
@ -568,15 +568,6 @@ tagAccessPredicate AuthSystemPrinter = cacheAPSystemFunction SystemPrinter (Just
|
||||
isPrinter <- lift $ exists [UserSystemFunctionUser ==. authId, UserSystemFunctionFunction ==. SystemPrinter, UserSystemFunctionIsOptOut ==. False]
|
||||
guardMExceptT isPrinter $ unauthorizedI MsgUnauthorizedSystemPrinter
|
||||
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
|
||||
| maybe True (`Set.notMember` studentList) mAuthId' -> Right $ if
|
||||
| is _Nothing mAuthId' -> return AuthenticationRequired
|
||||
@ -1505,6 +1496,8 @@ tagAccessPredicate AuthSelf = APDB $ \_ _ mAuthId route _ -> exceptT return retu
|
||||
UserNotificationR cID -> return $ Left cID
|
||||
UserPasswordR 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
|
||||
referencedUser <- case referencedUser' of
|
||||
Right uid -> return uid
|
||||
|
||||
@ -106,14 +106,17 @@ breadcrumb (UserPasswordR cID) = useRunDB $ do
|
||||
breadcrumb AdminNewFunctionaryInviteR = i18nCrumb MsgMenuLecturerInvite $ Just UsersR
|
||||
breadcrumb AdminFunctionaryInviteR = i18nCrumb MsgBreadcrumbFunctionaryInvite Nothing
|
||||
|
||||
breadcrumb AdminR = i18nCrumb MsgAdminHeading Nothing
|
||||
breadcrumb AdminTestR = i18nCrumb MsgMenuAdminTest $ Just AdminR
|
||||
breadcrumb AdminTestPdfR = i18nCrumb MsgMenuAdminTest $ Just AdminTestR
|
||||
breadcrumb AdminErrMsgR = i18nCrumb MsgMenuAdminErrMsg $ Just AdminR
|
||||
breadcrumb AdminTokensR = i18nCrumb MsgMenuAdminTokens $ Just AdminR
|
||||
breadcrumb AdminCrontabR = i18nCrumb MsgBreadcrumbAdminCrontab $ Just AdminR
|
||||
breadcrumb AdminAvsR = i18nCrumb MsgMenuAvs $ Just AdminR
|
||||
breadcrumb AdminLdapR = i18nCrumb MsgMenuLdap $ Just AdminR
|
||||
breadcrumb AdminR = i18nCrumb MsgAdminHeading Nothing
|
||||
breadcrumb AdminTestR = i18nCrumb MsgMenuAdminTest $ Just AdminR
|
||||
breadcrumb AdminTestPdfR = i18nCrumb MsgMenuAdminTest $ Just AdminTestR
|
||||
breadcrumb AdminErrMsgR = i18nCrumb MsgMenuAdminErrMsg $ Just AdminR
|
||||
breadcrumb AdminTokensR = i18nCrumb MsgMenuAdminTokens $ Just AdminR
|
||||
breadcrumb AdminCrontabR = i18nCrumb MsgBreadcrumbAdminCrontab $ Just AdminR
|
||||
breadcrumb AdminAvsR = i18nCrumb MsgMenuAvs $ Just AdminR
|
||||
breadcrumb AdminLdapR = i18nCrumb MsgMenuLdap $ Just AdminR
|
||||
breadcrumb ProblemUnreachableR = i18nCrumb MsgProblemsUnreachableHeading $Just AdminR
|
||||
breadcrumb ProblemWithoutAvsId = i18nCrumb MsgProblemsNoAvsIdHeading $ Just AdminR
|
||||
breadcrumb ProblemFbutNoR = i18nCrumb MsgProblemsRWithoutFHeading $ Just AdminR
|
||||
|
||||
breadcrumb PrintCenterR = i18nCrumb MsgMenuApc Nothing
|
||||
breadcrumb PrintSendR = i18nCrumb MsgMenuPrintSend $ Just PrintCenterR
|
||||
@ -732,6 +735,14 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the
|
||||
, navIcon = IconMenuAdmin
|
||||
, navChildren =
|
||||
[ NavLink
|
||||
{ navLabel = MsgProblemsHeading
|
||||
, navRoute = AdminR
|
||||
, navAccess' = NavAccessTrue
|
||||
, navType = NavTypeLink { navModal = False }
|
||||
, navQuick' = mempty
|
||||
, navForceActive = False
|
||||
}
|
||||
, NavLink
|
||||
{ navLabel = MsgMenuUsers
|
||||
, navRoute = UsersR
|
||||
, navAccess' = NavAccessTrue
|
||||
|
||||
@ -4,7 +4,8 @@
|
||||
|
||||
module Foundation.Yesod.Auth
|
||||
( authenticate
|
||||
, upsertCampusUser, upsertCampusUserByCn
|
||||
, ldapLookupAndUpsert
|
||||
, upsertCampusUser
|
||||
, decodeUserTest
|
||||
, CampusUserConversionException(..)
|
||||
, campusUserFailoverMode, updateUserLanguage
|
||||
@ -106,10 +107,10 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend
|
||||
| not isDummy -> res <$ update uid [ UserLastAuthentication =. Just now ]
|
||||
_other -> return res
|
||||
|
||||
$logDebugS "auth" $ tshow Creds{..}
|
||||
UniWorX{..} <- getYesod
|
||||
$logDebugS "auth" $ tshow Creds{..}
|
||||
ldapPool' <- getsYesod $ view _appLdapPool
|
||||
|
||||
flip catches excHandlers $ case appLdapPool of
|
||||
flip catches excHandlers $ case ldapPool' of
|
||||
Just ldapPool
|
||||
| Just upsertMode' <- upsertMode -> do
|
||||
ldapData <- campusUser ldapPool campusUserFailoverMode Creds{..}
|
||||
@ -152,14 +153,25 @@ _upsertCampusUserMode mMode cs@Creds{..}
|
||||
|
||||
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.
|
||||
( MonadHandler m, HandlerSite m ~ UniWorX
|
||||
, MonadThrow m
|
||||
)
|
||||
=> Text -> SqlPersistT m (Entity User)
|
||||
upsertCampusUserByCn persNo = upsertCampusUser UpsertCampusUserGuessUser [(ldapPrimaryKey,[Text.encodeUtf8 persNo])]
|
||||
-}
|
||||
|
||||
|
||||
-- | Upsert User DB according to given LDAP data (does not query LDAP itself)
|
||||
upsertCampusUser :: forall m.
|
||||
( MonadHandler m, HandlerSite m ~ UniWorX
|
||||
, MonadThrow m
|
||||
@ -208,7 +220,7 @@ decodeUserTest mbIdent ldapData = do
|
||||
|
||||
|
||||
decodeUser :: (MonadThrow m) => UTCTime -> UserDefaultConf -> UpsertCampusUserMode -> Ldap.AttrList [] -> m (User,_)
|
||||
decodeUser now UserDefaultConf{..} upsertMode ldapData = do
|
||||
decodeUser now UserDefaultConf{..} upsertMode ldapData = do
|
||||
let
|
||||
userTelephone = decodeLdap ldapUserTelephone
|
||||
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
|
||||
, userPostAddress = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO
|
||||
, userPinPassword = Nothing -- must be derived via AVS
|
||||
, userPrefersPostal = False
|
||||
, userPrefersPostal = userDefaultPrefersPostal
|
||||
, ..
|
||||
}
|
||||
userUpdate = [
|
||||
|
||||
@ -8,6 +8,22 @@ module Handler.Admin
|
||||
|
||||
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.ErrorMessage 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.Ldap as Handler.Admin
|
||||
|
||||
|
||||
getAdminR :: Handler Html
|
||||
getAdminR =
|
||||
siteLayoutMsg MsgAdminHeading $ do
|
||||
setTitleI MsgAdminHeading
|
||||
i18n MsgAdminPageEmpty
|
||||
getAdminR = do
|
||||
now <- liftIO getCurrentTime
|
||||
let nowaday = utctDay now
|
||||
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
|
||||
-}
|
||||
@ -4,7 +4,7 @@
|
||||
|
||||
module Handler.Admin.Avs
|
||||
( getAdminAvsR
|
||||
, postAdminAvsR
|
||||
, postAdminAvsR
|
||||
) where
|
||||
|
||||
import Import
|
||||
@ -14,23 +14,45 @@ import qualified Data.Text as Text
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import Handler.Utils
|
||||
import Handler.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 = 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 tmpl = identifyForm FIDAvsQueryPerson . validateForm validateAvsQueryPerson $ \html ->
|
||||
flip (renderAForm FormStandard) html $ AvsQueryPerson
|
||||
makeAvsPersonForm tmpl = identifyForm FIDAvsQueryPerson . validateForm validateAvsQueryPerson $ \html ->
|
||||
flip (renderAForm FormStandard) html $ AvsQueryPerson
|
||||
<$> aopt avsCardNoField (fslI MsgAvsCardNo) (avsPersonQueryCardNo <$> tmpl)
|
||||
<*> aopt textField (fslI MsgAvsVersionNo) (avsPersonQueryVersionNo <$> tmpl)
|
||||
<*> aopt textField (fslI MsgAvsFirstName) (avsPersonQueryFirstName <$> tmpl)
|
||||
<*> aopt textField (fslI MsgAvsLastName) (avsPersonQueryLastName <$> tmpl)
|
||||
<*> aopt textField (fslI MsgAvsInternalPersonalNo) (avsPersonQueryInternalPersonalNo <$> tmpl)
|
||||
<*> aopt textField (fslI MsgAvsVersionNo) (avsPersonQueryVersionNo <$> tmpl)
|
||||
<*> aopt avsInternalPersonalNoField
|
||||
(fslI MsgAvsInternalPersonalNo) (avsPersonQueryInternalPersonalNo <$> tmpl)
|
||||
|
||||
|
||||
validateAvsQueryPerson :: FormValidator AvsQueryPerson Handler ()
|
||||
validateAvsQueryPerson = do
|
||||
validateAvsQueryPerson = do
|
||||
AvsQueryPerson{..} <- State.get
|
||||
guardValidation MsgAvsQueryEmpty $
|
||||
is _Just avsPersonQueryCardNo ||
|
||||
@ -40,23 +62,34 @@ validateAvsQueryPerson = do
|
||||
is _Just avsPersonQueryVersionNo
|
||||
|
||||
makeAvsStatusForm :: Maybe AvsQueryStatus -> Form AvsQueryStatus
|
||||
makeAvsStatusForm tmpl = identifyForm FIDAvsQueryStatus . validateForm validateAvsQueryStatus $ \html ->
|
||||
makeAvsStatusForm tmpl = identifyForm FIDAvsQueryStatus . validateForm validateAvsQueryStatus $ \html ->
|
||||
flip (renderAForm FormStandard) html $
|
||||
parseAvsIds <$> areq textField (fslI MsgAvsPersonId) (unparseAvsIds <$> tmpl)
|
||||
where
|
||||
parseAvsIds :: Text -> AvsQueryStatus
|
||||
parseAvsIds txt = AvsQueryStatus $ Set.fromList ids
|
||||
where
|
||||
nonemptys = filter (not . Text.null) $ Text.strip <$> Text.split (==',') txt
|
||||
where
|
||||
nonemptys = filter (not . Text.null) $ Text.strip <$> Text.split (==',') txt
|
||||
ids = catMaybes $ readMay <$> nonemptys
|
||||
unparseAvsIds :: AvsQueryStatus -> Text
|
||||
unparseAvsIds (AvsQueryStatus ids) = Text.intercalate ", " $ tshow <$> Set.toAscList ids
|
||||
unparseAvsIds :: AvsQueryStatus -> Text
|
||||
unparseAvsIds (AvsQueryStatus ids) = Text.intercalate ", " $ tshow <$> Set.toAscList ids
|
||||
|
||||
validateAvsQueryStatus :: FormValidator AvsQueryStatus Handler ()
|
||||
validateAvsQueryStatus = do
|
||||
validateAvsQueryStatus = do
|
||||
AvsQueryStatus ids <- State.get
|
||||
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
|
||||
postAdminAvsR = do
|
||||
@ -66,31 +99,136 @@ postAdminAvsR = do
|
||||
Just AvsQuery{..} -> do
|
||||
((presult, pwidget), penctype) <- runFormPost $ makeAvsPersonForm Nothing
|
||||
|
||||
let procFormPerson fr = do
|
||||
let procFormPerson fr = do
|
||||
addMessage Info $ text2Html $ "Query: " <> tshow (toJSON fr)
|
||||
res <- avsQueryPerson fr
|
||||
case res of
|
||||
Left err -> return . Just $ tshow err
|
||||
Right jsn -> return . Just $ tshow jsn
|
||||
case res of
|
||||
Left err -> return . Just $ tshow err
|
||||
Right jsn -> return . Just $ Text.replace "},Avs" "},\n Avs" $ tshow jsn
|
||||
mbPerson <- formResultMaybe presult procFormPerson
|
||||
|
||||
((sresult, swidget), senctype) <- runFormPost $ makeAvsStatusForm Nothing
|
||||
let procFormStatus fr = do
|
||||
let procFormStatus fr = do
|
||||
addMessage Info $ text2Html $ "Query: " <> tshow (toJSON fr)
|
||||
res <- avsQueryStatus fr
|
||||
case res of
|
||||
Left err -> return . Just $ tshow err
|
||||
Right jsn -> return . Just $ tshow jsn
|
||||
case res of
|
||||
Left err -> return . Just $ tshow err
|
||||
Right jsn -> return . Just $ Text.replace "},Avs" "},\n Avs" $ tshow jsn
|
||||
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
|
||||
siteLayoutMsg MsgMenuAvs $ do
|
||||
setTitleI MsgMenuAvs
|
||||
let personForm = wrapForm pwidget def
|
||||
{ formAction = Just $ SomeRoute actionUrl
|
||||
, formEncoding = penctype
|
||||
}
|
||||
statusForm = wrapForm swidget def
|
||||
{ formAction = Just $ SomeRoute actionUrl
|
||||
, formEncoding = senctype
|
||||
}
|
||||
let wrapFormHere fw fe = wrapForm fw def { formAction = Just $ SomeRoute actionUrl, formEncoding = fe }
|
||||
personForm = wrapFormHere pwidget penctype
|
||||
statusForm = wrapFormHere swidget senctype
|
||||
crUsrForm = wrapFormHere crUsrWgt crUsrEnctype
|
||||
getLicForm = wrapFormHere getLicWgt getLicEnctype
|
||||
setLicForm = wrapFormHere setLicWgt setLicEnctype
|
||||
qryLicForm = wrapForm qryLicWgt def { formAction = Just $ SomeRoute actionUrl, formEncoding = qryLicEnctype, formSubmit = FormNoSubmit }
|
||||
-- TODO: use i18nWidgetFile instead if this is to become permanent
|
||||
$(widgetFile "avs")
|
||||
$(widgetFile "avs")
|
||||
|
||||
@ -10,67 +10,46 @@ module Handler.Admin.Ldap
|
||||
) where
|
||||
|
||||
import Import
|
||||
import qualified Control.Monad.State.Class as State
|
||||
-- import qualified Control.Monad.State.Class as State
|
||||
-- import Data.Aeson (encode)
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Text.Encoding as Text
|
||||
-- import qualified Data.Set as Set
|
||||
import Foundation.Yesod.Auth (decodeUserTest)
|
||||
|
||||
import Foundation.Yesod.Auth (decodeUserTest,ldapLookupAndUpsert,campusUserFailoverMode,CampusUserConversionException())
|
||||
import Handler.Utils
|
||||
|
||||
import qualified Ldap.Client as 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
|
||||
postAdminLdapR = do
|
||||
((presult, pwidget), penctype) <- runFormPost $ makeLdapPersonForm Nothing
|
||||
|
||||
let procFormPerson :: LdapQueryPerson -> Handler (Maybe (Ldap.AttrList []))
|
||||
procFormPerson LdapQueryPerson{..} = do
|
||||
ldapPool' <- getsYesod $ view _appLdapPool
|
||||
|
||||
if isNothing ldapPool'
|
||||
then addMessage Warning $ text2Html "LDAP Configuration missing."
|
||||
else addMessage Info $ text2Html "Input for LDAP test received."
|
||||
fmap join . for ldapPool' $ \ldapPool -> do
|
||||
ldapData <- 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
|
||||
|
||||
((presult, pwidget), penctype) <- runFormPost $ identifyForm ("adminLdapLookup"::Text) $ \html ->
|
||||
flip (renderAForm FormStandard) html $ areq textField (fslI MsgAdminUserIdent) Nothing
|
||||
|
||||
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
|
||||
|
||||
|
||||
((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
|
||||
siteLayoutMsg MsgMenuLdap $ do
|
||||
setTitleI MsgMenuLdap
|
||||
@ -78,7 +57,10 @@ postAdminLdapR = do
|
||||
{ formAction = Just $ SomeRoute actionUrl
|
||||
, formEncoding = penctype
|
||||
}
|
||||
|
||||
upsertForm = wrapForm uwidget def
|
||||
{ formAction = Just $ SomeRoute actionUrl
|
||||
, formEncoding = uenctype
|
||||
}
|
||||
presentUtf8 lv = Text.intercalate ", " (either tshow id . Text.decodeUtf8' <$> lv)
|
||||
presentLatin1 lv = Text.intercalate ", " ( Text.decodeLatin1 <$> lv)
|
||||
|
||||
|
||||
@ -83,8 +83,9 @@ postLmsAllR = do
|
||||
FormMissing -> return ()
|
||||
_other -> addMessage Warning "Kein korrekter LMS Knopf erkannt"
|
||||
|
||||
isAdmin <- hasReadAccessTo AdminR
|
||||
lmsTable <- runDB $ do
|
||||
view _2 <$> mkLmsAllTable
|
||||
view _2 <$> mkLmsAllTable isAdmin
|
||||
siteLayoutMsg MsgMenuQualifications $ do
|
||||
setTitleI MsgMenuQualifications
|
||||
$(widgetFile "lms-all")
|
||||
@ -100,9 +101,10 @@ resultAllQualificationTotal :: Lens' AllQualificationTableData Word64
|
||||
resultAllQualificationTotal = _dbrOutput . _3 . _unValue
|
||||
|
||||
|
||||
mkLmsAllTable :: DB (Any, Widget)
|
||||
mkLmsAllTable = do
|
||||
mkLmsAllTable :: Bool -> DB (Any, Widget)
|
||||
mkLmsAllTable isAdmin = do
|
||||
now <- liftIO getCurrentTime
|
||||
|
||||
let
|
||||
resultDBTable = DBTable{..}
|
||||
where
|
||||
@ -139,7 +141,12 @@ mkLmsAllTable = do
|
||||
, sortable Nothing (i18nCell MsgTableQualificationIsAvsLicence & cellTooltip MsgTableQualificationIsAvsLicenceTooltip)
|
||||
$ \(view (resultAllQualification . _qualificationAvsLicence) -> licence) -> maybeCell licence $ textCell . T.singleton . licence2char
|
||||
, 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)
|
||||
$ \(view resultAllQualificationActive -> n) -> wgtCell $ word2widget n
|
||||
, sortable Nothing (i18nCell MsgTableQualificationCountTotal) $ wgtCell . word2widget . view resultAllQualificationTotal
|
||||
@ -553,7 +560,7 @@ postLmsR sid qsh = do
|
||||
where
|
||||
-- i18nLms :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a
|
||||
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
|
||||
return (tbl, qent)
|
||||
|
||||
|
||||
@ -559,17 +559,42 @@ getForProfileDataR cID = do
|
||||
|
||||
makeProfileData :: Entity User -> DB Widget
|
||||
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] []
|
||||
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.^. SheetId E.==. corrector E.^. SheetCorrectorSheet
|
||||
E.where_ $ corrector E.^. SheetCorrectorUser E.==. E.val uid
|
||||
return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand)
|
||||
studies <- E.select $ E.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do
|
||||
E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid
|
||||
studies <- E.select $ E.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do
|
||||
E.on $ studyfeat E.^. StudyFeaturesField E.==. studyterms E.^. StudyTermsId
|
||||
E.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId
|
||||
E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid
|
||||
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
|
||||
(hasRows, ownedCoursesTable) <- mkOwnedCoursesTable uid -- Tabelle mit eigenen Kursen
|
||||
enrolledCoursesTable <- mkEnrolledCoursesTable uid -- Tabelle mit allen Teilnehmer: Kurs (link), Datum
|
||||
@ -584,7 +609,8 @@ makeProfileData (Entity uid User{..}) = do
|
||||
|
||||
cID <- encrypt uid
|
||||
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")
|
||||
return $(widgetFile "profileData")
|
||||
@ -908,7 +934,6 @@ mkCorrectionsTable =
|
||||
in dbTableWidget' validator DBTable{..}
|
||||
|
||||
|
||||
|
||||
-- | Table listing all qualifications that the given user is enrolled in
|
||||
mkQualificationsTable :: UserId -> DB Widget
|
||||
mkQualificationsTable =
|
||||
|
||||
@ -16,6 +16,7 @@ import Handler.Utils.Csv
|
||||
|
||||
-- import qualified Data.CaseInsensitive as CI
|
||||
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.Legacy 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 = do
|
||||
qualUsers <- runDB $ Ex.select $ do
|
||||
(qual Ex.:& qualUser Ex.:& user) <-
|
||||
(qual :& qualUser :& user) <-
|
||||
Ex.from $ Ex.table @Qualification
|
||||
`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.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.&&. E.isJust (user Ex.^. UserCompanyPersonalNumber)
|
||||
return
|
||||
|
||||
@ -85,6 +85,16 @@ postUsersR = do
|
||||
-- , sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM
|
||||
-- (AdminUserR <$> encrypt uid)
|
||||
-- (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
|
||||
(AdminUserR <$> encrypt uid)
|
||||
(toWgt userCompanyPersonalNumber)
|
||||
@ -92,6 +102,16 @@ postUsersR = do
|
||||
-- , sortable (Just "last-name") (i18nCell MsgName) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM
|
||||
-- (AdminUserR <$> encrypt uid)
|
||||
-- (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 "ldap-sync") (i18nCell MsgLdapSynced) $ \DBRow{ dbrOutput = Entity _ User{..} } -> maybe mempty dateTimeCell userLastLdapSynchronisation
|
||||
, flip foldMap universeF $ \function ->
|
||||
@ -171,6 +191,20 @@ postUsersR = do
|
||||
, ( "ldap-sync"
|
||||
, 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
|
||||
[ ( "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
|
||||
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.%))
|
||||
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
|
||||
-- | 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
|
||||
| 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
|
||||
[ prismAForm (singletonFilter "user-search") mPrev $ aopt textField (fslI MsgName)
|
||||
, prismAForm (singletonFilter "user-ident") mPrev $ aopt textField (fslI MsgAdminUserIdent)
|
||||
, prismAForm (singletonFilter "user-email") mPrev $ aopt textField (fslI MsgAdminUserEmail)
|
||||
-- , prismAForm (singletonFilter "matriculation") mPrev $ aopt matriculationField (fslI MsgTableMatrikelNr)
|
||||
, prismAForm (singletonFilter "user-email") mPrev $ aopt textField (fslI MsgAdminUserEmail)
|
||||
-- , prismAForm (singletonFilter "matriculation") mPrev $ aopt matriculationField (fslI MsgTableMatrikelNr)
|
||||
, prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumber)
|
||||
, 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 "school") mPrev $ aopt (lift `hoistField` selectFieldList schoolOptions) (fslI MsgCourseSchool)
|
||||
, prismAForm (singletonFilter "ldap-sync" . maybePrism _PathPiece) mPrev $ aopt utcTimeField (fslI MsgLdapSyncedBefore)
|
||||
@ -317,7 +369,7 @@ nullaryPathPiece ''UserAssimilateButton $ camelToPathPiece' 2
|
||||
embedRenderMessage ''UniWorX ''UserAssimilateButton id
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
getAdminUserR, postAdminUserR :: CryptoUUIDUser -> Handler Html
|
||||
getAdminUserR = postAdminUserR
|
||||
@ -337,7 +389,7 @@ postAdminUserR uuid = do
|
||||
return (school, userFunction E.?. UserFunctionFunction, isAdmin)
|
||||
|
||||
systemFunctionsF <- Set.fromList . map (userSystemFunctionFunction . entityVal) <$> selectList [UserSystemFunctionUser ==. uid, UserSystemFunctionIsOptOut ==. False] []
|
||||
let systemFunctions = (`Set.member` systemFunctionsF)
|
||||
let systemFunctions = (`Set.member` systemFunctionsF)
|
||||
|
||||
return ( user
|
||||
, setOf (folded . filtered (view $ _3 . _Value) . _1 . _entityKey) schools
|
||||
|
||||
@ -36,9 +36,9 @@ data AdminUserForm = AdminUserForm
|
||||
}
|
||||
|
||||
data AuthenticationKind = AuthKindLDAP | AuthKindPWHash | AuthKindNoLogin
|
||||
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
||||
instance Universe AuthenticationKind
|
||||
instance Finite AuthenticationKind
|
||||
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable, Universe, Finite)
|
||||
--instance Universe AuthenticationKind
|
||||
--instance Finite AuthenticationKind
|
||||
embedRenderMessage ''UniWorX ''AuthenticationKind id
|
||||
nullaryPathPiece ''AuthenticationKind $ camelToPathPiece' 2
|
||||
|
||||
|
||||
@ -4,14 +4,16 @@
|
||||
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
{-# OPTIONS_GHC -fno-warn-unused-imports #-}
|
||||
|
||||
module Handler.Utils.Avs
|
||||
( upsertAvsUser, upsertAvsUserById, upsertAvsUserByCard
|
||||
, getLicence, getLicenceDB
|
||||
-- , getLicence, getLicenceDB, getLicenceByAvsId -- not supported by interface
|
||||
, setLicence, setLicenceAvs, setLicencesAvs
|
||||
, checkLicences
|
||||
, retrieveDifferingLicences, computeDifferingLicences
|
||||
, synchAvsLicences
|
||||
, lookupAvsUser, lookupAvsUsers
|
||||
, AvsException(..)
|
||||
, updateReceivers
|
||||
) where
|
||||
|
||||
import Import
|
||||
@ -26,14 +28,14 @@ import qualified Data.Map as Map
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
-- import Auth.LDAP (ldapUserPrincipalName)
|
||||
import Foundation.Yesod.Auth (upsertCampusUserByCn,CampusUserConversionException())
|
||||
import Foundation.Yesod.Auth (ldapLookupAndUpsert, CampusUserConversionException())
|
||||
|
||||
import Handler.Utils.Company
|
||||
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.Utils as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
|
||||
|
||||
--------------------
|
||||
@ -43,7 +45,7 @@ import qualified Database.Esqueleto.Utils as E
|
||||
data AvsException
|
||||
= 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
|
||||
| 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
|
||||
| AvsPersonSearchEmpty -- AvsPersonSearch returned empty 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?
|
||||
-- getLicence :: UserId -> Handler (Maybe AvsLicence) -- with runDB
|
||||
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
|
||||
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
|
||||
Entity _ UserAvs{..} <- maybeThrowM (AvsUserUnassociated uid) $ getBy $ UniqueUserAvsUser uid
|
||||
setLicenceAvs userAvsPersonId lic
|
||||
|
||||
setLicenceAvs :: AvsPersonId -> AvsLicence -> DB ()
|
||||
setLicenceAvs :: (MonadHandler m, MonadThrow m, HandlerSite m ~ UniWorX) =>
|
||||
AvsPersonId -> AvsLicence -> m Bool
|
||||
setLicenceAvs apid lic = do
|
||||
let req = Set.singleton $ AvsPersonLicence { avsLicenceRampLicence = lic, avsLicencePersonID = apid }
|
||||
setLicencesAvs req
|
||||
|
||||
-- setLicencesAvs :: Set AvsPersonLicence -> DB ()
|
||||
|
||||
--setLicencesAvs :: Set AvsPersonLicence -> Handler Bool
|
||||
setLicencesAvs :: (MonadHandler m, MonadThrow m, HandlerSite m ~ UniWorX) =>
|
||||
Set AvsPersonLicence -> m ()
|
||||
setLicencesAvs pls = do
|
||||
AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery
|
||||
response <- throwLeftM . avsQuerySetLicences $ AvsQuerySetLicences pls
|
||||
case response of
|
||||
AvsResponseSetLicencesError{..} -> do
|
||||
let msg = "Set licence failed completely: " <> avsResponseSetLicencesStatus <> ". Details: " <> avsResponseSetLicencesMessage
|
||||
$logErrorS "AVS" msg
|
||||
throwM $ AvsSetLicencesFailed avsResponseSetLicencesStatus
|
||||
AvsResponseSetLicences responses ->
|
||||
forM_ responses $ \AvsLicenceResponse{..} ->
|
||||
unless (sloppyBool avsResponseSuccess) $ do
|
||||
-- TODO: create an Admin Problems overview page
|
||||
$logErrorS "AVS" $ "Set licence failed for " <> tshow avsResponsePersonID <> " due to " <> cropText avsResponseMessage
|
||||
Set AvsPersonLicence -> m Bool
|
||||
setLicencesAvs persLics = do
|
||||
AvsQuery{avsQuerySetLicences=aqsl} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery
|
||||
aux aqsl True persLics
|
||||
where
|
||||
aux aqsl batch0_ok pls
|
||||
| Set.null pls = return batch0_ok
|
||||
| otherwise = do
|
||||
let (batch1, batch2) = Set.splitAt avsMaxSetLicenceAtOnce pls
|
||||
response <- throwLeftM $ aqsl $ AvsQuerySetLicences batch1
|
||||
case response of
|
||||
AvsResponseSetLicencesError{..} -> do
|
||||
let msg = "Set AVS licences failed utterly: " <> avsResponseSetLicencesStatus <> ". Details: " <> cropText avsResponseSetLicencesMessage
|
||||
$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
|
||||
-- Only react to changes as compared to last seen status in avs.model
|
||||
-- TODO: turn into a job, once the interface is actually available
|
||||
checkLicences :: Handler ()
|
||||
checkLicences = do
|
||||
{-
|
||||
AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery
|
||||
AvsResponseGetLicences licences <- throwLeftM avsQueryGetAllLicences
|
||||
-- TODO: run in a background job, once the interface is actually available
|
||||
synchAvsLicences :: Handler Bool
|
||||
synchAvsLicences = do
|
||||
AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery
|
||||
allLicences <- 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
|
||||
-- rollfeld = Set.filter (`avsPersonLicenceIs` AvsLicenceRollfeld) nonvorfeld
|
||||
let (noOrVorfeld, rollfeld) = Set.spanAntitone (`avsPersonLicenceIsLEQ` AvsLicenceVorfeld) licences
|
||||
(_nolicence , vorfeld) = Set.spanAntitone (`avsPersonLicenceIsLEQ` AvsNoLicence) noOrVorfeld
|
||||
idsRollfeld = avsLicencePersonId <$> Set.toList rollfeld
|
||||
idsVorfeld = avsLicencePersonId <$> Set.toList vorfeld
|
||||
-- Note: FRADrive users with 'R' also own 'F' qualification, but AvsGetResponseGetLicences yields only either
|
||||
let nowaday = utctDay now
|
||||
noOne = AvsPersonId 0
|
||||
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
|
||||
-- idsRollfeld = concat $ Map.lookup AvsLicenceRollfeld licenceMap
|
||||
-- idsVorfeld = concat $ Map.lookup AvsLicenceVorfeld
|
||||
antijoinAvsLicences :: AvsLicence -> Set AvsPersonId -> DB (Set AvsPersonId,Set AvsPersonId)
|
||||
antijoinAvsLicences lic avsLics = fmap unwrapIds $
|
||||
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
|
||||
E.select $ do
|
||||
(qauli E.:& qualUser E.:& usrAvs) <-
|
||||
E.from $ E.table @Qualification
|
||||
`E.innerJoin` E.table @QualificationUser
|
||||
`E.on` (\(quali E.:& qualUser) -> qual E.^. QualificationId E.==. qualUser E.^. QualificationUserQualification)
|
||||
`E.innerJoin` E.table @UserAvs
|
||||
`E.on` (\(_ E.:& qualUser E.:& usrAvs) -> qualUser E.^. QualificationUserUser E.==. usrAvs E.^. UserAvsUser)
|
||||
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
|
||||
-- | Always update AVS Data
|
||||
upsertAvsUser :: Text -> Handler (Maybe UserId) -- TODO: change to Entity
|
||||
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!
|
||||
upsertAvsUser otherId = -- attempt LDAP lookup to find by eMail
|
||||
try (runDB $ ldapLookupAndUpsert otherId) >>= \case
|
||||
Right Entity{entityVal=User{userCompanyPersonalNumber=Just persNo}} -> upsertAvsUserByCard (Right $ mkAvsInternalPersonalNo persNo)
|
||||
Left (_err::SomeException) -> return Nothing -- TODO: ; merely for convenience, not necessary right now
|
||||
_ -> return Nothing
|
||||
|
||||
|
||||
upsertAvsUser :: Text -> Handler (Maybe UserId)
|
||||
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.
|
||||
-- | Given CardNo or internal Number, retrieve UserId. Create non-existing users, if possible. Always update.
|
||||
-- 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 persNo = do
|
||||
@ -187,11 +263,12 @@ upsertAvsUserByCard persNo = do
|
||||
case Set.elems adps of
|
||||
[] -> throwM AvsPersonSearchEmpty
|
||||
(_:_:_) -> throwM AvsPersonSearchAmbiguous
|
||||
[AvsDataPerson{avsPersonPersonID=appi}] -> do
|
||||
mbuid <- runDB $ getBy $ UniqueUserAvsId appi
|
||||
case mbuid of
|
||||
(Just (Entity _ UserAvs{userAvsUser=uau})) -> return $ Just uau
|
||||
Nothing -> upsertAvsUserById appi
|
||||
[AvsDataPerson{avsPersonPersonID=api}] -> upsertAvsUserById api -- always trigger an update
|
||||
-- do
|
||||
-- mbuid <- runDB $ getBy $ UniqueUserAvsId api
|
||||
-- case mbuid of
|
||||
-- (Just (Entity _ UserAvs{userAvsUser=uau})) -> return $ Just uau
|
||||
-- Nothing -> upsertAvsUserById api
|
||||
|
||||
|
||||
|
||||
@ -204,16 +281,18 @@ upsertAvsUserById api = do
|
||||
mbuid <- getBy (UniqueUserAvsId api)
|
||||
case (mbuid, mbapd) of
|
||||
(Nothing, Just AvsDataPerson{..}) -- FRADriver User does not exist yet, but found in AVS and has Internal Personal Number
|
||||
| Just persNo <- avsPersonInternalPersonalNo -> do
|
||||
candidates <- selectKeysList [UserCompanyPersonalNumber ==. avsPersonInternalPersonalNo] []
|
||||
| Just (avsInternalPersonalNo -> persNo) <- canonical avsPersonInternalPersonalNo -> do
|
||||
$logInfoS "AVS" $ "Creating new user with avsInternalPersonalNo " <> tshow persNo
|
||||
candidates <- selectKeysList [UserCompanyPersonalNumber ==. Just persNo] []
|
||||
case candidates of
|
||||
[uid] -> insertUniqueEntity $ UserAvs api uid
|
||||
[uid] -> $logInfoS "AVS" "Matching user found, linking." >> insertUniqueEntity (UserAvs api uid avsPersonPersonNo)
|
||||
(_:_) -> throwM AvsUserAmbiguous
|
||||
[] -> do
|
||||
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
|
||||
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
|
||||
case (mbuid, mbapd) of
|
||||
@ -222,10 +301,10 @@ upsertAvsUserById api = do
|
||||
let firmAddress = guessLicenceAddress avsPersonPersonCards
|
||||
mbCompany = firmAddress ^? _Just . _1 . _Just
|
||||
userFirmAddr= plaintextToStoredMarkup . mergeCompanyAddress <$> firmAddress
|
||||
addrCard = firmAddress ^? _Just . _3
|
||||
pinCard = Set.lookupMax avsPersonPersonCards
|
||||
userPin = tshowAvsFullCardNo . getFullCardNo <$> pinCard
|
||||
userPin = tshowAvsFullCardNo . getFullCardNo <$> pinCard
|
||||
fakeIdent = CI.mk $ "AVSID:" <> tshow api
|
||||
fakeNo = CI.mk $ "AVSNO:" <> tshow avsPersonPersonNo
|
||||
newUsr = AdminUserForm
|
||||
{ aufTitle = Nothing
|
||||
, aufFirstName = avsPersonFirstName
|
||||
@ -236,65 +315,58 @@ upsertAvsUserById api = do
|
||||
, aufSex = Nothing
|
||||
, aufMobile = Nothing
|
||||
, aufTelephone = Nothing
|
||||
, aufFPersonalNumber = avsPersonInternalPersonalNo
|
||||
, aufFPersonalNumber = avsInternalPersonalNo <$> canonical avsPersonInternalPersonalNo
|
||||
, aufFDepartment = Nothing
|
||||
, aufPostAddress = userFirmAddr
|
||||
, aufPrefersPostal = isJust firmAddress
|
||||
, aufPrefersPostal = True
|
||||
, 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
|
||||
, 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
|
||||
whenIsJust mbUid $ \uid -> runDB $ do
|
||||
mbUid <- addNewUser newUsr -- triggers JobSynchroniseLdapUser, JobSendPasswordReset and NotificationUserAutoModeUpdate -- TODO: check if these are failsafe
|
||||
whenIsJust mbUid $ \uid -> runDB $ do
|
||||
now <- liftIO getCurrentTime
|
||||
insert_ $ UserAvs avsPersonPersonID uid
|
||||
-- forM_ avsPersonPersonCards $ -- save all cards for later
|
||||
let cs :: Set AvsDataPersonCard = Set.fromList $ catMaybes [pinCard, addrCard]
|
||||
forM_ cs $ -- only save used cards for the postal address update detection
|
||||
\avsCard -> insert_ $ UserAvsCard avsPersonPersonID (avsDataCardNo avsCard) avsCard now
|
||||
upsertUserCompany uid mbCompany
|
||||
insert_ $ UserAvs avsPersonPersonID uid avsPersonPersonNo
|
||||
forM_ avsPersonPersonCards $ -- save all cards for later
|
||||
-- let cs :: Set AvsDataPersonCard = Set.fromList $ catMaybes [pinCard, addrCard]
|
||||
-- forM_ cs $ -- only save used cards for the postal address update detection
|
||||
\avsCard -> insert_ $ UserAvsCard avsPersonPersonID (avsDataCardNo avsCard) avsCard now
|
||||
upsertUserCompany uid mbCompany
|
||||
return mbUid
|
||||
|
||||
|
||||
(Just (Entity _ UserAvs{userAvsUser=uid}), Just AvsDataPerson{avsPersonPersonCards}) -> do -- known user, update address and pinPassword
|
||||
let firmAddress = guessLicenceAddress avsPersonPersonCards
|
||||
mbCompany = firmAddress ^? _Just . _1 . _Just
|
||||
userFirmAddr= plaintextToStoredMarkup . mergeCompanyAddress <$> firmAddress
|
||||
addrCard = firmAddress ^? _Just . _3
|
||||
mbCoFirmAddr= mergeCompanyAddress <$> firmAddress
|
||||
userFirmAddr= plaintextToStoredMarkup <$> mbCoFirmAddr
|
||||
pinCard = Set.lookupMax avsPersonPersonCards
|
||||
userPin = tshowAvsFullCardNo . getFullCardNo <$> pinCard
|
||||
runDB $ do
|
||||
now <- liftIO getCurrentTime
|
||||
upsertUserCompany uid mbCompany
|
||||
whenIsJust addrCard $ \aCard ->
|
||||
getBy (UniqueAvsCard $ avsDataCardNo aCard) >>= \case
|
||||
(Just (Entity uac UserAvsCard{..})) | aCard == userAvsCardCard -> -- address seen before, no change
|
||||
update uac [UserAvsCardLastSynch =. now]
|
||||
_ -> do -- possibly new address data
|
||||
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] []
|
||||
userPin = tshowAvsFullCardNo . getFullCardNo <$> pinCard
|
||||
runDB $ do
|
||||
now <- liftIO getCurrentTime
|
||||
oldCards <- selectList [UserAvsCardPersonId ==. api] []
|
||||
let oldAddrs = Set.fromList $ mapMaybe (maybeCompanyAddress . userAvsCardCard . entityVal) oldCards
|
||||
unless (maybe True (`Set.member` oldAddrs) mbCoFirmAddr) $ do -- update postal address, unless the exact address had been seen before
|
||||
updateWhere [UserId ==. uid] [UserPostAddress =. userFirmAddr]
|
||||
whenIsJust pinCard $ \pCard -> -- update pin, but only if it was unset or set to the value of an old card
|
||||
unlessM (exists [UserAvsCardCardNo ==. avsDataCardNo pCard]) $ do
|
||||
let oldPins = Just . tshowAvsFullCardNo . getFullCardNo . userAvsCardCard . entityVal <$> oldCards
|
||||
updateWhere [UserId ==. uid, UserPinPassword !=. userPin, UserPinPassword <-. Nothing:oldPins]
|
||||
[UserPinPassword =. userPin]
|
||||
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
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
lookupAvsUser :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) =>
|
||||
AvsPersonId -> m (Maybe AvsDataPerson)
|
||||
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}
|
||||
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)
|
||||
@ -18,4 +18,3 @@ determineSystemFunctions ldapFuncs = \case
|
||||
-- SJ: not sure this LDAP-specific key belongs here?
|
||||
SystemStudent -> False -- "student" `Set.member` ldapFuncs -- no such key identified at FraPort
|
||||
SystemPrinter -> False -- "department=IFM-IS2" zu viele Mitglieder
|
||||
SystemSap -> False
|
||||
|
||||
@ -11,6 +11,9 @@ import Import hiding (link)
|
||||
import qualified Database.Esqueleto.Legacy as E
|
||||
import qualified Database.Esqueleto.Utils as E hiding ((->.))
|
||||
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.Pagination
|
||||
@ -705,6 +708,39 @@ fltrRelevantStudyFeaturesSemesterUI :: DBFilterUI
|
||||
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 --
|
||||
----------------------------
|
||||
|
||||
@ -48,7 +48,7 @@ module Handler.Utils.Table.Pagination
|
||||
, linkEitherCell, linkEitherCellM, linkEitherCellM'
|
||||
, maybeAnchorCellM, maybeAnchorCellM', maybeLinkEitherCellM'
|
||||
, anchorCellC, anchorCellCM, anchorCellCM', linkEitherCellCM', maybeLinkEitherCellCM'
|
||||
, cellTooltip
|
||||
, cellTooltip, cellTooltipIcon
|
||||
, listCell, listCell', listCellOf, listCellOf'
|
||||
, ilistCell, ilistCell', ilistCellOf, ilistCellOf'
|
||||
, formCell, DBFormResult(..), getDBFormResult
|
||||
@ -1689,10 +1689,13 @@ i18nCell msg = cell $ do
|
||||
toWidget $ mr msg
|
||||
|
||||
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
|
||||
tipWdgt = iconTooltip (msg2widget msg) Nothing True
|
||||
|
||||
tipWdgt = iconTooltip (msg2widget msg) icn True
|
||||
|
||||
-- | Always display widget; maybe a link if user is Authorized.
|
||||
-- Also see variant `linkEmptyCell`
|
||||
anchorCell :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a) => url -> wgt -> DBCell m a
|
||||
|
||||
@ -47,14 +47,13 @@ import qualified Data.Text as Text
|
||||
|
||||
import Jobs.Types(Job, JobChildren)
|
||||
|
||||
|
||||
abbrvName :: User -> Text
|
||||
abbrvName User{userDisplayName, userFirstName, userSurname} =
|
||||
if | (lastDisplayName : tsrif) <- reverse nameParts
|
||||
abbrvName User{userDisplayName, userFirstName, userSurname} =
|
||||
if | (lastDisplayName : tsrif) <- reverse nameParts
|
||||
-> assemble $ reverse $ lastDisplayName : abbreviate tsrif
|
||||
| otherwise
|
||||
-> assemble $ abbreviate (Text.words userFirstName) <> [userSurname]
|
||||
where
|
||||
where
|
||||
nameParts = Text.words userDisplayName
|
||||
abbreviate = fmap (Text.take 1)
|
||||
assemble = Text.intercalate "."
|
||||
@ -72,11 +71,11 @@ userPrefersEmail = not . userPrefersLetter
|
||||
getPostalPreferenceAndAddress :: User -> (Bool, Maybe [Text])
|
||||
getPostalPreferenceAndAddress usr@User{..} =
|
||||
(((userPrefersPostal || isNothing userPinPassword) && postPossible) || emailImpossible, pa)
|
||||
where
|
||||
where
|
||||
orgEmail = CI.original userEmail
|
||||
emailImpossible = not ('@' `textElem` orgEmail && '.' `textElem` orgEmail)
|
||||
postPossible = isJust pa
|
||||
pa = getPostalAddress usr
|
||||
pa = getPostalAddress usr
|
||||
|
||||
getPostalAddress :: User -> Maybe [Text]
|
||||
getPostalAddress User{..}
|
||||
@ -85,22 +84,23 @@ getPostalAddress User{..}
|
||||
| Just abt <- userCompanyDepartment
|
||||
= Just $ if | "BVD" `isPrefixOf` abt -> [userDisplayName, abt, "Bodenverkehrsdienste"]
|
||||
| otherwise -> [userDisplayName, abt, "Hausbriefkasten" ]
|
||||
| otherwise
|
||||
| otherwise
|
||||
= 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
|
||||
getReceivers :: UserId -> DB (Entity User, [Entity User], Bool)
|
||||
getReceivers uid = do
|
||||
underling <- getJustEntity uid
|
||||
superVs <- selectList [UserSupervisorUser ==. uid, UserSupervisorRerouteNotifications ==. True] []
|
||||
let superIds = userSupervisorSupervisor . entityVal <$> superVs
|
||||
if null superIds
|
||||
if null superIds
|
||||
then return (underling, [underling], True)
|
||||
else do
|
||||
else do
|
||||
supers <- selectList [UserId <-. superIds] []
|
||||
if null supers then return (underling, [underling], True)
|
||||
else
|
||||
else
|
||||
return (underling, supers, uid `elem` (entityKey <$> supers))
|
||||
|
||||
|
||||
@ -152,7 +152,7 @@ matchesName (repack -> haystack) (repack -> needle)
|
||||
|
||||
guessUser :: PredDNF GuessUserInfo -- ^ guessing criteria
|
||||
-> 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
|
||||
-- Nothing in case of no result
|
||||
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
|
||||
|
||||
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
|
||||
GuessUserMatrikelnummer userMatriculation' -> user E.^. UserMatrikelnummer E.==. E.val (Just userMatriculation')
|
||||
GuessUserEduPersonPrincipalName userEPPN' -> user E.^. UserLdapPrimaryKey E.==. E.val (Just userEPPN')
|
||||
@ -184,7 +184,7 @@ guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria)
|
||||
$ criteria ^.. folded)
|
||||
|
||||
closeness :: Entity User -> Entity User -> Ordering
|
||||
closeness ul ur = maximum $ impureNonNull $ criteria <&> \term ->
|
||||
closeness ul ur = maximum $ impureNonNull $ criteria <&> \term ->
|
||||
let
|
||||
matches userField name = _entityVal . userField . to (`matchesName` 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]
|
||||
]
|
||||
|
||||
|
||||
-- Assuming the input list is sorted in descending order by closeness:
|
||||
takeClosest [] = []
|
||||
takeClosest [x] = [x]
|
||||
@ -235,7 +235,7 @@ guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria)
|
||||
convertLdapResults [] = Nothing
|
||||
convertLdapResults [x] = Just $ Right x
|
||||
convertLdapResults xs = Just $ Left $ NonEmpty.fromList xs
|
||||
|
||||
|
||||
if
|
||||
| [x] <- users'
|
||||
, Just True == matchesMatriculation x || didLdap
|
||||
@ -279,9 +279,9 @@ assimilateUser :: UserId -- ^ @newUserId@
|
||||
-- ^ Move all relevant properties (submissions, corrections, grades, ...) from @oldUserId@ to @newUserId@
|
||||
--
|
||||
-- Fatal errors are thrown, non-fatal warnings are returned
|
||||
assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
|
||||
assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
|
||||
E.insertSelectWithConflict
|
||||
UniqueCourseFavourite
|
||||
UniqueCourseFavourite
|
||||
(E.from $ \courseFavourite -> do
|
||||
E.where_ $ courseFavourite E.^. CourseFavouriteUser E.==. E.val oldUserId
|
||||
return $ CourseFavourite
|
||||
@ -398,7 +398,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
|
||||
)
|
||||
(\_current _excluded -> [])
|
||||
deleteWhere [ SubmissionUserUser ==. oldUserId ]
|
||||
|
||||
|
||||
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
|
||||
@ -587,7 +587,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
|
||||
)
|
||||
(\current excluded -> [ ExamPartResultLastChanged E.=. E.max (current E.^. ExamPartResultLastChanged) (excluded E.^. ExamPartResultLastChanged) ])
|
||||
deleteWhere [ ExamPartResultUser ==. oldUserId ]
|
||||
|
||||
|
||||
do
|
||||
collision <- E.selectMaybe . E.from $ \(examBonusA `E.InnerJoin` examBonusB) -> do
|
||||
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) ])
|
||||
deleteWhere [ ExamBonusUser ==. oldUserId ]
|
||||
|
||||
|
||||
let getExamResults = selectSource [ ExamResultUser ==. oldUserId ] []
|
||||
upsertExamResult oldEREnt@(Entity oldERId oldER) = do
|
||||
newER' <- getBy $ UniqueExamResult (examResultExam oldER) newUserId
|
||||
@ -775,19 +775,19 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
|
||||
delete oldSFId
|
||||
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
|
||||
-- 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 ]
|
||||
newLms <- selectList [ LmsUserUser ==. newUserId ] [ Asc LmsUserQualification ]
|
||||
let projQ = lmsUserQualification . entityVal
|
||||
oldQs = Set.fromList (projQ <$> oldLms)
|
||||
newQs = Set.fromList (projQ <$> newLms)
|
||||
qConflicts = oldQs `Set.intersection` newQs
|
||||
qResolvable = Set.fromList [ lmsUserQualification | Entity _ LmsUser{..} <- oldLms, isJust lmsUserEnded, lmsUserQualification `Set.member` qConflicts ]
|
||||
qProblems = qConflicts `Set.difference` qResolvable
|
||||
qResolvable = Set.fromList [ lmsUserQualification | Entity _ LmsUser{..} <- oldLms, isJust lmsUserEnded, lmsUserQualification `Set.member` qConflicts ]
|
||||
qProblems = qConflicts `Set.difference` qResolvable
|
||||
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 [ QualificationEditUser ==. oldUserId ] [ QualificationEditUser =. newUserId ]
|
||||
E.insertSelectWithConflict
|
||||
@ -802,19 +802,19 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
|
||||
E.<&> (qualificationUser E.^. QualificationUserFirstHeld)
|
||||
E.<&> (qualificationUser E.^. QualificationUserBlockedDue)
|
||||
)
|
||||
(\current excluded ->
|
||||
(\current excluded ->
|
||||
[ QualificationUserValidUntil E.=. combineWith current excluded E.greatest QualificationUserValidUntil
|
||||
, QualificationUserLastRefresh E.=. combineWith current excluded E.greatest QualificationUserLastRefresh
|
||||
, QualificationUserFirstHeld E.=. combineWith current excluded E.least QualificationUserFirstHeld
|
||||
, QualificationUserBlockedDue E.=. combineWith current excluded E.greatest QualificationUserBlockedDue -- Tested: PostgreSQL GREATEST/LEAST ignores NULL values
|
||||
]
|
||||
]
|
||||
)
|
||||
deleteWhere [ QualificationUserUser ==. oldUserId ]
|
||||
|
||||
-- Supervision is fully merged
|
||||
E.insertSelectWithConflict
|
||||
UniqueUserSupervisor
|
||||
(E.from $ \userSupervisor -> do
|
||||
(E.from $ \userSupervisor -> do
|
||||
E.where_ $ userSupervisor E.^. UserSupervisorSupervisor E.==. E.val oldUserId
|
||||
return $ UserSupervisor
|
||||
E.<# E.val newUserId
|
||||
@ -822,11 +822,11 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
|
||||
E.<&> (userSupervisor E.^. UserSupervisorRerouteNotifications)
|
||||
)
|
||||
(\current excluded -> [ UserSupervisorRerouteNotifications E.=. (current E.^. UserSupervisorRerouteNotifications E.||. excluded E.^. UserSupervisorRerouteNotifications) ] )
|
||||
deleteWhere [ UserSupervisorSupervisor ==. oldUserId]
|
||||
deleteWhere [ UserSupervisorSupervisor ==. oldUserId]
|
||||
|
||||
E.insertSelectWithConflict
|
||||
UniqueUserSupervisor
|
||||
(E.from $ \userSupervisor -> do
|
||||
(E.from $ \userSupervisor -> do
|
||||
E.where_ $ userSupervisor E.^. UserSupervisorUser E.==. E.val oldUserId
|
||||
return $ UserSupervisor
|
||||
E.<# (userSupervisor E.^. UserSupervisorSupervisor)
|
||||
@ -834,14 +834,14 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
|
||||
E.<&> (userSupervisor 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
|
||||
E.insertSelectWithConflict
|
||||
UniqueUserCompany
|
||||
(E.from $ \userCompany -> do
|
||||
(E.from $ \userCompany -> do
|
||||
E.where_ $ userCompany E.^. UserCompanyUser E.==. E.val oldUserId
|
||||
return $ UserCompany
|
||||
return $ UserCompany
|
||||
E.<# E.val newUserId
|
||||
E.<&> (userCompany E.^. UserCompanyCompany)
|
||||
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))
|
||||
-> EntityField val typ1
|
||||
-> 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)
|
||||
|
||||
@ -59,6 +59,11 @@ nameWidget displayName surname = toWidget $ nameHtml displayName surname
|
||||
userWidget :: HasUser c => c -> Widget
|
||||
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
|
||||
nameEmailWidget :: UserEmail -- ^ userEmail
|
||||
-> Text -- ^ userDisplayName
|
||||
|
||||
@ -17,6 +17,7 @@ import Import
|
||||
import Jobs.Queue
|
||||
|
||||
-- import Jobs.Handler.Intervals.Utils
|
||||
import Database.Esqueleto.Experimental ((:&)(..))
|
||||
import qualified Database.Esqueleto.Experimental as E
|
||||
--import qualified Database.Esqueleto.Legacy as E
|
||||
-- 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
|
||||
-- result :: [(Entity QualificationUser, Entity LmsUser, Entity LmsResult)]
|
||||
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.innerJoin` E.table @LmsUser
|
||||
`E.on` (\(quser E.:& luser) ->
|
||||
`E.on` (\(quser :& luser) ->
|
||||
luser E.^. LmsUserUser E.==. quser E.^. QualificationUserUser
|
||||
E.&&. luser E.^. LmsUserQualification E.==. quser E.^. QualificationUserQualification)
|
||||
`E.innerJoin` E.table @LmsResult
|
||||
`E.on` (\(_ E.:& luser E.:& lresult) ->
|
||||
`E.on` (\(_ :& luser :& lresult) ->
|
||||
luser E.^. LmsUserIdent E.==. lresult E.^. LmsResultIdent
|
||||
E.&&. luser E.^. LmsUserQualification E.==. lresult E.^. LmsResultQualification)
|
||||
E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid
|
||||
@ -239,9 +240,9 @@ dispatchJobLmsUserlist qid = JobHandlerAtomic act
|
||||
now <- liftIO getCurrentTime
|
||||
-- result :: [(Entity LmsUser, Entity LmsUserlist)]
|
||||
results <- E.select $ do
|
||||
(luser E.:& lulist) <- E.from $
|
||||
(luser :& lulist) <- E.from $
|
||||
E.table @LmsUser `E.leftJoin` E.table @LmsUserlist
|
||||
`E.on` (\(luser E.:& lulist) -> luser E.^. LmsUserIdent E.=?. lulist E.?. LmsUserlistIdent
|
||||
`E.on` (\(luser :& lulist) -> luser E.^. LmsUserIdent E.=?. lulist E.?. LmsUserlistIdent
|
||||
E.&&. luser E.^. LmsUserQualification E.=?. lulist E.?. LmsUserlistQualification)
|
||||
E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid
|
||||
E.&&. E.isNothing (luser E.^. LmsUserEnded) -- do not process closed learners
|
||||
|
||||
@ -45,7 +45,7 @@ o .:?~ key = o .: key <|> maybe empty parseJSON go
|
||||
|
||||
-- Like (.:?) but maps Just null to Nothing, ie. Nothing instead of Just ""
|
||||
(.:?!) :: (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
|
||||
@ -81,7 +81,58 @@ instance FromJSON SloppyBool where
|
||||
-- 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
|
||||
-- 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.justifyRight 8 '0'
|
||||
|
||||
instance Canonical AvsCardNo where
|
||||
canonical AvsCardNo{..} = AvsCardNo $ normalizeAvsCardNo avsCardNo
|
||||
-- canonical = AvsCardNo . normalizeAvsCardNo . avsCardNo
|
||||
|
||||
|
||||
data AvsFullCardNo = AvsFullCardNo { avsFullCardNo :: AvsCardNo, avsFullCardVersion :: AvsVersionNo }
|
||||
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.span Char.isDigit -> (c, pv))
|
||||
| Text.null pv
|
||||
= Just $ Right c
|
||||
= Just $ Right $ mkAvsInternalPersonalNo c
|
||||
| not $ Text.null c
|
||||
, Just ('.', v) <- Text.uncons pv
|
||||
, Just (Char.isDigit -> True, "") <- Text.uncons v
|
||||
@ -256,18 +312,19 @@ instance Ord AvsDataPersonCard where
|
||||
makeLenses_ ''AvsDataPersonCard
|
||||
{-
|
||||
instance Canonical AvsDataPersonCard where
|
||||
canonical proto = proto { avsDataStreet = null2nothing $ avsDataStreet proto
|
||||
, avsDataPostalCode = null2nothing $ avsDataPostalCode proto
|
||||
, avsDataCity = null2nothing $ avsDataCity proto
|
||||
, avsDataFirm = null2nothing $ avsDataFirm proto
|
||||
canonical proto = proto { avsDataStreet = canonical $ avsDataStreet proto
|
||||
, avsDataPostalCode = canonical $ avsDataPostalCode proto
|
||||
, avsDataCity = canonical $ avsDataCity proto
|
||||
, avsDataFirm = canonical $ avsDataFirm proto
|
||||
}
|
||||
-}
|
||||
instance Canonical AvsDataPersonCard where
|
||||
canonical proto =
|
||||
proto & _avsDataStreet %~ null2nothing
|
||||
& _avsDataPostalCode %~ null2nothing
|
||||
& _avsDataCity %~ null2nothing
|
||||
& _avsDataFirm %~ null2nothing
|
||||
proto & _avsDataStreet %~ canonical
|
||||
& _avsDataPostalCode %~ canonical
|
||||
& _avsDataCity %~ canonical
|
||||
& _avsDataFirm %~ canonical
|
||||
& _avsDataCardNo %~ canonical
|
||||
|
||||
-- TODO: use canonical in FromJSON/ToJSON instances for consistency
|
||||
instance FromJSON AvsDataPersonCard where
|
||||
@ -281,7 +338,7 @@ instance FromJSON AvsDataPersonCard where
|
||||
<*> v .:?! "PostalCode"
|
||||
<*> v .:?! "City"
|
||||
<*> v .:?! "Firm"
|
||||
<*> v .: "CardNo"
|
||||
<*> ((v .: "CardNo") <&> canonical)
|
||||
<*> v .: "VersionNo"
|
||||
|
||||
instance ToJSON AvsDataPersonCard where
|
||||
@ -289,16 +346,16 @@ instance ToJSON AvsDataPersonCard where
|
||||
catMaybes
|
||||
[ ("ValidTo" .=) <$> avsDataValidTo
|
||||
, ("IssueDate" .=) <$> avsDataIssueDate
|
||||
, ("Street" .=) <$> (avsDataStreet & null2nothing)
|
||||
, ("PostalCode" .=) <$> (avsDataPostalCode & null2nothing)
|
||||
, ("City" .=) <$> (avsDataCity & null2nothing)
|
||||
, ("Firm" .=) <$> (avsDataFirm & null2nothing)
|
||||
, ("Street" .=) <$> (avsDataStreet & canonical)
|
||||
, ("PostalCode" .=) <$> (avsDataPostalCode & canonical)
|
||||
, ("City" .=) <$> (avsDataCity & canonical)
|
||||
, ("Firm" .=) <$> (avsDataFirm & canonical)
|
||||
]
|
||||
<>
|
||||
[ "Valid" .= show avsDataValid
|
||||
, "CardColor" .= avsDataCardColor
|
||||
, "CardAreas" .= Set.foldl Text.snoc Text.empty avsDataCardAreas
|
||||
, "CardNo" .= avsDataCardNo
|
||||
, "CardNo" .= (avsDataCardNo & canonical)
|
||||
, "VersionNo" .= avsDataVersionNo
|
||||
]
|
||||
derivePersistFieldJSON ''AvsDataPersonCard
|
||||
@ -332,7 +389,7 @@ data AvsDataPerson = AvsDataPerson
|
||||
makeLenses_ ''AvsDataPerson
|
||||
|
||||
instance Canonical AvsDataPerson where
|
||||
canonical = over _avsPersonInternalPersonalNo null2nothing
|
||||
canonical = over _avsPersonInternalPersonalNo canonical
|
||||
. over _avsPersonPersonCards canonical
|
||||
|
||||
|
||||
@ -347,7 +404,7 @@ instance FromJSON AvsDataPerson where
|
||||
|
||||
instance ToJSON AvsDataPerson where
|
||||
toJSON AvsDataPerson{..} = object $
|
||||
catMaybes [ ("InternalPersonalNo" .=) <$> (avsPersonInternalPersonalNo & null2nothing) ]
|
||||
catMaybes [ ("InternalPersonalNo" .=) <$> (avsPersonInternalPersonalNo & canonical) ]
|
||||
<>
|
||||
[ "FirstName" .= avsPersonFirstName
|
||||
, "LastName" .= avsPersonLastName
|
||||
@ -470,7 +527,7 @@ newtype AvsQueryStatus = AvsQueryStatus (Set AvsPersonId)
|
||||
deriving (Eq, Ord, Show, Generic, Typeable)
|
||||
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)
|
||||
deriveJSON defaultOptions ''AvsQueryGetLicences
|
||||
|
||||
|
||||
@ -16,6 +16,18 @@ import Model.Types.TH.PathPiece
|
||||
|
||||
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"
|
||||
derivePersistFieldPathPiece ''ChangelogItem
|
||||
@ -31,6 +43,19 @@ data 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 = \case
|
||||
ChangelogHaskellCampusLogin -> ChangelogItemBugfix
|
||||
@ -150,3 +175,4 @@ changelogItemDays = Map.fromListWithKey (\k d1 d2 -> bool (error $ "Duplicate ch
|
||||
, (ChangelogMaterialsVideoStreaming, [day|2020-11-10|])
|
||||
, (ChangelogFixPersonalisedSheetFilesKeep, [day|2020-11-10|])
|
||||
]
|
||||
-}
|
||||
@ -81,7 +81,6 @@ data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prä
|
||||
| AuthExamOffice
|
||||
| AuthSystemExamOffice
|
||||
| AuthSystemPrinter
|
||||
| AuthSystemSap
|
||||
| AuthEvaluation
|
||||
| AuthCourseRegistered
|
||||
| AuthTutorialRegistered
|
||||
|
||||
@ -15,8 +15,7 @@ data SystemFunction
|
||||
= SystemExamOffice
|
||||
| SystemFaculty
|
||||
| SystemStudent
|
||||
| SystemPrinter
|
||||
| SystemSap
|
||||
| SystemPrinter
|
||||
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
||||
deriving anyclass (Universe, Finite, Hashable, NFData)
|
||||
|
||||
|
||||
@ -278,6 +278,7 @@ data UserDefaultConf = UserDefaultConf
|
||||
, userDefaultShowSex :: Bool
|
||||
, userDefaultExamOfficeGetSynced :: Bool
|
||||
, userDefaultExamOfficeGetLabels :: Bool
|
||||
, userDefaultPrefersPostal :: Bool
|
||||
} deriving (Show)
|
||||
|
||||
data PWHashConf = PWHashConf
|
||||
|
||||
42
src/Utils.hs
42
src/Utils.hs
@ -363,6 +363,9 @@ toWgt :: ToMarkup a
|
||||
toWgt = toWidget . toHtml
|
||||
|
||||
-- Convenience Functions to avoid type signatures:
|
||||
text2markup :: Text -> Markup
|
||||
text2markup t = [shamlet|#{t}|]
|
||||
|
||||
text2widget :: Text -> WidgetFor site ()
|
||||
text2widget t = [whamlet|#{t}|]
|
||||
|
||||
@ -619,6 +622,10 @@ trd3 (_,_,z) = z
|
||||
mTuple :: Applicative f => f a -> f b -> f (a, b)
|
||||
mTuple = liftA2 (,)
|
||||
|
||||
-- From Data.Tuple.Extra
|
||||
mapBoth :: (a -> b) -> (a,a) -> (b,b)
|
||||
mapBoth f ~(a,b) = (f a, f b)
|
||||
|
||||
-----------
|
||||
-- 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 = (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 = sequenceA . mapF
|
||||
|
||||
@ -816,10 +826,10 @@ toNothing = const Nothing
|
||||
toNothingS :: String -> Maybe b
|
||||
toNothingS = const Nothing
|
||||
|
||||
-- a more general formulation probably possible
|
||||
null2nothing :: MonoFoldable a => Maybe a -> Maybe a
|
||||
null2nothing (Just x) | null x = Nothing
|
||||
null2nothing other = other
|
||||
-- replaced by a more general formulation, see canonical
|
||||
-- null2nothing :: MonoFoldable a => Maybe a -> Maybe a
|
||||
-- null2nothing (Just x) | null x = Nothing
|
||||
-- null2nothing other = other
|
||||
|
||||
-- | Swap 'Nothing' for 'Just' and vice versa
|
||||
-- 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 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 --
|
||||
------------
|
||||
@ -1872,5 +1892,19 @@ makePrisms ''ExitCase
|
||||
class Canonical a where
|
||||
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
|
||||
canonical = Set.map canonical
|
||||
|
||||
@ -27,6 +27,8 @@ type AVSPersonStatus = "PersonStatus" :> ReqBody '[JSON] AvsQueryStatus :> Po
|
||||
type AVSGetRampLicences = "RampDrivingLicenceInfo" :> ReqBody '[JSON] AvsQueryGetLicences :> Post '[JSON] AvsResponseGetLicences
|
||||
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
|
||||
@ -45,15 +47,15 @@ data AvsQuery = AvsQuery
|
||||
{ avsQueryPerson :: forall m. MonadIO m => AvsQueryPerson -> m (Either ClientError AvsResponsePerson)
|
||||
, avsQueryStatus :: forall m. MonadIO m => AvsQueryStatus -> m (Either ClientError AvsResponseStatus)
|
||||
, 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)
|
||||
}
|
||||
|
||||
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 $ Set.singleton $ AvsObjPersonId $ AvsPersonId 0
|
||||
avsQueryAllLicences = AvsQueryGetLicences $ AvsObjPersonId $ AvsPersonId 0
|
||||
|
||||
|
||||
mkAvsQuery :: BaseUrl -> BasicAuthData -> ClientEnv -> AvsQuery
|
||||
@ -61,7 +63,7 @@ mkAvsQuery baseUrl basicAuth cliEnv = AvsQuery
|
||||
{ avsQueryPerson = \q -> liftIO $ catch404toEmpty <$> runClientM (rawQueryPerson q) cliEnv
|
||||
, avsQueryStatus = \q -> liftIO $ runClientM (rawQueryStatus 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
|
||||
}
|
||||
where
|
||||
@ -87,21 +89,32 @@ getValidLicence cutoff licence' cards = Set.lookupMax validLicenceCards
|
||||
cardMatch AvsDataPersonCard{..} =
|
||||
avsDataValid && (avsDataValidTo >= cutoff) && (licence `Set.member` avsDataCardAreas)
|
||||
|
||||
guessLicenceAddress :: Set AvsDataPersonCard -> Maybe (Maybe Text, Text, AvsDataPersonCard)
|
||||
guessLicenceAddress cards
|
||||
| Just c <- Set.lookupMax cards
|
||||
, card@AvsDataPersonCard{..} <- Set.foldr pickLicenceAddress c cards
|
||||
, Just street <- avsDataStreet
|
||||
|
||||
getCompanyAddress :: AvsDataPersonCard -> Maybe (Maybe Text, Text, AvsDataPersonCard)
|
||||
getCompanyAddress card@AvsDataPersonCard{..}
|
||||
| Just street <- avsDataStreet
|
||||
, Just pcode <- avsDataPostalCode
|
||||
, Just city <- avsDataCity
|
||||
= Just (avsDataFirm, Text.unlines [street, Text.unwords [pcode, city]], card)
|
||||
| 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 (Nothing , addr, _) = addr
|
||||
mergeCompanyAddress (Just firm, addr, _) = firm <> Text.cons '\n' addr
|
||||
|
||||
maybeCompanyAddress :: AvsDataPersonCard -> Maybe Text
|
||||
maybeCompanyAddress = fmap mergeCompanyAddress . getCompanyAddress
|
||||
|
||||
hasAddress :: AvsDataPersonCard -> Bool
|
||||
hasAddress AvsDataPersonCard{..} = isJust avsDataStreet && isJust avsDataCity && isJust avsDataPostalCode
|
||||
|
||||
@ -157,7 +170,7 @@ mergeAvsDataPerson = Map.unionWithKey merger
|
||||
in AvsDataPerson
|
||||
{ avsPersonFirstName = pickBy' Text.length avsPersonFirstName
|
||||
, avsPersonLastName = pickBy' Text.length avsPersonLastName
|
||||
, avsPersonInternalPersonalNo = pickBy' (Text.length . fromMaybe mempty) avsPersonInternalPersonalNo
|
||||
, avsPersonInternalPersonalNo = pickBy' (maybe 0 length) avsPersonInternalPersonalNo
|
||||
, avsPersonPersonNo = pickBy' id avsPersonPersonNo
|
||||
, avsPersonPersonID = api -- keys must be identical due to call with insertWithKey
|
||||
, avsPersonPersonCards = (Set.union `on` avsPersonPersonCards) pa pb
|
||||
|
||||
@ -299,7 +299,11 @@ data FormIdentifier
|
||||
| FIDExamAutoOccurrenceCalculate | FIDExamAutoOccurrenceConfirm | FIDExamAutoOccurrenceNudge UUID | FIDExamAutoOccurrenceIgnoreRoom UUID
|
||||
| FIDTestDownload
|
||||
| FIDAvsQueryPerson
|
||||
| FIDAvsQueryStatus
|
||||
| FIDAvsQueryStatus
|
||||
| FIDAvsCreateUser
|
||||
| FIDAvsQueryLicenceDiffs
|
||||
| FIDAvsQueryLicence
|
||||
| FIDAvsSetLicence
|
||||
| FIDLmsLetter
|
||||
deriving (Eq, Ord, Read, Show)
|
||||
|
||||
|
||||
@ -104,6 +104,7 @@ data Icon
|
||||
| IconPrintCenter
|
||||
| IconLetter
|
||||
| IconAt
|
||||
| IconSupervisor
|
||||
deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic, Typeable)
|
||||
deriving anyclass (Universe, Finite, NFData)
|
||||
|
||||
@ -186,6 +187,7 @@ iconText = \case
|
||||
IconPrintCenter -> "mail-bulk" -- From fontawesome v6 onwards: "envelope-bulk"
|
||||
IconLetter -> "mail-bulk" -- Problem "envelope" already used for email as well
|
||||
IconAt -> "at"
|
||||
IconSupervisor -> "head-side" -- must be notably different to user
|
||||
|
||||
nullaryPathPiece ''Icon $ camelToPathPiece' 1
|
||||
deriveLift ''Icon
|
||||
@ -218,7 +220,7 @@ iconStacked ic0 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 tooltip mIcon isInlineTooltip = let
|
||||
ic = iconText $ fromMaybe IconTooltipDefault mIcon
|
||||
|
||||
@ -125,6 +125,8 @@ makeClassyFor_ ''QualificationUser
|
||||
makeClassyFor_ ''LmsUser
|
||||
makeClassyFor_ ''LmsUserlist
|
||||
makeClassyFor_ ''LmsResult
|
||||
makeClassyFor_ ''UserAvs
|
||||
makeClassyFor_ ''UserAvsCard
|
||||
|
||||
_entityKey :: Getter (Entity record) (Key record)
|
||||
-- ^ Not a `Lens'` for safety
|
||||
|
||||
@ -42,7 +42,7 @@ import System.Process.Typed -- for calling pdftk for pdf encryption
|
||||
import Handler.Utils.Users
|
||||
import Handler.Utils.DateTime
|
||||
import Handler.Utils.Mail
|
||||
import Handler.Utils.Widgets (nameHtml')
|
||||
import Handler.Utils.Widgets (nameHtml')
|
||||
import Jobs.Handler.SendNotification.Utils
|
||||
|
||||
-- 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 metas doc = Fold.foldr act doc metas
|
||||
where
|
||||
act (_, Nothing) acc = acc
|
||||
act (k, Just v ) acc = P.setMeta k v acc
|
||||
act (k, Just v) acc | notNull k = P.setMeta k v acc
|
||||
act _ acc = acc
|
||||
|
||||
|
||||
-- | Add meta to pandoc. Existing variables will be overwritten.
|
||||
@ -377,7 +377,7 @@ data LetterRenewQualificationF = LetterRenewQualificationF
|
||||
, lmsPin :: Text
|
||||
, qualHolder :: UserDisplayName
|
||||
, qualExpiry :: Day
|
||||
, qualId :: QualificationId
|
||||
, qualId :: QualificationId
|
||||
, qualName :: Text
|
||||
, qualShort :: Text
|
||||
, qualDuration :: Maybe Int
|
||||
@ -386,8 +386,8 @@ data LetterRenewQualificationF = LetterRenewQualificationF
|
||||
|
||||
instance MDLetter LetterRenewQualificationF where
|
||||
getTemplate _ = templateRenewal
|
||||
getMailSubject l = SomeMessage $ MsgMailSubjectQualificationRenewal $ qualShort l
|
||||
getMailBody l = SomeMessage $ MsgMailBodyQualificationRenewal $ qualName l
|
||||
getMailSubject l = SomeMessage $ MsgMailSubjectQualificationRenewal $ qualShort l
|
||||
getMailBody l = SomeMessage $ MsgMailBodyQualificationRenewal $ qualName l
|
||||
letterMeta LetterRenewQualificationF{..} _lang DateTimeFormatter{ format } = mkMeta
|
||||
[ toMeta "login" lmsIdent
|
||||
, toMeta "pin" lmsPin
|
||||
@ -413,7 +413,7 @@ instance MDLetter LetterRenewQualificationF where
|
||||
|
||||
sendEmailOrLetter :: (MDLetter l) => UserId -> l -> Handler Bool
|
||||
sendEmailOrLetter recipient letter = do
|
||||
(underling, receivers, undercopy) <- liftHandler . runDB $ getReceivers recipient
|
||||
(underling, receivers, undercopy) <- runDB $ getReceivers recipient
|
||||
let tmpl = getTemplate $ pure letter
|
||||
pjid = getPJId letter
|
||||
-- Below are only needed if sent by email
|
||||
|
||||
@ -11,8 +11,10 @@ module Utils.Set
|
||||
, setPartitionEithers
|
||||
, setFromFunc
|
||||
, mapIntersectNotOne
|
||||
, set2NonEmpty
|
||||
) where
|
||||
|
||||
import qualified Data.List.NonEmpty as NonEmpty
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map.Strict()
|
||||
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)
|
||||
|
||||
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
43
templates/admin-problems.hamlet
Normal 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}
|
||||
@ -6,7 +6,39 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
<section>
|
||||
<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}
|
||||
$maybe answer <- mbPerson
|
||||
<p>
|
||||
@ -15,7 +47,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
<section>
|
||||
<p>
|
||||
Person Status:
|
||||
Person status:
|
||||
^{statusForm}
|
||||
$maybe answer <- mbStatus
|
||||
<p>
|
||||
|
||||
@ -15,6 +15,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
<p>
|
||||
^{iconTooltip testTooltipMsg Nothing False}
|
||||
$# ^{iconTooltip testTooltipMsg Nothing True} -- just a different size
|
||||
^{messageTooltip msgInfoTooltip}
|
||||
^{messageTooltip msgSuccessTooltip}
|
||||
^{messageTooltip msgWarningTooltip}
|
||||
|
||||
@ -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.
|
||||
@ -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.
|
||||
@ -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
|
||||
@ -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.
|
||||
@ -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
|
||||
@ -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
|
||||
@ -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
|
||||
@ -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.
|
||||
@ -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
|
||||
@ -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
|
||||
@ -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
|
||||
@ -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.
|
||||
@ -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
|
||||
@ -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.
|
||||
@ -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
|
||||
@ -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
|
||||
@ -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
|
||||
@ -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.
|
||||
@ -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
|
||||
@ -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
|
||||
@ -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
|
||||
@ -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
|
||||
@ -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
|
||||
@ -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
|
||||
@ -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.
|
||||
@ -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.
|
||||
@ -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)
|
||||
@ -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.
|
||||
@ -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
|
||||
@ -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.
|
||||
@ -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
|
||||
@ -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.
|
||||
@ -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
Reference in New Issue
Block a user