fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge remote-tracking branch 'origin/fradrive/localmaster'

Browse Source
This commit is contained in:
Steffen Jost 2023-04-04 13:37:46 +02:00
commit e1b2c8a17e
28 changed files with 518 additions and 172 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,7 +1,7 @@
# SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
#
# SPDX-License-Identifier: AGPL-3.0-or-later
AvsPersonInfo: AVS Personendaten
AvsPersonId: AVS Personen Id
AvsPersonNo: AVS Personennummer
AvsCardNo: Ausweiskartennummer
@ -29,4 +29,9 @@ RevokeUnknownLicencesFail: Nicht alle AVS Fahrberechtigungen unbekannter Fahrer
AvsCommunicationError: AVS Schnittstelle lieferte einen unerwarteten Fehler.
LicenceTableChangeAvs: Im AVS ändern
LicenceTableGrantFDrive: In FRADrive erteilen
LicenceTableRevokeFDrive: In FRADrive entziehen
LicenceTableRevokeFDrive: In FRADrive entziehen
TableAvsActiveCards: Gültige Ausweise
AvsCardColorGreen: Grün
AvsCardColorBlue: Blau
AvsCardColorRed: Rot
AvsCardColorYellow: Gelb

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

@ -1,7 +1,7 @@
# SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
#
# SPDX-License-Identifier: AGPL-3.0-or-later
AvsPersonInfo: AVS Person Info
AvsPersonId: AVS Person Id
AvsPersonNo: AVS Person Number
AvsCardNo: Card number
@ -30,3 +30,8 @@ AvsCommunicationError: AVS interface returned an unexpected error.
LicenceTableChangeAvs: Change in AVS
LicenceTableGrantFDrive: Grant in FRADrive
LicenceTableRevokeFDrive: Revoke in FRADrive
TableAvsActiveCards: Valid Cards
AvsCardColorGreen: Green
AvsCardColorBlue: Blue
AvsCardColorRed: Red
AvsCardColorYellow: Yellow

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

@ -20,5 +20,5 @@ PrintCourse: Kurse
PrintQualification: Qualifikation
PrintPDF !ident-ok: PDF
PrintManualRenewal: Vorfeldführerschein Renewal-Brief testweise versenden
PrintLmsUser: E-Learning Id
PrintLmsUser: E‑Learning Id
PrintJobs: Druckaufräge

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

@ -20,5 +20,5 @@ PrintCourse: Course
PrintQualification: Qualification
PrintPDF: PDF
PrintManualRenewal: Manual sending of an apron driver's licence renewal letter
PrintLmsUser: E-learning id
PrintLmsUser: E‑learning id
PrintJobs: Print jobs

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

@ -8,8 +8,8 @@ QualificationDescription: Beschreibung
QualificationValidDuration: Gültigkeitsdauer
QualificationAuditDuration: Aufbewahrung Audit Log
QualificationRefreshWithin: Erneurerungszeitraum
QualificationRefreshWithinTooltip: Zeitraum für Versand einer Benachrichtigung oder für automatischen Start des E-Learning
QualificationElearningStart: Wird das E-Learning automatisch gestartet?
QualificationRefreshWithinTooltip: Zeitraum für Versand einer Benachrichtigung oder für automatischen Start des E‑Learning
QualificationElearningStart: Wird das E‑Learning automatisch gestartet?
TableQualificationCountActive: Aktive
TableQualificationCountActiveTooltip: Anzahl Personen mit momentan gültiger Qualifikation
TableQualificationCountTotal: Gesamt
@ -29,7 +29,7 @@ QualificationUserNoRenewal: Läuft ohne Benachrichtigung aus
QualificationUserNone: Für diese Person sind keine Qualifikationen registriert.
QualificationBlockReason: Entzugsbegründung
LmsUser: Inhaber
LmsURL: Link E-Learning
LmsURL: Link E‑Learning
TableLmsEmail: E‑Mail
TableLmsIdent: LMS Identifikation
TableLmsElearning: E‑Learning
@ -41,20 +41,25 @@ TableLmsStaff: Interner Mitarbeiter?
TableLmsStarted: Begonnen
TableLmsReceived: Letzte Rückmeldung
TableLmsNotified: Versand Benachrichtigung
TableLmsNotifiedTooltip: Benachrichtigungen werden erst versendet wenn das LMS bestätigt die Eröffnung des E-Learning für den Benutzer bestätigt hat, was ein paar Stunden dauern kann!
TableLmsNotifiedTooltip: Benachrichtigungen werden erst versendet wenn das LMS bestätigt die Eröffnung des E‑Learning für den Benutzer bestätigt hat, was ein paar Stunden dauern kann!
TableLmsEnded: Beended
TableLmsStatus: Status E‑Learning
TableLmsStatusTooltip mbMonth@(Maybe Int): Zeigt an, seit wann ein E-Learning offen ist oder wann es mit Bestanden oder Durchgefalen abgeschlossen wurde. #{maybeToMessage "Anzeige erlischt " (fmap (flip pluralDEeN "Monat") mbMonth) " nach Abschluss."}
TableLmsStatusDay: Datum letzte Statusänderung E-Learning
TableLmsStatusTooltip mbMonth@(Maybe Int): Zeigt #{maybeToMessage "bis zu " (fmap (flip pluralDEeN "Monat") mbMonth) " nach Abschluss"} den letzten Zustand eines E‑Learnings an:
TableLmsStatusDay: Datum letzte Statusänderung E‑Learning
TableLmsSuccess: Bestanden
TableLmsFailed: Gesperrt
LmsStatusBlocked: Durchgefallen wegen zu vieler Fehlversuche
LmsStatusExpired: Durchgefallen nach Fristablauf
LmsStatusSuccess: E#{nonBreakableDash}Learning bestanden
LmsStatusPlanned: E#{nonBreakableDash}Learning wird gerade eröffnet (nur für Admin sichtbar)
LmsStatusDelay: Hinweis: Statusänderung können in seltenen Fällen mehrere Stunden bis zur Anzeige benötigen.
FilterLmsValid: Aktuell gültig
FilterLmsRenewal: Erneuerung anstehend
FilterLmsNotified: Benachrichtigt
CsvColumnLmsIdent: E-Learning Identifikator, einzigartig pro Qualifikation und Teilnehmer
CsvColumnLmsPin: PIN des E-Learning Zugangs
CsvColumnLmsIdent: E‑Learning Identifikator, einzigartig pro Qualifikation und Teilnehmer
CsvColumnLmsPin: PIN des E#{nonBreakableDash}Learning Zugangs
CsvColumnLmsResetPin: Wird die PIN bei der nächsten Synchronisation zurückgesetzt?
CsvColumnLmsDelete: Wird der Identifikator in der E-Learning Plattform bei der nächsten Synchronisation gelöscht?
CsvColumnLmsDelete: Wird der Identifikator in der E‑Learning Plattform bei der nächsten Synchronisation gelöscht?
CsvColumnLmsStaff: Handelt es sich um einen internen Mitarbeiter? (Aus historischen Gründen, wird momentan ignoriert.)
CsvColumnLmsSuccess: Zeitstempel der erfolgreichen Teilnahme (UTC)
CsvColumnLmsFailed: User was blocked by LMS, usually due to too many attempts
@ -65,32 +70,33 @@ LmsResultUpdate: LMS Ergebnis aktualisierung
LmsResultCsvExceptionDuplicatedKey: CSV Import fand uneindeutigen Schlüssel
LmsUserlistCsvExceptionDuplicatedKey: CSV Import fand uneindeutigen Schlüssel
LmsDirectUpload: Direkter Upload für automatisierte Systeme
LmsErrorNoRefreshElearning: Fehler: E-Learning wird nicht automatisch gestartet, da die Zeitspanne für den Erneurerungszeitraum nicht festgelegt wurde.
LmsErrorNoRefreshElearning: Fehler: E‑Learning wird nicht automatisch gestartet, da die Zeitspanne für den Erneurerungszeitraum nicht festgelegt wurde.
MailSubjectQualificationRenewal qname@Text: Qualifikation #{qname} muss demnächst erneuert werden
MailSubjectQualificationExpiry qname@Text: Qualifikation #{qname} läuft demnächst ab
MailSubjectQualificationExpired qname@Text: Qualifikation #{qname} ist ab sofort ungültig
MailBodyQualificationRenewal qname@Text: Qualifikation #{qname} muss demnächst durch einen E-Learning erneuert werden. Ansprechpartner werden gebeten, die Anmeldedaten im Anhang vertraulich an den Prüfling zu übermitteln.
MailBodyQualificationRenewal qname@Text: Qualifikation #{qname} muss demnächst durch einen E‑Learning erneuert werden. Ansprechpartner werden gebeten, die Anmeldedaten im Anhang vertraulich an den Prüfling zu übermitteln.
MailBodyQualificationExpiry: Diese Qualifikation läuft bald ab. Tätigkeiten, welche diese Qualifikation voraussetzen dürfen dann nicht länger ausgeübt werden!
MailBodyQualificationExpired: Diese Qualifikation is nun abgelaufen. Tätigkeiten, welche diese Qualifikation voraussetzen dürfen ab sofort nicht länger ausgeübt werden! Es ist möglich, dass die Qualifikation vorzeit ungültig wurde, z.B. wegen erfolgloser Teilnahme an einem verpflichtendem E-Learning.
MailBodyQualificationExpired: Diese Qualifikation is nun abgelaufen. Tätigkeiten, welche diese Qualifikation voraussetzen dürfen ab sofort nicht länger ausgeübt werden! Es ist möglich, dass die Qualifikation vorzeit ungültig wurde, z.B. wegen erfolgloser Teilnahme an einem verpflichtendem E‑Learning.
QualificationActExpire: Auslaufend markieren - keine Benachrichtigung zur Erneuerung senden
QualificationActUnexpire: Auslaufend aufheben - kostenpflichtige Benachrichtigung bei anstehender Erneuerung senden
QualificationSetExpire n@Int64: Benachrichtigung bei anstehender Erneuerung und E-Learning abgeschaltet für #{n} #{pluralDE n "Person" "Personen"}
QualificationSetUnexpire n@Int64: Benachrichtigung bei anstehender Erneuerung und E-Learning aktiviert für #{n} #{pluralDE n "Person" "Personen"}
QualificationSetExpire n@Int64: Benachrichtigung bei anstehender Erneuerung und E‑Learning abgeschaltet für #{n} #{pluralDE n "Person" "Personen"}
QualificationSetUnexpire n@Int64: Benachrichtigung bei anstehender Erneuerung und E‑Learning aktiviert für #{n} #{pluralDE n "Person" "Personen"}
QualificationActBlockSupervisor: Dauerhaft entziehen, mit sofortiger Wirkung
QualificationActBlock: Entziehen
QualificationActUnblock: Entzug löschen
QualificationStatusBlock l@QualificationShorthand n@Int m@Int: #{n}/#{m} #{l} entzogen
QualificationStatusUnblock l@QualificationShorthand n@Int m@Int: #{n}/#{m} #{l} reaktiviert
LmsRenewalInstructions: Weitere Anweisungen zur Verlängerung finden Sie im angehängten PDF. Um Missbrauch zu verhindern wurde das PDF mit dem im FRADrive hinterlegten PDF-Passwort des Prüflings verschlüsselt. Falls kein PDF-Passwort manuell hinterlegt wurde, ist das PDF-Passwort die Flughafen Ausweisnummer, inklusive Punkt und der Ziffer danach.
LmsNoRenewal: Leider kann diese Qualifikation nicht alleine durch E-Learning verlängert werden.
LmsActNotify: Benachrichtigung E-Learning erneut per Post oder E-Mail versenden
LmsActRenewPin: Neue zufällige E-Learning PIN zuweisen
LmsActRenewNotify: Neue zufällige E-Learning PIN zuweisen und Benachrichtigung per Post oder E-Mail versenden
LmsNotificationSend n@Int: E-Learning Benachrichtigungen an #{n} #{pluralDE n "Prüfling" "Prüflinge"} werden per Post oder E-Mail versendet.
LmsPinRenewal n@Int: E-Learning Pin ausgetauscht für #{n} #{pluralDE n "Prüfling" "Prüflinge"}.
LmsNoRenewal: Leider kann diese Qualifikation nicht alleine durch E‑Learning verlängert werden.
LmsActNotify: Benachrichtigung E‑Learning erneut per Post oder E-Mail versenden
LmsActRenewPin: Neue zufällige E‑Learning PIN zuweisen
LmsActRenewNotify: Neue zufällige E‑Learning PIN zuweisen und Benachrichtigung per Post oder E-Mail versenden
LmsStatusNotificationSent: Anmeldedaten wurden an Prüfling oder Ansprechpartner per Post oder E#{nonBreakableDash}Mail versendet; E#{nonBreakableDash}Learning ist derzeit offen
LmsNotificationSend n@Int: E‑Learning Benachrichtigungen an #{n} #{pluralDE n "Prüfling" "Prüflinge"} werden per Post oder E-Mail versendet.
LmsPinRenewal n@Int: E‑Learning Pin ausgetauscht für #{n} #{pluralDE n "Prüfling" "Prüflinge"}.
LmsActionFailed n@Int: Aktion nicht durchgeführt für #{n} #{pluralDE n "Person" "Personen"}, da diese derzeit nicht an einer Prüfung teilnehmen.
LmsStarted: E-Learning eröffnet
LmsStarted: E‑Learning eröffnet
LmsAutomaticQueuing n@Natural: Die folgenden Funktionen werden normalerweise einmal pro Tag um #{show n} Uhr ausgeführt.
LmsManualQueuing: Die folgenden Funktionen sollten einmal pro Tag ausgeführt werden.
BtnLmsEnqueue: Nutzer mit ablaufenden Qualifikationen zum E-Learning anmelden und benachrichtigen
BtnLmsDequeue: Nutzer mit beendetem E-Learning ggf. benachrichtigen und aufräumen
BtnLmsEnqueue: Nutzer mit ablaufenden Qualifikationen zum E‑Learning anmelden und benachrichtigen
BtnLmsDequeue: Nutzer mit beendetem E‑Learning ggf. benachrichtigen und aufräumen

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

