diff --git a/CHANGELOG.md b/CHANGELOG.md index 94ff09a18..e3ccc5918 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,36 @@ All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines. +## [27.3.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.3.1...v27.3.2) (2023-05-05) + + +### Bug Fixes + +* **build:** remove impossible ([90b38ca](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/90b38ca5dc319f2d175978242b2fdd4477568a3c)) + +## [27.3.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.3.0...v27.3.1) (2023-05-04) + +## [27.3.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.2.0...v27.3.0) (2023-05-02) + + +### Features + +* **qualfications:** renewal actions and filtering by card and personal number ([4df0243](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/4df024374d387fc85a833b3faffe1b6ef8edc7d9)) + + +### Bug Fixes + +* **avs:** chunk avs status query automatically ([352ee21](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/352ee215b4075c70dbf9229434e62c8e6d847ae4)) +* **build:** minor move parenthesis to make linter happy ([02bf1d9](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/02bf1d9a2ca433e55cf7d1e06f0ff300b53c7efb)) +* **build:** remove redundant constraints ([ea82d75](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ea82d75a0934f8e13f26af5cb8a06c11d32dc0c5)) +* **cvs:** export company in e-learning view ([2093cf5](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/2093cf501827ab2305f26ab5cf742f2b0be4a7de)) +* **email:** better wording for qualifcation expired notice ([412c56e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/412c56e78ceaef263e4ca8b8678bb0e8ea2efb9a)) +* **letter:** update receiver postal address before sending ([7d5c4bf](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/7d5c4bff2512154c087133e029713efa0657fa5a)) +* **profile:** bad email indicator ([6699f1d](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/6699f1d72f148ccd2c82bebb3f582cf61d711425)) +* **qualifications:** counts for lms/quals correct now ([33a847b](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/33a847baa3310e6e261409f2cda9d964cf5a821d)) +* **users:** assimilate merges possibly incomplete user fields ([52afd13](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/52afd13b6dc2b870ab8dbba956874e8950e07973)) +* **users:** prevent accidental user hijacking ([014d479](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/014d479df8f36515915bc7991bb97bad24dcbef9)) + ## [27.2.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.1.6...v27.2.0) (2023-04-06) diff --git a/build.sh b/build.sh index cf93767e7..0fe066222 100755 --- a/build.sh +++ b/build.sh @@ -9,5 +9,5 @@ set -e [ "${FLOCKER}" != "$0" ] && exec env FLOCKER="$0" flock -en .stack-work.lock "$0" "$@" || : echo "Building..." -stack build --fast --flag uniworx:-library-only --flag uniworx:dev $@ +stack build --fast --profile --library-profiling --executable-profiling --flag uniworx:-library-only --flag uniworx:dev $@ echo "Done." diff --git a/messages/auth/campus/de.msg b/messages/auth/campus/de.msg index 8755ecf03..1812fdf28 100644 --- a/messages/auth/campus/de.msg +++ b/messages/auth/campus/de.msg @@ -2,7 +2,7 @@ # # SPDX-License-Identifier: AGPL-3.0-or-later -CampusIdentPlaceholder: V.Nachname@fraport.de -CampusIdent: Fraport AG Kennung +CampusIdentPlaceholder: V.Nachname@fraport.de / E12345 +CampusIdent: Fraport Kennung CampusPassword: Passwort CampusPasswordPlaceholder: Passwort \ No newline at end of file diff --git a/messages/auth/campus/en.msg b/messages/auth/campus/en.msg index 55652d3fa..02ffd46fd 100644 --- a/messages/auth/campus/en.msg +++ b/messages/auth/campus/en.msg @@ -2,7 +2,7 @@ # # SPDX-License-Identifier: AGPL-3.0-or-later -CampusIdentPlaceholder: F.Last@fraport.de -CampusIdent: Fraport AG account +CampusIdentPlaceholder: F.Last@fraport.de / E12345 +CampusIdent: Fraport account CampusPassword: Password CampusPasswordPlaceholder: Password \ No newline at end of file diff --git a/messages/uniworx/categories/authorization/de-de-formal.msg b/messages/uniworx/categories/authorization/de-de-formal.msg index e16240aa5..b7ee11560 100644 --- a/messages/uniworx/categories/authorization/de-de-formal.msg +++ b/messages/uniworx/categories/authorization/de-de-formal.msg @@ -96,9 +96,9 @@ TutorialNoCapacity: In dieser Übung sind keine Plätze mehr frei. ExamOccurrenceNoCapacity: Zu diesem Termin/Raum sind keine Plätze mehr frei. CourseNotEmpty: In diesem Kurs sind momentan Teilnehmer:innen angemeldet. -LDAPLoginTitle: Fraport AG Login (Büko) -PWHashLoginTitle: FRADrive Login -PWHashLoginNote: Verwenden Sie dieses Formular für zugesandte FRADrive Logindaten. Angestellte der Fraport AG sollten stattdessen den Büko-Login verwenden! +LDAPLoginTitle: Fraport Login für interne und externe Nutzer +PWHashLoginTitle: Spezieller Funktionsnutzer Login +PWHashLoginNote: Verwenden Sie dieses Formular nur, wenn Sie explizit dazu aufgefordert wurden. Alle anderen sollten das andere Login Formular verwenden! DummyLoginTitle: Development-Login InternalLdapError: Interner Fehler beim Fraport Büko-Login CampusUserInvalidIdent: Konnte anhand des Fraport Büko-Logins keine eindeutige Identifikation ermitteln diff --git a/messages/uniworx/categories/authorization/en-eu.msg b/messages/uniworx/categories/authorization/en-eu.msg index d2ad99d62..59dad7860 100644 --- a/messages/uniworx/categories/authorization/en-eu.msg +++ b/messages/uniworx/categories/authorization/en-eu.msg @@ -97,9 +97,9 @@ TutorialNoCapacity: Tutorial has reached maximum capacity ExamOccurrenceNoCapacity: Occurrence/Room has reached maximum capacity CourseNotEmpty: There are currently no participants enrolled for this course. -LDAPLoginTitle: Fraport AG login (Büko) -PWHashLoginTitle: FRADrive login -PWHashLoginNote: Use this form if you have received special FRADrive credentials. Fraport AG employees should use the Büko login instead! +LDAPLoginTitle: Fraport login for intern and extern users +PWHashLoginTitle: Special function user login +PWHashLoginNote: Only use this login form if you have received special instructions to do so. All others should use the other login field. DummyLoginTitle: Development login InternalLdapError: Internal error during Fraport Büko login CampusUserInvalidIdent: Could not determine unique identification during Fraport Büko login diff --git a/messages/uniworx/categories/courses/tutorial/en-eu.msg b/messages/uniworx/categories/courses/tutorial/en-eu.msg index cdcf22eda..d793fe028 100644 --- a/messages/uniworx/categories/courses/tutorial/en-eu.msg +++ b/messages/uniworx/categories/courses/tutorial/en-eu.msg @@ -46,8 +46,8 @@ TutorialUsersDeregistered count: Successfully deregistered #{show count} partici TutorialUserDeregister: Deregister from tutorial TutorialUserSendMail: Send mail TutorialUserPrintQualification: Print certificate -TutorialUserGrantQualification: Grant Qualification -TutorialUserRenewQualification: Renew Qualification +TutorialUserGrantQualification: Grant qualification +TutorialUserRenewQualification: Renew qualification TutorialUserRenewedQualification n@Int: Successfully renewed qualification #{tshow n} tutorial #{pluralEN n "user" "users"} TutorialUserGrantedQualification n: Successfully granted qualification #{tshow n} tutorial #{pluralEN n "user" "users"} CommTutorial: Tutorial message diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index 6edfe9c1a..eae8b0e69 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -25,9 +25,11 @@ TableQualificationBlockedTooltip: Wann wurde die Qualifikation vorübergehend au TableQualificationBlockedTooltipSimple: Wann wurde die Qualifikation aus besonderem Grund wiederrufen? TableQualificationNoRenewal: Auslaufend TableQualificationNoRenewalTooltip: Es wird keine Benachrichtigung mehr versendet, wenn diese Qualifikation ablaufen sollte. Die Qualifikation kann noch weiterhin gültig sein. +QualificationScheduleRenewalTooltip: Wird eine Benachrichtigung versendet, falls diese Qualikation bald ablaufen sollte? QualificationUserNoRenewal: Läuft ohne Benachrichtigung aus QualificationUserNone: Für diese Person sind keine Qualifikationen registriert. QualificationBlockReason: Entzugsbegründung +QualificationExpired: Ungültig seit LmsUser: Inhaber LmsURL: Link E‑Learning TableLmsEmail: E‑Mail @@ -81,9 +83,11 @@ QualificationActExpire: Auslaufend markieren - keine Benachrichtigung zur Erneue 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"} -QualificationActBlockSupervisor: Dauerhaft entziehen, mit sofortiger Wirkung +QualificationActBlockSupervisor: Dauerhaft entziehen und Ansprechpartner entfernen, mit sofortiger Wirkung QualificationActBlock: Entziehen QualificationActUnblock: Entzug löschen +QualificationActGrant: Qualifikation vergeben +QualificationActRenew: Qualifikation regulär verlängern 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. diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg index 607189e1d..77a2dfbb5 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/messages/uniworx/categories/qualification/en-eu.msg @@ -25,9 +25,11 @@ TableQualificationBlockedTooltip: Why and when was this qualification temporaril TableQualificationBlockedTooltipSimple: When was this qualification revoked due to extraordinary reasons? TableQualificationNoRenewal: Discontinued TableQualificationNoRenewalTooltip: No renewal notifications will be send for this qualification upon expiry. The qualification may still be valid. +QualificationScheduleRenewalTooltip: Will there be a notification, if this qualification is about to expire soon? QualificationUserNoRenewal: Expires without further notification QualificationUserNone: No registered qualifications for this person. QualificationBlockReason: Reason for revoking +QualificationExpired: Expired on LmsUser: Licensee LmsURL: Link E-learning TableLmsEmail: Email @@ -63,13 +65,13 @@ CsvColumnLmsDelete: Will the identifier be deleted from the E-learning platfrom CsvColumnLmsStaff: Is the user an internal staff member? (Legacy, currently ignored) CsvColumnLmsSuccess: Timestamp of successful completion (UTC) CsvColumnLmsFailed: Blockier durch LMS, üblicherweise wegen zu vieler Fehlversuche -LmsUserlistInsert: New LMS User -LmsUserlistUpdate: Update of LMS User +LmsUserlistInsert: New LMS user +LmsUserlistUpdate: Update of LMS user LmsResultInsert: New LMS result LmsResultUpdate: Update of LMS result LmsResultCsvExceptionDuplicatedKey: CSV import with ambiguous key LmsUserlistCsvExceptionDuplicatedKey: CSV import with ambiguous key -LmsDirectUpload: Direct upload for automated Systems +LmsDirectUpload: Direct upload for automated systems LmsErrorNoRefreshElearning: Error: E-learning will not be started automatically due to refresh-within time period not being set. MailSubjectQualificationRenewal qname: Qualification #{qname} must be renewed shortly MailSubjectQualificationExpiry qname: Qualification #{qname} expires soon @@ -81,9 +83,11 @@ QualificationActExpire: Discontinue - qualification expires silently QualificationActUnexpire: Continue - send a possibly fee-paying notification upon due renewal 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 +QualificationActBlockSupervisor: Waive permanently and remove all supervisiors, effective immediately QualificationActBlock: Revoke QualificationActUnblock: Clear revocation +QualificationActGrant: Grant qualification +QualificationActRenew: Renew qualification 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. diff --git a/messages/uniworx/categories/term/de-de-formal.msg b/messages/uniworx/categories/term/de-de-formal.msg index 8a93e5698..80555c631 100644 --- a/messages/uniworx/categories/term/de-de-formal.msg +++ b/messages/uniworx/categories/term/de-de-formal.msg @@ -1,4 +1,4 @@ -# SPDX-FileCopyrightText: 2022 Gregor Kleen ,Steffen Jost ,Winnie Ros +# SPDX-FileCopyrightText: 2023 Gregor Kleen ,Steffen Jost ,Winnie Ros # # SPDX-License-Identifier: AGPL-3.0-or-later @@ -14,7 +14,7 @@ TermEnd: Ende Kursperiode LectureStart: Beginn Kurse TermEdited tid@TermId: Semester #{tid} erfolgreich editiert. TermNewTitle: Semester editieren/anlegen. -InvalidInput: Eingaben bitte korrigieren. +InvalidInput: Ungültige Eingabe, bitte korrigieren. Term !ident-ok: Semester TermPlaceholder: JJJJ TermStartDay: Erster Tag diff --git a/messages/uniworx/categories/user/de-de-formal.msg b/messages/uniworx/categories/user/de-de-formal.msg index ab6cdb32b..2184d08e4 100644 --- a/messages/uniworx/categories/user/de-de-formal.msg +++ b/messages/uniworx/categories/user/de-de-formal.msg @@ -22,7 +22,7 @@ AdminUserPostAddress: Postalische Anschrift AdminUserPrefersPostal: Briefe anstatt Email bevorzugt AdminUserPinPassword: Passwort zur Verschlüsselung von PDF Anhängen in Emails AdminUserNoPassword: Kein Passwort gesetzt -AdminUserAssimilate: Benutzer assimilieren +AdminUserAssimilate: Diesen Benutzer assimilieren von UserAdded: Benutzer erfolgreich angelegt UserCollision: Benutzer konnte wegen Eindeutigkeit nicht angelegt werden HeadingUserAdd: Benutzer:in anlegen diff --git a/messages/uniworx/categories/user/en-eu.msg b/messages/uniworx/categories/user/en-eu.msg index 64145dcaf..e45b9e154 100644 --- a/messages/uniworx/categories/user/en-eu.msg +++ b/messages/uniworx/categories/user/en-eu.msg @@ -22,7 +22,7 @@ AdminUserPostAddress: Postal Address AdminUserPrefersPostal: Prefers postal letters over email AdminUserPinPassword: Password used for PDF attachments to emails AdminUserNoPassword: No password set -AdminUserAssimilate: Assimilate user +AdminUserAssimilate: Assimilate user by another user UserAdded: Successfully added user UserCollision: Could not create user due to uniqueness constraint HeadingUserAdd: Add user diff --git a/messages/uniworx/utils/table_column/de-de-formal.msg b/messages/uniworx/utils/table_column/de-de-formal.msg index f0ce25d50..c3247ecf5 100644 --- a/messages/uniworx/utils/table_column/de-de-formal.msg +++ b/messages/uniworx/utils/table_column/de-de-formal.msg @@ -74,4 +74,6 @@ TableExamOfficeLabelStatus: Label-Farbe TableExamOfficeLabelPriority: Label-Priorität TableQualifications: Qualifikationen TableCompany: Firma +TableCompanies: Firmen +TableCompanyNos: Firmennummern TableSupervisor: Ansprechpartner diff --git a/messages/uniworx/utils/table_column/en-eu.msg b/messages/uniworx/utils/table_column/en-eu.msg index 6eeed21d1..5ff701e6a 100644 --- a/messages/uniworx/utils/table_column/en-eu.msg +++ b/messages/uniworx/utils/table_column/en-eu.msg @@ -74,4 +74,6 @@ TableExamOfficeLabelStatus: Label colour TableExamOfficeLabelPriority: Label priority TableQualifications: Qualifications TableCompany: Company +TableCompanies: Companies +TableCompanyNos: Company numbers TableSupervisor: Supervisor diff --git a/messages/uniworx/utils/utils/de-de-formal.msg b/messages/uniworx/utils/utils/de-de-formal.msg index 3dfdcd670..1d5b9d184 100644 --- a/messages/uniworx/utils/utils/de-de-formal.msg +++ b/messages/uniworx/utils/utils/de-de-formal.msg @@ -1,4 +1,4 @@ -# SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Winnie Ros +# SPDX-FileCopyrightText: 2023 Steffen Jost ,Gregor Kleen ,Sarah Vaupel ,Winnie Ros # # SPDX-License-Identifier: AGPL-3.0-or-later @@ -150,4 +150,6 @@ SheetGradingPassPoints': Bestehen nach Punkten SheetGradingPassBinary': Bestanden/Nicht bestanden SheetGradingPassAlways': Automatisch bestanden, sobald korrigiert SheetTypeNormal !ident-ok: Normal -SheetTypeBonus !ident-ok: Bonus \ No newline at end of file +SheetTypeBonus !ident-ok: Bonus + +InvalidFormAction: Keine Aktion ausgeführt wegen ungültigen Formulardaten \ No newline at end of file diff --git a/messages/uniworx/utils/utils/en-eu.msg b/messages/uniworx/utils/utils/en-eu.msg index 8e551020c..9162d42f4 100644 --- a/messages/uniworx/utils/utils/en-eu.msg +++ b/messages/uniworx/utils/utils/en-eu.msg @@ -1,4 +1,4 @@ -# SPDX-FileCopyrightText: 2022 Sarah Vaupel ,Winnie Ros +# SPDX-FileCopyrightText: 2023 Sarah Vaupel ,Winnie Ros ,Steffen Jost # # SPDX-License-Identifier: AGPL-3.0-or-later @@ -150,4 +150,6 @@ SheetGradingPassPoints': Passing by points SheetGradingPassBinary': Pass/Fail SheetGradingPassAlways': Automatically passed when corrected SheetTypeNormal: Normal -SheetTypeBonus: Bonus \ No newline at end of file +SheetTypeBonus: Bonus + +InvalidFormAction: No action taken due to invalid form data \ No newline at end of file diff --git a/models/avs.model b/models/avs.model index 45f2321d7..4f495bd25 100644 --- a/models/avs.model +++ b/models/avs.model @@ -29,5 +29,5 @@ UserAvsCard cardNo AvsFullCardNo card AvsDataPersonCard lastSynch UTCTime - UniqueAvsCard cardNo + -- UniqueAvsCard cardNo -- Note: cardNo is not unique; invalid cardNo may be reissued to different persons deriving Generic diff --git a/models/company.model b/models/company.model index 94688d1be..883aba0ff 100644 --- a/models/company.model +++ b/models/company.model @@ -14,7 +14,7 @@ Company UniqueCompanyShorthand shorthand -- UniqueCompanyAvsId avsId -- should be the case, unclear if enforcing works here, since we cannot query avs by company id Primary shorthand -- newtype Key Company = CompanyKey { unSchoolKey :: CompanyShorthand } - deriving Ord Eq Show Generic + deriving Ord Eq Show Generic Binary -- TODO: a way to populate this table (manually) CompanySynonym diff --git a/nix/docker/demo-version.json b/nix/docker/demo-version.json index 56758dcc8..3ce399bcb 100644 --- a/nix/docker/demo-version.json +++ b/nix/docker/demo-version.json @@ -1,3 +1,3 @@ { - "version": "27.2.0" + "version": "27.3.2" } diff --git a/nix/docker/version.json b/nix/docker/version.json index 56758dcc8..3ce399bcb 100644 --- a/nix/docker/version.json +++ b/nix/docker/version.json @@ -1,3 +1,3 @@ { - "version": "27.2.0" + "version": "27.3.2" } diff --git a/package-lock.json b/package-lock.json index 4fe896578..acf8f3ef2 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.2.0", + "version": "27.3.2", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 75550e181..19678e499 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.2.0", + "version": "27.3.2", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 3be4869eb..1fd6aa886 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 27.2.0 +version: 27.3.2 dependencies: - base - yesod @@ -147,6 +147,8 @@ dependencies: - extended-reals - rfc5051 - unidecode + - doctemplates + - doclayout - pandoc - pandoc-types - typed-process @@ -256,6 +258,7 @@ ghc-options: - -fno-max-relevant-binds - -j - -freduction-depth=0 + - -fprof-auto-calls when: - condition: flag(pedantic) ghc-options: diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 59614fd5a..25c26d110 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -137,7 +137,7 @@ mkUnreachableUsersTable = do E.&&. E.not_ ((user E.^. UserEmail) `E.like` E.val "%@%.%") pure user dbtRowKey = (E.^. UserId) - dbtProj = dbtProjFilteredPostId -- TODO: still don't understand the choices here + dbtProj = dbtProjId dbtColonnade = -} diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index 7d101e786..6d5952645 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -530,15 +530,14 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do return (usrAvs, user, qualUser, qual) dbtRowKey = queryUserAvs >>> (E.^. UserAvsPersonId) -- ) &&& (queryQualification >>> (E.?. QualificationId)) -- WHY IS THIS AN ERROR? -- Not sure what changes here: - dbtProj = dbtProjId -- Simple $ \(userAvs, user, qualUsr, quali) -> return (userAvs, user, qualUsr, quali) - -- dbtProj = dbtProjFilteredPostId + dbtProj = dbtProjId -- Simple $ \(userAvs, user, qualUsr, quali) -> return (userAvs, user, qualUsr, quali) dbtColonnade = mconcat [ 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) -> 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" + , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \(view (resultUser . _entityKey) -> uid) -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX" companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid @@ -554,6 +553,8 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do , sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \(preview $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> cellMaybe dayCell d , sortable (Just "blocked-due") (i18nCell MsgTableQualificationBlockedDue & cellTooltip MsgTableQualificationBlockedTooltip ) $ \(preview $ resultQualUser . _entityVal . _qualificationUserBlockedDue -> b) -> cellMaybe qualificationBlockedCell b + , sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip + ) $ \(preview $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> cellMaybe (flip ifIconCell IconNoNotification . not) b , sortable Nothing (i18nCell MsgTableAvsActiveCards) $ \(view $ resultUserAvs . _userAvsPersonId -> apid) -> foldMap avsPersonCardCell $ Map.lookup apid apidStatus ] dbtSorting = mconcat @@ -565,6 +566,7 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do , single ("last-refresh" , SortColumn $ queryQualUser >>> (E.?. QualificationUserLastRefresh)) , single ("first-held" , SortColumn $ queryQualUser >>> (E.?. QualificationUserFirstHeld)) , single ("blocked-due" , SortColumn $ queryQualUser >>> (E.?. QualificationUserBlockedDue)) + , single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.?. QualificationUserScheduleRenewal)) ] dbtFilter = mconcat diff --git a/src/Handler/Admin/Test.hs b/src/Handler/Admin/Test.hs index ca0d2aae8..7d80b6fc8 100644 --- a/src/Handler/Admin/Test.hs +++ b/src/Handler/Admin/Test.hs @@ -14,6 +14,7 @@ import Utils.Print import Handler.Utils import Jobs +import Data.Ratio ((%)) import Data.Char (isDigit) import qualified Data.Text as Text -- import qualified Data.Text.IO as Text @@ -97,7 +98,7 @@ postAdminTestR = do case btnResult of (FormSuccess CreateInf) -> addMessage Info "Informatik-Knopf gedrückt" (FormSuccess CreateMath) -> addMessage Warning "Knopf Mathematik erkannt" - (FormSuccess CrashApp) -> addMessage Error "Crash Button betätigt" >> error "Crash Button" + (FormSuccess CrashApp) -> addMessage Error "Crash Button Ratio 0 betätigt" >> error ("Crash Button" <> show (1 % 0)) FormMissing -> return () _other -> addMessage Warning "KEIN Knopf erkannt" diff --git a/src/Handler/Health.hs b/src/Handler/Health.hs index a34361191..aad83d566 100644 --- a/src/Handler/Health.hs +++ b/src/Handler/Health.hs @@ -17,6 +17,8 @@ import qualified Data.Set as Set import Control.Concurrent.STM.Delay +import System.Environment (lookupEnv) -- while git version number is not working + -- import Data.FileEmbed (embedStringFile) getHealthR :: Handler TypedContent @@ -107,7 +109,7 @@ getInstanceR = do getStatusR :: Handler Html getStatusR = do starttime <- getsYesod appStartTime - currtime <- liftIO getCurrentTime + (currtime, env_version) <- liftIO $ (,) <$> getCurrentTime <*> lookupEnv "VERSION_NR" -- ft <- formatTime' "%Y-%m-%d %H:%M:%S" currtime withUrlRenderer [hamlet| @@ -116,6 +118,9 @@ getStatusR = do Status <body> + $maybe env_ver <- env_version + <p> + Environment version #{env_ver} <p> Current Time <br> #{show currtime} <br> diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 8b3f3d9db..1499ebb1d 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de> +-- SPDX-FileCopyrightText: 2023 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de> -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -25,7 +25,7 @@ import Import import Jobs import Handler.Utils --- import Handler.Utils.Csv +import Handler.Utils.Users import Handler.Utils.LMS @@ -47,7 +47,6 @@ import Handler.LMS.Userlist as Handler.LMS import Handler.LMS.Result as Handler.LMS import Handler.LMS.Fake as Handler.LMS -- TODO: remove in production! --- import Handler.Utils.Qualification (validQualification) -- avoids repetition of local definitions single :: (k,a) -> Map k a @@ -105,26 +104,26 @@ resultAllQualificationActive = _dbrOutput . _2 . _unValue resultAllQualificationTotal :: Lens' AllQualificationTableData Word64 resultAllQualificationTotal = _dbrOutput . _3 . _unValue - + mkLmsAllTable :: Bool -> DB (Any, Widget) mkLmsAllTable isAdmin = do - now <- liftIO getCurrentTime - + svs <- getSupervisees let resultDBTable = DBTable{..} where dbtSQLQuery quali = do - let cusers = Ex.subSelectCount $ do - quser <- Ex.from $ Ex.table @QualificationUser - Ex.where_ $ quser Ex.^. QualificationUserQualification Ex.==. quali Ex.^. QualificationId - cactive = Ex.subSelectCount $ do - quser <- Ex.from $ Ex.table @QualificationUser - Ex.where_ $ quser Ex.^. QualificationUserQualification Ex.==. quali Ex.^. QualificationId - Ex.&&. validQualification (utctDay now) quser + let filterSvs luser = luser Ex.^. LmsUserQualification Ex.==. quali Ex.^. QualificationId + Ex.&&. (E.val isAdmin E.||. luser Ex.^. LmsUserUser `Ex.in_` E.vals svs) + cusers = Ex.subSelectCount $ do + luser <- Ex.from $ Ex.table @LmsUser + Ex.where_ $ filterSvs luser + cactive = Ex.subSelectCount $ do + luser <- Ex.from $ Ex.table @LmsUser + Ex.where_ $ filterSvs luser Ex.&&. E.isNothing (luser E.^. LmsUserStatus) -- Failed attempt using Join/GroupBy instead of subselect: see branch csv-osis-demo-groupby-problem return (quali, cactive, cusers) dbtRowKey = (Ex.^. QualificationId) - dbtProj = dbtProjId -- TODO: or dbtProjSimple what is the difference? + dbtProj = dbtProjId adminable = if isAdmin then sortable else \_ _ _ -> mempty dbtColonnade = dbColonnade $ mconcat [ colSchool $ resultAllQualification . _qualificationSchool @@ -195,38 +194,42 @@ postLmsEditR = error "TODO: STUB" data LmsTableCsv = LmsTableCsv -- L..T..C.. -> ltc.. - { ltcDisplayName :: UserDisplayName - , ltcEmail :: UserEmail - , ltcValidUntil :: Day - , ltcLastRefresh :: Day - , ltcFirstHeld :: Day - , ltcBlockedDue :: Maybe QualificationBlocked - , ltcLmsIdent :: Maybe LmsIdent - , ltcLmsStatus :: Maybe LmsStatus - , ltcLmsStarted :: Maybe UTCTime - , ltcLmsDatePin :: Maybe UTCTime - , ltcLmsReceived :: Maybe UTCTime - , ltcLmsNotified :: Maybe UTCTime - , ltcLmsEnded :: Maybe UTCTime + { ltcDisplayName :: UserDisplayName + , ltcEmail :: UserEmail + , ltcCompany :: Maybe Text + , ltcCompanyNumbers :: CsvSemicolonList Int + , ltcValidUntil :: Day + , ltcLastRefresh :: Day + , ltcFirstHeld :: Day + , ltcBlockedDue :: Maybe QualificationBlocked + , ltcLmsIdent :: Maybe LmsIdent + , ltcLmsStatus :: Maybe LmsStatus + , ltcLmsStarted :: Maybe UTCTime + , ltcLmsDatePin :: Maybe UTCTime + , ltcLmsReceived :: Maybe UTCTime + , ltcLmsNotified :: Maybe UTCTime + , ltcLmsEnded :: Maybe UTCTime } deriving Generic makeLenses_ ''LmsTableCsv ltcExample :: LmsTableCsv ltcExample = LmsTableCsv - { ltcDisplayName = "Max Mustermann" - , ltcEmail = "m.mustermann@example.com" - , ltcValidUntil = compDay - , ltcLastRefresh = compDay - , ltcFirstHeld = compDay - , ltcBlockedDue = Nothing - , ltcLmsIdent = Nothing - , ltcLmsStatus = Nothing - , ltcLmsStarted = Just compTime - , ltcLmsDatePin = Nothing - , ltcLmsReceived = Nothing - , ltcLmsNotified = Nothing - , ltcLmsEnded = Nothing + { ltcDisplayName = "Max Mustermann" + , ltcEmail = "m.mustermann@example.com" + , ltcCompany = Just "Example Brothers LLC, SecondaryJobs Inc" + , ltcCompanyNumbers = CsvSemicolonList [27,69] + , ltcValidUntil = compDay + , ltcLastRefresh = compDay + , ltcFirstHeld = compDay + , ltcBlockedDue = Nothing + , ltcLmsIdent = Nothing + , ltcLmsStatus = Nothing + , ltcLmsStarted = Just compTime + , ltcLmsDatePin = Nothing + , ltcLmsReceived = Nothing + , ltcLmsNotified = Nothing + , ltcLmsEnded = Nothing } where compTime :: UTCTime @@ -253,35 +256,37 @@ instance Csv.DefaultOrdered LmsTableCsv where instance CsvColumnsExplained LmsTableCsv where csvColumnsExplanations = genericCsvColumnsExplanations ltcOptions $ Map.fromList - [ ('ltcDisplayName, MsgLmsUser) - , ('ltcEmail , MsgTableLmsEmail) - , ('ltcValidUntil , MsgLmsQualificationValidUntil) - , ('ltcLastRefresh, MsgTableQualificationLastRefresh) - , ('ltcFirstHeld , MsgTableQualificationFirstHeld) - , ('ltcLmsIdent , MsgTableLmsIdent) - , ('ltcLmsStatus , MsgTableLmsStatus) - , ('ltcLmsStarted , MsgTableLmsStarted) - , ('ltcLmsDatePin , MsgTableLmsDatePin) - , ('ltcLmsReceived, MsgTableLmsReceived) - , ('ltcLmsEnded , MsgTableLmsEnded) + [ ('ltcDisplayName , SomeMessage MsgLmsUser) + , ('ltcEmail , SomeMessage MsgTableLmsEmail) + , ('ltcCompany , SomeMessage MsgTableCompanies) + , ('ltcCompanyNumbers , SomeMessage MsgTableCompanyNos) + , ('ltcValidUntil , SomeMessage MsgLmsQualificationValidUntil) + , ('ltcLastRefresh , SomeMessage MsgTableQualificationLastRefresh) + , ('ltcFirstHeld , SomeMessage MsgTableQualificationFirstHeld) + , ('ltcLmsIdent , SomeMessage MsgTableLmsIdent) + , ('ltcLmsStatus , SomeMessage MsgTableLmsStatus) + , ('ltcLmsStarted , SomeMessage MsgTableLmsStarted) + , ('ltcLmsDatePin , SomeMessage MsgTableLmsDatePin) + , ('ltcLmsReceived , SomeMessage MsgTableLmsReceived) + , ('ltcLmsEnded , SomeMessage MsgTableLmsEnded) ] -type LmsTableExpr = ( E.SqlExpr (Entity QualificationUser) - `E.InnerJoin` E.SqlExpr (Entity User) - ) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity LmsUser)) +type LmsTableExpr = E.SqlExpr (Entity QualificationUser) + `E.InnerJoin` E.SqlExpr (Entity User) + `E.InnerJoin` E.SqlExpr (Entity LmsUser) queryQualUser :: LmsTableExpr -> E.SqlExpr (Entity QualificationUser) -queryQualUser = $(sqlIJproj 2 1) . $(sqlLOJproj 2 1) +queryQualUser = $(sqlIJproj 3 1) queryUser :: LmsTableExpr -> E.SqlExpr (Entity User) -queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 2 1) +queryUser = $(sqlIJproj 3 2) -queryLmsUser :: LmsTableExpr -> E.SqlExpr (Maybe (Entity LmsUser)) -queryLmsUser = $(sqlLOJproj 2 2) +queryLmsUser :: LmsTableExpr -> E.SqlExpr (Entity LmsUser) +queryLmsUser = $(sqlIJproj 3 3) -type LmsTableData = DBRow (Entity QualificationUser, Entity User, Maybe (Entity LmsUser), E.Value (Maybe [Maybe UTCTime])) +type LmsTableData = DBRow (Entity QualificationUser, Entity User, Entity LmsUser, E.Value (Maybe [Maybe UTCTime]), [Entity UserCompany]) resultQualUser :: Lens' LmsTableData (Entity QualificationUser) resultQualUser = _dbrOutput . _1 @@ -289,12 +294,15 @@ resultQualUser = _dbrOutput . _1 resultUser :: Lens' LmsTableData (Entity User) resultUser = _dbrOutput . _2 -resultLmsUser :: Traversal' LmsTableData (Entity LmsUser) -resultLmsUser = _dbrOutput . _3 . _Just +resultLmsUser :: Lens' LmsTableData (Entity LmsUser) +resultLmsUser = _dbrOutput . _3 resultPrintAck :: Traversal' LmsTableData [Maybe UTCTime] resultPrintAck = _dbrOutput . _4 . _unValue . _Just +resultCompanyUser :: Lens' LmsTableData [Entity UserCompany] +resultCompanyUser = _dbrOutput . _5 + instance HasEntity LmsTableData User where hasEntity = resultUser @@ -330,71 +338,73 @@ isRenewPinAct LmsActRenewPinData = True lmsTableQuery :: QualificationId -> LmsTableExpr -> E.SqlQuery ( E.SqlExpr (Entity QualificationUser) , E.SqlExpr (Entity User) - , E.SqlExpr (Maybe (Entity LmsUser)) + , E.SqlExpr (Entity LmsUser) , E.SqlExpr (E.Value (Maybe [Maybe UTCTime])) -- outer maybe indicates, whether a printJob exists, inner maybe indicates all acknowledged printJobs ) -lmsTableQuery qid (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser) = do +lmsTableQuery qid (qualUser `E.InnerJoin` user `E.InnerJoin` lmsUser) = do -- RECALL: another outer join on PrintJob did not work out well, since -- - E.distinctOn [E.don $ printJob E.?. PrintJobLmsUser] $ do -- types, but destroys the ability to sort interactively, since distinctOn requires sorting; -- - using noExsists on printJob join condition works, but only deliver single value; -- experiments with separate sub-query showed that we would need two subsqueries to learn whether the request was indeed the latest - E.on $ user E.^. UserId E.=?. lmsUser E.?. LmsUserUser - E.&&. E.val qid E.=?. lmsUser E.?. LmsUserQualification -- NOTE: condition was once erroneously placed in where-clause, which does not work + E.on $ user E.^. UserId E.==. lmsUser E.^. LmsUserUser + E.&&. E.val qid E.==. lmsUser E.^. LmsUserQualification -- NOTE: condition was once erroneously placed in where-clause, which does not work E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser E.where_ $ E.val qid E.==. qualUser E.^. QualificationUserQualification -- TODO: decide whether to use subSelect or LeftOuterJoin and delete the other! -- Letztes Datum anzeigen, wenn mehrere, dann diese in klickbaren Tooltip verstecken! let printAcknowledged = E.subSelectMaybe . E.from $ \pj -> do E.where_ $ E.isJust (pj E.^. PrintJobLmsUser) - E.&&. ((lmsUser E.?. LmsUserIdent) E.==. (pj E.^. PrintJobLmsUser)) + E.&&. ((lmsUser E.^. LmsUserIdent) E.=?. (pj E.^. PrintJobLmsUser)) let pjOrder = [E.desc $ pj E.^. PrintJobCreated, E.desc $ pj E.^. PrintJobAcknowledged] -- latest created comes first! This is assumed to be the case later on! pure $ --(E.arrayAggWith E.AggModeAll (pj E.^. PrintJobCreated ) pjOrder, -- return two aggregates only works with select, the restricted typr of subSelect does not seem to support this! E.arrayAggWith E.AggModeAll (pj E.^. PrintJobAcknowledged) pjOrder return (qualUser, user, lmsUser, printAcknowledged) -mkLmsTable :: forall h p cols act act'. - ( Functor h, ToSortable h - , Ord act, PathPiece act, RenderMessage UniWorX act - , AsCornice h p LmsTableData (DBCell (MForm Handler) (FormResult (First act', DBFormResult UserId Bool LmsTableData))) cols +mkLmsTable :: ( Functor h, ToSortable h + , AsCornice h p LmsTableData (DBCell (MForm Handler) (FormResult (First LmsTableActionData, DBFormResult UserId Bool LmsTableData))) cols ) => Bool -> Entity Qualification - -> Map act (AForm Handler act') - -> cols - -> PSValidator (MForm Handler) (FormResult (First act', DBFormResult UserId Bool LmsTableData)) - -> DB (FormResult (act', Set UserId), Widget) + -> Map LmsTableAction (AForm Handler LmsTableActionData) + -> (Map CompanyId Company -> cols) + -> PSValidator (MForm Handler) (FormResult (First LmsTableActionData, DBFormResult UserId Bool LmsTableData)) + -> DB (FormResult (LmsTableActionData, Set UserId), Widget) mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do now <- liftIO getCurrentTime - currentRoute <- fromMaybe (error "mkLmsAllTable called from 404-handler") <$> liftHandler getCurrentRoute -- we know the route here - let - -- currentRoute = LmsR (qualificationSchool quali) (qualificationShorthand quali) -- bad idea as seen + -- lookup all companies + cmpMap <- memcachedBy (Just . Right $ 5 * diffMinute) ("CompanyDictionary"::Text) $ do + cmps <- selectList [] [Asc CompanyId] + return $ Map.fromAscList $ fmap (\c -> (entityKey c, entityVal c)) cmps + let nowaday = utctDay now - mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday + -- mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName) dbtIdent :: Text dbtIdent = "qualification" - dbtSQLQuery q = lmsTableQuery qid q + dbtSQLQuery = lmsTableQuery qid dbtRowKey = queryUser >>> (E.^. UserId) - dbtProj = dbtProjId - - dbtColonnade = cols + dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr, printAcks) -> do + cmpUsr <- selectList [UserCompanyUser ==. entityKey usr] [Asc UserCompanyCompany] + return (qualUsr, usr, lmsUsr, printAcks, cmpUsr) + dbtColonnade = cols cmpMap dbtSorting = mconcat - [ single $ sortUserNameLink queryUser - , single $ sortUserEmail queryUser + [ single $ sortUserNameLink queryUser + , single $ sortUserEmail queryUser + , single $ sortUserMatriclenr queryUser , single ("valid-until" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserValidUntil)) , single ("last-refresh" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserLastRefresh)) , single ("first-held" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserFirstHeld)) , single ("blocked-due" , SortColumnNeverNull$ queryQualUser >>> (E.^. QualificationUserBlockedDue)) , single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal)) - , single ("lms-ident" , SortColumnNullsInv $ queryLmsUser >>> (E.?. LmsUserIdent)) - , single ("lms-pin" , SortColumnNullsInv $ queryLmsUser >>> (E.?. LmsUserPin)) - , single ("lms-status" , SortColumnNullsInv $ views (to queryLmsUser) (E.?. LmsUserStatus)) - , single ("lms-started" , SortColumnNullsInv $ queryLmsUser >>> (E.?. LmsUserStarted)) - , single ("lms-datepin" , SortColumnNullsInv $ queryLmsUser >>> (E.?. LmsUserDatePin)) - , single ("lms-received" , SortColumnNullsInv $ queryLmsUser >>> (E.?. LmsUserReceived)) - , single ("lms-notified" , SortColumnNullsInv $ queryLmsUser >>> (E.?. LmsUserNotified)) -- cannot include printJob acknowledge date - , single ("lms-ended" , SortColumnNullsInv $ queryLmsUser >>> (E.?. LmsUserEnded)) + , single ("lms-ident" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserIdent)) + , single ("lms-pin" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserPin)) + , single ("lms-status" , SortColumnNullsInv $ views (to queryLmsUser) (E.^. LmsUserStatus)) + , single ("lms-started" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserStarted)) + , single ("lms-datepin" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserDatePin)) + , single ("lms-received" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserReceived)) + , single ("lms-notified" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserNotified)) -- cannot include printJob acknowledge date + , single ("lms-ended" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserEnded)) , single ( "user-company" , SortColumn $ \row -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId @@ -404,17 +414,17 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do ] dbtFilter = mconcat [ single $ fltrUserNameEmail queryUser - , single ("lms-ident" , FilterColumn . E.mkContainsFilterWith (Just . LmsIdent) $ views (to queryLmsUser) (E.?. LmsUserIdent)) + , single ("lms-ident" , FilterColumn . E.mkContainsFilterWith LmsIdent $ views (to queryLmsUser) (E.^. LmsUserIdent)) -- , single ("lms-status" , FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) ((E.>=. E.val nowaday) . (E.^. LmsUserStatus))) -- LmsStatus cannot be filtered easily within the DB -- , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) ((E.>=. E.val nowaday) . (E.^. QualificationUserValidUntil))) , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification nowaday)) - , single ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion -> - if | Just renewal <- mbRenewal - , Just True <- getLast criterion -> quser E.^. QualificationUserValidUntil E.<=. E.val renewal - E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday - | otherwise -> E.true - ) - , single ("lms-notified", FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) (E.isJust . (E.?. LmsUserNotified))) + -- , single ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion -> + -- if | Just renewal <- mbRenewal + -- , Just True <- getLast criterion -> quser E.^. QualificationUserValidUntil E.<=. E.val renewal + -- E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday + -- | otherwise -> E.true + -- ) + , single ("lms-notified", FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) (E.isJust . (E.^. LmsUserNotified))) , single ("avs-number" , FilterColumn . E.mkExistsFilter $ \row criterion -> E.from $ \usrAvs -> -- do E.where_ $ usrAvs E.^. UserAvsUser E.==. queryUser row E.^. UserId @@ -428,18 +438,31 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do testcrit = maybe testname testnumber $ readMay $ CI.original criterion E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId E.&&. testcrit - ) + ) + , single ("avs-card" , FilterColumn $ \(queryUser -> user) (criterion :: Set.Set Text) -> case readAvsFullCardNo =<< Set.lookupMin criterion of + Nothing -> E.false + Just cardNo -> E.exists $ E.from $ \(avsCard `E.InnerJoin` usrAvs) -> do + E.on $ usrAvs E.^. UserAvsPersonId E.==. avsCard E.^. UserAvsCardPersonId + E.where_ $ usrAvs E.^. UserAvsUser E.==. user E.^. UserId + E.&&. (avsCard E.^. UserAvsCardCardNo E.==. E.val cardNo) + ) + , single ("personal-number", FilterColumn $ \(queryUser -> user) (criteria :: Set.Set Text) -> if + | Set.null criteria -> E.true + | otherwise -> E.any (\c -> user E.^. UserCompanyPersonalNumber `E.hasInfix` E.val c) criteria + ) ] dbtFilterUI mPrev = mconcat - [ fltrUserNameEmailHdrUI MsgLmsUser mPrev - , prismAForm (singletonFilter "lms-ident" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent) - -- , prismAForm (singletonFilter "lms-status" . maybePrism _PathPiece) mPrev $ aopt (selectField' (Just $ SomeMessage MsgTableNoFilter) $ return (optionsPairs [(MsgTableLmsSuccess,"success"::Text),(MsgTableLmsFailed,"blocked")])) (fslI MsgTableLmsStatus) - , prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo) + [ prismAForm (singletonFilter "lms-ident" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent) + , fltrUserNameEmailHdrUI MsgLmsUser mPrev , prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany) + , prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumber) + , prismAForm (singletonFilter "avs-card" ) mPrev $ aopt textField (fslI MsgAvsCardNo) + , prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo) , prismAForm (singletonFilter "validity" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid) , prismAForm (singletonFilter "lms-notified" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsNotified) - , if isNothing mbRenewal then mempty - else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal) + -- , prismAForm (singletonFilter "lms-status" . maybePrism _PathPiece) mPrev $ aopt (selectField' (Just $ SomeMessage MsgTableNoFilter) $ return (optionsPairs [(MsgTableLmsSuccess,"success"::Text),(MsgTableLmsFailed,"blocked")])) (fslI MsgTableLmsStatus) + -- , if isNothing mbRenewal then mempty + -- else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal) ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtCsvEncode = Just DBTCsvEncode @@ -456,6 +479,8 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do doEncode' = LmsTableCsv <$> view (resultUser . _entityVal . _userDisplayName) <*> view (resultUser . _entityVal . _userDisplayEmail) + <*> (view resultCompanyUser >>= getCompanies) + <*> (view resultCompanyUser >>= getCompanyNos) <*> view (resultQualUser . _entityVal . _qualificationUserValidUntil) <*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh) <*> view (resultQualUser . _entityVal . _qualificationUserFirstHeld) @@ -467,12 +492,17 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do <*> (join . preview (resultLmsUser . _entityVal . _lmsUserReceived)) <*> (join . preview (resultLmsUser . _entityVal . _lmsUserNotified)) -- TODO: only exports last email date / print job sending date, not print acknowledge <*> (join . preview (resultLmsUser . _entityVal . _lmsUserEnded)) + getCompanies cmps = case mapMaybe (flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) cmps of + [] -> pure Nothing + somecmps -> pure $ Just $ intercalate ", " $ fmap (view (_companyName . _CI)) somecmps + getCompanyNos = pure . CsvSemicolonList . mapMaybe (preview (_Just . _companyAvsId) . flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) + dbtCsvDecode = Nothing dbtExtraReps = [] dbtParams = if not isAdmin then def {dbParamsFormAction = Nothing, dbParamsFormSubmit = FormNoSubmit} else DBParamsForm { dbParamsFormMethod = POST - , dbParamsFormAction = Just $ SomeRoute currentRoute + , dbParamsFormAction = Nothing -- Just $ SomeRoute currentRoute , dbParamsFormAttrs = [] , dbParamsFormSubmit = FormSubmit , dbParamsFormAdditional @@ -504,8 +534,7 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do getLmsR, postLmsR :: SchoolId -> QualificationShorthand -> Handler Html getLmsR = postLmsR postLmsR sid qsh = do - isAdmin <- hasReadAccessTo AdminR - currentRoute <- fromMaybe (error "correctionsR called from 404-handler") <$> getCurrentRoute -- This should never be called from a 404 handler + isAdmin <- hasReadAccessTo AdminR ((lmsRes, lmsTable), Entity qid quali) <- runDB $ do qent <- getBy404 $ SchoolQualificationShort sid qsh let acts :: Map LmsTableAction (AForm Handler LmsTableActionData) @@ -515,20 +544,21 @@ postLmsR sid qsh = do -- , singletonMap LmsActRenewPin $ pure LmsActRenewPinData ] -- lmsStatusLink = toMaybe isAdmin LmsUserR - colChoices = mconcat + colChoices cmpMap = mconcat [ if not isAdmin then mempty else dbSelectIf (applying _2) id (return . view (resultUser . _entityKey)) (\r -> isJust $ r ^? resultLmsUser) -- TODO: refactor using function "is" , colUserNameModalHdr MsgLmsUser AdminUserR , colUserEmail - , sortable (Just "user-company") (i18nCell MsgTableCompany) $ \( view $ resultUser . _entityKey -> uid) -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX" - companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do - E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId - E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid - E.orderBy [E.asc (comp E.^. CompanyName)] - return (comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor) - let companies = intersperse (text2markup ", ") $ - (\(E.Value cmpName, E.Value cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> companies' - icnSuper = text2markup " " <> icon IconSupervisor - pure $ toWgt $ mconcat companies + , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultCompanyUser -> cmps) -> + let icnSuper = text2markup " " <> icon IconSupervisor + cs = [ (cmpName, cmpSpr) + | Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps + , let cmpEnt = Map.lookup cmpId cmpMap + , Just Company{companyName = cmpName} <- [cmpEnt] + ] + companies = intercalate (text2markup ", ") $ + (\(cmpName, cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> cs + in wgtCell companies + , colUserMatriclenr , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \( view $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> dayCell d , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d , sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d @@ -536,22 +566,22 @@ postLmsR sid qsh = do ) $ \( view $ resultQualUser . _entityVal . _qualificationUserBlockedDue -> b) -> qualificationBlockedCell b , sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip ) $ \( view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification - , sortable (Just "lms-ident") (i18nCell MsgTableLmsIdent) $ \(preview $ resultLmsUser . _entityVal . _lmsUserIdent . _getLmsIdent -> lid) -> foldMap textCell lid + , sortable (Just "lms-ident") (i18nCell MsgTableLmsIdent) $ \(view $ resultLmsUser . _entityVal . _lmsUserIdent . _getLmsIdent -> lid) -> textCell lid , sortable (Just "lms-pin") (i18nCell MsgTableLmsPin & cellAttrs <>~ [("uw-hide-column-default-hidden",mempty)] - ) $ \(preview $ resultLmsUser . _entityVal . _lmsUserPin -> pin) -> foldMap textCell pin - , sortable (Just "lms-status") (i18nCell MsgTableLmsStatus) $ \(preview $ resultLmsUser . _entityVal . _lmsUserStatus -> status) -> foldMap lmsStatusCell $ join status - , sortable (Just "lms-started") (i18nLms MsgTableLmsStarted) $ \(preview $ resultLmsUser . _entityVal . _lmsUserStarted -> d) -> foldMap dateTimeCell d - , 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 & cellTooltip MsgTableLmsNotifiedTooltip) $ \row -> + ) $ \(view $ resultLmsUser . _entityVal . _lmsUserPin -> pin) -> textCell pin + , sortable (Just "lms-status") (i18nCell MsgTableLmsStatus) $ \(view $ resultLmsUser . _entityVal . _lmsUserStatus -> status) -> foldMap lmsStatusCell status + , sortable (Just "lms-started") (i18nLms MsgTableLmsStarted) $ \(view $ resultLmsUser . _entityVal . _lmsUserStarted -> d) -> dateTimeCell d + , sortable (Just "lms-datepin") (i18nLms MsgTableLmsDatePin) $ \(view $ resultLmsUser . _entityVal . _lmsUserDatePin -> d) -> dateTimeCell d + , sortable (Just "lms-received") (i18nLms MsgTableLmsReceived) $ \(view $ resultLmsUser . _entityVal . _lmsUserReceived -> d) -> foldMap dateTimeCell d + --, sortable (Just "lms-notified") (i18nLms MsgTableLmsNotified) $ \(view $ resultLmsUser . _entityVal . _lmsUserNotified -> d) -> foldMap dateTimeCell $ join d + , sortable (Just "lms-notified") (i18nLms MsgTableLmsNotified & cellTooltip MsgTableLmsNotifiedTooltip) $ \row -> -- 4 Cases: -- - No notification: LmsUserNotified == Nothing -- - Email sent : LmsUserNotified == Just _ && PrintJobId == Nothing -- - Letter printed : LmsUserNotified == Just _ && PrintJobId == Just _ -- - Letter sent : LmsUserNotified == Just _ && PrintJobId == Just _ && PrintJobAcknowledged == Just _ - let notifyDate = join $ row ^? resultLmsUser . _entityVal . _lmsUserNotified - lmsident = row ^? resultLmsUser . _entityVal . _lmsUserIdent + let notifyDate = row ^. resultLmsUser . _entityVal . _lmsUserNotified + lmsident = row ^. resultLmsUser . _entityVal . _lmsUserIdent recipient = row ^. hasUser letterDates = row ^? resultPrintAck lastLetterDate = headDef Nothing =<< letterDates @@ -561,7 +591,7 @@ postLmsR sid qsh = do cDate = if | not letterSent -> foldMap dateTimeCell notifyDate | Just d <- lastLetterDate -> dateTimeCell d | otherwise -> i18nCell MsgPrintJobUnacknowledged - lprLink :: Maybe (Route UniWorX) = lmsident <&> (\lid -> urlRoute (PrintCenterR, [("print-job-lmsid", toPathPiece lid)])) + lprLink :: Route UniWorX = lmsident & (\lid -> urlRoute (PrintCenterR, [("print-job-lmsid", toPathPiece lid)])) cAckDates = case letterDates of Just ackDates@(_:_:_) -> spacerCell <> modalCell [whamlet| <h1> @@ -573,11 +603,10 @@ postLmsR sid qsh = do $maybe ackdate <- mbackdate ^{formatTimeW SelFormatDateTime ackdate} $nothing - _{MsgPrintJobUnacknowledged} - $maybe lu <- lprLink - <p> - <a href=@{lu}> - _{MsgPrintJobs} + _{MsgPrintJobUnacknowledged} + <p> + <a href=@{lprLink}> + _{MsgPrintJobs} |] -- (PrintCenterR, [("pj-lmsid", toPathPiece lu)]) _ -> mempty @@ -586,7 +615,7 @@ postLmsR sid qsh = do then mempty else cIcon <> spacerCell <> cDate <> cAckDates -- , sortable (Just "lms-notified-alternative") (i18nLms MsgTableLmsNotified) $ \(preview resultPrintAck -> d) -> textCell (show d) - , sortable (Just "lms-ended") (i18nLms MsgTableLmsEnded) $ \(preview $ resultLmsUser . _entityVal . _lmsUserEnded -> d) -> foldMap dateTimeCell $ join d + , sortable (Just "lms-ended") (i18nLms MsgTableLmsEnded) $ \(view $ resultLmsUser . _entityVal . _lmsUserEnded -> d) -> foldMap dateTimeCell d ] where -- i18nLms :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a @@ -613,7 +642,7 @@ postLmsR sid qsh = do when (isRenewPinAct action) $ addMessageI Success $ MsgLmsPinRenewal numExaminees when (isNotifyAct action) $ addMessageI Success $ MsgLmsNotificationSend numExaminees when (diffSelected /= 0) $ addMessageI Warning $ MsgLmsActionFailed diffSelected - redirect currentRoute + reloadKeepGetParams $ LmsR sid qsh let heading = citext2widget $ "LMS " <> qualificationName quali siteLayout heading $ do diff --git a/src/Handler/LMS/Result.hs b/src/Handler/LMS/Result.hs index c9bec0c04..6662d7574 100644 --- a/src/Handler/LMS/Result.hs +++ b/src/Handler/LMS/Result.hs @@ -96,7 +96,7 @@ mkResultTable sid qsh qid = do E.where_ $ lmsresult E.^. LmsResultQualification E.==. E.val qid return lmsresult dbtRowKey = (E.^. LmsResultId) - dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference? + dbtProj = dbtProjId dbtColonnade = dbColonnade $ mconcat [ sortable (Just csvLmsIdent) (i18nCell MsgTableLmsIdent) $ \(view $ _dbrOutput . _entityVal . _lmsResultIdent . _getLmsIdent -> ident) -> textCell ident , sortable (Just csvLmsSuccess) (i18nCell MsgTableLmsSuccess) $ \(view $ _dbrOutput . _entityVal . _lmsResultSuccess -> success) -> dayCell success diff --git a/src/Handler/LMS/Userlist.hs b/src/Handler/LMS/Userlist.hs index a9ccbf942..407c7436e 100644 --- a/src/Handler/LMS/Userlist.hs +++ b/src/Handler/LMS/Userlist.hs @@ -94,7 +94,7 @@ mkUserlistTable sid qsh qid = do E.where_ $ lmslist E.^. LmsUserlistQualification E.==. E.val qid return lmslist dbtRowKey = (E.^. LmsUserlistId) - dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference? + dbtProj = dbtProjId dbtColonnade = dbColonnade $ mconcat [ sortable (Just csvLmsIdent) (i18nCell MsgTableLmsIdent) $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> textCell $ lmsUserlistIdent & getLmsIdent , sortable (Just csvLmsBlocked) (i18nCell MsgTableLmsFailed) $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> ifIconCell lmsUserlistFailed IconBlocked diff --git a/src/Handler/LMS/Users.hs b/src/Handler/LMS/Users.hs index 5af247638..97ab76850 100644 --- a/src/Handler/LMS/Users.hs +++ b/src/Handler/LMS/Users.hs @@ -95,7 +95,7 @@ mkUserTable _sid qsh qid = do E.&&. E.isNothing (lmsuser E.^. LmsUserEnded) return lmsuser dbtRowKey = (E.^. LmsUserId) - dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference? + dbtProj = dbtProjId dbtColonnade = dbColonnade $ mconcat [ sortable (Just csvLmsIdent) (i18nCell MsgTableLmsIdent) $ \(view $ _dbrOutput . _entityVal . _lmsUserIdent . _getLmsIdent -> ident) -> textCell ident , sortable (Just csvLmsPin) (i18nCell MsgTableLmsPin & cellAttrs <>~ [("uw-hide-column-default-hidden",mempty)] @@ -177,7 +177,8 @@ getLmsUsersDirectR sid qsh = do --csvRenderedHeader = lmsUserTableCsvHeader --cvsRendered = CsvRendered {..} csvRendered = toCsvRendered lmsUserTableCsvHeader $ lmsUser2csv cutoff . entityVal <$> lms_users - fmtOpts = def { csvIncludeHeader = lmsDownloadHeader + fmtOpts = (review csvPreset CsvPresetRFC) + { csvIncludeHeader = lmsDownloadHeader , csvDelimiter = lmsDownloadDelimiter , csvUseCrLf = lmsDownloadCrLf } diff --git a/src/Handler/PrintCenter.hs b/src/Handler/PrintCenter.hs index c6faa651e..c06b156d1 100644 --- a/src/Handler/PrintCenter.hs +++ b/src/Handler/PrintCenter.hs @@ -2,7 +2,7 @@ -- -- SPDX-License-Identifier: AGPL-3.0-or-later -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeApplications, ExistentialQuantification #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Handler.PrintCenter @@ -25,6 +25,8 @@ import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH import Utils.Print +import Utils.Print.Letters (MDLetter) + -- import Data.Aeson (encode) import qualified Data.Text as Text -- import qualified Data.Set as Set @@ -37,20 +39,24 @@ import Handler.Utils single :: (k,a) -> Map k a single = uncurry Map.singleton +data SomeLetter = forall l . (MDLetter l) => SomeLetter l -- a record selector would be useless here due to the escaped type variable + data LRQF = LRQF - { lrqfUser :: Either UserEmail UserId - , lrqfSuper :: Maybe (Either UserEmail UserId) - , lrqfQuali :: Entity Qualification - , lrqfIdent :: LmsIdent - , lrqfPin :: Text - , lrqfExpiry:: Day + { lrqfLetter :: Text + , lrqfUser :: Either UserEmail UserId + , lrqfSuper :: Maybe (Either UserEmail UserId) + , lrqfQuali :: Entity Qualification + , lrqfIdent :: LmsIdent + , lrqfPin :: Text + , lrqfExpiry :: Day } deriving (Eq, Generic) makeRenewalForm :: Maybe LRQF -> Form LRQF makeRenewalForm tmpl = identifyForm FIDLmsLetter . validateForm validateLetterRenewQualificationF $ \html -> do -- now_day <- utctDay <$> liftIO getCurrentTime flip (renderAForm FormStandard) html $ LRQF - <$> areq (userField False Nothing) (fslI MsgLmsUser) (lrqfUser <$> tmpl) + <$> areq textField (fslI MsgLmsUser) (lrqfLetter <$> tmpl) + <*> areq (userField False Nothing) (fslI MsgLmsUser) (lrqfUser <$> tmpl) <*> aopt (userField False Nothing) (fslI MsgTableSupervisor) (lrqfSuper <$> tmpl) <*> areq qualificationFieldEnt (fslI MsgQualificationName) (lrqfQuali <$> tmpl) <*> areq lmsField (fslI MsgTableLmsIdent) (lrqfIdent <$> tmpl) @@ -64,8 +70,9 @@ validateLetterRenewQualificationF = -- do -- LRQF{..} <- State.get return () -lrqf2letter :: LRQF -> DB (Entity User, LetterRenewQualificationF) -lrqf2letter LRQF{..} = do +lrqf2letter :: LRQF -> DB (Entity User, SomeLetter) +lrqf2letter LRQF{..} + | lrqfLetter == "r" = do usr <- getUser lrqfUser rcvr <- mapM getUser lrqfSuper let letter = LetterRenewQualificationF @@ -81,7 +88,24 @@ lrqf2letter LRQF{..} = do , qualSchool = lrqfQuali ^. _qualificationSchool , qualDuration = lrqfQuali ^. _qualificationValidDuration } - return (fromMaybe usr rcvr, letter) + return (fromMaybe usr rcvr, SomeLetter letter) + | lrqfLetter == "e" = do + rcvr <- mapM getUser lrqfSuper + usr <- getUser lrqfUser + usrUuid <- encrypt $ entityKey usr + let letter = LetterExpireQualificationF + { leqfHolderUUID = usrUuid + , leqfHolderID = usr ^. _entityKey + , leqfHolderDN = usr ^. _userDisplayName + , leqfHolderSN = usr ^. _userSurname + , leqfExpiry = lrqfExpiry + , leqfId = lrqfQuali ^. _entityKey + , leqfName = lrqfQuali ^. _qualificationName . _CI + , leqfShort = lrqfQuali ^. _qualificationShorthand . _CI + , leqfSchool = lrqfQuali ^. _qualificationSchool + } + return (fromMaybe usr rcvr, SomeLetter letter) + | otherwise = error "Unknown Letter Type encountered. Use 'e' or 'r' only." where getUser :: Either UserEmail UserId -> DB (Entity User) getUser (Right uid) = getEntity404 uid @@ -157,12 +181,11 @@ pjTableQuery (printJob `E.LeftOuterJoin` recipient return (printJob, recipient, sender, course, quali) mkPJTable :: DB (FormResult (PJTableActionData, Set PrintJobId), Widget) -mkPJTable = do - currentRoute <- fromMaybe (error "mkPJTable called from 404-handler") <$> liftHandler getCurrentRoute -- albeit we do know the route here +mkPJTable = do let dbtSQLQuery = pjTableQuery dbtRowKey = queryPrintJob >>> (E.^. PrintJobId) - dbtProj = dbtProjFilteredPostId + dbtProj = dbtProjId dbtColonnade = mconcat [ dbSelectIf (applying _2) id (return . view (resultPrintJob . _entityKey)) (\r -> isNothing $ r ^. resultPrintJob . _entityVal . _printJobAcknowledged) , sortable (Just "created") (i18nCell MsgPrintJobCreated) $ \( view $ resultPrintJob . _entityVal . _printJobCreated -> t) -> dateTimeCell t @@ -176,7 +199,7 @@ mkPJTable = do , sortable (Just "sender") (i18nCell MsgPrintSender) $ \(preview resultSender -> u) -> maybeCell u $ cellHasUserLink AdminUserR , sortable (Just "course") (i18nCell MsgPrintCourse) $ \(preview $ resultCourse . _entityVal -> c) -> maybeCell c courseCell , sortable (Just "qualification")(i18nCell MsgPrintQualification) $ \(preview $ resultQualification . _entityVal -> q) -> maybeCell q qualificationCell - , sortable (Just "lmsid") (i18nCell MsgPrintLmsUser) $ \( view $ resultPrintJob . _entityVal . _printJobLmsUser -> l) -> foldMap textCell (getLmsIdent <$> l) + , sortable (Just "lmsid") (i18nCell MsgPrintLmsUser) $ \( view $ resultPrintJob . _entityVal . _printJobLmsUser -> l) -> foldMap (textCell . getLmsIdent) l ] dbtSorting = mconcat [ single ("name" , SortColumn $ queryPrintJob >>> (E.^. PrintJobName)) @@ -227,7 +250,7 @@ mkPJTable = do dbtExtraReps = [] dbtParams = DBParamsForm { dbParamsFormMethod = POST - , dbParamsFormAction = Just $ SomeRoute currentRoute + , dbParamsFormAction = Nothing -- Just $ SomeRoute currentRoute , dbParamsFormAttrs = [] , dbParamsFormSubmit = FormSubmit , dbParamsFormAdditional @@ -254,8 +277,7 @@ mkPJTable = do getPrintCenterR, postPrintCenterR :: Handler Html getPrintCenterR = postPrintCenterR -postPrintCenterR = do - currentRoute <- fromMaybe (error "printCenterR called from 404-handler") <$> getCurrentRoute -- This should never be called from a 404 handler +postPrintCenterR = do (pjRes, pjTable) <- runDB mkPJTable formResult pjRes $ \case @@ -263,7 +285,7 @@ postPrintCenterR = do now <- liftIO getCurrentTime num <- runDB $ updateWhereCount [PrintJobAcknowledged ==. Nothing, PrintJobId <-. pjIds] [PrintJobAcknowledged =. Just now] addMessageI Success $ MsgPrintJobAcknowledge num - redirect currentRoute + reloadKeepGetParams PrintCenterR siteLayoutMsg MsgMenuApc $ do setTitleI MsgMenuApc @@ -279,7 +301,8 @@ postPrintSendR = do let nowaday = utctDay now uid = usr ^. _entityKey mkLetter qual = LRQF - { lrqfUser = Right uid + { lrqfLetter = "r" + , lrqfUser = Right uid , lrqfSuper = Nothing , lrqfQuali = qual , lrqfIdent = LmsIdent "stuvwxyz" @@ -290,7 +313,9 @@ postPrintSendR = do ((sendResult, sendWidget), sendEnctype) <- runFormPost $ makeRenewalForm def_lrqf let procFormSend lrqf = do - ok <- (runDB (lrqf2letter lrqf) >>= printLetter (Just uid)) >>= \case + ok <- (runDB (lrqf2letter lrqf) >>= \case + (entUsr, SomeLetter l) -> printLetter (Just uid) (entUsr, l) + ) >>= \case Left err -> do let msg = "PDF printing failed with error: " <> err $logErrorS "LPR" msg diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 242c3c355..2a5e2c0b8 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -1,9 +1,8 @@ --- SPDX-FileCopyrightText: 2022 Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de> +-- SPDX-FileCopyrightText: 2022-23 Steffen Jost <S.Jost@fraport.de>,Steffen Jost <jost@tcs.ifi.lmu.de> -- -- SPDX-License-Identifier: AGPL-3.0-or-later {-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances -{-# OPTIONS -Wno-unused-top-binds #-} -- TODO: remove me, for debugging only {-# LANGUAGE TypeApplications #-} module Handler.Qualification @@ -17,7 +16,7 @@ import Import -- import Jobs import Handler.Utils --- import Handler.Utils.Csv +import Handler.Utils.Users import Handler.Utils.LMS @@ -46,9 +45,10 @@ getQualificationSchoolR :: SchoolId -> Handler Html getQualificationSchoolR ssh = redirect (QualificationAllR, [("qualification-overview-school", toPathPiece ssh)]) getQualificationAllR :: Handler Html -getQualificationAllR = do -- TODO just a stub +getQualificationAllR = do + isAdmin <- hasReadAccessTo AdminR qualiTable <- runDB $ do - view _2 <$> mkQualificationAllTable + view _2 <$> mkQualificationAllTable isAdmin siteLayoutMsg MsgMenuQualifications $ do setTitleI MsgMenuQualifications $(widgetFile "qualification-all") @@ -63,15 +63,9 @@ resultAllQualificationActive = _dbrOutput . _2 . _unValue resultAllQualificationTotal :: Lens' AllQualificationTableData Word64 resultAllQualificationTotal = _dbrOutput . _3 . _unValue -getSupervisees :: DB (Set UserId) -getSupervisees = do - uid <- requireAuthId - svs <- userSupervisorUser . entityVal <<$>> selectList [UserSupervisorSupervisor ==. uid] [Asc UserSupervisorUser] - return $ Set.insert uid $ Set.fromAscList svs - -mkQualificationAllTable :: DB (Any, Widget) -mkQualificationAllTable = do +mkQualificationAllTable :: Bool -> DB (Any, Widget) +mkQualificationAllTable isAdmin = do svs <- getSupervisees now <- liftIO getCurrentTime let @@ -79,7 +73,7 @@ mkQualificationAllTable = do where dbtSQLQuery quali = do let filterSvs quser = quser Ex.^. QualificationUserQualification Ex.==. quali Ex.^. QualificationId - Ex.&&. quser Ex.^. QualificationUserUser `Ex.in_` E.vals svs + Ex.&&. (E.val isAdmin E.||. quser Ex.^. QualificationUserUser `Ex.in_` E.vals svs) cusers = Ex.subSelectCount $ do quser <- Ex.from $ Ex.table @QualificationUser Ex.where_ $ filterSvs quser @@ -88,7 +82,7 @@ mkQualificationAllTable = do Ex.where_ $ filterSvs quser Ex.&&. validQualification (utctDay now) quser return (quali, cactive, cusers) dbtRowKey = (Ex.^. QualificationId) - dbtProj = dbtProjId -- TODO: or dbtProjSimple what is the difference? + dbtProj = dbtProjId dbtColonnade = dbColonnade $ mconcat [ colSchool $ resultAllQualification . _qualificationSchool , sortable (Just "qshort") (i18nCell MsgQualificationShort) $ \(view resultAllQualification -> quali) -> @@ -151,26 +145,32 @@ mkQualificationAllTable = do -- postQualificationEditR = error "TODO" data QualificationTableCsv = QualificationTableCsv -- Q..T..C.. -> qtc.. - { qtcDisplayName :: UserDisplayName - , qtcEmail :: UserEmail - , qtcValidUntil :: Day - , qtcLastRefresh :: Day - , qtcBlocked :: Maybe Day - , qtcLmsStatusTxt :: Maybe Text - , qtcLmsStatusDay :: Maybe Day + { qtcDisplayName :: UserDisplayName + , qtcEmail :: UserEmail + , qtcCompany :: Maybe Text + , qtcCompanyNumbers :: CsvSemicolonList Int + , qtcValidUntil :: Day + , qtcLastRefresh :: Day + , qtcBlocked :: Maybe Day + , qtcScheduleRenewal:: Bool + , qtcLmsStatusTxt :: Maybe Text + , qtcLmsStatusDay :: Maybe Day } deriving Generic makeLenses_ ''QualificationTableCsv qtcExample :: QualificationTableCsv qtcExample = QualificationTableCsv - { qtcDisplayName = "Max Mustermann" - , qtcEmail = "m.mustermann@example.com" - , qtcValidUntil = compDay - , qtcLastRefresh = compDay - , qtcBlocked = Nothing - , qtcLmsStatusTxt = Just "Success" - , qtcLmsStatusDay = Just compDay + { qtcDisplayName = "Max Mustermann" + , qtcEmail = "m.mustermann@example.com" + , qtcCompany = Just "Example Brothers LLC, SecondaryJobs Inc" + , qtcCompanyNumbers = CsvSemicolonList [27,69] + , qtcValidUntil = compDay + , qtcLastRefresh = compDay + , qtcBlocked = Nothing + , qtcScheduleRenewal= True + , qtcLmsStatusTxt = Just "Success" + , qtcLmsStatusDay = Just compDay } where compTime :: UTCTime @@ -185,7 +185,7 @@ qtcOptions = Csv.defaultOptions { Csv.fieldLabelModifier = renameLtc } renameLtc other = replaceLtc $ camelToPathPiece' 1 other replaceLtc ('l':'m':'s':'-':t) = prefixLms t replaceLtc other = other - prefixLms = ("e-learn-" <>) + prefixLms = ("elearn-" <>) instance Csv.ToNamedRecord QualificationTableCsv where toNamedRecord = Csv.genericToNamedRecord qtcOptions @@ -195,18 +195,21 @@ instance Csv.DefaultOrdered QualificationTableCsv where instance CsvColumnsExplained QualificationTableCsv where csvColumnsExplanations = genericCsvColumnsExplanations qtcOptions $ Map.fromList - [ ('qtcDisplayName, MsgLmsUser) - , ('qtcEmail , MsgTableLmsEmail) - , ('qtcValidUntil , MsgLmsQualificationValidUntil) - , ('qtcLastRefresh, MsgTableQualificationLastRefresh) - , ('qtcLmsStatusTxt, MsgTableLmsStatus) - , ('qtcLmsStatusDay, MsgTableLmsStatusDay) + [ ('qtcDisplayName , SomeMessage MsgLmsUser) + , ('qtcEmail , SomeMessage MsgTableLmsEmail) + , ('qtcCompany , SomeMessage MsgTableCompanies) + , ('qtcCompanyNumbers , SomeMessage MsgTableCompanyNos) + , ('qtcValidUntil , SomeMessage MsgLmsQualificationValidUntil) + , ('qtcLastRefresh , SomeMessage MsgTableQualificationLastRefresh) + , ('qtcScheduleRenewal, SomeMessage MsgQualificationScheduleRenewalTooltip) + , ('qtcLmsStatusTxt , SomeMessage MsgTableLmsStatus) + , ('qtcLmsStatusDay , SomeMessage MsgTableLmsStatusDay) ] -type QualificationTableExpr = ( E.SqlExpr (Entity QualificationUser) - `E.InnerJoin` E.SqlExpr (Entity User) - ) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity LmsUser)) +type QualificationTableExpr = ( E.SqlExpr (Entity QualificationUser) + `E.InnerJoin` E.SqlExpr (Entity User) + ) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity LmsUser)) queryQualUser :: QualificationTableExpr -> E.SqlExpr (Entity QualificationUser) queryQualUser = $(sqlIJproj 2 1) . $(sqlLOJproj 2 1) @@ -218,7 +221,7 @@ queryLmsUser :: QualificationTableExpr -> E.SqlExpr (Maybe (Entity LmsUser)) queryLmsUser = $(sqlLOJproj 2 2) -type QualificationTableData = DBRow (Entity QualificationUser, Entity User, Maybe (Entity LmsUser)) +type QualificationTableData = DBRow (Entity QualificationUser, Entity User, Maybe (Entity LmsUser), [Entity UserCompany]) resultQualUser :: Lens' QualificationTableData (Entity QualificationUser) resultQualUser = _dbrOutput . _1 @@ -229,6 +232,9 @@ resultUser = _dbrOutput . _2 resultLmsUser :: Traversal' QualificationTableData (Entity LmsUser) resultLmsUser = _dbrOutput . _3 . _Just +resultCompanyUser :: Lens' QualificationTableData [Entity UserCompany] +resultCompanyUser = _dbrOutput . _4 + instance HasEntity QualificationTableData User where hasEntity = resultUser @@ -242,21 +248,32 @@ data QualificationTableAction | QualificationActBlockSupervisor | QualificationActBlock | QualificationActUnblock - deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) + | QualificationActRenew + | QualificationActGrant + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) instance Universe QualificationTableAction instance Finite QualificationTableAction nullaryPathPiece ''QualificationTableAction $ camelToPathPiece' 2 embedRenderMessage ''UniWorX ''QualificationTableAction id --- Not yet needed, since there is no additional data for now: +{- +isAdminAct :: QualificationTableAction -> Bool +isAdminAct QualificationActExpire = False +isAdminAct QualificationActUnexpire = False +isAdminAct QualificationActBlockSupervisor = False +isAdminAct _ = True +-} + data QualificationTableActionData = QualificationActExpireData | QualificationActUnexpireData | QualificationActBlockSupervisorData - | QualificationActBlockData { qualTableActBlockReason :: Text} + | QualificationActBlockData { qualTableActBlockReason :: Text } | QualificationActUnblockData - deriving (Eq, Ord, Read, Show, Generic) + | QualificationActRenewData + | QualificationActGrantData { qualTableActGrantUntil :: Day } + deriving (Eq, Ord, Read, Show, Generic) isExpiryAct :: QualificationTableActionData -> Bool isExpiryAct QualificationActExpireData = True @@ -284,18 +301,21 @@ qualificationTableQuery qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin` mkQualificationTable :: ( Functor h, ToSortable h - , AsCornice h p QualificationTableData (DBCell (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableData))) cols + , AsCornice h p QualificationTableData (DBCell (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableData))) cols ) => Bool -> Entity Qualification -> Map QualificationTableAction (AForm Handler QualificationTableActionData) - -> cols + -> (Map CompanyId Company -> cols) -> PSValidator (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableData)) -> DB (FormResult (QualificationTableActionData, Set UserId), Widget) mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do svs <- getSupervisees - now <- liftIO getCurrentTime - currentRoute <- fromMaybe (error "mkQualificationTable called from 404-handler") <$> liftHandler getCurrentRoute + now <- liftIO getCurrentTime + -- lookup all companies + cmpMap <- memcachedBy (Just . Right $ 5 * diffMinute) ("CompanyDictionary"::Text) $ do + cmps <- selectList [] [Asc CompanyId] + return $ Map.fromAscList $ fmap (\c -> (entityKey c, entityVal c)) cmps let nowaday = utctDay now mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday @@ -303,13 +323,21 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do dbtIdent :: Text dbtIdent = "qualification" fltrSvs = if isAdmin then const E.true else \quser -> quser E.^. QualificationUserUser `Ex.in_` E.vals svs - dbtSQLQuery q = qualificationTableQuery qid fltrSvs q + dbtSQLQuery = qualificationTableQuery qid fltrSvs dbtRowKey = queryUser >>> (E.^. UserId) - dbtProj = dbtProjId -- FilteredPostId - dbtColonnade = cols + dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr) -> do + -- cmps <- E.select . E.from $ \(usrComp `E.InnerJoin` comp) -> do + -- E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId + -- E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val (entityKey usr) + -- E.orderBy [E.asc (comp E.^. CompanyName)] + -- return (comp E.^. CompanyName, comp E.^. CompanyAvsId, usrComp E.^. UserCompanySupervisor) + cmpUsr <- selectList [UserCompanyUser ==. entityKey usr] [Asc UserCompanyCompany] + return (qualUsr, usr, lmsUsr, cmpUsr) + dbtColonnade = cols cmpMap dbtSorting = mconcat - [ single $ sortUserNameLink queryUser - , single $ sortUserEmail queryUser + [ single $ sortUserNameLink queryUser + , single $ sortUserEmail queryUser + , single $ sortUserMatriclenr queryUser , single ("valid-until" , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil)) , single ("last-refresh" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh)) , single ("blocked-due" , SortColumnNeverNull $ queryQualUser >>> (E.^. QualificationUserBlockedDue)) @@ -317,7 +345,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do -- , single ("lms-status" , SortColumn $ views (to queryLmsUser) (E.?. LmsUserStatus)) , single ("lms-status-plus",SortColumnNeverNull $ \row -> E.coalesce [E.explicitUnsafeCoerceSqlExprValue "timestamp" $ (queryLmsUser row E.?. LmsUserStatus) E.#>>. "{day}" , queryLmsUser row E.?. LmsUserStarted]) - , single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal)) + , single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal)) , single ( "user-company" , SortColumn $ \row -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId @@ -332,6 +360,17 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do E.where_ $ usrAvs E.^. UserAvsUser E.==. queryUser row E.^. UserId E.&&. ((E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.==. (E.explicitUnsafeCoerceSqlExprValue "citext" (usrAvs E.^. UserAvsNoPerson) :: E.SqlExpr (E.Value (CI Text))) )) + , single ("avs-card" , FilterColumn $ \(queryUser -> user) (criterion :: Set.Set Text) -> case readAvsFullCardNo =<< Set.lookupMin criterion of + Nothing -> E.false + Just cardNo -> E.exists $ E.from $ \(avsCard `E.InnerJoin` usrAvs) -> do + E.on $ usrAvs E.^. UserAvsPersonId E.==. avsCard E.^. UserAvsCardPersonId + E.where_ $ usrAvs E.^. UserAvsUser E.==. user E.^. UserId + E.&&. (avsCard E.^. UserAvsCardCardNo E.==. E.val cardNo) + ) + , single ("personal-number", FilterColumn $ \(queryUser -> user) (criteria :: Set.Set Text) -> if + | Set.null criteria -> E.true + | otherwise -> E.any (\c -> user E.^. UserCompanyPersonalNumber `E.hasInfix` E.val c) criteria + ) , single ("user-company", FilterColumn . E.mkExistsFilter $ \row criterion -> E.from $ \(usrComp `E.InnerJoin` comp) -> do let testname = (E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf` @@ -351,8 +390,10 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do ] dbtFilterUI mPrev = mconcat [ fltrUserNameEmailHdrUI MsgLmsUser mPrev - , prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo) - , prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany) + , prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany) + , prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumber) + , prismAForm (singletonFilter "avs-card" ) mPrev $ aopt textField (fslI MsgAvsCardNo) + , prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo) , prismAForm (singletonFilter "validity" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid) , if isNothing mbRenewal then mempty else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal) @@ -372,11 +413,19 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do doEncode' = QualificationTableCsv <$> view (resultUser . _entityVal . _userDisplayName) <*> view (resultUser . _entityVal . _userDisplayEmail) + <*> (view resultCompanyUser >>= getCompanies) + <*> (view resultCompanyUser >>= getCompanyNos) <*> view (resultQualUser . _entityVal . _qualificationUserValidUntil) <*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh) <*> preview (resultQualUser . _entityVal . _qualificationUserBlockedDue . _Just . _qualificationBlockedDay) + <*> view (resultQualUser . _entityVal . _qualificationUserScheduleRenewal) <*> getStatusPlusTxt <*> getStatusPlusDay + getCompanies cmps = case mapMaybe (flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) cmps of + [] -> pure Nothing + somecmps -> pure $ Just $ intercalate ", " $ fmap (view (_companyName . _CI)) somecmps + getCompanyNos = pure . CsvSemicolonList . mapMaybe (preview (_Just . _companyAvsId) . flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) + getStatusPlusTxt = (join . preview (resultLmsUser . _entityVal . _lmsUserStatus)) >>= \case Just LmsBlocked{} -> return $ Just "Failed" @@ -393,7 +442,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do dbtExtraReps = [] dbtParams = DBParamsForm { dbParamsFormMethod = POST - , dbParamsFormAction = Just $ SomeRoute currentRoute + , dbParamsFormAction = Nothing , dbParamsFormAttrs = [] , dbParamsFormSubmit = FormSubmit , dbParamsFormAdditional @@ -419,38 +468,48 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do getQualificationR, postQualificationR :: SchoolId -> QualificationShorthand -> Handler Html getQualificationR = postQualificationR -postQualificationR sid qsh = do - currentRoute <- fromMaybe (error "correctionsR called from 404-handler") <$> getCurrentRoute -- This should never be called from a 404 handler - isAdmin <- hasReadAccessTo AdminR +postQualificationR sid qsh = do + isAdmin <- hasReadAccessTo AdminR + now <- liftIO getCurrentTime + let nowaday = utctDay now ((lmsRes, qualificationTable), Entity qid quali) <- runDB $ do - qent@Entity{entityVal=Qualification{qualificationAuditDuration=auditMonths}} <- getBy404 $ SchoolQualificationShort sid qsh - let acts :: Map QualificationTableAction (AForm Handler QualificationTableActionData) + qent@Entity{entityVal=Qualification{ + qualificationAuditDuration=auditMonths + , qualificationValidDuration=validMonths + }} <- getBy404 $ SchoolQualificationShort sid qsh + + let dayExpiry = flip addGregorianDurationClip nowaday . fromMonths <$> validMonths + acts :: Map QualificationTableAction (AForm Handler QualificationTableActionData) acts = mconcat $ [ singletonMap QualificationActExpire $ pure QualificationActExpireData , singletonMap QualificationActUnexpire $ pure QualificationActUnexpireData ] ++ bool - [ singletonMap QualificationActBlockSupervisor $ pure QualificationActBlockSupervisorData ] -- nonAdmin Supervisor - [ singletonMap QualificationActUnblock $ pure QualificationActUnblockData + [ singletonMap QualificationActBlockSupervisor $ pure QualificationActBlockSupervisorData ] -- nonAdmin actions, ie. Supervisor + [ singletonMap QualificationActUnblock $ pure QualificationActUnblockData -- Admin-only actions , singletonMap QualificationActBlock $ QualificationActBlockData <$> apreq textField (fslI MsgQualificationBlockReason) Nothing + , singletonMap QualificationActRenew $ pure QualificationActRenewData + , singletonMap QualificationActGrant + (QualificationActGrantData <$> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry) ] isAdmin linkLmsUser = toMaybe isAdmin LmsUserR linkUserName = bool ForProfileR ForProfileDataR isAdmin blockedDueCell = bool qualificationBlockedCellNoReason qualificationBlockedCell isAdmin - colChoices = mconcat - [ dbSelect (applying _2) id (return . view (resultUser . _entityKey)) + colChoices cmpMap = mconcat + [ dbSelect (applying _2) id (return . view (hasEntity . _entityKey)) , colUserNameModalHdr MsgLmsUser linkUserName - , colUserEmail - , sortable (Just "user-company") (i18nCell MsgTableCompany) $ \( view $ resultUser . _entityKey -> uid) -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX" - companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do - E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId - E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid - E.orderBy [E.asc (comp E.^. CompanyName)] - return (comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor) - let companies = intersperse (text2markup ", ") $ - (\(E.Value cmpName, E.Value cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> companies' - icnSuper = text2markup " " <> icon IconSupervisor - pure $ toWgt $ mconcat companies + , colUserEmail + , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultCompanyUser -> cmps) -> + let icnSuper = text2markup " " <> icon IconSupervisor + cs = [ (cmpName, cmpSpr) + | Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps + , let cmpEnt = Map.lookup cmpId cmpMap + , Just Company{companyName = cmpName} <- [cmpEnt] + ] + companies = intercalate (text2markup ", ") $ + (\(cmpName, cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> cs + in wgtCell companies + , guardMonoid isAdmin colUserMatriclenr , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \( view $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> dayCell d , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d , sortable (Just "blocked-due") (i18nCell MsgTableQualificationBlockedDue & cellTooltip MsgTableQualificationBlockedTooltipSimple @@ -467,7 +526,15 @@ postQualificationR sid qsh = do tbl <- mkQualificationTable isAdmin qent acts colChoices psValidator return (tbl, qent) - formResult lmsRes $ \case + formResult lmsRes $ \case + (QualificationActRenewData, selectedUsers) | isAdmin -> do + noks <- runDB $ renewValidQualificationUsers qid $ Set.toList selectedUsers + addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks + reloadKeepGetParams $ QualificationR sid qsh + (QualificationActGrantData grantValidday, selectedUsers) | isAdmin -> do + runDB . forM_ selectedUsers $ upsertQualificationUser qid nowaday grantValidday Nothing + addMessageI (if 0 < Set.size selectedUsers then Success else Warning) . MsgTutorialUserGrantedQualification $ Set.size selectedUsers + reloadKeepGetParams $ QualificationR sid qsh (action, selectedUsers) | isExpiryAct action -> do let isUnexpire = action == QualificationActUnexpireData upd <- runDB $ updateWhereCount @@ -476,10 +543,9 @@ postQualificationR sid qsh = do let msgKind = if upd > 0 then Success else Warning msgVal = upd & if isUnexpire then MsgQualificationSetUnexpire else MsgQualificationSetExpire addMessageI msgKind msgVal - redirect currentRoute - (action, selectedUsers) | isBlockAct action && (isAdmin || action == QualificationActBlockSupervisorData) -> do - now <- liftIO getCurrentTime - let nowaday = utctDay now + reloadKeepGetParams $ QualificationR sid qsh + (action, selectedUsers) | isBlockAct action && (isAdmin || action == QualificationActBlockSupervisorData) -> do + let selUserIds = Set.toList selectedUsers qubr = case action of QualificationActUnblockData -> Nothing QualificationActBlockSupervisorData -> Just $ mkQualificationBlocked QualificationBlockReturnedByCompany nowaday @@ -488,7 +554,11 @@ postQualificationR sid qsh = do , qualificationBlockedReason = qualTableActBlockReason } _ -> error "Handle.Qualification.isBlockAct returned non-block action" - oks <- runDB $ qualificationUserBlocking qid (Set.toList selectedUsers) qubr + + oks <- runDB $ do + deleteWhere [UserSupervisorUser <-. selUserIds] + deleteWhere [UserCompanyUser <-. selUserIds] + qualificationUserBlocking qid selUserIds qubr let nrq = length selectedUsers warnLevel = if | oks < 0 -> Error @@ -498,8 +568,8 @@ postQualificationR sid qsh = do | isNothing qubr -> MsgQualificationStatusUnblock | otherwise -> MsgQualificationStatusBlock addMessageI warnLevel $ fbmsg qsh oks nrq - redirect currentRoute - _ -> addMessageI Error MsgUnauthorized + reloadKeepGetParams $ QualificationR sid qsh + _ -> addMessageI Error MsgInvalidFormAction let heading = citext2widget $ qualificationName quali siteLayout heading $ do diff --git a/src/Handler/SAP.hs b/src/Handler/SAP.hs index 5365b00fd..79e69d222 100644 --- a/src/Handler/SAP.hs +++ b/src/Handler/SAP.hs @@ -97,7 +97,8 @@ getQualificationSAPDirectR = do , qual Ex.^. QualificationSapId ) let csvRendered = toCsvRendered sapUserTableCsvHeader $ sapRes2csv qualUsers - fmtOpts = def { csvIncludeHeader = True + fmtOpts = (review csvPreset CsvPresetRFC) + { csvIncludeHeader = True , csvDelimiter = ',' , csvUseCrLf = True } diff --git a/src/Handler/Tutorial/Users.hs b/src/Handler/Tutorial/Users.hs index b32f1aeb8..207bc1731 100644 --- a/src/Handler/Tutorial/Users.hs +++ b/src/Handler/Tutorial/Users.hs @@ -66,7 +66,7 @@ postTUsersR tid ssh csh tutn = do tutEnt@(Entity tutid _) <- fetchTutorial tid ssh csh tutn qualifications <- getCourseQualifications cid now <- liftIO getCurrentTime - let minDur :: Maybe Int = minimumMaybe $ catMaybes (view _qualificationValidDuration <$> qualifications) -- no instance Ord CalendarDiffDays + let minDur :: Maybe Int = minimumMaybe $ mapMaybe (view _qualificationValidDuration) qualifications -- no instance Ord CalendarDiffDays dayExpiry = flip addGregorianDurationClip (utctDay now) . fromMonths <$> minDur colChoices = mconcat $ catMaybes [ pure $ dbSelect (applying _2) id (return . view (hasEntity . _entityKey)) diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 2c68d028a..6c830642d 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de> +-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de> -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -45,7 +45,7 @@ import Auth.Dummy (apDummy) hijackUserForm :: Form () -hijackUserForm csrf = do +hijackUserForm = \csrf -> do (btnResult, btnView) <- mopt (buttonField BtnHijack) "" Nothing return (btnResult >>= guard . is _Just, mconcat [toWidget csrf, fvWidget btnView]) @@ -100,7 +100,7 @@ postUsersR = do (AdminUserR <$> encrypt uid) (nameWidget userDisplayName userSurname) , sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \DBRow{ dbrOutput = entUsr } -> cellHasMatrikelnummerLinked entUsr - , sortable (Just "user-company") (i18nCell MsgTableCompany) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX" + , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX" companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid @@ -334,7 +334,7 @@ postUsersR = do , dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } , dbtParams = DBParamsForm { dbParamsFormMethod = POST - , dbParamsFormAction = Just $ SomeRoute UsersR + , dbParamsFormAction = Nothing -- Just $ SomeRoute (UsersR, [("users-user-company","fraport")]) , dbParamsFormAttrs = [] , dbParamsFormSubmit = FormSubmit , dbParamsFormAdditional @@ -351,21 +351,21 @@ postUsersR = do , dbtExtraReps = [] } + -- $logInfoS "UsersFormResult" $ tshow usersRes formResult usersRes $ \case (act, usersSet) - | Set.null usersSet && isNotSetSupervisor act -> do - addMessageI Info MsgActionNoUsersSelected - redirect UsersR + | Set.null usersSet && isNotSetSupervisor act -> + addMessageI Info MsgActionNoUsersSelected (UserLdapSyncData, userSet) -> do runDBJobs . forM_ userSet $ \uid -> queueDBJob $ JobSynchroniseLdapUser uid - addMessageI Success . MsgSynchroniseLdapUserQueued $ Set.size userSet - redirect UsersR + addMessageI Success . MsgSynchroniseLdapUserQueued $ Set.size userSet + redirectKeepGetParams UsersR (UserHijack, Set.minView -> Just (uid, _)) -> hijackUser uid >>= sendResponse (UserRemoveSupervisorData, userSet) -> do runDB $ deleteWhere [UserSupervisorUser <-. Set.toList userSet] addMessageI Success $ MsgUsersRemoveSupervisors $ Set.size userSet - redirect UsersR + redirectKeepGetParams UsersR (act, usersSet) | isActionSupervisor act -> do avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser $ getActionSupervisors act @@ -382,8 +382,8 @@ postUsersR = do if nrSuperNotFound > 0 then addMessageI Warning $ MsgUsersChangeSupervisorsWarning (Set.size usersSet) (length supersFound) nrSuperNotFound else addMessageI Success $ MsgUsersChangeSupervisorsSuccess (Set.size usersSet) (length supersFound) - redirect UsersR - _other -> error "Should not be possible" + redirectKeepGetParams UsersR + _other -> addMessageI Error MsgInvalidFormAction ((allUsersRes, allUsersWgt), allUsersEnctype) <- runFormPost . identifyForm FIDAllUsersAction $ buttonForm @@ -563,8 +563,8 @@ postAdminUserR uuid = do redirect $ AdminUserR uuid let assimilateForm' = renderAForm FormStandard $ areq (checkMap (first $ const MsgAssimilateUserNotFound) Right $ userField False Nothing) (fslI MsgUserAssimilateUser) Nothing - assimilateAction oldUserId = do - res <- try . runDB . setSerializable $ assimilateUser uid oldUserId + assimilateAction newUserId = do + res <- try . runDB . setSerializable $ assimilateUser newUserId uid case res of Left (err :: UserAssimilateException) -> addMessageModal Error (i18n MsgAssimilateUserHaveError) $ Right @@ -583,7 +583,8 @@ postAdminUserR uuid = do #{tshow warning} |] addMessageI Success MsgAssimilateUserSuccess - redirect $ AdminUserR uuid + newUuid <- encrypt newUserId + redirect $ AdminUserR newUuid ((rightsResult, rightsFormWidget), rightsFormEnctype) <- runFormPost . identifyForm FIDUserRights $ userRightsForm ((authResult, authFormWidget), authFormEnctype) <- runFormPost . identifyForm FIDUserAuthentication $ userAuthenticationForm ((systemFunctionsResult, systemFunctionsWidget), systemFunctionsEnctype) <- runFormPost . identifyForm FIDUserSystemFunctions $ renderAForm FormStandard systemFunctionsForm' diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index 1ff03ffde..d13be8cee 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de> +-- SPDX-FileCopyrightText: 2023 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de> -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -137,3 +137,22 @@ redirectAlternatives = go Just xs' -> over _1 (x :) $ nunsnoc xs' nsnoc [] x = x :| [] nsnoc (x' : xs) x = x' :| (xs ++ [x]) + +-- | redirect to currentRoute, if Just otherwise to given default +reload :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route (HandlerSite m) -> m a +reload r = getCurrentRoute >>= redirect . fromMaybe r + +-- | like `reload`, preserving all GET parameters +reloadKeepGetParams :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route (HandlerSite m) -> m a +reloadKeepGetParams r = liftHandler $ do + getps <- reqGetParams <$> getRequest + route <- fromMaybe r <$> getCurrentRoute + -- addMessage Info $ toHtml (show getps) -- DEBUG ONLY + -- RECALL: redirect GET parameters are used like so: -- redirect (UsersR, [("users-user-company","fraport")]) + redirect (route, getps) + +-- | redirect preserving all GET parameters +redirectKeepGetParams :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route (HandlerSite m) -> m a +redirectKeepGetParams route = liftHandler $ do + getps <- reqGetParams <$> getRequest + redirect (route, getps) \ No newline at end of file diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index b3e3dfd8f..3a6083fae 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -339,12 +339,16 @@ guessAvsUser (Text.splitAt 6 -> ("AVSNO:", avsnoTxt)) = ifMaybeM (readMay avsnoT _ -> return Nothing guessAvsUser someid = do let maybeUpsertAvsUserByCard = maybeCatchAll . upsertAvsUserByCard - extractUid (Entity _ UserAvs{userAvsUser=uid}) = return $ Just uid - extractUidCard (Entity _ UserAvsCard{userAvsCardPersonId=avid}) = getBy $ UniqueUserAvsId avid case discernAvsCardPersonalNo someid of - Just cid@(Left cardNo) -> - maybeM (maybeUpsertAvsUserByCard cid) extractUid $ runDB $ - maybeM (return Nothing) extractUidCard $ getBy $ UniqueAvsCard cardNo + Just cid@(Left _cardNo) -> maybeUpsertAvsUserByCard cid + -- NOTE: card validity might be outdated, so we must always check with avs + -- maybeM (maybeUpsertAvsUserByCard cid) extractUid $ runDB $ do + -- let extractUid (Entity _ UserAvs{userAvsUser=uid}) = return $ Just uid + -- extractUidCard UserAvsCard{userAvsCardPersonId=avid} = getBy $ UniqueUserAvsId avid + -- cards <- selectList [UserAvsCardCardNo ==. cardNo] [] + -- case [c | cent <- cards, let c = entityVal cent, avsDataValid (userAvsCardCard c)] of + -- [justOneCard] -> maybeM (return Nothing) extractUidCard (return $ Just justOneCard) + -- _ -> return Nothing Just cid@(Right _wholeNumber) -> maybeUpsertAvsUserByCard cid >>= \case Nothing -> @@ -493,15 +497,16 @@ upsertAvsUserById api = do [UserPinPassword =. userPin] insert_ $ UserAvsCard api (getFullCardNo pCard) pCard now upsertUserCompany uid mbCompany userFirmAddr - forM_ avsPersonPersonCards $ \aCard -> void $ upsert UserAvsCard + forM_ avsPersonPersonCards $ \aCard -> do + let fcn = getFullCardNo aCard + -- probably not efficient, but fixes the problem that AvsCardNo is not unique as assumed before and may get reused + deleteWhere [UserAvsCardCardNo ==. fcn] + insert_ $ UserAvsCard { userAvsCardPersonId = api - , userAvsCardCardNo = getFullCardNo aCard + , userAvsCardCardNo = fcn , userAvsCardCard = aCard , userAvsCardLastSynch = now } - [ UserAvsCardCard =. aCard - , UserAvsCardLastSynch =. now - ] return $ Just uid diff --git a/src/Handler/Utils/DateTime.hs b/src/Handler/Utils/DateTime.hs index a29ff5f6b..80669b061 100644 --- a/src/Handler/Utils/DateTime.hs +++ b/src/Handler/Utils/DateTime.hs @@ -8,7 +8,8 @@ module Handler.Utils.DateTime ( utcToLocalTime, utcToZonedTime , localTimeToUTC, TZ.LocalToUTCResult(..), localTimeToUTCSimple , toTimeOfDay - , toMidnight, beforeMidnight, toMidday, toMorning, addHours + , toMidnight, beforeMidnight, toMidday, toMorning + , toFullHour, roundDownToMinutes, addHours , formatDiffDays, formatCalendarDiffDays , formatTime' , formatTime, formatTimeUser, formatTimeW, formatTimeMail @@ -68,6 +69,18 @@ toMidnight = toTimeOfDay 0 0 0 toMidday :: Day -> UTCTime toMidday = toTimeOfDay 12 0 0 +-- | Round up to next full hour +toFullHour :: UTCTime -> UTCTime +toFullHour t = t{utctDayTime=rounded} + where + rounded = fromInteger $ 3600 * (1 + (truncate (utctDayTime t) `div` 3600)) + +roundDownToMinutes :: Integer -> UTCTime -> UTCTime +roundDownToMinutes f t = t{utctDayTime=rounded} + where + rounded = fromInteger $ factor * (truncate (utctDayTime t) `div` factor) + factor = 60 * f + -- | One second before the end of day beforeMidnight :: Day -> UTCTime beforeMidnight = toTimeOfDay 23 59 59 diff --git a/src/Handler/Utils/LMS.hs b/src/Handler/Utils/LMS.hs index 5d815669e..4eeb608fe 100644 --- a/src/Handler/Utils/LMS.hs +++ b/src/Handler/Utils/LMS.hs @@ -45,7 +45,8 @@ getLmsCsvDecoder :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m, From getLmsCsvDecoder = do LmsConf{..} <- getsYesod $ view _appLmsConf if | Just upDelim <- lmsUploadDelimiter -> do - let fmtOpts = def { csvDelimiter = upDelim + let fmtOpts = (review csvPreset CsvPresetRFC) + { csvDelimiter = upDelim , csvIncludeHeader = lmsUploadHeader } csvOpts = def { csvFormat = fmtOpts } diff --git a/src/Handler/Utils/Qualification.hs b/src/Handler/Utils/Qualification.hs index 1e8302ecf..c259e9867 100644 --- a/src/Handler/Utils/Qualification.hs +++ b/src/Handler/Utils/Qualification.hs @@ -137,4 +137,35 @@ qualificationUserBlocking qid uids qb = do , transactionUser = uid , transactionQualificationBlock = qb } + return $ fromIntegral oks + +qualificationUserUnblockByReason :: + ( AuthId (HandlerSite m) ~ Key User + , IsPersistBackend (YesodPersistBackend (HandlerSite m)) + , BaseBackend (YesodPersistBackend (HandlerSite m)) ~ SqlBackend + , BackendCompatible SqlBackend (YesodPersistBackend (HandlerSite m)) + , PersistQueryWrite (YesodPersistBackend (HandlerSite m)) + , PersistUniqueWrite (YesodPersistBackend (HandlerSite m)) + , HasInstanceID (HandlerSite m) InstanceId + , YesodAuthPersist (HandlerSite m) + , HasAppSettings (HandlerSite m) + , MonadHandler m + , MonadCatch m + , Num n + ) => QualificationId -> [UserId] -> Text -> ReaderT (YesodPersistBackend (HandlerSite m)) m n +qualificationUserUnblockByReason qid uids reason = do + blockedUsers <- selectList [ QualificationUserQualification ==. qid + , QualificationUserBlockedDue !=. Nothing + , QualificationUserUser <-. uids + ] [Asc QualificationUserId] + let toUnblock = filter (\quent -> Just reason == quent ^? _entityVal . _qualificationUserBlockedDue . _Just . _qualificationBlockedReason) blockedUsers + oks <- updateWhereCount [ QualificationUserId <-. (view _entityKey <$> toUnblock) ] + [ QualificationUserBlockedDue =. Nothing ] + forM_ toUnblock $ \ubl -> do + audit TransactionQualificationUserBlocking + { -- transactionQualificationUser = quid + transactionQualification = qid + , transactionUser = ubl ^. _entityVal . _qualificationUserUser + , transactionQualificationBlock = Nothing + } return $ fromIntegral oks \ No newline at end of file diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs index 473b3c484..07a122af2 100644 --- a/src/Handler/Utils/Table/Columns.hs +++ b/src/Handler/Utils/Table/Columns.hs @@ -718,7 +718,7 @@ fltrRelevantStudyFeaturesSemesterUI = fltrFeaturesSemesterUI {- -- colUserCompany :: (HandlerSite (DBCell m) ~ UniWorX, IsDBTable m c, HasEntity a User) => Colonnade Sortable a (DBCell m c) -colUserCompany = sortable (Just "user-company") (i18nCell MsgTableCompany) $ \heu -> do +colUserCompany = sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \heu -> do let uid = heu ^. hasEntity . _entityKey companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid @@ -732,7 +732,7 @@ colUserCompany = sortable (Just "user-company") (i18nCell MsgTableCompany) $ \he -- PROBLEM: how to type sqlCell compatible with dbTable that as actions, i.e. MForm instead of YesodDB? colUserCompany :: (IsDBTable (YesodDB UniWorX) c, HasEntity a User) => Colonnade Sortable a (DBCell (YesodDB UniWorX) c) -colUserCompany = sortable (Just "user-company") (i18nCell MsgTableCompany) $ \heu -> +colUserCompany = sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \heu -> let uid = heu ^. hasEntity . _entityKey in sqlCell $ do companies' <- E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 10b90e28f..d3852d2eb 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -716,6 +716,7 @@ dbtProjId' :: forall fs r r'. => ReaderT (DBTProjCtx fs r) (MaybeT (ReaderT SqlBackend (HandlerFor UniWorX))) r' dbtProjId' = view _dbtProjRow +-- | Reicht das Ergebnis der SQL-Abfrage direkt durch an colonnade und csv dbtProjId :: forall fs r r'. ( fs ~ (), DBRow r ~ r' ) => ReaderT (DBTProjCtx fs r) (MaybeT (ReaderT SqlBackend (HandlerFor UniWorX))) r' @@ -727,6 +728,7 @@ dbtProjSimple' :: forall fs r r' r''. -> ReaderT (DBTProjCtx fs r) (MaybeT (ReaderT SqlBackend (HandlerFor UniWorX))) r' dbtProjSimple' cont = (views _dbtProjRow . set _dbrOutput) <=< (hoist lift . magnify (_dbtProjRow . _dbrOutput)) $ lift . cont =<< ask +-- | Transformation des SQL Ergbnistyp vor dem Weiterreichen an colonnade oder csv durch eine einfache monadische Funktion dbtProjSimple :: forall fs r r' r''. ( fs ~ (), DBRow r'' ~ r' ) => (r -> DB r'') @@ -743,11 +745,14 @@ withFilteredPost proj = do guardM . lift . lift $ p r' return r' +-- | Wie `dbtProjId` plus zusätzliches Filtern der SQL-Abfrage in Haskell +-- Nur zu Verwenden, wenn Filter mit mkFilterProjectedPost verwendet werden; ein Typfehler weist daraufhin, wenn dies nötig ist! dbtProjFilteredPostId :: forall fs r r'. ( fs ~ DBTProjFilterPost r', DBRow r ~ r' ) => ReaderT (DBTProjCtx fs r) (MaybeT (ReaderT SqlBackend (HandlerFor UniWorX))) r' dbtProjFilteredPostId = withFilteredPost dbtProjId' +-- | Kombination aus `dbtProjFilteredPostId` und `dbtProjSimple`, d.h. Ergeniszeilen in Haskell transformieren und filtern dbtProjFilteredPostSimple :: forall fs r r' r''. ( fs ~ DBTProjFilterPost r', DBRow r'' ~ r' ) => (r -> DB r'') @@ -964,7 +969,7 @@ instance Monoid' x => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) En instance Default (DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) x) where def = DBParamsForm { dbParamsFormMethod = POST - , dbParamsFormAction = Nothing + , dbParamsFormAction = Nothing -- Recall: Nothing preserves GET Parameters , dbParamsFormAttrs = [] , dbParamsFormSubmit = FormSubmit , dbParamsFormAdditional = \_ -> return (pure (), mempty) diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index 512291970..f583e65b1 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -18,6 +18,7 @@ module Handler.Utils.Users , getPostalAddress, getPostalPreferenceAndAddress , abbrvName , getReceivers + , getSupervisees ) where import Import @@ -34,7 +35,7 @@ import qualified Data.Aeson as JSON import qualified Data.Aeson.Types as JSON import qualified Data.Set as Set -import qualified Data.List as List +-- import qualified Data.List as List import qualified Data.CaseInsensitive as CI import qualified Database.Esqueleto.Legacy as E @@ -110,6 +111,13 @@ getReceivers uid = do then directResult else return (underling, receivers, uid `elem` (entityKey <$> receivers)) +-- | return underlings for currently logged in user +getSupervisees :: DB (Set UserId) +getSupervisees = do + uid <- requireAuthId + svs <- userSupervisorUser . entityVal <<$>> selectList [UserSupervisorSupervisor ==. uid] [Asc UserSupervisorUser] + return $ Set.insert uid $ Set.fromAscList svs + computeUserAuthenticationDigest :: AuthenticationMode -> Digest SHA3_256 computeUserAuthenticationDigest = hashlazy . JSON.encode @@ -287,6 +295,16 @@ assimilateUser :: UserId -- ^ @newUserId@ -- -- Fatal errors are thrown, non-fatal warnings are returned assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do + -- retrieve user entities first, to ensure they both exist + (oldUserEnt, newUserEnt) <- do + oldUser <- getEntity oldUserId + newUser <- getEntity newUserId + case (oldUser, newUser) of + (Just old, Just new) -> return (old,new) + _ -> tellError UserAssimilateCouldNotDetermineUserIdents + let oldUser = oldUserEnt ^. _entityVal + newUser = newUserEnt ^. _entityVal + E.insertSelectWithConflict UniqueCourseFavourite (E.from $ \courseFavourite -> do @@ -859,18 +877,56 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do (\current _excluded -> [ UserCompanySupervisor E.=. (current E.^. UserCompanySupervisor)] ) deleteWhere [ UserCompanyUser ==. oldUserId] - userIdents <- E.select . E.from $ \user -> do - E.where_ $ user E.^. UserId `E.in_` E.valList [newUserId, oldUserId] - return ( user E.^. UserId - , user E.^. UserIdent - ) - case (,) <$> List.lookup (E.Value oldUserId) userIdents <*> List.lookup (E.Value newUserId) userIdents of - Just (E.Value oldIdent, E.Value newIdent') - | oldIdent /= newIdent' -> audit $ TransactionUserIdentChanged oldIdent newIdent' - | otherwise -> return () - _other -> tellError UserAssimilateCouldNotDetermineUserIdents + mbOldAvsId <- getBy $ UniqueUserAvsUser oldUserId + mbNewAvsId <- getBy $ UniqueUserAvsUser newUserId + case (mbOldAvsId,mbNewAvsId) of + (Nothing, _) + -> return () + (Just Entity{entityVal=UserAvs{userAvsPersonId=oldAvsId}}, Just _) + -> deleteWhere [UserAvsCardPersonId ==. oldAvsId] >> deleteBy (UniqueUserAvsUser oldUserId) + (Just Entity{entityVal=oldUserAvs}, Nothing) + -> -- deleteBy $ UniqueUserAvsUser oldUserId -- maybe we need this due to double uniqueness?! + void $ upsertBy (UniqueUserAvsId (oldUserAvs ^. _userAvsPersonId)) oldUserAvs{userAvsUser=newUserId} [UserAvsUser =. newUserId] + + -- merge some optional / incomplete user fields + let mergeBy :: forall a . PersistField a => (a -> a -> Bool) -> EntityField User a -> Maybe (Update User) + mergeBy cmp uf = let ufl = fieldLens uf + oldV = oldUserEnt ^. ufl + newV = newUserEnt ^. ufl + in toMaybe (cmp oldV newV) (uf =. oldV) + + mergeMaybe :: forall b . PersistField b => EntityField User (Maybe b) -> Maybe (Update User) + mergeMaybe = mergeBy (\oldV newV -> isNothing newV && isJust oldV) + + update newUserId $ catMaybes -- NOTE: persist does shortcircuit null updates as expected + [ mergeMaybe UserLdapPrimaryKey + , mergeBy (<) UserAuthentication + , mergeBy (>) UserLastAuthentication + , mergeBy (<) UserCreated + , toMaybe (not (validEmail' (newUser ^. _userEmail )) && validEmail' (oldUser ^. _userEmail)) + (UserEmail =. oldUser ^. _userEmail) + , toMaybe (not (validEmail' (newUser ^. _userDisplayEmail)) && validEmail' (oldUser ^. _userDisplayEmail)) + (UserDisplayEmail =. oldUser ^. _userDisplayEmail) + , mergeMaybe UserMatrikelnummer + , toMaybe (isNothing (newUser ^. _userPostAddress) && isJust (oldUser ^. _userPostAddress)) + (UserPostAddress =. oldUser ^. _userPostAddress) + , toMaybe (isNothing (newUser ^. _userPostAddress) && isJust (oldUser ^. _userPostAddress)) + (UserPostLastUpdate =. oldUser ^. _userPostLastUpdate) + , toMaybe ((isJust (newUser ^. _userPostAddress) || isJust (oldUser ^. _userPostAddress)) + && (newUser ^. _userPrefersPostal || oldUser ^. _userPrefersPostal)) + (UserPrefersPostal =. True) + , mergeMaybe UserPinPassword + , mergeMaybe UserLanguages + , mergeMaybe UserSex + , mergeMaybe UserBirthday + , mergeMaybe UserTelephone + , mergeMaybe UserMobile + ] delete oldUserId + let oldUsrIdent = oldUser ^. _userIdent + newUsrIdent = newUser ^. _userIdent + when (oldUsrIdent /= newUsrIdent) $ audit $ TransactionUserIdentChanged oldUsrIdent newUsrIdent audit $ TransactionUserAssimilated newUserId oldUserId where tellWarning :: UserAssimilateExceptionReason -> ReaderT SqlBackend (WriterT (Set UserAssimilateException) Handler) () diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 36e668a08..074a3b866 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -217,7 +217,7 @@ dispatchJobLmsResults qid = JobHandlerAtomic act return (quser, luser, lresult) now <- liftIO getCurrentTime let locDay = localDay $ TZ.utcToLocalTimeTZ appTZ now - forM_ results $ \(Entity _quid QualificationUser{..}, Entity luid LmsUser{..}, Entity lrid LmsResult{..}) -> do + forM_ results $ \(Entity quid QualificationUser{..}, Entity luid LmsUser{..}, Entity lrid LmsResult{..}) -> do -- three separate DB operations per result is not so nice. All within one transaction though. let lmsUserStartedDay = localDay $ TZ.utcToLocalTimeTZ appTZ lmsUserStarted saneDate = lmsResultSuccess `inBetween` (lmsUserStartedDay, min qualificationUserValidUntil locDay) @@ -226,15 +226,18 @@ dispatchJobLmsResults qid = JobHandlerAtomic act -- newValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) qualificationUserValidUntil -- renew from old validUntil onwards note <- if saneDate && replaceLmsStatus lmsUserStatus newStatus then do - _ok <- renewValidQualificationUsers qid [qualificationUserUser] -- blocked remains unaffected + _ok <- renewValidQualificationUsers qid [qualificationUserUser] -- ignores possible blocks -- when (ok==1) $ update luid -- we end lms regardless of wether a regular renewal was successful, since BPol users may simultaneoysly have on-premise renewal courses and E-Learnings + + -- WORKAROUND LMS-Bug [supposedly fixed now, but isnt]: sometimes we receive success and failure simultaneously; success is correct, hence we must unblock if the reason was e-learning + -- _ok <- qualificationUserUnblockByReason qid [qualificationUserUser] (qualificationBlockedReasonText QualificationBlockFailedELearning) -- affects audit log + when (Just (qualificationBlockedReasonText QualificationBlockFailedELearning) == qualificationUserBlockedDue ^? _Just . _qualificationBlockedReason) $ + update quid [ QualificationUserBlockedDue =. Nothing ] + update luid [ LmsUserStatus =. newStatus , LmsUserReceived =. Just lmsResultTimestamp ] - -- WORKAROUND LMS-Bug [supposedly fixed now]: sometimes we receive success and failure simultaneously; success is correct, hence we must unblock if the reason was e-learning - -- when (Just (qualificationBlockedReasonText QualificationBlockFailedELearning) == qUsr ^? _qualificationUserBlockedDue . _Just . _qualificationBlockedReason) $ - -- update quid [ QualificationUserBlockedDue =. Nothing ] return Nothing else do let errmsg = [st|LMS success with insane date #{tshow lmsResultSuccess} received for #{tshow lmsUserIdent}|] diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs index bd9aaa0e9..a12980ed6 100644 --- a/src/Model/Types/Avs.hs +++ b/src/Model/Types/Avs.hs @@ -197,6 +197,7 @@ discernAvsCardPersonalNo _ = Nothing newtype AvsPersonId = AvsPersonId { avsPersonId :: Int } -- untagged Int deriving (Eq, Ord, Generic) deriving newtype (NFData, PathPiece, PersistField, PersistFieldSql, Csv.ToField, Csv.FromField, Hashable, Binary) +-- TODO: consider using "makeWrapped ''AvsPersonId" instance E.SqlString AvsPersonId -- As opposed to AvsObjPersonId, AvsPersonId is an untagged Int with respect to FromJSON/ToJSON, as needed by AVS API; instance FromJSON AvsPersonId where @@ -590,6 +591,7 @@ deriveJSON defaultOptions type AvsResponseStatus :: Type newtype AvsResponseStatus = AvsResponseStatus (Set AvsStatusPerson) deriving (Eq, Ord, Show, Generic) +makeWrapped ''AvsResponseStatus deriveJSON defaultOptions { fieldLabelModifier = dropCamel 2 , omitNothingFields = True @@ -601,6 +603,7 @@ instance Semigroup AvsResponseStatus where newtype AvsResponsePerson = AvsResponsePerson (Set AvsDataPerson) deriving (Eq, Ord, Show, Generic) +-- makeWrapped ''AvsResponsePerson deriveJSON defaultOptions { fieldLabelModifier = dropCamel 2 , omitNothingFields = True @@ -610,6 +613,7 @@ deriveJSON defaultOptions newtype AvsResponseContact = AvsResponseContact (Set AvsDataContact) deriving (Eq, Ord, Show, Generic) +makeWrapped ''AvsResponseContact deriveJSON defaultOptions { fieldLabelModifier = dropCamel 2 , omitNothingFields = True @@ -666,10 +670,12 @@ deriveJSON defaultOptions newtype AvsQueryStatus = AvsQueryStatus (Set AvsPersonId) deriving (Eq, Ord, Show, Generic) deriveJSON defaultOptions ''AvsQueryStatus +makeWrapped ''AvsQueryStatus newtype AvsQueryContact = AvsQueryContact (Set AvsObjPersonId) -- note the difference to AvsQueryStatus, which receives a list of id, whereas here we sent a list of single-field object deriving (Eq, Ord, Show, Generic) deriveJSON defaultOptions ''AvsQueryContact +makeWrapped ''AvsQueryContact newtype AvsQueryGetLicences = AvsQueryGetLicences AvsObjPersonId -- this should have been a set, but the specification was implemented differently deriving (Eq, Ord, Show, Generic) diff --git a/src/Model/Types/Csv.hs b/src/Model/Types/Csv.hs index 794bb0b8b..159339062 100644 --- a/src/Model/Types/Csv.hs +++ b/src/Model/Types/Csv.hs @@ -85,7 +85,8 @@ instance Default CsvOptions where } instance Default CsvFormatOptions where - def = csvPreset # CsvPresetRFC + def = csvPreset # CsvPresetRFC -- DO NOT CHANGE! + -- Changing the default to CsvPresetXlsx will cause internal server errors due to partial record selectors failing, like `csvIncludeHeader` data CsvPreset = CsvPresetRFC | CsvPresetXlsx diff --git a/src/Utils/Avs.hs b/src/Utils/Avs.hs index 00580b26a..9f19af2b6 100644 --- a/src/Utils/Avs.hs +++ b/src/Utils/Avs.hs @@ -32,10 +32,10 @@ type AVSGetRampLicences = "RampDrivingLicenceInfo" :> ReqBody '[JSON] AvsQueryG type AVSSetRampLicences = "RampDrivingLicence" :> ReqBody '[JSON] AvsQuerySetLicences :> Post '[JSON] AvsResponseSetLicences avsMaxSetLicenceAtOnce :: Int -avsMaxSetLicenceAtOnce = 90 -- maximum input set size for avsQuerySetLicences as enforced by AVS +avsMaxSetLicenceAtOnce = 80 -- maximum input set size for avsQuerySetLicences as enforced by AVS -avsMaxGetStatusAtOnce :: Int -avsMaxGetStatusAtOnce = 900 -- maximum input set size for avsQueryStatus as enforced by AVS +avsMaxQueryAtOnce :: Int +avsMaxQueryAtOnce = 500 -- maximum input set size for avsQueryStatus as enforced by AVS avsApi :: Proxy AVS @@ -78,10 +78,10 @@ mkAvsQuery _ _ _ = AvsQuery } #else mkAvsQuery baseUrl basicAuth cliEnv = AvsQuery - { avsQueryPerson = \q -> liftIO $ catch404toEmpty <$> runClientM (rawQueryPerson q) cliEnv - , avsQueryStatus = \q -> liftIO $ runClientM (splitQueryStatus q) cliEnv - , avsQueryContact = \q -> liftIO $ runClientM (rawQueryContact q) cliEnv - , avsQuerySetLicences = \q -> liftIO $ runClientM (rawQuerySetLicences q) cliEnv + { avsQueryPerson = \q -> liftIO $ catch404toEmpty <$> runClientM (rawQueryPerson q) cliEnv + , avsQueryStatus = \q -> liftIO $ runClientM (splitQuery rawQueryStatus q) cliEnv + , avsQueryContact = \q -> liftIO $ runClientM (splitQuery rawQueryContact q) cliEnv + , avsQuerySetLicences = \q -> liftIO $ runClientM (rawQuerySetLicences q) cliEnv -- TODO: currently uses setLicencesAvs for splitting to ensure return of correctly set licences -- , avsQueryGetLicences = \q -> liftIO $ runClientM (rawQueryGetLicences q) cliEnv , avsQueryGetAllLicences = liftIO $ runClientM (rawQueryGetLicences avsQueryAllLicences) cliEnv } @@ -96,25 +96,18 @@ mkAvsQuery baseUrl basicAuth cliEnv = AvsQuery | baseUrl == base = Right $ AvsResponsePerson mempty -- WORKAROUND: AVS server erroneously returns 404 if no matching person could be found in its database! catch404toEmpty other = other - -- TODO: make a generic implementation for this - splitQueryStatus :: AvsQueryStatus -> ClientM AvsResponseStatus - splitQueryStatus q@(AvsQueryStatus avids) - | Set.size avids <= avsMaxGetStatusAtOnce = rawQueryStatus q - | otherwise = do - let (avid_1,avid_2) = Set.splitAt avsMaxGetStatusAtOnce avids - res1 <- rawQueryStatus (AvsQueryStatus avid_1) - res2 <- splitQueryStatus (AvsQueryStatus avid_2) - return $ res1 <> res2 - - -- splitQuery :: (a -> Set b) -> (Set b -> a) -> (a -> ClientM c) -> a -> ClientM c - -- splitQuery toSet fromSet rawQuery q - -- | Set.size (toSet q) <= avsMaxGetStatusAtOnce = rawQueryStatus q - -- | otherwise = do - -- let (fromSet -> avid_1,fromSet -> avid_2) = Set.splitAt avsMaxGetStatusAtOnce (toSet q) - -- res1 <- rawQuery avid_1 - -- res2 <- splitQuery toSet fromSet rawQuery avid_2 - -- return $ fromSet (toSet res1 <> toSet res2) - +splitQuery :: (Wrapped a, Wrapped c, Unwrapped a ~ Set b, Semigroup (Unwrapped c)) + => (a -> ClientM c) -> a -> ClientM c +splitQuery rawQuery q + | avsMaxQueryAtOnce >= Set.size s = rawQuery q + | otherwise = do + -- $logInfoS "AVS" $ "Splitting large query for input Set " <> tshow (Set.size s) -- would require MonadLogger ClientM + let (avsid1, avsid2) = Set.splitAt avsMaxQueryAtOnce s + res1 <- rawQuery $ view _Unwrapped' avsid1 + res2 <- splitQuery rawQuery $ view _Unwrapped' avsid2 + return $ view _Unwrapped' (res1 ^. _Wrapped' <> res2 ^. _Wrapped') + where + s = view _Wrapped' q #endif ----------------------- diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 9ad82b29f..1dfdc2703 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Felix Hamann <felix.hamann@campus.lmu.de>,Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Wolfgang Witt <Wolfgang.Witt@campus.lmu.de> +-- SPDX-FileCopyrightText: 2023 Felix Hamann <felix.hamann@campus.lmu.de>,Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Wolfgang Witt <Wolfgang.Witt@campus.lmu.de> -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -307,7 +307,8 @@ data FormIdentifier | FIDAvsQueryLicence | FIDAvsSetLicence | FIDBtnAvsImportUnknown - | FIDBtnAvsRevokeUnknown + | FIDBtnAvsRevokeUnknown + | FIDHijackUser deriving (Eq, Ord, Read, Show) instance PathPiece FormIdentifier where @@ -1089,6 +1090,7 @@ wrapForm' :: Button site button => button -> WidgetT site IO () -> FormSettings wrapForm' btn formWidget FormSettings{..} = do formId <- maybe newIdent (return . toPathPiece) formAnchor formActionUrl <- traverse toTextUrl formAction + let hasAction = isJust formActionUrl $(widgetFile "widgets/form/form") diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 8d8108ee5..2375e3f3c 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -128,7 +128,7 @@ makeClassyFor_ ''LmsResult makeClassyFor_ ''UserAvs makeClassyFor_ ''UserAvsCard -makeClassyFor_ ''UserCompany +makeLenses_ ''UserCompany makeLenses_ ''Company _entityKey :: Getter (Entity record) (Key record) diff --git a/src/Utils/Print.hs b/src/Utils/Print.hs index 7bd9e2c5d..c4cef4499 100644 --- a/src/Utils/Print.hs +++ b/src/Utils/Print.hs @@ -16,8 +16,11 @@ module Utils.Print -- , compileTemplate, makePDF , _Meta, addMeta , toMeta, mbMeta -- single values - , mkMeta, appMeta, applyMetas -- multiple values + , mkMeta, appMeta, applyMetas -- multiple values + -- , MDMail + -- , MDLetter , LetterRenewQualificationF(..) + , LetterExpireQualificationF(..) -- , LetterCourseCertificate() , makeCourseCertificates ) where @@ -42,6 +45,7 @@ import Text.Hamlet import System.Exit import System.Process.Typed -- for calling pdftk for pdf encryption +import Handler.Utils.Memcached import Handler.Utils.Users import Handler.Utils.DateTime import Handler.Utils.Mail @@ -49,8 +53,10 @@ import Handler.Utils.Widgets (nameHtml') import Handler.Utils.Avs (updateReceivers) import Jobs.Handler.SendNotification.Utils +import Utils.Print.Instances () import Utils.Print.Letters import Utils.Print.RenewQualification +import Utils.Print.ExpireQualification import Utils.Print.CourseCertificate @@ -108,31 +114,34 @@ import Utils.Print.CourseCertificate -- | read and writes markdown, applying it as its own template to apply meta -mdTemplating :: Text -> P.Meta -> HandlerFor UniWorX (Either P.PandocError P.Pandoc) +mdTemplating :: Text -> P.Meta -> HandlerFor UniWorX (Either Text P.Pandoc) mdTemplating template meta = runExceptT $ do let readerOpts = def { P.readerExtensions = P.pandocExtensions , P.readerStripComments = True } - doc <- ExceptT $ $cachedHereBinary ("pandoc: \n" <> template) (pure . P.runPure $ P.readMarkdown readerOpts template) - tmpl <- ExceptT $ $cachedHereBinary ("template: \n" <> template) (pure . P.runPure $ compileTemplate template) + -- doc <- ExceptT (pure . over _Left P.renderError . P.runPure $ P.readMarkdown readerOpts template) + -- tmpl <- ExceptT (pure . over _Left P.renderError . P.runPure $ compileTemplate template) + doc <- ExceptT $ memcachedBy (Just . Right $ 6 * diffHour) ("pandoc-md: \n" <> template) (pure . over _Left P.renderError . P.runPure $ P.readMarkdown readerOpts template) + tmpl <- ExceptT $ memcachedBy (Just . Right $ 6 * diffHour) ("template-md: \n" <> template) (pure . over _Left P.renderError . P.runPure $ compileTemplate template) let writerOpts = def { P.writerExtensions = P.pandocExtensions , P.writerTemplate = Just tmpl } - ExceptT . pure . P.runPure $ do - md_txt <- P.writeMarkdown writerOpts $ appMeta setIsDeFromLang $ addMeta meta doc - P.readMarkdown readerOpts md_txt + ExceptT . pure . over _Left P.renderError . P.runPure $ do + md_txt <- P.writeMarkdown writerOpts $ appMeta setIsDeFromLang $ addMeta meta doc + addMeta meta <$> P.readMarkdown readerOpts md_txt -- NOTE: meta is lost along the way somehow, despite P.pandocExtensions containing Ext_yaml_metadata_block + -- | creates a PDF using a LaTeX template -pdfLaTeX :: LetterKind -> P.Pandoc -> HandlerFor UniWorX (Either P.PandocError LBS.ByteString) +pdfLaTeX :: LetterKind -> P.Pandoc -> HandlerFor UniWorX (Either Text LBS.ByteString) pdfLaTeX lk doc = do - e_tmpl <- $cachedHereBinary ("LetterKind:" <> tshow lk) (liftIO . P.runIO $ compileTemplate $ templateLatex lk) - actRight e_tmpl $ \tmpl -> liftIO . P.runIO $ do + -- e_tmpl <- fmap (over _Left P.renderError) . liftIO . P.runIO $ compileTemplate $ templateLatex lk + e_tmpl <- memcachedBy (Just . Right $ 6 * diffHour) ("LetterKind-latex: \n" <> tshow lk) (fmap (over _Left P.renderError) . liftIO . P.runIO $ compileTemplate $ templateLatex lk) + actRight e_tmpl $ \tmpl -> fmap (over _Left P.renderError) . liftIO . P.runIO $ do let writerOpts = def { P.writerExtensions = P.pandocExtensions , P.writerTemplate = Just tmpl } makePDF writerOpts $ appMeta setIsDeFromLang doc - - + renderLetter :: (MDLetter l) => Entity User -> l -> Text -> Handler (Either Text LBS.ByteString) renderLetter rcvrEnt@Entity{entityVal=rcvr} mdl apcIdent = do @@ -151,8 +160,8 @@ renderLetter rcvrEnt@Entity{entityVal=rcvr} mdl apcIdent = do --, toMeta "rcvr-email" $ rcvr & userDisplayEmail -- note that some templates use "email" already otherwise ] e_md <- mdTemplating tmpl meta - result <- actRight e_md $ pdfLaTeX kind - return $ over _Left P.renderError result + actRight e_md $ pdfLaTeX kind + -- TODO: apcIdent does not make sense for multiple letters renderLetters :: (MDLetter l, Foldable f) => Entity User -> f l -> Text -> Handler (Either Text LBS.ByteString) @@ -180,8 +189,9 @@ renderLetters rcvrEnt@Entity{entityVal=rcvr} mdls apcIdent Right doc2 -> pure $ Right $ doc1 <> doc2 doc <- foldrM templateCombine (Right mempty) mdls - result <- actRight doc $ pdfLaTeX kind - return $ over _Left P.renderError result + -- result <- actRight doc $ pdfLaTeX kind + -- return $ over _Left P.renderError result + actRight doc $ pdfLaTeX kind | otherwise = return $ Left "renderLetters received empty set of letters" @@ -377,7 +387,7 @@ encryptPDF pw bs = over _Left (decodeUtf8 . LBS.toStrict) . exit2either <$> read -- | Internal only, use `printLetter` instead lprPDF :: (MonadHandler m, HasAppSettings (HandlerSite m)) => FilePath -> LBS.ByteString -> m (Either Text Text) lprPDF (sanitizeCmdArg' -> jb) bs = do - mbLprServerArg <- $cachedHereBinary ("lprServer"::Text) getLprServerArg + mbLprServerArg <- getLprServerArg case mbLprServerArg of Nothing -> return $ Right "Print command ignored due to setting 'mail-reroute-to' being set." Just lprServerArg -> do diff --git a/src/Utils/Print/ExpireQualification.hs b/src/Utils/Print/ExpireQualification.hs new file mode 100644 index 000000000..7bd3fd9c8 --- /dev/null +++ b/src/Utils/Print/ExpireQualification.hs @@ -0,0 +1,84 @@ +-- SPDX-FileCopyrightText: 2023 Steffen Jost <jost@tcs.ifi.lmu.de> +-- +-- SPDX-License-Identifier: AGPL-3.0-or-later + +{-# OPTIONS_GHC -fno-warn-unused-top-binds #-} + +module Utils.Print.ExpireQualification where + +import Import +import Text.Hamlet + +-- import Data.Char as Char +-- import qualified Data.Text as Text +import qualified Data.CaseInsensitive as CI + +import Data.FileEmbed (embedFile) + +import Utils.Print.Letters +import Handler.Utils.Widgets (nameHtml) -- , nameHtml') + + +data LetterExpireQualificationF = LetterExpireQualificationF + { leqfHolderUUID:: CryptoUUIDUser + , leqfHolderID :: UserId + , leqfHolderDN :: UserDisplayName + , leqfHolderSN :: UserSurname + , leqfExpiry :: Day + , leqfId :: QualificationId + , leqfName :: Text + , leqfShort :: Text + , leqfSchool :: SchoolId + } + deriving (Eq, Show) + +-- TODO: use markdown to generate the Letter +instance MDMail LetterExpireQualificationF where + getMailSubject l = SomeMessage $ MsgMailSubjectQualificationExpired $ leqfShort l + getMailBody LetterExpireQualificationF{..} DateTimeFormatter{ format } = + let expiryDate = format SelFormatDate leqfExpiry + userDisplayName = leqfHolderDN + userSurname = leqfHolderSN + qualificationName = leqfName + qualificationShorthand = CI.mk leqfShort + qualificationSchool = leqfSchool + qname = qualificationName + ihamletSomeMessage _ _ _ = (mempty :: Html) -- TODO: use markdown for letter + editNotifications = () -- TODO: use markdown for letter + in $(ihamletFile "templates/mail/qualificationExpired.hamlet") + +instance MDLetter LetterExpireQualificationF where + encrypPDFfor _ = NoPassword + getLetterKind _ = Din5008 + getLetterEnvelope _ = 'e' + getTemplate _ = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/fraport_f_expiry.md") + + letterMeta LetterExpireQualificationF{..} DateTimeFormatter{ format } lang Entity{entityKey=rcvrId, entityVal=User{userDisplayName}} = + let isSupervised = rcvrId /= leqfHolderID + in mkMeta $ + guardMonoid isSupervised + [ toMeta "supervisor" userDisplayName + , toMeta "de-opening" ("Sehr geehrte Damen und Herren,"::Text) + , toMeta "en-opening" ("Dear Sir or Madam,"::Text) + ] <> + [ toMeta "lang" lang + , toMeta "licenceholder" leqfHolderDN + , toMeta "expiry" (format SelFormatDate leqfExpiry) + ] + + getPJId LetterExpireQualificationF{..} = + PrintJobIdentification + { pjiName = "Expiry" + , pjiApcAcknowledge = "exp-" <> tshow (ciphertext leqfHolderUUID) + , pjiRecipient = Nothing -- to be filled later + , pjiSender = Nothing + , pjiCourse = Nothing + , pjiQualification = Just leqfId + , pjiLmsUser = Nothing + , pjiFileName = "expire_" <> CI.original (unSchoolKey leqfSchool) <> "-" <> leqfShort <> "_" <> leqfHolderSN + -- let nameRecipient = abbrvName <$> recipient + -- nameSender = abbrvName <$> sender + -- nameCourse = CI.original . courseShorthand <$> course + -- nameQuali = CI.original . qualificationShorthand <$> quali + -- in .. = T.replace " " "-" (T.intercalate "_" . catMaybes $ [Just printJobName, nameQuali, nameCourse, nameSender, nameRecipient]) + } \ No newline at end of file diff --git a/src/Utils/Print/Instances.hs b/src/Utils/Print/Instances.hs new file mode 100644 index 000000000..2d469021c --- /dev/null +++ b/src/Utils/Print/Instances.hs @@ -0,0 +1,66 @@ +-- SPDX-FileCopyrightText: 2022-23 Steffen Jost <jost@tcs.ifi.lmu.de> +-- +-- SPDX-License-Identifier: AGPL-3.0-or-later + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Utils.Print.Instances where + +import Import.NoModel +-- import Import + +import qualified Text.DocTemplates.Internal as D +import qualified Text.DocLayout as D +import qualified Text.Pandoc as P + +----------------------------- +-- Pandoc Orphan Instances -- +----------------------------- + +-- deriving anyclass instance Generic IOException +-- deriving anyclass instance Binary IOException +-- deriving anyclass instance Binary HttpException +-- deriving anyclass instance Binary P.PandocError + + +-- required for memcaching compiled markdown and LaTeX templates +instance Binary P.RowHeadColumns +instance Binary P.RowSpan +instance Binary P.ColWidth +instance Binary P.ColSpan +instance Binary P.Alignment +instance Binary P.TableHead +instance Binary P.TableBody +instance Binary P.TableFoot +instance Binary P.MathType +instance Binary P.Cell +instance Binary P.Caption +instance Binary P.Citation +instance Binary P.CitationMode +instance Binary P.ListNumberStyle +instance Binary P.ListNumberDelim +instance Binary P.Format +instance Binary P.QuoteType +instance Binary P.Inline +instance Binary P.Row +instance Binary P.Block +instance Binary P.MetaValue +instance Binary P.Meta +instance Binary P.Pandoc + +-- -- and for memchaching a LaTeX template +deriving instance Binary D.Border +deriving instance Binary D.Alignment +deriving instance Binary D.Pipe +deriving instance Binary D.Variable +deriving instance (Binary a) => Binary (D.Doc a) +deriving instance (Binary a) => Binary (P.Template a) + +deriving instance NFData D.Border +deriving instance NFData D.Alignment +deriving instance NFData D.Pipe +deriving instance NFData D.Variable +deriving instance (NFData a) => NFData (D.Doc a) +deriving instance (NFData a) => NFData (P.Template a) + +-- TODO: sadly this is not yet enough. \ No newline at end of file diff --git a/src/Utils/Print/Letters.hs b/src/Utils/Print/Letters.hs index 2b4b94ac0..e57d2b5ab 100644 --- a/src/Utils/Print/Letters.hs +++ b/src/Utils/Print/Letters.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de> +-- SPDX-FileCopyrightText: 2022-23 Steffen Jost <jost@tcs.ifi.lmu.de> -- -- SPDX-License-Identifier: AGPL-3.0-or-later diff --git a/src/Utils/Print/RenewQualification.hs b/src/Utils/Print/RenewQualification.hs index fd953c40a..7327d651b 100644 --- a/src/Utils/Print/RenewQualification.hs +++ b/src/Utils/Print/RenewQualification.hs @@ -9,8 +9,8 @@ module Utils.Print.RenewQualification where import Import import Text.Hamlet -import Data.Char as Char -import qualified Data.Text as Text +-- import Data.Char as Char +-- import qualified Data.Text as Text import qualified Data.CaseInsensitive as CI import Data.FileEmbed (embedFile) @@ -55,7 +55,7 @@ instance MDMail LetterRenewQualificationF where instance MDLetter LetterRenewQualificationF where encrypPDFfor _ = PasswordUnderling getLetterKind _ = PinLetter - getLetterEnvelope l = maybe 'q' (Char.toLower . fst) $ Text.uncons (qualShort l) + getLetterEnvelope _ = 'f' -- maybe 'q' (Char.toLower . fst) $ Text.uncons (qualShort l) getTemplate _ = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/fraport_renewal.md") letterMeta l@LetterRenewQualificationF{..} DateTimeFormatter{ format } lang Entity{entityKey=rcvrId, entityVal=User{userDisplayName}} = diff --git a/src/Utils/Users.hs b/src/Utils/Users.hs index 36721dd7c..2339fbed5 100644 --- a/src/Utils/Users.hs +++ b/src/Utils/Users.hs @@ -73,7 +73,7 @@ addNewUser AddUserData{..} = do , userExamOfficeGetLabels = userDefaultExamOfficeGetLabels , userNotificationSettings = def , userLanguages = Nothing - , userCsvOptions = def + , userCsvOptions = def { csvFormat = review csvPreset CsvPresetXlsx } , userTokensIssuedAfter = Nothing , userCreated = now , userLastLdapSynchronisation = Nothing diff --git a/stack.yaml b/stack.yaml index f4dc5c9ae..2c7b72c31 100644 --- a/stack.yaml +++ b/stack.yaml @@ -7,8 +7,12 @@ flags: cffi: true rebuild-ghc-options: true -ghc-options: - "$everything": -fno-prof-auto +#ghc-options: +# "$everything": -fno-prof-auto + +build: + library-profiling: true + executable-profiling: true nix: packages: [] @@ -67,7 +71,7 @@ extra-deps: commit: 843683d024f767de236f74d24a3348f69181a720 - git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git - commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 # <- references debug with traceStack; master ref: cb75191e0c5490246ae2cbcc2a00e7985cf2aadb subdirs: - yesod-core - yesod-static diff --git a/stack.yaml.lock b/stack.yaml.lock index 709ec0205..cb7c7063a 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -240,12 +240,12 @@ packages: git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git pantry-tree: size: 5954 - sha256: bca827b8f5b4b649ef6d8f0e06fc5ae9b825f9def16fb472173d2fbf12fb5dc2 - commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb + sha256: 08c8da10b32c8d9f784238fd87232bf90b752e82f81ef2c52c62210f9aadda9a + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 original: subdir: yesod-core git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git - commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 - completed: subdir: yesod-static name: yesod-static @@ -254,11 +254,11 @@ packages: pantry-tree: size: 2949 sha256: 32c1608243a5309005ce11e2aa379ac1d6f8c380c529785eb510770118f3da06 - commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 original: subdir: yesod-static git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git - commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 - completed: subdir: yesod-persistent name: yesod-persistent @@ -267,11 +267,11 @@ packages: pantry-tree: size: 497 sha256: 3778ef2964e1a3890afc22cc9124eacb40e64b62bed4983a85d3b99897f54c5c - commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 original: subdir: yesod-persistent git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git - commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 - completed: subdir: yesod-newsfeed name: yesod-newsfeed @@ -280,11 +280,11 @@ packages: pantry-tree: size: 488 sha256: 53ebad62655863a657dcf749ffd3de46f6af90dd71f55bc4d50805ac48ddb099 - commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 original: subdir: yesod-newsfeed git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git - commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 - completed: subdir: yesod-form name: yesod-form @@ -293,11 +293,11 @@ packages: pantry-tree: size: 1914 sha256: 260b7f16a8e1d58da137eb91aeed3a11ccbe59ba3e614457a635b9dc3e71426f - commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 original: subdir: yesod-form git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git - commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 - completed: subdir: yesod-form-multi name: yesod-form-multi @@ -306,11 +306,11 @@ packages: pantry-tree: size: 328 sha256: b21fc50db43733dfe6e285345856610ba4feb83329e9cf953bf8047ba18ecbd6 - commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 original: subdir: yesod-form-multi git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git - commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 - completed: subdir: yesod-auth name: yesod-auth @@ -319,11 +319,11 @@ packages: pantry-tree: size: 1212 sha256: d335b940a207f8155f421b7146746a72d20db6ad54412154f2c829a59bf21e08 - commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 original: subdir: yesod-auth git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git - commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 - completed: subdir: yesod-auth-oauth name: yesod-auth-oauth @@ -332,11 +332,11 @@ packages: pantry-tree: size: 321 sha256: 39d2f7d5d1abb3a2953858c5f23880e60ecfcdad0549ddc2570204f9c47649f4 - commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 original: subdir: yesod-auth-oauth git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git - commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 - completed: subdir: yesod-sitemap name: yesod-sitemap @@ -345,11 +345,11 @@ packages: pantry-tree: size: 314 sha256: 971f48af7011ff7816872d067e5de9cadafdd371bdf209170b77df36001abd27 - commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 original: subdir: yesod-sitemap git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git - commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 - completed: subdir: yesod-test name: yesod-test @@ -358,11 +358,11 @@ packages: pantry-tree: size: 563 sha256: 3d5022e8e3f8e77abcf075c42cf49efaa26f4951159bbb5ab50b69fdfeacb7c1 - commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 original: subdir: yesod-test git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git - commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 - completed: subdir: yesod-bin name: yesod-bin @@ -371,11 +371,11 @@ packages: pantry-tree: size: 1295 sha256: 422d7816965b79826c6c24582d76dadbacd1bfb3e9a8f31208867cd788f2a5b8 - commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 original: subdir: yesod-bin git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git - commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 - completed: subdir: yesod name: yesod @@ -384,11 +384,11 @@ packages: pantry-tree: size: 666 sha256: cb53ef3f2036185d2b4752d6fbc5d78470b4504e646e7eb4dd2397f2599daf42 - commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 original: subdir: yesod git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git - commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 - completed: subdir: yesod-eventsource name: yesod-eventsource @@ -397,11 +397,11 @@ packages: pantry-tree: size: 324 sha256: 6d393201852cd024e377159ba836398e24d191563e08165430113d3c1384aff2 - commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 original: subdir: yesod-eventsource git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git - commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 - completed: subdir: yesod-websockets name: yesod-websockets @@ -410,11 +410,11 @@ packages: pantry-tree: size: 485 sha256: 02df6117e9b74a77879ea750130ba2d8ad8d3c99e14ca678320cb578984301e5 - commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 original: subdir: yesod-websockets git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git - commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 - completed: name: cryptonite version: '0.29' diff --git a/templates/letter/din5008.latex b/templates/letter/din5008.latex index c6c88f17e..0816d2ec5 100644 --- a/templates/letter/din5008.latex +++ b/templates/letter/din5008.latex @@ -66,7 +66,8 @@ $endif$ % if luatex or xetex \usepackage{fontspec} \setmonofont{DejaVu Sans Mono} -\fi +\fi +\renewcommand{\familydefault}{\sfdefault} $if(mathspec)$ \ifXeTeX diff --git a/templates/letter/din5008with_pin.latex b/templates/letter/din5008with_pin.latex index 22e3b0a0f..68047cc04 100644 --- a/templates/letter/din5008with_pin.latex +++ b/templates/letter/din5008with_pin.latex @@ -67,6 +67,7 @@ $endif$ \usepackage{fontspec} \setmonofont{DejaVu Sans Mono} \fi +\renewcommand{\familydefault}{\sfdefault} $if(mathspec)$ \ifXeTeX diff --git a/templates/letter/fraport_f_expiry.md b/templates/letter/fraport_f_expiry.md new file mode 100644 index 000000000..2d899f237 --- /dev/null +++ b/templates/letter/fraport_f_expiry.md @@ -0,0 +1,130 @@ +--- +### Metadaten, welche hier eingestellt werden: +# Absender +de-subject: 'Entzug "F" (Vorfeldführerschein)' +en-subject: Revocation of apron driving license +author: Fraport AG - Fahrerausbildung (AVN-AR) +phone: +49 69 690-28467 +email: fahrerausbildung@fraport.de +place: Frankfurt am Main +return-address: + - 60547 Frankfurt +de-opening: Liebe Fahrberechtigungsinhaber, +en-opening: Dear driver, +de-closing: | + Mit freundlichen Grüßen, + Ihre Fraport Fahrerausbildung +en-closing: | + With kind regards, + Your Fraport Driver Training +encludes: +hyperrefoptions: hidelinks + +### Metadaten, welche automatisch ersetzt werden: +date: 11.11.1111 +expiry: 00.00.0000 +lang: de-de +is-de: true +# Emfpänger +licenceholder: P. Rüfling +address: + - E. M. Pfänger + - Musterfirma GmbH + - Musterstraße 11 + - 12345 Musterstadt +... +$if(titleblock)$ +$titleblock$ + +$endif$ +$for(header-includes)$ +$header-includes$ + +$endfor$ +$for(include-before)$ +$include-before$ + +$endfor$ + +$if(is-de)$ + +<!-- deutsche Version des Briefes --> +$if(supervisor)$ + leider hat $licenceholder$ +$else$ + leider haben Sie +$endif$ +den Wissenstest im Rahmen des Recurrent Trainings Vorfeldführerschein nicht bestanden +oder die Ablauffrist nicht eingehalten. + + +Die Qualifikation „Vorfeldführerschein“ ist somit nicht mehr gültig. + + +$if(supervisor)$ +**$licenceholder$** darf +$else$ + Sie dürfen +$endif$ +ab sofort keine Fahrzeuge mehr eigenständig auf dem Vorfeld des Frankfurter Flughafens führen. + + +Um die Fahrberechtigung wiederzuerlangen, ist die Teilnahme an einem Grundkurs Vorfeldführerschein erforderlich. + +$if(supervisor)$ +Hierfür wenden Sie sich bitte an die Fahrerausbildung der Fraport AG unter: + +Telefon + + : $phone$ + +Email + + : $email$ + +$else$ +Hierfür wenden Sie sich bitte an Ihren Arbeitgeber. +$endif$ + +$else$ +<!-- englische Version des Briefes --> +we regret to inform you that +$if(supervisor)$ + **$licenceholder$** +$else$ + you +$endif$ +did not pass the required knowledge test within the alotted time +for the renewal of the apron driving licence. + + +The qualification „Vorfeldführerschein“ (apron driving lincence) is therefore invalid now. + + +$if(supervisor)$ + $licenceholder$ +$else$ + You +$endif$ +may no longer drive a vehicle on the apron of Frankfurt airport, effective immediately. + + +In order to regain this apron driving licence, a full participation in a +basic training course is required. + +$if(supervisor)$ +Please contact the Fraport driving school team, if you want to book a course: + +Phone + + : $phone$ + +Email + + : $email$ + +$else$ +Please contact you employer to book a course for you. +$endif$ + +$endif$ diff --git a/templates/letter/fraport_qualification.md b/templates/letter/fraport_qualification.md index 5f43711a5..2a7f86a65 100644 --- a/templates/letter/fraport_qualification.md +++ b/templates/letter/fraport_qualification.md @@ -5,18 +5,19 @@ lang: de-de is-de: true date: 11.11.1111 -test1: this **is really** a test -test2: 'this **is another** test' -test3: | - <h1>First</h1> - <p>Here is some text with <em>emphasis</em> to see. ... \renewcommand{\familydefault}{\sfdefault} + +\vspace*{2cm} + + +\begin{huge}\sffamily\textbf{% $if(is-de)$ - -\medskip - -\begin{huge}\sffamily\textbf{Teilnahmebescheinigung}\end{huge} +Teilnahmebescheinigung +$else$ +Certificate of attendance +$endif$ +}\end{huge} \vspace{\fill} @@ -27,23 +28,46 @@ $endif$ $if(company)$ ## $company$ {-} $endif$ +$if(is-de)$ hat $if(course-begin)$ $if(course-end)$ -von $course-begin$ bis $course-end$ +vom $course-begin$ bis zum $course-end$ $else$ am $course-begin$ $endif$ $endif$ -an der Veranstaltung -\centerline{\sffamily\LARGE{$course-name$}} -der Fahrerausbildung der Fraport AG teilgenommen. +an der Veranstaltung +$else$ +attended +$if(course-begin)$ +$if(course-end)$ +from $course-begin$ to $course-end$ +$else$ +on $course-begin$ +$endif$ +$endif$ +the course +$endif$ + +\vspace*{1.2EX} +\textbf{\LARGE $course-name$} +\vspace*{1.1EX} + +$if(is-de)$ +der Fahrerausbildung der Fraport AG teilgenommen. +$else$ +taught by Fahrerausbildung of Fraport AG. +$endif$ -\vspace{\fill} \vspace{\fill} $if(course-content)$ -## Inhalte: {-} +$if(is-de)$ +## Inhalte {-} +$else$ +## Course content {-} +$endif$ %%%course-content%%% @@ -51,11 +75,20 @@ $if(course-content)$ $endif$ -\vspace{\fill} \vspace{\fill} +$if(is-de)$ Mit Aushändigung der Teilnahmebescheinigung wird der erfolgreiche Abschluss des Kurses bestätigt. -Dieses Zertifikat wurde maschinell erstellt. + + +Dieses Zertifikat wurde maschinell erstellt. +$else$ +The successful completion of the course is confirmed +by handing out this certificate. + + +This is machine generated certificate requires no signature. +$endif$ \medskip @@ -65,20 +98,5 @@ Fraport College \vspace{\fill} \vspace{\fill} \vspace{\fill} -\vspace{\fill} -\vspace{\fill} - -<!-- deutsche version --> - -$else$ - -<!-- english version --> - -# Certificate of attendance - -**English version is not yet implemened.** -TODO - -$endif$ \clearpage \ No newline at end of file diff --git a/templates/letter/fraport_renewal.md b/templates/letter/fraport_renewal.md index 17745bf5d..d7707d78a 100644 --- a/templates/letter/fraport_renewal.md +++ b/templates/letter/fraport_renewal.md @@ -13,7 +13,7 @@ de-opening: Liebe Fahrberechtigungsinhaber, en-opening: Dear driver, de-closing: | Mit freundlichen Grüßen, - Ihre Fahrerausbildung + Ihre Fraport Fahrerausbildung en-closing: | With kind regards, Your Fraport Driver Training @@ -133,7 +133,7 @@ $if(supervisor)$ to regain the apron driving licence. $else$ you have to participate in a basic training course again to regain - your apron driving licnece. + your apron driving licence. $endif$ diff --git a/templates/letter/plain_article.latex b/templates/letter/plain_article.latex index e95489125..bdd9d7cd9 100644 --- a/templates/letter/plain_article.latex +++ b/templates/letter/plain_article.latex @@ -51,15 +51,19 @@ $endif$ \fi \ifPDFTeX + \usepackage{helvet} \usepackage[$if(fontenc)$$fontenc$$else$T1$endif$]{fontenc} \usepackage[utf8]{inputenc} - \usepackage{textcomp} % provide euro and other symbols - \usepackage{DejaVuSansMono} % better monofont + \usepackage{textcomp}% provide euro and other symbols + \usepackage{DejaVuSansMono}% better monofont + \renewcommand{\familydefault}{\sfdefault} \else % if luatex or xetex \usepackage{fontspec} + %\setmainfont{TeXGyreHeros}%could not install the package somehow tex-gyre in default.nix/shell.nix did not work + \setmainfont{DejaVu Sans} \setmonofont{DejaVu Sans Mono} - %\renewcommand{\familydefault}{\sfdefault} + \renewcommand{\familydefault}{\sfdefault} \fi $if(mathspec)$ diff --git a/templates/mail/qualificationExpired.hamlet b/templates/mail/qualificationExpired.hamlet index 0a4179acb..a8ba9c974 100644 --- a/templates/mail/qualificationExpired.hamlet +++ b/templates/mail/qualificationExpired.hamlet @@ -29,7 +29,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later #{qualificationName} <dt>_{SomeMessage MsgLmsUser} <dd>#{nameHtml userDisplayName userSurname} - <dt>_{SomeMessage MsgLmsQualificationValidUntil} + <dt>_{SomeMessage MsgQualificationExpired} <dd>#{expiryDate} diff --git a/templates/widgets/form/form.hamlet b/templates/widgets/form/form.hamlet index 7d4a7901f..371a7c701 100644 --- a/templates/widgets/form/form.hamlet +++ b/templates/widgets/form/form.hamlet @@ -5,7 +5,7 @@ $# $# SPDX-License-Identifier: AGPL-3.0-or-later $# Wrapper for all kinds of forms -<form ##{formId} method=#{decodeUtf8 (renderStdMethod formMethod)} action=#{fromMaybe "" formActionUrl} enctype=#{formEncoding} *{formAttrs}> +<form ##{formId} method=#{decodeUtf8 (renderStdMethod formMethod)} :hasAction:action=#{fromMaybe "" formActionUrl} enctype=#{formEncoding} *{formAttrs}> $# Distinguish different falvours of submit button layouts here: $case formSubmit $of FormNoSubmit diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index b5f4549ba..d165ed9fc 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -163,7 +163,7 @@ fillDb = do , userAuthentication = pwSimple , userLastAuthentication = Nothing , userTokensIssuedAfter = Nothing - , userMatrikelnummer = Just "94094094094" + , userMatrikelnummer = Just "12345678" , userEmail = "S.Jost@Fraport.de" , userDisplayEmail = "jost@tcs.ifi.lmu.de" , userDisplayName = "Steffen Jost" @@ -680,6 +680,10 @@ fillDb = do void . insert' $ UserAvs (AvsPersonId 4) sbarth 4 void . insert' $ UserAvs (AvsPersonId 5) fhamann 5 void . insert' $ UserAvs (AvsPersonId 77) tinaTester 77 + insert_ $ UserAvsCard (AvsPersonId 12345678) (AvsFullCardNo (AvsCardNo "1234") "4") (AvsDataPersonCard True Nothing Nothing AvsCardColorGelb (Set.fromList ['F']) Nothing Nothing Nothing Nothing (AvsCardNo "1234") "4") now + insert_ $ UserAvsCard (AvsPersonId 2) (AvsFullCardNo (AvsCardNo "3344") "1") (AvsDataPersonCard True Nothing Nothing AvsCardColorRot (Set.fromList ['F','R']) Nothing Nothing Nothing Nothing (AvsCardNo "3344") "1") now + insert_ $ UserAvsCard (AvsPersonId 3) (AvsFullCardNo (AvsCardNo "7788") "1") (AvsDataPersonCard False Nothing Nothing AvsCardColorRot (Set.fromList ['F','R']) Nothing Nothing Nothing Nothing (AvsCardNo "7788") "1") now + insert_ $ UserAvsCard (AvsPersonId 4) (AvsFullCardNo (AvsCardNo "9999") "4") (AvsDataPersonCard True Nothing Nothing AvsCardColorGelb (Set.fromList ['F']) Nothing Nothing Nothing Nothing (AvsCardNo "9999") "4") now let f_descr = Just $ htmlToStoredMarkup [shamlet|<p>Berechtigung zum Führen eines Fahrzeuges auf den Fahrstrassen des Vorfeldes.|] let r_descr = Just $ htmlToStoredMarkup [shamlet|<p>Berechtigung zum Führen eines Fahrzeuges auf dem gesamten Rollfeld.|] @@ -932,7 +936,7 @@ fillDb = do <section> <h3>Benötigte Unterlagen <ul> - <li>Sehtest, + <li>Sehtest, # <i>bitte vorab hochladen! <li>Regulärer Führerschein, <i>Bitte mitbringen.