From 32fdfbd31e5ec68a42c533f1e269b2e962458220 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 27 Jan 2023 16:40:21 +0100 Subject: [PATCH 01/15] fix(build) --- test/User.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/test/User.hs b/test/User.hs index 60e32e0b3..293fb7c36 100644 --- a/test/User.hs +++ b/test/User.hs @@ -56,4 +56,5 @@ fakeUser adjUser = adjUser User{..} userCompanyDepartment = Nothing userPinPassword = Nothing userPostAddress = Nothing + userLastUpdate = Nothing userPrefersPostal = userDefaultPrefersPostal From 703a32033b2d0f3edbd8693df7b6e22b4b5f0061 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 27 Jan 2023 16:42:47 +0100 Subject: [PATCH 02/15] fix(build) --- test/User.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/User.hs b/test/User.hs index 293fb7c36..239488fff 100644 --- a/test/User.hs +++ b/test/User.hs @@ -56,5 +56,5 @@ fakeUser adjUser = adjUser User{..} userCompanyDepartment = Nothing userPinPassword = Nothing userPostAddress = Nothing - userLastUpdate = Nothing + userPostLastUpdate = Nothing userPrefersPostal = userDefaultPrefersPostal From 5e887293d9da007980aa08fb8c4619198499309f Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 27 Jan 2023 16:44:31 +0100 Subject: [PATCH 03/15] fix(build) --- test/ModelSpec.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/test/ModelSpec.hs b/test/ModelSpec.hs index d3b8698e4..58220bdef 100644 --- a/test/ModelSpec.hs +++ b/test/ModelSpec.hs @@ -139,6 +139,7 @@ instance Arbitrary User where userCompanyDepartment <- arbitrary userPinPassword <- arbitrary userPostAddress <- arbitrary -- TODO: not a good address + userPostLastUpdate <- arbitrary userPrefersPostal <- arbitrary userExamOfficeGetSynced <- arbitrary userExamOfficeGetLabels <- arbitrary From 529f9884bf849f6bf67867d025cff545eae95a77 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 27 Jan 2023 23:22:56 +0100 Subject: [PATCH 04/15] chore(release): 27.0.19 --- CHANGELOG.md | 2 ++ nix/docker/demo-version.json | 2 +- nix/docker/version.json | 2 +- package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 6 files changed, 7 insertions(+), 5 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 0aa7f5698..32a41f43b 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,8 @@ All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines. +## [27.0.19](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.0.18...v27.0.19) (2023-01-27) + ## [27.0.18](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.0.17...v27.0.18) (2023-01-25) ## [27.0.17](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.0.16...v27.0.17) (2023-01-22) diff --git a/nix/docker/demo-version.json b/nix/docker/demo-version.json index 4df134a2d..e3f82320d 100644 --- a/nix/docker/demo-version.json +++ b/nix/docker/demo-version.json @@ -1,3 +1,3 @@ { - "version": "27.0.18" + "version": "27.0.19" } diff --git a/nix/docker/version.json b/nix/docker/version.json index 4df134a2d..e3f82320d 100644 --- a/nix/docker/version.json +++ b/nix/docker/version.json @@ -1,3 +1,3 @@ { - "version": "27.0.18" + "version": "27.0.19" } diff --git a/package-lock.json b/package-lock.json index bfc7bfd35..8f0e38252 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.0.18", + "version": "27.0.19", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 571b6f854..12c51d31d 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.0.18", + "version": "27.0.19", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 1aca0a7f1..2ce9b059e 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 27.0.18 +version: 27.0.19 dependencies: - base - yesod From a8b1c3640955f589a416258657cb19daf806cc37 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 31 Jan 2023 13:17:09 +0100 Subject: [PATCH 05/15] refactor(qualifications): adjust tooltip lms blocked --- messages/uniworx/categories/qualification/de-de-formal.msg | 4 ++-- messages/uniworx/categories/qualification/en-eu.msg | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index a9ce21d18..774b3b178 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -21,7 +21,7 @@ LmsQualificationValidUntil: Gültig bis TableQualificationLastRefresh: Zuletzt erneuert TableQualificationFirstHeld: Erstmalig TableQualificationBlockedDue: Suspendiert -TableQualificationBlockedTooltip: Wann wurde die Qualifikation vorübergehend außer Kraft gesetzt und wer hat das veranlasst? +TableQualificationBlockedTooltip: Wann wurde die Qualifikation vorübergehend außer Kraft gesetzt und warum wurde dies veranlasst? TableQualificationNoRenewal: Storniert TableQualificationNoRenewalTooltip: Es wird keine Benachrichtigung mehr versand, wenn diese Qualifikation ablaufen sollte. Die Qualifikation kann noch gültig sein. LmsUser: Inhaber @@ -86,4 +86,4 @@ MppBadLanguage: Sprache muss derzeit "de" oder "en" sein. 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 \ No newline at end of file +BtnLmsDequeue: Nutzer mit beendetem E-Learning ggf. benachrichtigen und aufräumen diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg index ef14f66c9..7d31de380 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/messages/uniworx/categories/qualification/en-eu.msg @@ -21,7 +21,7 @@ LmsQualificationValidUntil: Valid until TableQualificationLastRefresh: Last renewed TableQualificationFirstHeld: First held TableQualificationBlockedDue: Suspended -TableQualificationBlockedTooltip: When was the qualification temporarily suspended and who requested this? +TableQualificationBlockedTooltip: Why and when was this qualification temporarily suspended? TableQualificationNoRenewal: Canceled TableQualificationNoRenewalTooltip: No renewal notifications will be send for this qualification upon expiry. The qualification may still be valid. LmsUser: Licensee @@ -86,4 +86,4 @@ MppBadLanguage: Language currently restricted to "en" or "de". 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. \ No newline at end of file +BtnLmsDequeue: Dequeue users with finished e-learning and notify, if appropriate. From f434eff0832d1bbecce4fb5a48b9e19a16541142 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 31 Jan 2023 13:32:39 +0100 Subject: [PATCH 06/15] refactor(notifications): change notifications defaults --- src/Model/Types/Mail.hs | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/src/Model/Types/Mail.hs b/src/Model/Types/Mail.hs index c64b71bf1..cba46cefd 100644 --- a/src/Model/Types/Mail.hs +++ b/src/Model/Types/Mail.hs @@ -81,6 +81,18 @@ instance Default NotificationSettings where defaultOff = HashSet.fromList [ NTSheetSoonInactive , NTExamRegistrationSoonInactive + , NTSubmissionRated + , NTSubmissionEdited + , NTSubmissionUserCreated + , NTSubmissionUserDeleted + , NTSheetActive + , NTSheetHint + , NTSheetSolution + , NTSheetInactive + , NTCorrectionsAssigned + , NTCorrectionsNotDistributed + , NTUserAuthModeUpdate + , NTCourseRegistered ] instance ToJSON NotificationSettings where From ed147dbd20b89d32281dbcaed3a1ba7cb00c347b Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 31 Jan 2023 14:38:49 +0100 Subject: [PATCH 07/15] fix(user): check reachability by post or email did not account for department --- src/Handler/Admin.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index e9bbde606..a0895774f 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -146,6 +146,7 @@ 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.^. UserEmail) `E.like` E.val "%@%.%") return user @@ -225,4 +226,4 @@ retrieveDriversRWithoutF nowaday = do {- getAdjustLicences :: SchoolId -> QualificationShortand -> Handler Html --} \ No newline at end of file +-} From 6ff26fcc6c542460836d0a9aebd1abd23a309692 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 31 Jan 2023 18:36:15 +0100 Subject: [PATCH 08/15] core(avs): add tooltip about lms notifications --- messages/uniworx/categories/qualification/de-de-formal.msg | 1 + messages/uniworx/categories/qualification/en-eu.msg | 1 + src/Handler/LMS.hs | 2 +- 3 files changed, 3 insertions(+), 1 deletion(-) diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index 774b3b178..70a471163 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -36,6 +36,7 @@ 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! TableLmsEnded: Beended TableLmsStatus: Status E-Learning TableLmsSuccess: Bestanden diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg index 7d31de380..00a6115d3 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/messages/uniworx/categories/qualification/en-eu.msg @@ -36,6 +36,7 @@ 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! TableLmsEnded: Ended TableLmsStatus: Status e-learning TableLmsSuccess: Completed diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index f4ad4555f..d2eafeecd 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -534,7 +534,7 @@ postLmsLSR sid qsh nlimit noffset , sortable (Just "lms-datepin") (i18nLms MsgTableLmsDatePin) $ \(preview $ resultLmsUser . _entityVal . _lmsUserDatePin -> d) -> foldMap dateTimeCell d , sortable (Just "lms-received") (i18nLms MsgTableLmsReceived) $ \(preview $ resultLmsUser . _entityVal . _lmsUserReceived -> d) -> foldMap dateTimeCell $ join d --, sortable (Just "lms-notified") (i18nLms MsgTableLmsNotified) $ \(preview $ resultLmsUser . _entityVal . _lmsUserNotified -> d) -> foldMap dateTimeCell $ join d - , sortable (Just "lms-notified") (i18nLms MsgTableLmsNotified) $ \row -> + , sortable (Just "lms-notified") (i18nLms MsgTableLmsNotified & cellTooltip MsgTableLmsNotifiedTooltip) $ \row -> -- 4 Cases: -- - No notification: LmsUserNotified == Nothing -- - Email sent : LmsUserNotified == Just _ && PrintJobId == Nothing From f70c63bf151dd8a96fddef4dc8ee0a1a6897aceb Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 1 Feb 2023 10:54:42 +0100 Subject: [PATCH 09/15] refactor(letter): minor rephrase --- messages/uniworx/categories/qualification/de-de-formal.msg | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index 70a471163..4c3310606 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -65,7 +65,7 @@ MailSubjectQualificationExpired qname@Text: Qualifikation #{qname} ist ab sofort MailBodyQualificationRenewal qname@Text: Sie müssen Qualifikation #{qname} demnächst durch einen E-Learning Kurs erneuern, siehe Anhang. 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. -LmsRenewalInstructions: Anweisungen zur Verlängerung finden Sie im angehängten PDF. Um Missbrauch zu verhindern wurde das PDF dem von Ihnen in FRADrive hinterlegten PDF-Passwort verschlüsselt. Falls kein PDF-Passwort hinterlegt wurde, ist das PDF-Passwort Ihre Fraport Ausweisnummer, inklusive Punkt und der Ziffer danach. +LmsRenewalInstructions: Anweisungen zur Verlängerung finden Sie im angehängten PDF. Um Missbrauch zu verhindern wurde das PDF dem von Ihnen in FRADrive hinterlegten PDF-Passwort verschlüsselt. Falls kein PDF-Passwort manuell hinterlegt wurde, ist das PDF-Passwort Ihre 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 From 086e49e2ae126f6acb9be774b0351d37443c31d8 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 1 Feb 2023 13:20:51 +0100 Subject: [PATCH 10/15] fix(sap): do not export e-accounts --- src/Handler/SAP.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Handler/SAP.hs b/src/Handler/SAP.hs index cf83e6c22..4e8b98ebc 100644 --- a/src/Handler/SAP.hs +++ b/src/Handler/SAP.hs @@ -53,10 +53,11 @@ instance ToNamedRecord SapUserTableCsv where , "Ausprägung" Csv..= csvSUTausprägung ] --- | Removes all elements containing Nothing, which should not be returend by the query anyway (only qualfications with sap id and users with internal personnel number must be transmitted) +-- | Removes all personalNummer which are not numbers (i.e. excludes E-Accounts), which should not be returned by the query anyway (only qualfications with sap id and users with internal personnel number must be transmitted) -- TODO: once temporary suspensions are implemented, a user must be transmitted to SAP in two rows: firstheld->suspensionFrom & suspensionTo->validTo sapRes2csv :: [(Ex.Value (Maybe Text), Ex.Value Day, Ex.Value Day, Ex.Value (Maybe Text))] -> [SapUserTableCsv] sapRes2csv l = [ res | (Ex.Value (Just persNo), Ex.Value firstHeld, Ex.Value validUntil, Ex.Value (Just sapId)) <- l + , readMay persNo > Just 0 -- filter E-accounts for SAP export , let res = SapUserTableCsv { csvSUTpersonalNummer = persNo , csvSUTqualifikation = sapId @@ -101,4 +102,4 @@ getQualificationSAPDirectR = do csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered -- direct Download see: --- https://ersocon.net/blog/2017/2/22/creating-csv-files-in-yesod \ No newline at end of file +-- https://ersocon.net/blog/2017/2/22/creating-csv-files-in-yesod From e9eeaca22933b9483a4bd1348292f9c298ad696a Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 1 Feb 2023 18:00:53 +0100 Subject: [PATCH 11/15] chore(avs): set qu-renewal flag; tutorial add space separated --- .../uniworx/categories/avs/de-de-formal.msg | 2 +- messages/uniworx/categories/avs/en-eu.msg | 2 +- .../courses/courses/de-de-formal.msg | 2 +- .../categories/courses/courses/en-eu.msg | 2 +- .../categories/qualification/de-de-formal.msg | 3 ++- .../categories/qualification/en-eu.msg | 1 + src/Audit/Types.hs | 9 ++++---- src/Handler/Admin/Avs.hs | 10 +++++---- src/Handler/Course/ParticipantInvite.hs | 2 +- src/Handler/SAP.hs | 2 +- src/Handler/Tutorial/Users.hs | 2 +- src/Handler/Users.hs | 4 ++-- src/Handler/Utils/Qualification.hs | 22 +++++++++++-------- src/Utils/Form.hs | 12 ++++++++++ 14 files changed, 48 insertions(+), 27 deletions(-) diff --git a/messages/uniworx/categories/avs/de-de-formal.msg b/messages/uniworx/categories/avs/de-de-formal.msg index e1c14dd4f..7a63ec25d 100644 --- a/messages/uniworx/categories/avs/de-de-formal.msg +++ b/messages/uniworx/categories/avs/de-de-formal.msg @@ -28,4 +28,4 @@ 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 \ No newline at end of file +LicenceTableRevokeFDrive: In FRADrive zum Vortag entziehen \ No newline at end of file diff --git a/messages/uniworx/categories/avs/en-eu.msg b/messages/uniworx/categories/avs/en-eu.msg index 7499244f6..91efb95f9 100644 --- a/messages/uniworx/categories/avs/en-eu.msg +++ b/messages/uniworx/categories/avs/en-eu.msg @@ -28,4 +28,4 @@ RevokeUnknownLicencesFail: Not all AVS driving licences of unknown drivers could AvsCommunicationError: AVS interface returned an unexpected error. LicenceTableChangeAvs: Change in AVS LicenceTableGrantFDrive: Grant in FRADrive -LicenceTableRevokeFDrive: Revoke in FRADrive +LicenceTableRevokeFDrive: Revoke yesterday in FRADrive diff --git a/messages/uniworx/categories/courses/courses/de-de-formal.msg b/messages/uniworx/categories/courses/courses/de-de-formal.msg index d18a54779..6d349743c 100644 --- a/messages/uniworx/categories/courses/courses/de-de-formal.msg +++ b/messages/uniworx/categories/courses/courses/de-de-formal.msg @@ -83,7 +83,7 @@ CourseParticipantsRegisterHeading: Kursteilnehmer:innen hinzufügen CourseParticipantsRegisterActionAddParticipants: Personen zum Kurs anmelden CourseParticipantsRegisterActionAddTutorialMembers: Personen zu Kurs und Übungsgruppe anmelden CourseParticipantsRegisterUsersField: Zum Kurs anzumeldende Personen -CourseParticipantsRegisterUsersFieldTip: Bitte Ausweiskartennummer inklusive Punkt, Fraport Personalnummer oder Email angeben. Mehrere Personen bitte mit Komma getrennt angeben. +CourseParticipantsRegisterUsersFieldTip: Bitte Ausweiskartennummer inklusive Punkt, Fraport Personalnummer oder Email angeben. Mehrere Personen bitte mit Komma oder Leerzeichen trennen. CourseParticipantsRegisterTutorialOption: Kursteilnehmer:innen zu Übungsgruppe anmelden? CourseParticipantsRegisterTutorialField: Übungsgruppe CourseParticipantsRegisterTutorialFieldTip: Ist aktuell keine Übungsgruppe mit diesem Namen vorhanden, wird eine neue erstellt. Ist bereits eine Übungsgruppe mit diesem Namen vorhanden, werden die Kursteilnehmenden dieser hinzugefügt. diff --git a/messages/uniworx/categories/courses/courses/en-eu.msg b/messages/uniworx/categories/courses/courses/en-eu.msg index 2bde12186..b2d0a823d 100644 --- a/messages/uniworx/categories/courses/courses/en-eu.msg +++ b/messages/uniworx/categories/courses/courses/en-eu.msg @@ -83,7 +83,7 @@ CourseParticipantsRegisterHeading: Add course participants CourseParticipantsRegisterActionAddParticipants: Add course participants CourseParticipantsRegisterActionAddTutorialMembers: Add course and tutorial participants CourseParticipantsRegisterUsersField: Persons to register for course -CourseParticipantsRegisterUsersFieldTip: Please enter id card no (including dot), Fraport personnel number or email. Please separate multiple entries with commas. +CourseParticipantsRegisterUsersFieldTip: Please enter id card no (including dot), Fraport personnel number or email. Please separate multiple entries with comma or space. CourseParticipantsRegisterTutorialOption: Register course participants for tutorial? CourseParticipantsRegisterTutorialField: Tutorial CourseParticipantsRegisterTutorialFieldTip: If there is no tutorial with this name, a new one will be created. If there is a tutorial with this name, the course participants will be registered for it. diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index 4c3310606..c0e62cfcb 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -23,7 +23,8 @@ TableQualificationFirstHeld: Erstmalig TableQualificationBlockedDue: Suspendiert TableQualificationBlockedTooltip: Wann wurde die Qualifikation vorübergehend außer Kraft gesetzt und warum wurde dies veranlasst? TableQualificationNoRenewal: Storniert -TableQualificationNoRenewalTooltip: Es wird keine Benachrichtigung mehr versand, wenn diese Qualifikation ablaufen sollte. Die Qualifikation kann noch gültig sein. +TableQualificationNoRenewalTooltip: Es wird keine Benachrichtigung mehr versendet, wenn diese Qualifikation ablaufen sollte. Die Qualifikation kann noch gültig sein. +QualificationUserNoRenewal: Läuft ohne Benachrichtigung aus LmsUser: Inhaber TableLmsEmail: E-Mail TableLmsIdent: LMS Identifikation diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg index 00a6115d3..3eaae500d 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/messages/uniworx/categories/qualification/en-eu.msg @@ -24,6 +24,7 @@ TableQualificationBlockedDue: Suspended TableQualificationBlockedTooltip: Why and when was this qualification temporarily suspended? TableQualificationNoRenewal: Canceled TableQualificationNoRenewalTooltip: No renewal notifications will be send for this qualification upon expiry. The qualification may still be valid. +QualificationUserNoRenewal: Expires without further notification LmsUser: Licensee TableLmsEmail: Email TableLmsIdent: LMS Identifier diff --git a/src/Audit/Types.hs b/src/Audit/Types.hs index d01835b7b..fcc6a1f8f 100644 --- a/src/Audit/Types.hs +++ b/src/Audit/Types.hs @@ -199,10 +199,11 @@ data Transaction } | TransactionQualificationUserEdit - { transactionQualificationUser :: QualificationUserId - , transactionQualification :: QualificationId - , transactionUser :: UserId - , transactionQualificationValidUntil :: Day + { transactionQualificationUser :: QualificationUserId + , transactionQualification :: QualificationId + , transactionUser :: UserId + , transactionQualificationValidUntil :: Day + , transactionQualificationScheduleRenewal :: Maybe Bool -- Maybe, because some update may leave it unchanged (also avoids DB Migration) } | TransactionQualificationUserDelete { transactionQualificationUser :: QualificationUserId diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index 8c0f53cd9..3ab112505 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -333,8 +333,9 @@ embedRenderMessage ''UniWorX ''LicenceTableAction id data LicenceTableActionData = LicenceTableChangeAvsData | LicenceTableRevokeFDriveData --TODO: add { licenceTableChangeFDriveQId :: QualificationId to avoid lookup later - | LicenceTableGrantFDriveData { licenceTableChangeFDriveQId :: QualificationId - , licenceTableChangeFDriveEnd :: Day + | LicenceTableGrantFDriveData { licenceTableChangeFDriveQId :: QualificationId + , licenceTableChangeFDriveEnd :: Day + , licenceTableChangeFDriveRenew :: Maybe Bool } deriving (Eq, Ord, Read, Show, Generic) @@ -423,7 +424,7 @@ getProblemAvsSynchR = do nups <- runDB $ do qId <- getKeyBy404 $ UniqueQualificationAvsLicence $ Just alic selectedUsers <- view _userAvsUser <<$>> selectList [UserAvsPersonId <-. Set.toList apids] [] - forM_ selectedUsers $ upsertQualificationUser qId nowaday $ pred nowaday + forM_ selectedUsers $ upsertQualificationUser qId nowaday (pred nowaday) Nothing return $ length selectedUsers addMessageI Success $ MsgRevokeFraDriveLicences alic nups redirect ProblemAvsSynchR -- must be outside runDB @@ -433,7 +434,7 @@ getProblemAvsSynchR = do uas <- selectList [UserAvsPersonId <-. Set.toList apids] [] let uids = view _userAvsUser <$> uas -- addMessage Info $ text2Html $ "UIDs: " <> tshow uids -- DEBUG - forM_ uids $ upsertQualificationUser licenceTableChangeFDriveQId nowaday licenceTableChangeFDriveEnd + forM_ uids $ upsertQualificationUser licenceTableChangeFDriveQId nowaday licenceTableChangeFDriveEnd licenceTableChangeFDriveRenew (length uids,) <$> get404 licenceTableChangeFDriveQId addMessageI Success $ MsgSetFraDriveLicences (citext2string qualificationShorthand) n redirect ProblemAvsSynchR -- must be outside runDB @@ -577,6 +578,7 @@ mkLicenceTable PaginationParameters{..} dbtIdent aLic apids = do else singletonMap LicenceTableGrantFDrive $ LicenceTableGrantFDriveData <$> apreq (selectField . fmap mkOptionList $ mapM qualOpt avsQualifications) (fslI MsgQualificationName) aLicQid <*> apreq dayField (fslI MsgLmsQualificationValidUntil) Nothing -- apreq?! + <*> aopt (convertField not not (boolField . Just $ SomeMessage MsgBoolIrrelevant)) (fslI MsgQualificationUserNoRenewal) Nothing ] dbtParams = DBParamsForm { dbParamsFormMethod = POST diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index 0e079ec23..de3941e78 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/src/Handler/Course/ParticipantInvite.hs @@ -143,7 +143,7 @@ postCAddUserR tid ssh csh = do ((usersToAdd :: FormResult AddUserRequest, formWgt), formEncoding) <- runFormPost . renderWForm FormStandard $ do today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime - auReqUsers <- wreq (textField & cfCommaSeparatedSet) (fslI MsgCourseParticipantsRegisterUsersField & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) mempty + auReqUsers <- wreq (textField & cfAnySeparatedSet) (fslI MsgCourseParticipantsRegisterUsersField & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) mempty auReqTutorial <- optionalActionW ( areq (textField & cfCI) (fslI MsgCourseParticipantsRegisterTutorialField & setTooltip MsgCourseParticipantsRegisterTutorialFieldTip) (Just . CI.mk $ tshow today) ) -- TODO: use user date display setting ( fslI MsgCourseParticipantsRegisterTutorialOption ) diff --git a/src/Handler/SAP.hs b/src/Handler/SAP.hs index 4e8b98ebc..7fd0bd7b0 100644 --- a/src/Handler/SAP.hs +++ b/src/Handler/SAP.hs @@ -57,7 +57,7 @@ instance ToNamedRecord SapUserTableCsv where -- TODO: once temporary suspensions are implemented, a user must be transmitted to SAP in two rows: firstheld->suspensionFrom & suspensionTo->validTo sapRes2csv :: [(Ex.Value (Maybe Text), Ex.Value Day, Ex.Value Day, Ex.Value (Maybe Text))] -> [SapUserTableCsv] sapRes2csv l = [ res | (Ex.Value (Just persNo), Ex.Value firstHeld, Ex.Value validUntil, Ex.Value (Just sapId)) <- l - , readMay persNo > Just 0 -- filter E-accounts for SAP export + , readMay persNo > Just (0::Int) -- filter E-accounts for SAP export , let res = SapUserTableCsv { csvSUTpersonalNummer = persNo , csvSUTqualifikation = sapId diff --git a/src/Handler/Tutorial/Users.hs b/src/Handler/Tutorial/Users.hs index 325a075a1..912d0c886 100644 --- a/src/Handler/Tutorial/Users.hs +++ b/src/Handler/Tutorial/Users.hs @@ -100,7 +100,7 @@ postTUsersR tid ssh csh tutn = do (TutorialUserGrantQualificationData{..}, selectedUsers) -> do -- today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime today <- utctDay <$> liftIO getCurrentTime - runDB . forM_ selectedUsers $ upsertQualificationUser tuQualification today tuValidUntil + runDB . forM_ selectedUsers $ upsertQualificationUser tuQualification today tuValidUntil Nothing addMessageI Success . MsgTutorialUserGrantedQualification $ Set.size selectedUsers redirect $ CTutorialR tid ssh csh tutn TUsersR (TutorialUserSendMailData{}, selectedUsers) -> do diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index fa83c8ce6..1ee201656 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -188,10 +188,10 @@ postUsersR = do acts = mconcat [ singletonMap UserLdapSync $ pure UserLdapSyncData , singletonMap UserAddSupervisor $ UserAddSupervisorData - <$> apopt (textField & cfCommaSeparatedSet) (fslI MsgMppSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing + <$> apopt (textField & cfAnySeparatedSet) (fslI MsgMppSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing <*> apopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just True) , singletonMap UserSetSupervisor $ UserSetSupervisorData - <$> apopt (textField & cfCommaSeparatedSet) (fslI MsgMppSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing + <$> apopt (textField & cfAnySeparatedSet) (fslI MsgMppSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing <*> apopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just True) , singletonMap UserRemoveSupervisor $ pure UserRemoveSupervisorData ] diff --git a/src/Handler/Utils/Qualification.hs b/src/Handler/Utils/Qualification.hs index 408ed063f..cb9700ad1 100644 --- a/src/Handler/Utils/Qualification.hs +++ b/src/Handler/Utils/Qualification.hs @@ -11,23 +11,27 @@ module Handler.Utils.Qualification import Import -upsertQualificationUser :: QualificationId -> Day -> Day -> UserId -> DB () -upsertQualificationUser qualificationUserQualification today qualificationUserValidUntil qualificationUserUser = do +upsertQualificationUser :: QualificationId -> Day -> Day -> Maybe Bool -> UserId -> DB () +upsertQualificationUser qualificationUserQualification qualificationUserLastRefresh qualificationUserValidUntil mbScheduleRenewal qualificationUserUser = do Entity quid _ <- upsert QualificationUser - { qualificationUserLastRefresh = today - , qualificationUserFirstHeld = today + { qualificationUserFirstHeld = qualificationUserLastRefresh , qualificationUserBlockedDue = Nothing - , qualificationUserScheduleRenewal = True + , qualificationUserScheduleRenewal = fromMaybe True mbScheduleRenewal , .. } - [ QualificationUserValidUntil =. qualificationUserValidUntil - , QualificationUserLastRefresh =. today - , QualificationUserBlockedDue =. Nothing - ] + ( + [ QualificationUserScheduleRenewal =. scheduleRenewal | Just scheduleRenewal <- [mbScheduleRenewal] + ] ++ + [ QualificationUserValidUntil =. qualificationUserValidUntil + , QualificationUserLastRefresh =. qualificationUserLastRefresh + , QualificationUserBlockedDue =. Nothing + ] + ) audit TransactionQualificationUserEdit { transactionQualificationUser = quid , transactionQualification = qualificationUserQualification , transactionUser = qualificationUserUser , transactionQualificationValidUntil = qualificationUserValidUntil + , transactionQualificationScheduleRenewal = mbScheduleRenewal } \ No newline at end of file diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index e9c7203c9..f5d8af0f3 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -22,6 +22,7 @@ import Utils.Lens import Text.Blaze (Markup) import qualified Text.Blaze.Internal as Blaze (null) import qualified Data.Text as T +import qualified Data.Char as C import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI @@ -849,6 +850,17 @@ cfCI = convertField CI.mk CI.original cfCommaSeparatedSet :: (Functor m) => Field m Text -> Field m (Set Text) cfCommaSeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . mapMaybe (assertM' (not . T.null) . T.strip) . T.splitOn ",") (T.intercalate ", " . Set.toList) +cfAnySeparatedSet :: (Functor m) => Field m Text -> Field m (Set Text) +cfAnySeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . mapMaybe (assertM' (not . T.null) . T.strip) . T.split anySeparator) (T.intercalate ", " . Set.toList) + where anySeparator :: Char -> Bool + anySeparator c = C.isSeparator c || c == ',' || c == ';' + +-- -- TODO: consider using package ordered-containers? +-- cfAnySeparatedList :: (Functor m) => Field m Text -> Field m [Text] +-- cfAnySeparatedList = guardField (not . null) . convertField (mapMaybe (assertM' (not . T.null) . T.strip) . T.split anySeparator) (T.intercalate ", ") +-- where anySeparator :: Char -> Bool +-- anySeparator c = C.isSeparator c || c == ',' || c == ';' + isoField :: Functor m => AnIso' a b -> Field m a -> Field m b isoField (cloneIso -> fieldIso) = convertField (view fieldIso) (review fieldIso) From 394ce3066c47ab6a937fea5e4753799593964456 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 2 Feb 2023 09:57:02 +0100 Subject: [PATCH 12/15] chore(course): direct link for add participant to existing tutorial --- .../utils/navigation/menu/de-de-formal.msg | 1 + .../uniworx/utils/navigation/menu/en-eu.msg | 3 ++- routes | 1 + src/Foundation/Navigation.hs | 22 ++++++++++++++----- src/Handler/Course/ParticipantInvite.hs | 17 +++++++++----- 5 files changed, 33 insertions(+), 11 deletions(-) diff --git a/messages/uniworx/utils/navigation/menu/de-de-formal.msg b/messages/uniworx/utils/navigation/menu/de-de-formal.msg index ae5a5eff4..7e22bc31c 100644 --- a/messages/uniworx/utils/navigation/menu/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/menu/de-de-formal.msg @@ -30,6 +30,7 @@ MenuLogout !ident-ok: Logout MenuCourseList: Kurse MenuCourseMembers: Kursteilnehmer:innen MenuCourseAddMembers: Kursteilnehmer:innen hinzufügen +MenuTutorialAddMembers: Tutorium Teilnehmer:innen hinzufügen MenuCourseCommunication: Kursmitteilung (E-Mail) MenuCourseExamOffice: Prüfungsbeauftragte MenuTermShow: Semester diff --git a/messages/uniworx/utils/navigation/menu/en-eu.msg b/messages/uniworx/utils/navigation/menu/en-eu.msg index 938038732..b517d4136 100644 --- a/messages/uniworx/utils/navigation/menu/en-eu.msg +++ b/messages/uniworx/utils/navigation/menu/en-eu.msg @@ -29,7 +29,8 @@ MenuLogin: Login MenuLogout: Logout MenuCourseList: Courses MenuCourseMembers: Participants -MenuCourseAddMembers: Add participants +MenuCourseAddMembers: Add course participants +MenuTutorialAddMembers: Add tutorium participants MenuCourseCommunication: Course message (email) MenuCourseExamOffice: Exam offices MenuTermShow: Semesters diff --git a/routes b/routes index 5246a375a..1005a6a7e 100644 --- a/routes +++ b/routes @@ -209,6 +209,7 @@ /edit TEditR GET POST !tutorANDtutor-control /delete TDeleteR GET POST /participants TUsersR GET POST !tutor + /participants/add TAddUserR GET POST !tutor /register TRegisterR POST !timeANDcapacityANDcourse-registeredANDregister-group !timeANDtutorial-registered /communication TCommR GET POST !tutor /tutor-invite TInviteR GET POST !tutorANDtutor-control diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 5191afa77..c47b1f295 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -283,11 +283,12 @@ breadcrumb (CourseR tid ssh csh (TutorialR tutn sRoute)) = case sRoute of TUsersR -> useRunDB . maybeT (i18nCrumb MsgBreadcrumbTutorial . Just $ CourseR tid ssh csh CTutorialListR) $ do guardM . lift . hasReadAccessTo $ CTutorialR tid ssh csh tutn TUsersR return (CI.original tutn, Just $ CourseR tid ssh csh CTutorialListR) - TEditR -> i18nCrumb MsgMenuTutorialEdit . Just $ CTutorialR tid ssh csh tutn TUsersR - TDeleteR -> i18nCrumb MsgMenuTutorialDelete . Just $ CTutorialR tid ssh csh tutn TUsersR - TCommR -> i18nCrumb MsgMenuTutorialComm . Just $ CTutorialR tid ssh csh tutn TUsersR - TRegisterR -> i18nCrumb MsgBreadcrumbTutorialRegister . Just $ CourseR tid ssh csh CShowR - TInviteR -> i18nCrumb MsgBreadcrumbTutorInvite . Just $ CTutorialR tid ssh csh tutn TUsersR + TAddUserR -> i18nCrumb MsgMenuTutorialAddMembers . Just $ CTutorialR tid ssh csh tutn TUsersR + TEditR -> i18nCrumb MsgMenuTutorialEdit . Just $ CTutorialR tid ssh csh tutn TUsersR + TDeleteR -> i18nCrumb MsgMenuTutorialDelete . Just $ CTutorialR tid ssh csh tutn TUsersR + TCommR -> i18nCrumb MsgMenuTutorialComm . Just $ CTutorialR tid ssh csh tutn TUsersR + TRegisterR -> i18nCrumb MsgBreadcrumbTutorialRegister . Just $ CourseR tid ssh csh CShowR + TInviteR -> i18nCrumb MsgBreadcrumbTutorInvite . Just $ CTutorialR tid ssh csh tutn TUsersR breadcrumb (CourseR tid ssh csh (SheetR shn sRoute)) = case sRoute of SShowR -> useRunDB . maybeT (i18nCrumb MsgBreadcrumbSheet . Just $ CourseR tid ssh csh SheetListR) $ do @@ -1619,6 +1620,17 @@ pageActions (CTutorialR tid ssh csh tutn TUsersR) = do membersSecondary <- pageQuickActions NavQuickViewPageActionSecondary $ CourseR tid ssh csh CUsersR return [ NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuTutorialAddMembers + , navRoute = CTutorialR tid ssh csh tutn TAddUserR + , navAccess' = NavAccessTrue + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + , NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuCourseMembers , navRoute = CourseR tid ssh csh CUsersR diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index de3941e78..e129b9d53 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/src/Handler/Course/ParticipantInvite.hs @@ -4,6 +4,7 @@ module Handler.Course.ParticipantInvite ( getCAddUserR, postCAddUserR + , getTAddUserR, postTAddUserR ) where import Import @@ -116,9 +117,16 @@ instance Monoid AddParticipantsResult where mappend = (<>) -getCAddUserR, postCAddUserR :: TermId -> SchoolId -> CourseShorthand -> Handler Html +getCAddUserR, postCAddUserR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCAddUserR = postCAddUserR -postCAddUserR tid ssh csh = do +postCAddUserR tid ssh csh = do + today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime + postTAddUserR tid ssh csh (CI.mk $ tshow today) -- Don't use user date display setting, so that tutorial default names conform to all users + + +getTAddUserR, postTAddUserR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler Html +getTAddUserR = postTAddUserR +postTAddUserR tid ssh csh tut = do cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh currentRoute <- fromMaybe (error "postCAddUserR called from 404-handler") <$> getCurrentRoute @@ -141,11 +149,10 @@ postCAddUserR tid ssh csh = do | otherwise -> redirect $ CourseR tid ssh csh CUsersR - ((usersToAdd :: FormResult AddUserRequest, formWgt), formEncoding) <- runFormPost . renderWForm FormStandard $ do - today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime + ((usersToAdd :: FormResult AddUserRequest, formWgt), formEncoding) <- runFormPost . renderWForm FormStandard $ do auReqUsers <- wreq (textField & cfAnySeparatedSet) (fslI MsgCourseParticipantsRegisterUsersField & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) mempty auReqTutorial <- optionalActionW - ( areq (textField & cfCI) (fslI MsgCourseParticipantsRegisterTutorialField & setTooltip MsgCourseParticipantsRegisterTutorialFieldTip) (Just . CI.mk $ tshow today) ) -- TODO: use user date display setting + ( areq (textField & cfCI) (fslI MsgCourseParticipantsRegisterTutorialField & setTooltip MsgCourseParticipantsRegisterTutorialFieldTip) (Just tut) ) ( fslI MsgCourseParticipantsRegisterTutorialOption ) ( Just True ) return $ AddUserRequest <$> auReqUsers <*> auReqTutorial From ca59adee03cb7783935cf75b186466d50b1ac964 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 2 Feb 2023 12:57:52 +0100 Subject: [PATCH 13/15] chore(lms): increase readability printed lms pins --- src/Handler/Utils/LMS.hs | 2 +- templates/letter/din5008.latex | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Handler/Utils/LMS.hs b/src/Handler/Utils/LMS.hs index 024a68f0e..ee3b89d9f 100644 --- a/src/Handler/Utils/LMS.hs +++ b/src/Handler/Utils/LMS.hs @@ -150,4 +150,4 @@ randomLMSIdentBut banList = untilJustMaxM maxLmsUserIdentRetries getIdentOk randomLMSpw :: MonadIO m => m Text randomLMSpw = randomText extra lengthPassword where - extra = "-+*.:;=!?#$" + extra = "+*:=!?#" -- you cannot distinguish ;: and ., in printed letters diff --git a/templates/letter/din5008.latex b/templates/letter/din5008.latex index 76d67a42d..fc4dc02ee 100644 --- a/templates/letter/din5008.latex +++ b/templates/letter/din5008.latex @@ -138,7 +138,7 @@ $endif$ $endif$ \begin{textblock}{65}(84,232)%hpos,vpos - \textcolor{black!33}{ + \textcolor{black!39}{ \begin{labeling}{Login:x} \item[Login:] $login$ \item[Pin:] $pin$ From 451dcd0a092132dd051d6a69463d322d3db5cc8d Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 2 Feb 2023 13:12:12 +0100 Subject: [PATCH 14/15] chore(company): assign company supervisors for new users (model:add column) --- models/users.model | 3 ++- src/Foundation/Yesod/Auth.hs | 3 ++- src/Handler/Utils/Company.hs | 13 ++++++++--- src/Handler/Utils/Users.hs | 3 ++- test/Database/Fill.hs | 45 ++++++++++++++++++++++++------------ 5 files changed, 46 insertions(+), 21 deletions(-) diff --git a/models/users.model b/models/users.model index 40ae1bee2..77a330744 100644 --- a/models/users.model +++ b/models/users.model @@ -88,7 +88,8 @@ UserGroupMember UserCompany user UserId company CompanyId OnDeleteCascade OnUpdateCascade - supervisor Bool -- is this user a company supervisor? + supervisor Bool -- should this user be made supervisor for all _new_ users associated with this company? + supervisorReroute Bool default=true -- if supervisor is true, should this supervisor receive email for _new_ company users? UniqueUserCompany user company -- a user may belong to multiple companies, but to each one only once deriving Generic UserSupervisor diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs index c43da2b16..d231fd94d 100644 --- a/src/Foundation/Yesod/Auth.hs +++ b/src/Foundation/Yesod/Auth.hs @@ -182,7 +182,8 @@ upsertCampusUser upsertMode ldapData = do userDefaultConf <- getsYesod $ view _appUserDefaults (newUser,userUpdate) <- decodeUser now userDefaultConf upsertMode ldapData - + --TODO: newUser should be associated with a company and company supervisor through Handler.Utils.Company.upsertUserCompany, but this is called by upsertAvsUser already - conflict? + oldUsers <- for (userLdapPrimaryKey newUser) $ \pKey -> selectKeysList [ UserLdapPrimaryKey ==. Just pKey ] [] user@(Entity userId userRec) <- case oldUsers of diff --git a/src/Handler/Utils/Company.hs b/src/Handler/Utils/Company.hs index 837bb5181..74990a803 100644 --- a/src/Handler/Utils/Company.hs +++ b/src/Handler/Utils/Company.hs @@ -12,15 +12,22 @@ import qualified Data.CaseInsensitive as CI import qualified Data.Char as Char import qualified Data.Text as Text +import Database.Persist.Postgresql -- | Ensure that the given user is linked to the given company upsertUserCompany :: UserId -> Maybe Text -> DB () upsertUserCompany uid (Just cName) | notNull cName = do cid <- upsertCompany cName void $ upsertBy (UniqueUserCompany uid cid) - (UserCompany uid cid False) - [] -upsertUserCompany uid _ = deleteWhere [ UserCompanyUser ==. uid ] + (UserCompany uid cid False False) + [] + superVs <- selectList [UserCompanyCompany ==. cid, UserCompanySupervisor ==. True] [] + upsertManyWhere [ UserSupervisor super uid reroute + | Entity{entityVal=UserCompany{userCompanyUser=super, userCompanySupervisorReroute=reroute, userCompanySupervisor=True}} <- superVs + ] [] [] [] +upsertUserCompany uid _ = + deleteWhere [ UserCompanyUser ==. uid ] -- maybe also delete company supervisors? + upsertCompany :: Text -> DB CompanyId upsertCompany cName = diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index d40992ab3..eacfb92a7 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -821,7 +821,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do return $ UserSupervisor E.<# E.val newUserId E.<&> (userSupervisor E.^. UserSupervisorUser) - E.<&> (userSupervisor E.^. UserSupervisorRerouteNotifications) + E.<&> (userSupervisor E.^. UserSupervisorRerouteNotifications) ) (\current excluded -> [ UserSupervisorRerouteNotifications E.=. (current E.^. UserSupervisorRerouteNotifications E.||. excluded E.^. UserSupervisorRerouteNotifications) ] ) deleteWhere [ UserSupervisorSupervisor ==. oldUserId] @@ -847,6 +847,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.<# E.val newUserId E.<&> (userCompany E.^. UserCompanyCompany) E.<&> (userCompany E.^. UserCompanySupervisor) + E.<&> (userCompany E.^. UserCompanySupervisorReroute) ) (\current _excluded -> [ UserCompanySupervisor E.=. (current E.^. UserCompanySupervisor)] ) deleteWhere [ UserCompanyUser ==. oldUserId] diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index e4545302e..e5a687782 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -28,6 +28,8 @@ import Data.List (foldl) import System.Directory (getModificationTime) import System.FilePath.Glob (glob) +import Database.Persist.Postgresql + {- Needed for File Tests only import qualified Data.Conduit.Combinators as C import Paths_uniworx (getDataFileName) @@ -435,7 +437,7 @@ fillDb = do manyUsers <- insertMany . getZipList $ manyUser <$> ZipList ((,,) <$> firstNames <*> middlenames <*> surnames) <*> ZipList matrikel matUsers <- selectList [UserMatrikelnummer !=. Nothing] [] insertMany_ [UserAvs (AvsPersonId n) uid n | Entity uid User{userMatrikelnummer = fmap readMay -> Just (Just n)} <- matUsers] - + let tmin = -1 tmax = 2 trange = [tmin..tmax] @@ -488,20 +490,33 @@ fillDb = do nice <- insert' $ Company "N*ICE Aircraft Services & Support GmbH" "N*ICE" 33 False Nothing ffacil <- insert' $ Company "Fraport Facility Services GmbH" "GCS" 44 False Nothing bpol <- insert' $ Company "Bundespolizeidirektion Flughafen Frankfurt am Main" "BPol" 5555 False Nothing - void . insert' $ UserCompany jost fraportAg True - void . insert' $ UserCompany svaupel nice True - void . insert' $ UserCompany gkleen nice False - void . insert' $ UserCompany gkleen fraGround False - void . insert' $ UserCompany fhamann bpol False - void . insert' $ UserCompany fhamann ffacil True - void . insert' $ UserCompany fhamann nice False - void . insert' $ UserSupervisor jost gkleen True - void . insert' $ UserSupervisor jost svaupel False - void . insert' $ UserSupervisor jost sbarth False - void . insert' $ UserSupervisor jost tinaTester True - void . insert' $ UserSupervisor svaupel gkleen False - void . insert' $ UserSupervisor svaupel fhamann True - void . insert' $ UserSupervisor sbarth tinaTester True + void . insert' $ UserCompany jost fraportAg True True + void . insert' $ UserCompany svaupel nice True False + void . insert' $ UserCompany gkleen nice False False + void . insert' $ UserCompany gkleen fraGround False True + void . insert' $ UserCompany fhamann bpol False False + void . insert' $ UserCompany fhamann ffacil True True + void . insert' $ UserCompany fhamann nice False False + -- void . insert' $ UserSupervisor jost gkleen True + -- void . insert' $ UserSupervisor jost svaupel False + -- void . insert' $ UserSupervisor jost sbarth False + -- void . insert' $ UserSupervisor jost tinaTester True + -- void . insert' $ UserSupervisor svaupel gkleen False + -- void . insert' $ UserSupervisor svaupel fhamann True + -- void . insert' $ UserSupervisor sbarth tinaTester True + let supvs = [ UserSupervisor jost gkleen True + , UserSupervisor jost svaupel False + , UserSupervisor jost sbarth False + , UserSupervisor jost tinaTester True + , UserSupervisor svaupel gkleen False + , UserSupervisor svaupel fhamann True + , UserSupervisor sbarth tinaTester True + , UserSupervisor gkleen fhamann False + ] + upsertManyWhere supvs [] [] [] + -- upsertManyWhere supvs [] [] [] -- NOTE: multiple calls like this are ok + -- insertMany_ supvs -- NOTE: multiple calls like this throw an error! + ifi <- insert' $ School "Institut für Informatik" "IfI" (Just $ 14 * nominalDay) (Just $ 10 * nominalDay) True (ExamModeDNF predDNFFalse) (ExamCloseOnFinished True) SchoolAuthorshipStatementModeOptional (Just ifiAuthorshipStatement) True SchoolAuthorshipStatementModeRequired (Just ifiAuthorshipStatement) False mi <- insert' $ School "Institut für Mathematik" "MI" Nothing Nothing False (ExamModeDNF predDNFFalse) (ExamCloseOnFinished False) SchoolAuthorshipStatementModeNone Nothing True SchoolAuthorshipStatementModeOptional Nothing True avn <- insert' $ School "Fahrerausbildung" "FA" Nothing Nothing False (ExamModeDNF predDNFFalse) (ExamCloseOnFinished False) SchoolAuthorshipStatementModeNone Nothing True SchoolAuthorshipStatementModeOptional Nothing True From 1c02b85fa256302b01c18baa64c8d0b7f9ffb671 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 2 Feb 2023 18:56:56 +0100 Subject: [PATCH 15/15] fix(letter): email wrapper for renewal letter reinstated in full again --- .../categories/qualification/de-de-formal.msg | 2 +- src/Handler/Utils/Users.hs | 4 +- .../Handler/SendNotification/Qualification.hs | 6 ++- src/Utils/Print.hs | 42 +++++++++++++------ templates/letter/fraport_renewal.md | 2 +- .../mail/body/qualificationRenewal.hamlet | 25 +++++++++++ templates/mail/genericMailLetter.hamlet | 3 +- 7 files changed, 63 insertions(+), 21 deletions(-) create mode 100644 templates/mail/body/qualificationRenewal.hamlet diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index c0e62cfcb..a8315ef26 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -63,7 +63,7 @@ LmsErrorNoRefreshElearning: Fehler: E-Learning wird nicht automatisch gestartet, 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: Sie müssen Qualifikation #{qname} demnächst durch einen E-Learning Kurs erneuern, siehe Anhang. +MailBodyQualificationRenewal qname@Text: Sie müssen die Qualifikation #{qname} demnächst durch einen E-Learning Kurs erneuern, siehe Anhang. 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. LmsRenewalInstructions: Anweisungen zur Verlängerung finden Sie im angehängten PDF. Um Missbrauch zu verhindern wurde das PDF dem von Ihnen in FRADrive hinterlegten PDF-Passwort verschlüsselt. Falls kein PDF-Passwort manuell hinterlegt wurde, ist das PDF-Passwort Ihre Flughafen Ausweisnummer, inklusive Punkt und der Ziffer danach. diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index eacfb92a7..d2707ff66 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -59,11 +59,11 @@ abbrvName User{userDisplayName, userFirstName, userSurname} = assemble = Text.intercalate "." --- deprecated, used getPostalAddressIfPreferred +-- deprecated, used getPostalPreferenceAndAddress userPrefersLetter :: User -> Bool userPrefersLetter = fst . getPostalPreferenceAndAddress --- deprecated, used getPostalAddressIfPreferred +-- deprecated, used getPostalPreferenceAndAddress userPrefersEmail :: User -> Bool userPrefersEmail = not . userPrefersLetter diff --git a/src/Jobs/Handler/SendNotification/Qualification.hs b/src/Jobs/Handler/SendNotification/Qualification.hs index 0d519e183..a10f320bd 100644 --- a/src/Jobs/Handler/SendNotification/Qualification.hs +++ b/src/Jobs/Handler/SendNotification/Qualification.hs @@ -73,16 +73,18 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do <*> getBy (UniqueQualificationUser nQualification jRecipient) <*> getBy (UniqueLmsQualificationUser nQualification jRecipient) case query of - (Just User{userDisplayName}, Just Qualification{..}, Just (Entity _ QualificationUser{..}), Just(Entity luid LmsUser{..})) -> do + (Just User{userDisplayName, userSurname}, Just Qualification{..}, Just (Entity _ QualificationUser{..}), Just(Entity luid LmsUser{..})) -> do let qname = CI.original qualificationName let letter = LetterRenewQualificationF { lmsLogin = lmsUserIdent , lmsPin = lmsUserPin , qualHolder = userDisplayName + , qualHolderSN = userSurname , qualExpiry = qualificationUserValidUntil - , qualId = nQualification + , qualId = nQualification , qualName = qname , qualShort = CI.original qualificationShorthand + , qualSchool = qualificationSchool , qualDuration = qualificationValidDuration } $logInfoS "LMS" $ "Notify " <> tshow encRecipient <> " for renewal of qualification " <> qname diff --git a/src/Utils/Print.hs b/src/Utils/Print.hs index fd03915d5..2700c2fad 100644 --- a/src/Utils/Print.hs +++ b/src/Utils/Print.hs @@ -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, nameHtml') import Handler.Utils.Avs (updateReceivers) import Jobs.Handler.SendNotification.Utils @@ -368,28 +368,47 @@ convertProto f (IsTime t) = P.toMetaValue $ f t class MDLetter l where getTemplate :: Proxy l -> Text - getMailSubject :: l -> SomeMessage UniWorX -- only used if letter is sent by email as pdf attachment - getMailBody :: l -> SomeMessage UniWorX -- only used if letter is sent by email as pdf attachment - letterMeta :: l -> Lang -> DateTimeFormatter -> P.Meta + getMailSubject :: l -> SomeMessage UniWorX -- only used if letter is sent by email as pdf attachment + getMailBody :: l -> DateTimeFormatter -> HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX) -- only used if letter is sent by email as pdf attachment + letterMeta :: l -> DateTimeFormatter -> Lang -> P.Meta getPJId :: l -> PrintJobIdentification data LetterRenewQualificationF = LetterRenewQualificationF { lmsLogin :: LmsIdent , lmsPin :: Text , qualHolder :: UserDisplayName + , qualHolderSN :: UserSurname , qualExpiry :: Day , qualId :: QualificationId , qualName :: Text , qualShort :: Text + , qualSchool :: SchoolId , qualDuration :: Maybe Int } deriving (Eq, Show) +-- this type is specific to this letter to avoid code duplication for derived data or constants +data LetterRenewQualificationFData = LetterRenewQualificationFData { lmsUrl, lmsUrlLogin, lmsIdent :: Text } + deriving (Eq, Show) + +letterRenewalQualificationFData :: LetterRenewQualificationF -> LetterRenewQualificationFData +letterRenewalQualificationFData LetterRenewQualificationF{lmsLogin} = LetterRenewQualificationFData{..} + where + lmsUrl = "https://drive.fraport.de" + lmsUrlLogin = lmsUrl <> "/?login=" <> lmsIdent + lmsIdent = getLmsIdent lmsLogin + instance MDLetter LetterRenewQualificationF where getTemplate _ = templateRenewal getMailSubject l = SomeMessage $ MsgMailSubjectQualificationRenewal $ qualShort l - getMailBody l = SomeMessage $ MsgMailBodyQualificationRenewal $ qualName l - letterMeta LetterRenewQualificationF{..} _lang DateTimeFormatter{ format } = mkMeta + -- getMailBody l = SomeMessage $ MsgMailBodyQualificationRenewal $ qualName l + getMailBody l@LetterRenewQualificationF{..} DateTimeFormatter{ format } = + let LetterRenewQualificationFData{..} = letterRenewalQualificationFData l + in $(ihamletFile "templates/mail/body/qualificationRenewal.hamlet") + + letterMeta l@LetterRenewQualificationF{..} DateTimeFormatter{ format } _lang = + let LetterRenewQualificationFData{..} = letterRenewalQualificationFData l + in mkMeta [ toMeta "login" lmsIdent , toMeta "pin" lmsPin , toMeta "examinee" qualHolder @@ -398,10 +417,7 @@ instance MDLetter LetterRenewQualificationF where , toMeta "url-text" lmsUrl , toMeta "url" lmsUrlLogin ] - where - lmsUrl = "https://drive.fraport.de" - lmsUrlLogin = lmsUrl <> "/?login=" <> lmsIdent - lmsIdent = getLmsIdent lmsLogin + getPJId LetterRenewQualificationF{..} = PrintJobIdentification { pjiName = "Renewal" @@ -418,8 +434,7 @@ sendEmailOrLetter recipient letter = do let tmpl = getTemplate $ pure letter pjid = getPJId letter -- Below are only needed if sent by email - mailSubject = getMailSubject letter - mailBody = getMailBody letter + mailSubject = getMailSubject letter undername = underling ^. _userDisplayName -- nameHtml' underling undermail = CI.original $ underling ^. _userEmail now <- liftIO getCurrentTime @@ -428,7 +443,8 @@ sendEmailOrLetter recipient letter = do let (preferPost, postal) = getPostalPreferenceAndAddress rcvrUsr isSupervised = recipient /= svr lang = selectDeEn $ rcvrUsr & userLanguages -- select either German or English only, default de; see Utils.Lang - lMeta = letterMeta letter lang formatter <> mkMeta ( + mailBody = getMailBody letter formatter + lMeta = letterMeta letter formatter lang <> mkMeta ( ( if isSupervised then [ toMeta "supervisor" (rcvrUsr & userDisplayName) diff --git a/templates/letter/fraport_renewal.md b/templates/letter/fraport_renewal.md index 0aab28550..07978d9ed 100644 --- a/templates/letter/fraport_renewal.md +++ b/templates/letter/fraport_renewal.md @@ -89,7 +89,7 @@ Sollte bis zum Ablaufdatum das E-Learning nicht erfolgreich abgeschlossen sein, zur Wiedererlangung der Fahrberechtigung "F" erneut ein Grundkurs bei der Fahrerausbildung absolviert werden. Bei Fragen können Sie sich gerne an das Team der Fahrerausbildung wenden. -(Please contact us if you prefer letters in English.) +(Please contact us if you prefer letters in English.!) $else$ diff --git a/templates/mail/body/qualificationRenewal.hamlet b/templates/mail/body/qualificationRenewal.hamlet new file mode 100644 index 000000000..66a619e37 --- /dev/null +++ b/templates/mail/body/qualificationRenewal.hamlet @@ -0,0 +1,25 @@ +$newline never + +$# SPDX-FileCopyrightText: 2022 Steffen Jost +$# +$# SPDX-License-Identifier: AGPL-3.0-or-later + +

+ _{SomeMessage $ MsgMailBodyQualificationRenewal qualName} + +

+

+
_{SomeMessage MsgQualificationName} +
+ + #{qualName} +
_{SomeMessage MsgLmsUser} +
#{nameHtml qualHolder qualHolderSN} +
_{SomeMessage MsgLmsQualificationValidUntil} +
#{format SelFormatDate qualExpiry} + +

+ _{SomeMessage MsgLmsRenewalInstructions} # + + + _{SomeMessage MsgMppURL} #{lmsUrl} diff --git a/templates/mail/genericMailLetter.hamlet b/templates/mail/genericMailLetter.hamlet index 703596b65..434debd80 100644 --- a/templates/mail/genericMailLetter.hamlet +++ b/templates/mail/genericMailLetter.hamlet @@ -18,8 +18,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later

_{mailSubject} -

- _{mailBody} + ^{mailBody} $if isSupervised

_{SomeMessage MsgMailSupervisorNote}