@ -8,8 +8,8 @@ QualificationDescription: Description
QualificationValidDuration: Validity period
QualificationAuditDuration: Audit log keept
QualificationRefreshWithin: Refresh within
QualificationRefreshWithinTooltip: Period before expiry to send a notification or to start e-learning
QualificationElearningStart: Is e-learning automatically started?
QualificationRefreshWithinTooltip: Period before expiry to send a notification or to start e‑learning
QualificationElearningStart: Is e‑learning automatically started?
TableQualificationCountActive: Active
TableQualificationCountActiveTooltip: Number of currently valid qualification holders
TableQualificationCountTotal: Total
@ -41,19 +41,24 @@ TableLmsStaff: Staff?
TableLmsStarted: Started
TableLmsReceived: Last update
TableLmsNotified: Notification sent
TableLmsNotifiedTooltip: Notfications are not sent before the LMS acknowledges the opening of the e-learning course for the user, which may take several hours!
TableLmsNotifiedTooltip: Notfications are not sent before the LMS acknowledges the opening of the e‑learning course for the user, which may take several hours!
TableLmsEnded: Ended
TableLmsStatus: Status e-learning
TableLmsStatusTooltip mbMonth: Shows since when an e-learning is open or when it was closed, including the result. #{maybeToMessage "Shown for " (fmap (flip pluralENsN "month") mbMonth) " after closure."}
TableLmsStatusDay: Date of last e-learning status change
TableLmsStatus: Status e‑learning
TableLmsStatusTooltip mbMonth: Shows #{maybeToMessage "for up to " (fmap (flip pluralENsN "month") mbMonth) " after closure"} the last e#{nonBreakableDash}learning status change:
TableLmsStatusDay: Date of last e‑learning status change
TableLmsSuccess: Completed
TableLmsFailed: Blocked
LmsStatusBlocked: Failed after too many attempts
LmsStatusExpired: Failed due to expiry
LmsStatusSuccess: Passed
LmsStatusPlanned: E#{nonBreakableDash}learning is about to be opened (visible to Admins only)
LmsStatusDelay: Note that status changes may occassionaly require more than a hour to be displayed here.
FilterLmsValid: Currently valid
FilterLmsRenewal: Renewal due
FilterLmsNotified: Notified
CsvColumnLmsIdent: E-learning identifier, unique for each qualification and user
CsvColumnLmsPin: PIN for e-learning access
CsvColumnLmsResetPin: Will the e-learning PIN be reset upon next synchronisation?
CsvColumnLmsIdent: E#{nonBreakableDash}learning identifier, unique for each qualification and user
CsvColumnLmsPin: PIN for e#{nonBreakableDash}learning access
CsvColumnLmsResetPin: Will the e#{nonBreakableDash}learning PIN be reset upon next synchronisation?
CsvColumnLmsDelete: Will the identifier be deleted from the E-learning platfrom upon next synchronisation?
CsvColumnLmsStaff: Is the user an internal staff member? (Legacy, currently ignored)
CsvColumnLmsSuccess: Timestamp of successful completion (UTC)
@ -69,13 +74,13 @@ LmsErrorNoRefreshElearning: Error: E-learning will not be started automatically
MailSubjectQualificationRenewal qname: Qualification #{qname} must be renewed shortly
MailSubjectQualificationExpiry qname: Qualification #{qname} expires soon
MailSubjectQualificationExpired qname: Qualification #{qname} is no longer valid
MailBodyQualificationRenewal qname: The qualification #{qname} must be renewed soon by completing an e-learning course, otherwise it will expire. Supervisors are kindly requested to forward the login data confidentially to the examinee.
MailBodyQualificationRenewal qname: The qualification #{qname} must be renewed soon by completing an e‑learning course, otherwise it will expire. Supervisors are kindly requested to forward the login data confidentially to the examinee.
MailBodyQualificationExpiry: This qualification expires soon. You may then no longer execute any duties that require this qualification as a precondition!
MailBodyQualificationExpired: This qualification is now expired. You may no longer execute any duties that require this qualification as a precondition! It is possible that the qualification expired prematurely, e.g. due to a failed compulsory e-learning.
MailBodyQualificationExpired: This qualification is now expired. You may no longer execute any duties that require this qualification as a precondition! It is possible that the qualification expired prematurely, e.g. due to a failed compulsory e‑learning.
QualificationActExpire: Discontinue - qualification expires silently
QualificationActUnexpire: Continue - send a possibly fee-paying notification upon due renewal
QualificationSetExpire n: Expiry notification and e-learning deactivated for #{n} #{pluralENs n "person"}
QualificationSetUnexpire n: Expiry notification and e-learning activated for #{n} #{pluralENs n "person"}
QualificationSetExpire n: Expiry notification and e‑learning deactivated for #{n} #{pluralENs n "person"}
QualificationSetUnexpire n: Expiry notification and e‑learning activated for #{n} #{pluralENs n "person"}
QualificationActBlockSupervisor: Waive permanently, effective immediately
QualificationActBlock: Revoke
QualificationActUnblock: Clear revocation
@ -83,14 +88,15 @@ QualificationStatusBlock l n m: #{n}/#{m} #{l} revoked
QualificationStatusUnblock l n m: #{n}/#{m} #{l} reactivated
LmsRenewalInstructions: Instruction on how to accomplish the renewal are enclosed in the attached PDF. In order to avoid misuse, the PDF is encrypted with the FRADrive PDF-password of the examinee. If no PDF-password had been chosen yet, then the password is the Fraport id card number of the examinee, including the punctuation mark and the digit thereafter.
LmsNoRenewal: Unfortunately, this particular qualification cannot be renewed through E-learning only.
LmsActNotify: Resend e-learning notification by post or email
LmsActRenewPin: Randomly replace e-learning PIN
LmsActRenewNotify: Randomly replace e-learning PIN and re-send notification by post or email
LmsActNotify: Resend e‑learning notification by post or email
LmsActRenewPin: Randomly replace e‑learning PIN
LmsActRenewNotify: Randomly replace e‑learning PIN and re-send notification by post or email
LmsStatusNotificationSent: E-learning pin has been sent to examinee or supervisor by letter post or by email; e‑learning is currently open
LmsNotificationSend n: E-learning notifications will be sent to #{n} #{pluralENs n "examinee"} by letter post or by email.
LmsPinRenewal n: E-learning pin replaced randomly for #{n} #{pluralENs n "examinee"}.
LmsActionFailed n: No action for #{n} #{pluralENs n "person"}, since there was no ongoing examination.
LmsStarted: E-learning open since
LmsAutomaticQueuing n@Natural: The following functions are executed daily at #{show n} o'clock.
LmsManualQueuing: The following functions should be executed daily.
BtnLmsEnqueue: Enqueue users with expiring qualifications for e-learning and notify them.
BtnLmsDequeue: Dequeue users with finished e-learning and notify, if appropriate.
BtnLmsEnqueue: Enqueue users with expiring qualifications for e‑learning and notify them.
BtnLmsDequeue: Dequeue users with finished e‑learning and notify, if appropriate.

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

@ -16,7 +16,7 @@ TableTerm !ident-ok: Semester
TableCourseSchool: Institut
TableSubmissionGroup: Feste Abgabegruppe
TableNoSubmissionGroup: Keine feste Abgabegruppe
TableMatrikelNr: Matrikelnummer
TableMatrikelNr: AVS Nr
TableSex: Geschlecht
TableBirthday: Geburtsdatum
TableSchool: Institut
@ -56,7 +56,7 @@ TableTutorialTime: Zeit
TableTutorialDeregisterUntil: Abmeldungen bis
TableActionsHead: Aktionen
TableNoFilter: Keine Einschränkung
TableUserMatriculation: Matrikelnummer
TableUserMatriculation: ASV Nummer
TableColumnStudyFeatures: Studiendaten
TableSchoolShort: Kürzel
TableSchoolName !ident-ok: Name

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

@ -16,7 +16,7 @@ TableTerm: Semester
TableCourseSchool: Department
TableSubmissionGroup: Registered submission group
TableNoSubmissionGroup: No registered submission group
TableMatrikelNr: Matriculation
TableMatrikelNr: AVS No
TableSex: Sex
TableBirthday: Birthday
TableSchool: Department
@ -56,7 +56,7 @@ TableTutorialDeregisterUntil: Deregister until
TableActionsHead: Actions
TableTutorialTime: Time
TableNoFilter: No restriction
TableUserMatriculation: Matriculation
TableUserMatriculation: AVS Number
TableColumnStudyFeatures: Features of study
TableSchoolShort: Shorthand
TableSchoolName: Name

1
routes
View File

@ -67,6 +67,7 @@
/admin/tokens AdminTokensR GET POST
/admin/crontab AdminCrontabR GET
/admin/avs AdminAvsR GET POST
/admin/avs/#CryptoUUIDUser AdminAvsUserR GET
/admin/ldap AdminLdapR GET POST
/admin/problems AdminProblemsR GET
/admin/problems/no-contact ProblemUnreachableR GET

7
src/Foundation/I18n.hs
View File

@ -251,6 +251,13 @@ embedRenderMessage ''UniWorX ''AvsLicence id -- required by UniWorXAvsMessages
mkMessageAddition ''UniWorX "Qualification" "messages/uniworx/categories/qualification" "de-de-formal"
mkMessageAddition ''UniWorX "Avs" "messages/uniworx/categories/avs" "de-de-formal"
instance RenderMessage UniWorX AvsDataCardColor where
renderMessage _foundation _ls (AvsCardColorMisc t) = Text.cons '*' t
renderMessage f ls AvsCardColorGrün = renderMessage f ls MsgAvsCardColorGreen
renderMessage f ls AvsCardColorBlau = renderMessage f ls MsgAvsCardColorBlue
renderMessage f ls AvsCardColorRot = renderMessage f ls MsgAvsCardColorRed
renderMessage f ls AvsCardColorGelb = renderMessage f ls MsgAvsCardColorYellow
instance RenderMessage UniWorX TermIdentifier where
renderMessage _foundation _ls = termToText -- TODO: respect user selected Datetime Format

1
src/Foundation/Navigation.hs
View File

@ -113,6 +113,7 @@ breadcrumb AdminErrMsgR = i18nCrumb MsgMenuAdminErrMsg $ Just
breadcrumb AdminTokensR = i18nCrumb MsgMenuAdminTokens $ Just AdminR
breadcrumb AdminCrontabR = i18nCrumb MsgBreadcrumbAdminCrontab $ Just AdminR
breadcrumb AdminAvsR = i18nCrumb MsgMenuAvs $ Just AdminR
breadcrumb AdminAvsUserR{} = i18nCrumb MsgAvsPersonInfo $ Just AdminAvsR
breadcrumb AdminLdapR = i18nCrumb MsgMenuLdap $ Just AdminR
breadcrumb AdminProblemsR = i18nCrumb MsgProblemsHeading $ Just AdminR
breadcrumb ProblemUnreachableR = i18nCrumb MsgProblemsUnreachableHeading $ Just AdminProblemsR

62
src/Handler/Admin.hs
View File

@ -51,11 +51,12 @@ getAdminProblemsR = do
diffLics <- try retrieveDifferingLicences <&> \case
-- (Left (UnsupportedContentType "text/html" resp)) -> Left $ text2widget "Html received"
(Left e) -> Left $ text2widget $ tshow (e :: SomeException)
(Right AvsLicenceDifferences{..}) -> Right ( Set.size avsLicenceDiffRevokeAll
, Set.size avsLicenceDiffGrantVorfeld
, Set.size avsLicenceDiffRevokeRollfeld
, Set.size avsLicenceDiffGrantRollfeld
)
(Right AvsLicenceDifferences{..}) -> Right
( Set.size avsLicenceDiffRevokeAll
, Set.size avsLicenceDiffGrantVorfeld
, Set.size avsLicenceDiffRevokeRollfeld
, Set.size avsLicenceDiffGrantRollfeld
)
-- Attempt to format results in a nicer way failed, since rendering Html within a modal destroyed the page layout itself
-- let procDiffLics (to0, to1, to2) = Right (Set.size to0, Set.size to1, Set.size to2)
-- diffLics <- (procDiffLics <$> retrieveDifferingLicences) `catches`
@ -85,7 +86,7 @@ getAdminProblemsR = do
getProblemUnreachableR :: Handler Html
getProblemUnreachableR = do
unreachables <- runDB retrieveUnreachableUsers'
unreachables <- runDB retrieveUnreachableUsers
siteLayoutMsg MsgProblemsUnreachableHeading $ do
setTitleI MsgProblemsUnreachableHeading
[whamlet|
@ -94,7 +95,7 @@ getProblemUnreachableR = do
<ul>
$forall usr <- unreachables
<li>
^{linkUserWidget ForProfileR usr} (#{usr ^. _userDisplayEmail} / #{usr ^. _userEmail})
^{linkUserWidget ForProfileDataR usr} (#{usr ^. _userDisplayEmail} / #{usr ^. _userEmail})
|]
getProblemFbutNoR :: Handler Html
@ -141,31 +142,30 @@ mkUnreachableUsersTable = do
-}
areAllUsersReachable :: DB Bool
-- areAllUsersReachable = isNothing <$> E.selectOne retrieveUnreachableUsers
areAllUsersReachable = E.selectNotExists retrieveUnreachableUsers
-- areAllUsersReachable = isNothing <$> E.selectOne retrieveUnreachableUsers'
-- areAllUsersReachable = E.selectNotExists retrieveUnreachableUsers'
areAllUsersReachable = null <$> 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.isNothing (user E.^. UserCompanyDepartment) E.||. user E.^. UserCompanyPersonalNumber `E.ilike` E.justVal "E%")
-- E.&&. E.not_ ((user E.^. UserDisplayEmail) `E.like` E.val "%@%.%")
-- E.&&. E.not_ ((user E.^. UserEmail) `E.like` E.val "%@%.%")
-- return user
retrieveUnreachableUsers :: E.SqlQuery (E.SqlExpr (Entity User))
retrieveUnreachableUsers = do
user <- E.from $ E.table @User
E.where_ $ E.isNothing (user E.^. UserPostAddress)
E.&&. E.isNothing (user E.^. UserCompanyDepartment)
E.&&. E.not_ ((user E.^. UserDisplayEmail) `E.like` E.val "%@%.%")
E.&&. E.not_ ((user E.^. UserEmail) `E.like` E.val "%@%.%")
return user
retrieveUnreachableUsers' :: DB [Entity User]
retrieveUnreachableUsers' = do
obviousUnreachable <- E.select retrieveUnreachableUsers
emailUsers <- E.select $ do
user <- E.from $ E.table @User
E.where_ $ E.isNothing (user E.^. UserPostAddress)
E.&&. E.isNothing (user E.^. UserCompanyDepartment)
E.&&. ( ((user E.^. UserDisplayEmail) `E.like` E.val "%@%.%")
E.||. ((user E.^. UserEmail) `E.like` E.val "%@%.%"))
pure user
let hasInvalidEmail = isNothing . getEmailAddress . entityVal
invaldEmail = filter hasInvalidEmail emailUsers
return $ obviousUnreachable ++ invaldEmail
retrieveUnreachableUsers :: DB [Entity User]
retrieveUnreachableUsers = do
emailOnlyUsers <- E.select $ do
user <- E.from $ E.table @User
E.where_ $ E.isNothing (user E.^. UserPostAddress)
E.&&. (E.isNothing (user E.^. UserCompanyDepartment) E.||. user E.^. UserCompanyPersonalNumber `E.ilike` E.justVal "E%")
return user
return $ filter hasInvalidEmail emailOnlyUsers
where
hasInvalidEmail = isNothing . getEmailAddress . entityVal
allDriversHaveAvsId :: Day -> DB Bool
-- allDriversHaveAvsId = fmap isNothing . E.selectOne . retrieveDriversWithoutAvsId

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

@ -9,6 +9,7 @@
module Handler.Admin.Avs
( getAdminAvsR, postAdminAvsR
, getAdminAvsUserR
, getProblemAvsSynchR, postProblemAvsSynchR
) where
@ -144,7 +145,7 @@ postAdminAvsR = do
|]
mAvsQuery <- getsYesod $ view _appAvsQuery
case mAvsQuery of
Nothing -> return mempty
Nothing -> siteLayoutMsg MsgMenuAvs [whamlet|Error: AVS interface configuration is incomplete.|] -- should never occur after initilisation
Just AvsQuery{..} -> do
((presult, pwidget), penctype) <- runFormPost $ makeAvsPersonForm Nothing
@ -365,7 +366,8 @@ postProblemAvsSynchR = getProblemAvsSynchR
getProblemAvsSynchR = do
let catchAllAvs' r = flip catch (\err -> addMessageModal Error (i18n MsgAvsCommunicationError) (Right (text2widget $ tshow (err :: SomeException))) >> redirect r)
catchAllAvs = catchAllAvs' ProblemAvsSynchR -- == current route; use only in conditions that are not repeated upon reload; do not call redirect within catchAllAvs actions!
AvsLicenceDifferences{..} <- catchAllAvs' AdminR retrieveDifferingLicences
(AvsLicenceDifferences{..}, apidStatus) <- catchAllAvs' AdminR retrieveDifferingLicencesStatus
-- TODO: for all ids, uery PersonStatus and create a Map from AvsId to a List of all valid Cards
--
unknownLicenceOwners' <- whenNonEmpty avsLicenceDiffRevokeAll $ \neZeros ->
@ -421,10 +423,10 @@ getProblemAvsSynchR = do
-- licence differences
((tres0,tb0),(tres1up,tb1up),(tres1down,tb1down),(tres2,tb2)) <- runDB $ (,,,)
<$> mkLicenceTable "avsLicDiffRevokeVorfeld" AvsLicenceVorfeld avsLicenceDiffRevokeAll
<*> mkLicenceTable "avsLicDiffGrantVorfeld" AvsNoLicence avsLicenceDiffGrantVorfeld
<*> mkLicenceTable "avsLicDiffRevokeRollfeld" AvsLicenceRollfeld avsLicenceDiffRevokeRollfeld
<*> mkLicenceTable "avsLicDiffGrantRollfeld" AvsNoLicence avsLicenceDiffGrantRollfeld
<$> mkLicenceTable apidStatus "avsLicDiffRevokeVorfeld" AvsLicenceVorfeld avsLicenceDiffRevokeAll
<*> mkLicenceTable apidStatus "avsLicDiffGrantVorfeld" AvsNoLicence avsLicenceDiffGrantVorfeld
<*> mkLicenceTable apidStatus "avsLicDiffRevokeRollfeld" AvsLicenceRollfeld avsLicenceDiffRevokeRollfeld
<*> mkLicenceTable apidStatus "avsLicDiffGrantRollfeld" AvsNoLicence avsLicenceDiffGrantRollfeld
now <- liftIO getCurrentTime
let nowaday = utctDay now
@ -510,8 +512,8 @@ instance HasUser LicenceTableData where
hasUser = resultUser . _entityVal
mkLicenceTable :: Text -> AvsLicence -> Set AvsPersonId -> DB (FormResult (LicenceTableActionData, Set AvsPersonId), Widget)
mkLicenceTable dbtIdent aLic apids = do
mkLicenceTable :: AvsPersonIdMapPersonCard -> Text -> AvsLicence -> Set AvsPersonId -> DB (FormResult (LicenceTableActionData, Set AvsPersonId), Widget)
mkLicenceTable apidStatus dbtIdent aLic apids = do
currentRoute <- fromMaybe (error "mkLicenceTable called from 404-handler") <$> liftHandler getCurrentRoute
avsQualifications <- selectList [QualificationAvsLicence !=. Nothing] []
now <- liftIO getCurrentTime
@ -535,7 +537,7 @@ mkLicenceTable dbtIdent aLic apids = do
[ dbSelect (applying _2) id $ return . view (resultUserAvs . _userAvsPersonId)
-- $ \DBRow{dbrOutput=(_,_,apid,_)} -> return apid -- return . view resultAvsPID -- does not type due to traversal
, colUserNameLink AdminUserR
, sortable (Just "avspersonno") (i18nCell MsgAvsPersonNo) $ \(view resultUserAvs -> a) -> avsPersonNoCell a
, sortable (Just "avspersonno") (i18nCell MsgAvsPersonNo) $ \(view resultUserAvs -> a) -> avsPersonNoLinkedCell a
-- , colUserCompany
, sortable (Just "user-company") (i18nCell MsgTableCompany) $ \(view (resultUser . _entityKey) -> uid) -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX"
companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
@ -553,6 +555,7 @@ mkLicenceTable dbtIdent aLic apids = do
, sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \(preview $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> cellMaybe dayCell d
, sortable (Just "blocked-due") (i18nCell MsgTableQualificationBlockedDue & cellTooltip MsgTableQualificationBlockedTooltip
) $ \(preview $ resultQualUser . _entityVal . _qualificationUserBlockedDue -> b) -> cellMaybe qualificationBlockedCell b
, sortable Nothing (i18nCell MsgTableAvsActiveCards) $ \(view $ resultUserAvs . _userAvsPersonId -> apid) -> foldMap avsPersonCardCell $ Map.lookup apid apidStatus
]
dbtSorting = mconcat
[ single $ sortUserNameLink queryUser
@ -630,4 +633,53 @@ mkLicenceTable dbtIdent aLic apids = do
let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap
return (act, usrSet)
over _1 postprocess <$> dbTable validator DBTable{..}
over _1 postprocess <$> dbTable validator DBTable{..}
getAdminAvsUserR :: CryptoUUIDUser -> Handler Html
getAdminAvsUserR uuid = do
uid <- decrypt uuid
Entity{entityVal=UserAvs{..}} <- runDB $ getBy404 $ UniqueUserAvsUser uid
mAvsQuery <- getsYesod $ view _appAvsQuery
resWgt <- case mAvsQuery of
Nothing -> return [whamlet|Error: AVS interface configuration is incomplete.|] -- should never occur after initilisation
Just AvsQuery{..} -> do
mbContact <- avsQueryContact $ AvsQueryContact $ Set.singleton $ AvsObjPersonId userAvsPersonId
mbDataPerson <- lookupAvsUser userAvsPersonId
return [whamlet|
<p>
Vorläufige Admin Ansicht AVS Daten.
Ansicht zeigt aktuelle Daten.
Es erfolgte damit aber noch kein Update der FRADrive Daten.
<p>
<dl .deflist>
<dt .deflist__dt>InfoPersonContact <br>
<i>(bevorzugt)
<dd .deflist__dd>
$case mbContact
$of Left err
Fehler: #{tshow err}
$of Right contactInfo
#{decodeUtf8 (Pretty.encodePretty (toJSON contactInfo))}
<dt .deflist__dt>PersonStatus und mehrere PersonSearch <br>
<i>(benötigt mehrere AVS Abfragen)
<dd .deflist__dd>
$maybe dataPerson <- mbDataPerson
#{decodeUtf8 (Pretty.encodePretty (toJSON dataPerson))}
$nothing
Keine Daten erhalten.
<h3>
Provisorische formatierte Ansicht
<p>
Generisch formatierte Ansicht, die zeigt, in welche Richtung die Endansicht gehen könnte.
In der Endansicht wären nur ausgewählte Felder mit besserer Bennenung in einer manuell gewählten Reihenfolge sichtbar.
<p>
^{foldMap jsonWidget mbContact}
<p>
^{foldMap jsonWidget mbDataPerson}
|]
let heading = [whamlet|_{MsgAvsPersonNo} #{userAvsNoPerson}|]
siteLayout heading $ do
setTitle $ toHtml $ show userAvsNoPerson
resWgt

12
src/Handler/LMS.hs
View File

@ -91,8 +91,8 @@ postLmsAllR = do
lmsTable <- runDB $ do
view _2 <$> mkLmsAllTable isAdmin
siteLayoutMsg MsgMenuQualifications $ do
setTitleI MsgMenuQualifications
siteLayoutMsg MsgMenuLms $ do
setTitleI MsgMenuLms
$(widgetFile "lms-all")
type AllQualificationTableData = DBRow (Entity Qualification, Ex.Value Word64, Ex.Value Word64)
@ -615,13 +615,13 @@ postLmsR sid qsh = do
when (diffSelected /= 0) $ addMessageI Warning $ MsgLmsActionFailed diffSelected
redirect currentRoute
let heading = citext2widget $ qualificationName quali
let heading = citext2widget $ "LMS " <> qualificationName quali
siteLayout heading $ do
setTitle $ toHtml $ unSchoolKey sid <> "-" <> qsh
setTitle $ toHtml $ "LMS " <> unSchoolKey sid <> "-" <> qsh
$(widgetFile "lms")
-- intended to be viewed primarily in a modal, vie lmsStatusPlusCell'
-- intended to be viewed primarily in a modal, wie lmsStatusPlusCell
getLmsUserR :: CryptoUUIDUser -> Handler Html
getLmsUserR uuid = do
uid <- decrypt uuid
@ -648,6 +648,6 @@ getLmsUserR uuid = do
let heading = [whamlet|_{MsgMenuLmsUser} ^{userWidget user}|]
siteLayout heading $ do
setTitle $ toHtml $ "Qualifkationen " <> userDisplayName
setTitle $ toHtml userDisplayName
$(widgetFile "lms-user")
-- $(i18nWidgetFile "lms-user")

6
src/Handler/Qualification.hs
View File

@ -18,7 +18,7 @@ import Import
-- import Jobs
import Handler.Utils
-- import Handler.Utils.Csv
-- import Handler.Utils.LMS
import Handler.Utils.LMS
import qualified Data.Set as Set
@ -460,8 +460,8 @@ postQualificationR sid qsh = do
-- , sortable (Just "lms-started") (i18nCell MsgTableLmsElearning <> spacerCell <> i18nCell MsgTableLmsStarted)
-- $ \(preview $ resultLmsUser . _entityVal . _lmsUserStarted -> d) -> foldMap dateTimeCell d
-- , sortable (Just "lms-status") (i18nCell MsgTableLmsStatus) $ \(preview $ resultLmsUser . _entityVal . _lmsUserStatus -> status) -> foldMap lmsStatusCell $ join status
, sortable (Just "lms-status-plus")(i18nCell MsgTableLmsStatus & cellTooltip (MsgTableLmsStatusTooltip auditMonths))
$ \(preview $ resultLmsUser . _entityVal -> lu) -> foldMap (lmsStatusPlusCell' linkLmsUser) lu
, sortable (Just "lms-status-plus")(i18nCell MsgTableLmsStatus & cellTooltipWgt Nothing (lmsStatusInfoCell isAdmin auditMonths))
$ \(preview $ resultLmsUser . _entityVal -> lu) -> foldMap (lmsStatusPlusCell linkLmsUser) lu
]
psValidator = def & defaultSorting [SortDescBy "last-refresh"]
tbl <- mkQualificationTable isAdmin qent acts colChoices psValidator

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

@ -80,7 +80,7 @@ postTUsersR tid ssh csh tutn = do
psValidator = def
& defaultSortingByName
& restrictSorting (\name _ -> none (== name) ["note", "registration", "tutorials", "exams", "submission-group", "state"]) -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information
& restrictFilter (\name _ -> none (== name) ["tutorial", "exam", "submission-group", "active", "has-personalised-sheet-files"])
& restrictFilter (\name _ -> none (== name) ["tutorial", "exam", "submission-group", "active", "has-personalised-sheet-files"])
isInTut q = E.exists $ do
tutorialParticipant <- E.from $ E.table @TutorialParticipant
E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. queryUser q E.^. UserId

15
src/Handler/Users.hs
View File

@ -99,9 +99,7 @@ postUsersR = do
, sortable (Just "name") (i18nCell MsgName) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM
(AdminUserR <$> encrypt uid)
(nameWidget userDisplayName userSurname)
-- , sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM
-- (AdminUserR <$> encrypt uid)
-- (toWgt userMatrikelnummer)
, sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \DBRow{ dbrOutput = entUsr } -> cellHasMatrikelnummerLinked entUsr
, sortable (Just "user-company") (i18nCell MsgTableCompany) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX"
companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
@ -215,6 +213,9 @@ postUsersR = do
, ( "display-name"
, SortColumn $ \user -> user E.^. UserDisplayName
)
, ( "matriculation"
, SortColumn $ \user -> user E.^. UserMatrikelnummer
)
, ( "personal-number"
, SortColumn $ \user -> user E.^. UserCompanyPersonalNumber
)
@ -262,10 +263,10 @@ postUsersR = do
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.%))
)
-- , ( "matriculation", FilterColumn $ \user (criteria :: Set.Set Text) -> if
-- | Set.null criteria -> E.true -- TODO: why can this be eFalse and work still?
-- | otherwise -> E.any (\c -> user E.^. UserMatrikelnummer `E.hasInfix` E.val c) criteria
-- )
, ( "matriculation", FilterColumn $ \user (criteria :: Set.Set Text) -> if
| Set.null criteria -> E.true
| otherwise -> E.any (\c -> user E.^. UserMatrikelnummer `E.hasInfix` E.val c) criteria
)
, ( "personal-number", FilterColumn $ \user (criteria :: Set.Set Text) -> if
| Set.null criteria -> E.true -- TODO: why can this be eFalse and work still?
| otherwise -> E.any (\c -> user E.^. UserCompanyPersonalNumber `E.hasInfix` E.val c) criteria

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

@ -14,11 +14,13 @@ module Handler.Utils.Avs
-- , getLicence, getLicenceDB, getLicenceByAvsId -- not supported by interface
, AvsLicenceDifferences(..)
, setLicence, setLicenceAvs, setLicencesAvs
, retrieveDifferingLicences, computeDifferingLicences
, retrieveDifferingLicences, retrieveDifferingLicencesStatus
, computeDifferingLicences
, synchAvsLicences
, lookupAvsUser, lookupAvsUsers
, AvsException(..)
, updateReceivers
, AvsPersonIdMapPersonCard
) where
import Import
@ -178,6 +180,18 @@ data AvsLicenceDifferences = AvsLicenceDifferences
}
deriving (Show)
#ifdef DEVELOPMENT
-- avsLicenceDifferences2LicenceIds is not used in DEVELOPMENT build
#else
avsLicenceDifferences2LicenceIds :: AvsLicenceDifferences -> Set AvsPersonId
avsLicenceDifferences2LicenceIds AvsLicenceDifferences{..} = Set.unions
[ avsLicenceDiffRevokeAll
, avsLicenceDiffGrantVorfeld
, avsLicenceDiffRevokeRollfeld
, avsLicenceDiffGrantRollfeld
]
#endif
avsLicenceDifferences2personLicences :: AvsLicenceDifferences -> Set AvsPersonLicence
avsLicenceDifferences2personLicences AvsLicenceDifferences{..} =
Set.map (AvsPersonLicence AvsNoLicence) avsLicenceDiffRevokeAll
@ -188,24 +202,50 @@ avsLicenceDifferences2personLicences AvsLicenceDifferences{..} =
computeDifferingLicences :: AvsResponseGetLicences -> Handler (Set AvsPersonLicence)
computeDifferingLicences = fmap avsLicenceDifferences2personLicences . getDifferingLicences
retrieveDifferingLicences :: Handler AvsLicenceDifferences
retrieveDifferingLicences = do
#ifdef DEVELOPMENT
avsUsrs <- runDB $ selectList [] [LimitTo 444]
getDifferingLicences $ AvsResponseGetLicences $ Set.fromList $
[ AvsPersonLicence AvsLicenceVorfeld $ AvsPersonId 77 -- AVS:1 FD:2
, AvsPersonLicence AvsLicenceRollfeld $ AvsPersonId 12345678 -- AVS:2 FD:1
, AvsPersonLicence AvsLicenceVorfeld $ AvsPersonId 5 -- AVS:1 FD:0 (nichts)
, AvsPersonLicence AvsLicenceVorfeld $ AvsPersonId 2 -- AVS:1 FD:0 (ungültig)
-- , AvsPersonLicence AvsLicenceVorfeld $ AvsPersonId 4 -- AVS:1 FD:1
] ++ [AvsPersonLicence AvsLicenceVorfeld avsid | Entity _ UserAvs{userAvsPersonId = avsid} <- avsUsrs]
#else
AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery
allLicences <- throwLeftM avsQueryGetAllLicences
getDifferingLicences allLicences
#endif
type AvsPersonIdMapPersonCard = Map AvsPersonId (Set AvsDataPersonCard)
avsResponseStatusMap :: AvsResponseStatus -> AvsPersonIdMapPersonCard
avsResponseStatusMap (AvsResponseStatus status) = Map.fromDistinctAscList [(avsStatusPersonID,avsStatusPersonCardStatus) | AvsStatusPerson{..}<- Set.toAscList status]
retrieveDifferingLicences :: Handler AvsLicenceDifferences
retrieveDifferingLicences = fst <$> retrieveDifferingLicences' False
retrieveDifferingLicencesStatus :: Handler (AvsLicenceDifferences, AvsPersonIdMapPersonCard)
retrieveDifferingLicencesStatus = retrieveDifferingLicences' True
retrieveDifferingLicences' :: Bool -> Handler (AvsLicenceDifferences, AvsPersonIdMapPersonCard)
retrieveDifferingLicences' getStatus = do
#ifdef DEVELOPMENT
avsUsrs <- runDB $ selectList [] [LimitTo 444]
let allLicences = AvsResponseGetLicences $ Set.fromList $
[ AvsPersonLicence AvsLicenceVorfeld $ AvsPersonId 77 -- AVS:1 FD:2
, AvsPersonLicence AvsLicenceRollfeld $ AvsPersonId 12345678 -- AVS:2 FD:1
, AvsPersonLicence AvsLicenceVorfeld $ AvsPersonId 5 -- AVS:1 FD:0 (nichts)
, AvsPersonLicence AvsLicenceVorfeld $ AvsPersonId 2 -- AVS:1 FD:0 (ungültig)
-- , AvsPersonLicence AvsLicenceVorfeld $ AvsPersonId 4 -- AVS:1 FD:1
] ++ [AvsPersonLicence AvsLicenceVorfeld avsid | Entity _ UserAvs{userAvsPersonId = avsid} <- avsUsrs]
#else
AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery
allLicences <- throwLeftM avsQueryGetAllLicences
#endif
lDiff <- getDifferingLicences allLicences
#ifdef DEVELOPMENT
let mkAdpc valid color = AvsDataPersonCard valid Nothing Nothing color (Set.singleton 'F') Nothing Nothing Nothing Nothing (AvsCardNo "1234") "5"
lStat = AvsResponseStatus $ bool mempty fakes getStatus -- not really needed, but avoids unused variable error
fakes = Set.fromList $
[ AvsStatusPerson (AvsPersonId 77 ) $ Set.singleton $ mkAdpc True AvsCardColorGelb
, AvsStatusPerson (AvsPersonId 12345678) $ Set.fromList [mkAdpc False AvsCardColorGrün, mkAdpc True AvsCardColorGelb, mkAdpc False AvsCardColorBlau, mkAdpc True AvsCardColorRot, mkAdpc True $ AvsCardColorMisc "Violett"]
, AvsStatusPerson (AvsPersonId 5 ) $ Set.fromList [mkAdpc True AvsCardColorGrün, mkAdpc False AvsCardColorGelb, mkAdpc True AvsCardColorBlau, mkAdpc False AvsCardColorRot, mkAdpc True $ AvsCardColorMisc "Pink"]
, AvsStatusPerson (AvsPersonId 2 ) $ Set.singleton $ mkAdpc True AvsCardColorGrün
] <>
[ AvsStatusPerson avsid $ Set.singleton $ mkAdpc (even $ avsPersonId avsid) AvsCardColorGelb | Entity _ UserAvs{userAvsPersonId = avsid} <- avsUsrs ]
#else
let statQry = avsLicenceDifferences2LicenceIds lDiff
lStat <- if getStatus && notNull statQry then throwLeftM $ avsQueryStatus $ AvsQueryStatus statQry else return $ AvsResponseStatus mempty -- avoid unnecessary avs calls
#endif
return (lDiff, avsResponseStatusMap lStat)
getDifferingLicences :: AvsResponseGetLicences -> Handler AvsLicenceDifferences
getDifferingLicences (AvsResponseGetLicences licences) = do
now <- liftIO getCurrentTime
@ -394,7 +434,7 @@ upsertAvsUserById api = do
, audSurname = avsSurname
, audDisplayName = avsFirstName <> Text.cons ' ' avsSurname
, audDisplayEmail = "" -- Email is unknown in this version of the avs query, to be updated later (FUTURE TODO)
, audMatriculation = Nothing
, audMatriculation = Just $ tshow avsPersonPersonNo
, audSex = Nothing
, audBirthday = Nothing
, audMobile = Nothing
@ -420,7 +460,7 @@ upsertAvsUserById api = do
return mbUid
(Just (Entity _ UserAvs{userAvsUser=uid})
, Just AvsDataPerson{avsPersonPersonCards, avsPersonInternalPersonalNo, avsPersonFirstName= Text.strip -> avsFirstName, avsPersonLastName= Text.strip -> avsSurname}) -> do -- known user, update address and pinPassword
, Just AvsDataPerson{avsPersonPersonCards, avsPersonInternalPersonalNo, avsPersonPersonNo, avsPersonFirstName= Text.strip -> avsFirstName, avsPersonLastName= Text.strip -> avsSurname}) -> do -- known user, update address and pinPassword
let (mbCompany, mbCoFirmAddr, _) = guessLicenceAddress avsPersonPersonCards
userFirmAddr = plaintextToStoredMarkup <$> mbCoFirmAddr
pinCard = Set.lookupMax avsPersonPersonCards
@ -430,6 +470,7 @@ upsertAvsUserById api = do
update uid [ UserFirstName =. avsFirstName -- update in case of name changes via AVS; might be changed again through LDAP
, UserSurname =. avsSurname
, UserDisplayName =. avsFirstName <> Text.cons ' ' avsSurname
, UserMatrikelnummer =. Just (tshow avsPersonPersonNo) -- TODO: Deactivate this update after Q2/2023; this is only needed since UserMatrikelnummer was used for AVSNO later
, UserCompanyPersonalNumber =. avsInternalPersonalNo <$> canonical avsPersonInternalPersonalNo
]
oldCards <- selectList [UserAvsCardPersonId ==. api] []

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

@ -20,6 +20,7 @@ module Handler.Utils.LMS
, lmsDeletionDate
, lmsUserToDelete, _lmsUserToDelete
, lmsUserToDeleteExpr
, lmsStatusInfoCell
, lmsStatusIcon, lmsUserStatusWidget
, randomLMSIdent, randomLMSIdentBut
, randomLMSpw, maxLmsUserIdentRetries
@ -103,15 +104,15 @@ makeLmsFilename ftag (citext2lower -> qsh) = do
getYMTH :: MonadHandler m => m Text
getYMTH = formatTime' "%Y%m%d%H" =<< liftIO getCurrentTime
--
--
lmsDeletionDate :: Handler Day
lmsDeletionDate = do
lmsDeletionDate = do
LmsConf{lmsDeletionDays} <- getsYesod $ view _appLmsConf
addDays (fromIntegral $ negate lmsDeletionDays) . utctDay <$> liftIO getCurrentTime
-- | Decide whether LMS platform should delete an identifier
lmsUserToDeleteExpr :: Day -> E.SqlExpr (Entity LmsUser) -> E.SqlExpr (E.Value Bool)
lmsUserToDeleteExpr cutoff lmslist = E.isNothing (lmslist E.^. LmsUserEnded)
lmsUserToDeleteExpr cutoff lmslist = E.isNothing (lmslist E.^. LmsUserEnded)
E.&&. E.not_ (E.isNothing $ lmslist E.^. LmsUserStatus)
E.&&. E.explicitUnsafeCoerceSqlExprValue "timestamp" ((lmslist E.^. LmsUserStatus) E.#>>. "{day}") E.<=. E.val cutoff
@ -154,29 +155,58 @@ randomLMSIdent = LmsIdent <$> randomText [] lengthIdent -- idents must not conta
randomLMSIdentBut :: MonadIO m => Set LmsIdent -> m (Maybe LmsIdent)
randomLMSIdentBut banList = untilJustMaxM maxLmsUserIdentRetries getIdentOk
where
getIdentOk = do
where
getIdentOk = do
l <- randomLMSIdent
return $ toMaybe (Set.notMember l banList) l
randomLMSpw :: MonadIO m => m Text -- may contain all kinds of symbols, but our users had trouble with some, like ',' '.' ':' '_'
randomLMSpw = randomText extra lengthPassword
randomLMSpw = randomText extra lengthPassword
where
extra = "+=!?" -- you cannot distinguish ;: and ., in printed letters
lmsStatusInfoCell :: Bool -> Maybe Int -> Widget
lmsStatusInfoCell extendedInfo auditMonths =
[whamlet|$newline never
<p>
_{MsgTableLmsStatusTooltip auditMonths}
<p>
<dl .glossary>
$if extendedInfo
<dt>^{icon IconPlanned}
<dd>_{MsgLmsStatusPlanned}
<dt>^{icon IconNotificationSent}
<dd>_{MsgLmsStatusNotificationSent}
<dt>^{icon IconNotOK}
<dd>_{MsgLmsStatusBlocked}
<dt>^{icon IconExpired}
<dd>_{MsgLmsStatusExpired}
<dt>^{icon IconOK}
<dd>_{MsgLmsStatusSuccess}
<p>
_{MsgLmsStatusDelay}
|]
lmsStatusIcon :: LmsStatus -> Icon
lmsStatusIcon LmsSuccess{} = IconOK
lmsStatusIcon LmsExpired{} = IconExpired
lmsStatusIcon _other = IconNotOK
lmsUserStatusWidget :: LmsUser -> Widget
lmsUserStatusWidget LmsUser{lmsUserStatus=Just lStat} =
lmsUserStatusWidget :: Bool -> LmsUser -> Widget
lmsUserStatusWidget _ LmsUser{lmsUserStatus=Just lStat} =
[whamlet|$newline never
^{formatTimeW SelFormatDate (lmsStatusDay lStat)}
\ ^{icon (lmsStatusIcon lStat)}
^{formatTimeW SelFormatDate (lmsStatusDay lStat)}
\ ^{icon (lmsStatusIcon lStat)}
|]
lmsUserStatusWidget LmsUser{lmsUserStarted} =
-- previously: IconWaitingForUser for lmsUserStatus==Nothing
lmsUserStatusWidget _ LmsUser{lmsUserNotified=Just d} =
[whamlet|$newline never
^{formatTimeW SelFormatDate lmsUserStarted}
\ ^{icon IconWaitingForUser}
^{formatTimeW SelFormatDate d}
\ ^{icon IconNotificationSent}
|]
lmsUserStatusWidget True LmsUser{lmsUserStarted} = -- E-Learning started, but not yet notified; only intended for Admins
[whamlet|$newline never
^{formatTimeW SelFormatDate lmsUserStarted}
\ ^{icon IconPlanned}
|]
lmsUserStatusWidget _ _ = mempty

45
src/Handler/Utils/Table/Cells.hs
View File

@ -7,6 +7,7 @@ module Handler.Utils.Table.Cells where
import Import hiding (link)
import Text.Blaze (ToMarkup(..))
import qualified Data.Set as Set
import Handler.Utils.Table.Pagination
import Handler.Utils.DateTime
@ -217,6 +218,16 @@ cellHasUserModal toLink user =
cellHasMatrikelnummer :: (IsDBTable m a, HasUser u) => u -> DBCell m a
cellHasMatrikelnummer = maybe mempty textCell . view _userMatrikelnummer
cellHasMatrikelnummerLinked :: (IsDBTable m a, HasEntity u User) => u -> DBCell m a
cellHasMatrikelnummerLinked usr
| Just matNr <- usrEntity ^. _userMatrikelnummer = cell $ do
uuid <- liftHandler $ encrypt $ usrEntity ^. _entityKey
modal (text2widget matNr) (Left $ SomeRoute $ AdminAvsUserR uuid)
| otherwise = mempty
where
usrEntity = usr ^. hasEntityUser
cellHasEMail :: (IsDBTable m a, HasUser u) => u -> DBCell m a
cellHasEMail = emailCell . view _userDisplayEmail
@ -356,15 +367,15 @@ cryptoidCell = addCellClass ("cryptoid" :: Text) . textCell . toPathPiece
lmsStatusCell :: IsDBTable m a => LmsStatus -> DBCell m a
lmsStatusCell ls = iconCell (lmsStatusIcon ls) <> spacerCell <> dayCell (lmsStatusDay ls)
lmsStatusPlusCell :: IsDBTable m a => LmsUser -> DBCell m a
lmsStatusPlusCell LmsUser{lmsUserStatus=Just lStat} = lmsStatusCell lStat
lmsStatusPlusCell LmsUser{lmsUserStarted} = iconCell IconWaitingForUser <> spacerCell <> dateCell lmsUserStarted
-- lmsStatusPlusCell :: IsDBTable m a => LmsUser -> DBCell m a
-- lmsStatusPlusCell LmsUser{lmsUserStatus=Just lStat} = lmsStatusCell lStat
-- lmsStatusPlusCell LmsUser{lmsUserStarted} = iconCell IconWaitingForUser <> spacerCell <> dateCell lmsUserStarted
lmsStatusPlusCell' :: IsDBTable m a => Maybe (CryptoUUIDUser -> Route UniWorX) -> LmsUser -> DBCell m a
lmsStatusPlusCell' Nothing lu = wgtCell $ lmsUserStatusWidget lu
lmsStatusPlusCell' (Just toLink) lu = cell $ do
lmsStatusPlusCell :: IsDBTable m a => Maybe (CryptoUUIDUser -> Route UniWorX) -> LmsUser -> DBCell m a
lmsStatusPlusCell Nothing lu = wgtCell $ lmsUserStatusWidget False lu
lmsStatusPlusCell (Just toLink) lu = cell $ do
uuid <- liftHandler $ encrypt $ lu ^. _lmsUserUser
modal (lmsUserStatusWidget lu) (Left $ SomeRoute $ toLink uuid)
modal (lmsUserStatusWidget True lu) (Left $ SomeRoute $ toLink uuid)
qualificationBlockedCellNoReason :: IsDBTable m a => Maybe QualificationBlocked -> DBCell m a
qualificationBlockedCellNoReason Nothing = mempty
@ -379,5 +390,23 @@ qualificationBlockedCell (Just QualificationBlocked{..})
where
mkCellWith c = c qualificationBlockedReason <> spacerCell <> iconCell IconBlocked <> spacerCell <> dayCell qualificationBlockedDay
avsPersonNoCell :: (IsDBTable m c, HasUserAvs a) => a -> DBCell m c
avsPersonNoCell :: (IsDBTable m c, HasUserAvs a) => a -> DBCell m c
avsPersonNoCell = numCell . view _userAvsNoPerson
avsPersonNoLinkedCell :: (IsDBTable m c, HasUserAvs a) => a -> DBCell m c
avsPersonNoLinkedCell a = cell $ do
uuid <- liftHandler $ encrypt $ a ^. _userAvsUser
modal (toWgt $ toMessage $ a ^. _userAvsNoPerson) (Left $ SomeRoute $ AdminAvsUserR uuid)
avsPersonCardCell :: (IsDBTable m c) => Set AvsDataPersonCard -> DBCell m c
avsPersonCardCell cards = wgtCell
[whamlet|
$newline never
<ul .list--iconless .list--inline .list--comma-separated>
$forall c <- validColors
<li>
_{c}
|]
where
validCards = Set.filter avsDataValid cards
validColors = Set.toDescList $ Set.map avsDataCardColor validCards

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

@ -442,8 +442,8 @@ fltrUserMatriculationUI :: DBFilterUI
fltrUserMatriculationUI mPrev = prismAForm (singletonFilter "user-matriculation") mPrev $ aopt textField (fslI MsgTableUserMatriculation)
colUserMatriclenr :: (IsDBTable m c, HasUser a) => Colonnade Sortable a (DBCell m c)
colUserMatriclenr = sortable (Just "user-matriclenumber") (i18nCell MsgTableMatrikelNr) cellHasMatrikelnummer
colUserMatriclenr :: (IsDBTable m c, HasEntity a User) => Colonnade Sortable a (DBCell m c)
colUserMatriclenr = sortable (Just "user-matriclenumber") (i18nCell MsgTableMatrikelNr) cellHasMatrikelnummerLinked
sortUserMatriclenr :: IsString d => (t -> E.SqlExpr (Entity User)) -> (d, SortColumn t r')
sortUserMatriclenr queryUser = ("user-matriclenumber", SortColumn $ queryUser >>> (E.^. UserMatrikelnummer))

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

@ -48,7 +48,7 @@ module Handler.Utils.Table.Pagination
, linkEitherCell, linkEitherCellM, linkEitherCellM'
, maybeAnchorCellM, maybeAnchorCellM', maybeLinkEitherCellM'
, anchorCellC, anchorCellCM, anchorCellCM', linkEitherCellCM', maybeLinkEitherCellCM'
, cellTooltip, cellTooltipIcon
, cellTooltip, cellTooltipIcon, cellTooltipWgt
, listCell, listCell', listCellOf, listCellOf'
, ilistCell, ilistCell', ilistCellOf, ilistCellOf'
, formCell, DBFormResult(..), getDBFormResult
@ -1700,9 +1700,12 @@ cellTooltip :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a -
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)
cellTooltipIcon icn = cellTooltipWgt icn . msg2widget
cellTooltipWgt :: (IsDBTable m a) => Maybe Icon -> Widget-> DBCell m a -> DBCell m a
cellTooltipWgt icn wgt = cellContents.mapped %~ (<> tipWdgt)
where
tipWdgt = iconTooltip (msg2widget msg) icn True
tipWdgt = iconTooltip wgt icn True
-- | Always display widget; maybe a link if user is Authorized.
-- Also see variant `linkEmptyCell`

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

@ -13,7 +13,7 @@ import Text.Hamlet (shamletFile)
import Handler.Utils.DateTime
import qualified Data.Char as Char
import qualified Data.HashMap.Strict as Aeson -- ON UPDATE replace with: import qualified Data.Aeson.KeyMap as Aeson
---------
-- Simple utilities for consistent display
@ -198,3 +198,36 @@ roomReferenceWidget RoomReferenceLink{..} = $(widgetFile "widgets/room-reference
where
linkText = uriToString id roomRefLink mempty
instrModal = modal (i18n MsgRoomReferenceLinkInstructions) $ Right $(widgetFile "widgets/room-reference/link-instructions-modal")
----------
-- JSON --
----------
-- Data.Aeson.Encode.Pretty.encodePretty did not render in Html properly, hence jsonWidget
jsonWidget :: ToJSON a => a -> Widget
jsonWidget x = jsonWidgetAux $ toJSON x
where
jsonWidgetAux :: Value -> Widget
jsonWidgetAux Null = [whamlet|Null|]
jsonWidgetAux (Bool b) = toWidget $ boolSymbol b
jsonWidgetAux (String s) = [whamlet|#{s}|]
jsonWidgetAux (Number n) = [whamlet|#{show n}|]
jsonWidgetAux (Array l)
| 1 >= length l = foldMap jsonWidgetAux l -- empty arrays don't show
| otherwise =
[whamlet|
<ul>
$forall x <- sort l
<li>^{jsonWidgetAux x}
|]
jsonWidgetAux (Object o) = case Aeson.toList o of -- toAscList not supported
[ ] -> mempty -- empty objects don't show
[(_,v)] -> jsonWidgetAux v
r -> [whamlet|
<dl .deflist>
$forall (k,v) <- sort r
<dt .deflist__dt>#{k}
<dd .deflist__dd>^{jsonWidgetAux v}
|]

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

@ -100,7 +100,7 @@ instance FromJSON AvsInternalPersonalNo where
instance ToJSON AvsInternalPersonalNo where
toJSON (AvsInternalPersonalNo ipn) = toJSON $ normalizeAvsInternalPersonalNo ipn
type instance Element AvsInternalPersonalNo = Char
type instance Element AvsInternalPersonalNo = Char
instance MonoFoldable AvsInternalPersonalNo where
ofoldMap f = ofoldr (mappend . f) mempty . avsInternalPersonalNo
ofoldr x y = Text.foldr x y . avsInternalPersonalNo
@ -207,7 +207,10 @@ instance ToJSON AvsPersonId where
instance Show AvsPersonId where
show = show . avsPersonId
instance Read AvsPersonId where
readPrec = fmap AvsPersonId readPrec
readPrec = fmap AvsPersonId readPrec
_AvsPersonId :: Iso AvsPersonId AvsPersonId Int Int
_AvsPersonId = iso avsPersonId AvsPersonId
-- | Non-existing default, also needed for query all ramp driving licences
avsPersonIdZero :: AvsPersonId
@ -281,12 +284,13 @@ licence2char AvsLicenceRollfeld = 'R'
data AvsDataCardColor = AvsCardColorMisc Text | AvsCardColorGrün | AvsCardColorBlau | AvsCardColorRot | AvsCardColorGelb
deriving (Eq, Ord, Read, Show, Generic)
deriving anyclass (NFData)
-- instance RenderMessage declared in Foundation.I18n
instance ToJSON AvsDataCardColor where
toJSON AvsCardColorGrün = "Grün"
toJSON AvsCardColorBlau = "Blau"
toJSON AvsCardColorRot = "Rot"
toJSON AvsCardColorGelb = "Gelb"
toJSON AvsCardColorGrün = "Grün"
toJSON AvsCardColorBlau = "Blau"
toJSON AvsCardColorRot = "Rot"
toJSON AvsCardColorGelb = "Gelb"
toJSON (AvsCardColorMisc t) = String t
instance FromJSON AvsDataCardColor where
@ -657,7 +661,7 @@ deriveJSON defaultOptions
} ''AvsQueryPerson
newtype AvsQueryStatus = AvsQueryStatus (Set AvsPersonId)
deriving (Eq, Ord, Show, Generic)
deriving (Eq, Ord, Show, Generic)
deriveJSON defaultOptions ''AvsQueryStatus
newtype AvsQueryContact = AvsQueryContact (Set AvsObjPersonId) -- note the difference to AvsQueryStatus, which receives a list of id, whereas here we sent a list of single-field object

2
src/Utils/Avs.hs
View File

@ -68,7 +68,7 @@ mkAvsQuery :: BaseUrl -> BasicAuthData -> ClientEnv -> AvsQuery
mkAvsQuery _ _ _ = AvsQuery
{ avsQueryPerson = \_ -> return . Right $ AvsResponsePerson mempty
, avsQueryStatus = \_ -> return . Right $ AvsResponseStatus mempty
, avsQueryContact = \_ -> return . Right $ AvsResponseContact $ Set.singleton $ AvsDataContact (AvsPersonId 1234567) (AvsPersonInfo "AVSNO:123" "Heribert" "Sumpfmeier" (-1) Nothing Nothing Nothing Nothing) (AvsFirmInfo "Lange Firma" 7 "Kurz" Nothing Nothing Nothing Nothing Nothing Nothing)
, avsQueryContact = \_ -> return . Right $ AvsResponseContact $ Set.singleton $ AvsDataContact (AvsPersonId 1234567) (AvsPersonInfo "123123123" "Heribert" "Sumpfmeier" (-1) Nothing Nothing Nothing Nothing) (AvsFirmInfo "Lange Firma" 7 "Kurz" Nothing Nothing Nothing Nothing Nothing Nothing)
, avsQuerySetLicences = \_ -> return . Right $ AvsResponseSetLicences mempty
, avsQueryGetAllLicences = return . Right $ AvsResponseGetLicences mempty
}

11
src/Utils/Icon.hs
View File

@ -68,11 +68,14 @@ data Icon
| IconRegisterTemplate
| IconNoCorrectors
| IconTooltipDefault
| IconNotificationSuccess
| IconNotificationSuccess -- used for popups
| IconNotificationInfo
| IconNotificationWarning
| IconNotificationError
| IconNotificationNonactive
| IconNotification -- used for email and lettes
| IconNoNotification
| IconNotificationSent
| IconFavourite
| IconLanguage
| IconNavContainerClose | IconPageActionChildrenClose
@ -93,7 +96,6 @@ data Icon
| IconFileUploadSession
| IconStandaloneFieldError
| IconFileUser
| IconNotification | IconNoNotification
| IconPersonalIdentification
| IconMenuWorkflows
| IconVideo
@ -106,7 +108,7 @@ data Icon
| IconLetter
| IconAt
| IconSupervisor
| IconWaitingForUser
-- | IconWaitingForUser
| IconExpired
deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic)
deriving anyclass (Universe, Finite, NFData)
@ -180,6 +182,7 @@ iconText = \case
IconStandaloneFieldError -> "exclamation"
IconFileUser -> "file-user"
IconNotification -> "envelope"
IconNotificationSent -> "envelope-open" -- "paper-plane", "shipping-fast", "hourglass-half"
IconNoNotification -> "bell-slash"
IconPersonalIdentification -> "id-card"
IconMenuWorkflows -> "project-diagram"
@ -192,7 +195,7 @@ iconText = \case
IconLetter -> "mail-bulk" -- Problem "envelope" already used for email as well
IconAt -> "at"
IconSupervisor -> "head-side" -- must be notably different to user
IconWaitingForUser -> "user-cog" -- Waiting on a user to do something
-- IconWaitingForUser -> "user-cog" -- Waiting on a user to do something
IconExpired -> "hourglass-end"
nullaryPathPiece ''Icon $ camelToPathPiece' 1

2
templates/lms-user.hamlet
View File

@ -34,7 +34,7 @@ $else
<dd .deflist__dd>^{formatTimeW SelFormatDateTime (lmsUserStarted lmsUsr)}
$maybe _ <- lmsUserStatus lmsUsr
<dt .deflist__dt>_{MsgTableLmsStatus}
<dd .deflist__dd>^{lmsUserStatusWidget lmsUsr}
<dd .deflist__dd>^{lmsUserStatusWidget True lmsUsr}
<dt .deflist__dt>_{MsgTableLmsIdent}
<dd .deflist__dd .email>#{getLmsIdent (lmsUserIdent lmsUsr)}
<dt .deflist__dt>_{MsgTableLmsPin}

127
test/Database/Fill.hs
View File

@ -163,7 +163,7 @@ fillDb = do
, userAuthentication = pwSimple
, userLastAuthentication = Nothing
, userTokensIssuedAfter = Nothing
, userMatrikelnummer = Nothing
, userMatrikelnummer = Just "94094094094"
, userEmail = "e12345@fraport.de"
, userDisplayEmail = "jost@tcs.ifi.lmu.de"
, userDisplayName = "Steffen Jost"
@ -358,7 +358,126 @@ fillDb = do
, userExamOfficeGetSynced = False
, userExamOfficeGetLabels = True
}
_stranger1 <- insert User
{ userIdent = "AVSID:996699"
, userAuthentication = AuthLDAP
, userLastAuthentication = Nothing
, userTokensIssuedAfter = Nothing
, userMatrikelnummer = Nothing
, userEmail = "E996699@fraport.de"
, userDisplayEmail = ""
, userDisplayName = "Stranger One"
, userSurname = "One"
, userFirstName = "Stranger"
, userTitle = Nothing
, userMaxFavourites = userDefaultMaxFavourites
, userMaxFavouriteTerms = userDefaultMaxFavouriteTerms
, userTheme = ThemeMossGreen
, userDateTimeFormat = userDefaultDateTimeFormat
, userDateFormat = userDefaultDateFormat
, userTimeFormat = userDefaultTimeFormat
, userDownloadFiles = userDefaultDownloadFiles
, userWarningDays = userDefaultWarningDays
, userLanguages = Nothing
, userNotificationSettings = def
, userCreated = now
, userLastLdapSynchronisation = Nothing
, userLdapPrimaryKey = Nothing
, userCsvOptions = def
, userSex = Just SexMale
, userBirthday = Nothing
, userShowSex = userDefaultShowSex
, userTelephone = Nothing
, userMobile = Nothing
, userCompanyPersonalNumber = Just "E996699"
, userCompanyDepartment = Just "AVN-Strange"
, userPinPassword = Nothing
, userPostAddress = Nothing
, userPostLastUpdate = Nothing
, userPrefersPostal = False
, userExamOfficeGetSynced = False
, userExamOfficeGetLabels = True
}
_stranger2 <- insert User
{ userIdent = "AVSID:669966"
, userAuthentication = AuthLDAP
, userLastAuthentication = Nothing
, userTokensIssuedAfter = Nothing
, userMatrikelnummer = Nothing
, userEmail = "E669966@fraport.de"
, userDisplayEmail = ""
, userDisplayName = "Stranger Two"
, userSurname = "Stranger"
, userFirstName = "Two"
, userTitle = Nothing
, userMaxFavourites = userDefaultMaxFavourites
, userMaxFavouriteTerms = userDefaultMaxFavouriteTerms
, userTheme = ThemeMossGreen
, userDateTimeFormat = userDefaultDateTimeFormat
, userDateFormat = userDefaultDateFormat
, userTimeFormat = userDefaultTimeFormat
, userDownloadFiles = userDefaultDownloadFiles
, userWarningDays = userDefaultWarningDays
, userLanguages = Nothing
, userNotificationSettings = def
, userCreated = now
, userLastLdapSynchronisation = Nothing
, userLdapPrimaryKey = Nothing
, userCsvOptions = def
, userSex = Just SexMale
, userBirthday = Nothing
, userShowSex = userDefaultShowSex
, userTelephone = Nothing
, userMobile = Nothing
, userCompanyPersonalNumber = Just "669966"
, userCompanyDepartment = Just "AVN-Strange"
, userPinPassword = Nothing
, userPostAddress = Nothing
, userPostLastUpdate = Nothing
, userPrefersPostal = False
, userExamOfficeGetSynced = False
, userExamOfficeGetLabels = True
}
_stranger3 <- insert User
{ userIdent = "AVSID:6969"
, userAuthentication = AuthLDAP
, userLastAuthentication = Nothing
, userTokensIssuedAfter = Nothing
, userMatrikelnummer = Nothing
, userEmail = "E6969@fraport.de"
, userDisplayEmail = ""
, userDisplayName = "Stranger 3 Three"
, userSurname = "Three"
, userFirstName = "Stranger"
, userTitle = Nothing
, userMaxFavourites = userDefaultMaxFavourites
, userMaxFavouriteTerms = userDefaultMaxFavouriteTerms
, userTheme = ThemeMossGreen
, userDateTimeFormat = userDefaultDateTimeFormat
, userDateFormat = userDefaultDateFormat
, userTimeFormat = userDefaultTimeFormat
, userDownloadFiles = userDefaultDownloadFiles
, userWarningDays = userDefaultWarningDays
, userLanguages = Nothing
, userNotificationSettings = def
, userCreated = now
, userLastLdapSynchronisation = Nothing
, userLdapPrimaryKey = Nothing
, userCsvOptions = def
, userSex = Just SexMale
, userBirthday = Nothing
, userShowSex = userDefaultShowSex
, userTelephone = Nothing
, userMobile = Nothing
, userCompanyPersonalNumber = Just "E996699"
, userCompanyDepartment = Just "AVN-Strange"
, userPinPassword = Nothing
, userPostAddress = Just $ markdownToStoredMarkup ("Kartoffelweg 12 \n666 Höllensumpf \nFreiland"::Text)
, userPostLastUpdate = Nothing
, userPrefersPostal = False
, userExamOfficeGetSynced = False
, userExamOfficeGetLabels = True
}
let
firstNames = [ "James", "John", "Robert", "Michael"
, "William", "David", "Mary", "Richard"
@ -419,8 +538,8 @@ fillDb = do
, userShowSex = userDefaultShowSex
, userTelephone = Nothing
, userMobile = Nothing
, userCompanyPersonalNumber = Nothing
, userCompanyDepartment = Nothing
, userCompanyPersonalNumber = bool Nothing (Just "E123" ) (even $ length firstName)
, userCompanyDepartment = bool Nothing (Just "AVN-A") (even $ length userSurname)
, userPinPassword = Nothing
, userPostAddress = Nothing
, userPostLastUpdate = Nothing