diff --git a/CHANGELOG.md b/CHANGELOG.md index 1eefa6acb..bb7fd8e96 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,14 +2,108 @@ 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.4.49](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/t27.4.48...t27.4.49) (2023-11-09) +## [27.4.59](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.58...v27.4.59) (2024-02-13) ### Bug Fixes +* **sql:** remove potential bug in relation to missing parenthesis after not_ ([42695cf](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/42695cf5ef9f21691dc027f1ec97d57eec72f03e)) + +## [27.4.58](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.57...v27.4.58) (2024-02-08) + + +### Bug Fixes + +* **health:** negative interface routes working as intended now ([3303c4e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/3303c4eebf928e527d2f9c1eb6e2495c10b94b13)) +* **lms:** previouly failed notifications will be sent again ([263894b](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/263894b05899ce55635d790f5334729fbc655ecc)) + +## [27.4.57](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.56...v27.4.57) (2024-02-06) + + +### Bug Fixes + +* **course:** fix [#147](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/147) abort addd participant aborts now ([d332c0c](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/d332c0c11afd8b1dfe1343659f0b1626c968bbde)) +* **health:** fix [#151](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/151) by offering route /health/interface/* ([c71814d](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/c71814d1ef1efc16c278136dfd6ebd86bd1d20db)) +* **health:** fix [#153](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/153) and offer interface health route matching ([ce3852e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ce3852e3d365e62b32d181d58b7cbcc749e49373)) + +## [27.4.56](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.55...v27.4.56) (2023-12-20) + + +### Bug Fixes + +* **firm:** improve supervisor filter by caching ([88f24fe](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/88f24fe6f199290a83af2d204ba9aa2a838d11b8)) +* **firm:** improve supervisor filter yet once more ([c7b5a3c](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/c7b5a3c6cb70c314ecbfbe25969b4b6be1d43161)) +* **users:** fix [#121](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/121) by providing last login column, which was the last part missing ([decc5af](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/decc5af6829998e2d0db79382bbd9a7bad7b5b09)) + +## [27.4.55](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.54...v27.4.55) (2023-12-14) + + +### Bug Fixes + +* **build:** while the blank is necessary to prevent unnecessary migrations, it is not allowed either, see [#133](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/133) ([a4b2af7](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/a4b2af7f157444ead8c9df989741b266f7c2b4f2)) +* **firm:** supervisor filter performance ([db77850](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/db77850c4f4cd1d68bfd38e02e0ae24584e1e556)) +* **migration:** fix [#133](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/133) by removing old outdated migrations irrelevant to FRADrive ([d4f0d69](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/d4f0d69428a4f7fc887cb6854cb59e3dea83b9bc)) +* **migration:** ignore superfluous migration entries gracefully ([1d48b62](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/1d48b627f6b8cf1b03e2ef63850c36c429c9d3d6)) +* **school:** fix [#133](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/133) by adjusting default value ([2509358](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/25093588784381a19f34e5b091677b908420ddea)) + +## [27.4.54](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.53...v27.4.54) (2023-12-11) + + +### Bug Fixes + +* **db:** prevent superfluous migrations ([b73557a](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/b73557a1eee4315911c6369032447f8d1836d964)) + +## [27.4.53](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.52...v27.4.53) (2023-12-09) + + +### Bug Fixes + +* **admin:** minor fixes and translations for admin problem page ([30fae33](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/30fae33dedb1501e570e9edca288fea3c84ac84a)) +* **avs:** background synch was only triggerd by manual synchs ([48ef25a](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/48ef25aa8ffbbd96c1578ae85b76f090d9042595)) +* **firm:** group multi select field supervisor ([fc0ca7b](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/fc0ca7b854a686cf395dadf81b7423e530fd26b8)) +* **firm:** set supervisor field not all fields required ([9878956](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/9878956716b04c7ae88989cb9b059d3edcb923dc)) +* **firm:** supervisor filter ([3acb847](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/3acb847915010d10358ea02000c231dbba7cba26)) +* **form:** multiSelectField working with grouped options ([3aa8901](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/3aa89019a8b4393da0eca715871a3793c1e3abb2)) +* **print:** keep print jobs on user merge and lms id deletion ([a15862e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/a15862ea72bc374af870ef3a23f86ae32c2c67a9)) + +## [27.4.52](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.51...v27.4.52) (2023-12-01) + + +### Bug Fixes + +* **build:** redundant parenthesis ([50eda5f](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/50eda5f65f7394fe519546609fe748490cb4dd72)) +* **firm:** restrict firm access to company supervisors only ([0a06efd](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/0a06efd76c63180c996657c2c7d78efc5bddd83d)) +* **firm:** supervisor changes led to inconsistent DB ([1d3345c](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/1d3345cbba1cb65ee49c6f62e145750545439642)) + +## [27.4.51](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.50...v27.4.51) (2023-11-24) + + +### Bug Fixes + +* **build:** minor errors firm handler ([06bb44c](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/06bb44cf715375b5dd0141a46f8e10924ad6cd9c)) +* **cache:** remove risky caching for submissions ([4ae59fc](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/4ae59fc1fa658e1462139ddddd6dc80308d85872)) +* **firm:** show default supervisors with no employees too ([0f9a7a8](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/0f9a7a8c53d216ca7a6d0a25462b19ab1fa00bb4)) + +## [27.4.50](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.49...v27.4.50) (2023-11-17) + + +### Bug Fixes + +* **avs:** preserve unset pin passwords in update ([8c4f848](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/8c4f848675e1125547d1fdfa05560affe4794118)) * **build:** fix whitespace in routes ([a24e44e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/a24e44efc9a20d3934d96640bb9e21b3b6d55b96)) +* **build:** minor ([954a239](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/954a23936a35ea6c32247d7e191312e63888c12d)) +* **firm:** add sql indices for frequent filters to greatly enhance performance ([63e6d94](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/63e6d94df2fd1ce879cb59d14bc854f3c2556586)) +* **firm:** firm messaging now works fine ([65cdc8d](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/65cdc8ddfef19eb3a5578c536575f91ba9717a13)) +* **firm:** foreign supervisor counts correct and sortable ([601ce7a](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/601ce7abdf2a392d30f1ff799a2338968be795f1)) +* **firm:** sending messages works, but not test messages ([42ff02d](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/42ff02d27e431a8855db7bf3046a1b74d297e6da)) * **lms:** improve sorting for firm all ([3865bda](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/3865bda64d488c161b55e1f6eb48ca1b742dff98)) -* **lms:** mark as ended only if not seen for at least one day ([8165892](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/8165892b2e4f945780bb8420cfc4eed50fdd294d)) +* **lms:** LMS restart failing due to old LmsUser entry ([6761767](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/6761767c6ca8cab62a22aa6f755e6231e07ab411)) + +## [27.4.49](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.48...v27.4.49) (2023-11-09) + + +### Bug Fixes + * **lms:** report log did not match qualification ([390ff31](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/390ff317ea3bb4ef8918c9cda858f5f228e4a882)) ## [27.4.48](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.47...v27.4.48) (2023-11-07) @@ -26,25 +120,6 @@ All notable changes to this project will be documented in this file. See [standa ### Bug Fixes -* **build:** comment planned model changes ([bc4594b](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/bc4594bea250df07ade834fd908f092c0423e785)) -* **build:** minor ([954a239](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/954a23936a35ea6c32247d7e191312e63888c12d)) -* **build:** Update ParticipantInvite.hs ([f888da3](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/f888da3ab0df45bb3c515ebb7cbb43569fdaa1fa)) -* **build:** Update ParticipantInvite.hs ([fa4f9b2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/fa4f9b24475261afc1e534541c8878a85e6a1b10)) -* **build:** Update Utils.hs ([87f0b2e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/87f0b2edab2bcf696b7b776e47272ef2204c0b75)) -* **course:** grant qualifications now issues and unblocks ([5d8d8cf](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/5d8d8cf17e634ecb950a1c329c859fb93f94ef77)) -* **firm:** foreign supervisor counts correct and sortable ([601ce7a](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/601ce7abdf2a392d30f1ff799a2338968be795f1)) -* **hoogle:** remove erroneous comment ([c011d88](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/c011d887cece8338920355b540aa4b233e0b994f)) -* **lms:** disable workaround for late lms success ([cb9e09d](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/cb9e09d071d22f41a92ab8140d7aaa643c748373)) -* **lms:** do not mark lms users with open status as ended ([a848126](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/a84812640f02981875275c96e37338de4ab49996)) -* **lms:** sorting and filtering lms status ([f48862e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/f48862efbcb95e92203a200267e1bcc613af4af1)) -* **lms:** sorting and filtering lms status works throughout now ([ae44703](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ae4470333e2b1b5c271b38092210c094822f4a19)) -* **print:** apc ident aliases did not stop at first success ([b7d4f69](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/b7d4f6913d8b1a70c1b7ef73782cf29861dc11a7)) -* **qualifications:** latest block could ignore itself ([bb708ca](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/bb708ca540557b41d33996cfea9a390a457ed855)) -* **sap:** combine immediate next day licence chnages for SAP ([f4adfdf](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/f4adfdf87270930d4ca6611f2a9956613fcace53)) -* **sap:** combine immediate next day licence chnages for SAP ([cbb44f1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/cbb44f106ad59e0a53ca04963ade5544120b7e21)) -* **sap:** combineBlocks yet another bug squashed ([3924d14](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/3924d14abd868305b42c9d04913536b4999dc45b)) -* **sap:** compileBlocks ([b4a88ab](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/b4a88abcf85783c350ad2bf3a5e973d13d1eb1f6)) -* **sap:** yet another fix for finding date intervals ([fde97b0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/fde97b048ab04ab59c9e3f2a2f74bb2c1e996b22)) * **course:** grant qualifications now issues and unblocks ([5d8d8cf](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/5d8d8cf17e634ecb950a1c329c859fb93f94ef77)) * **users:** allow prefer postal setting for users with fraport department ([a9d56c5](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/a9d56c51dcc727f8637b09a0e849372e75032f5e)) diff --git a/config/settings.yml b/config/settings.yml index ecc94093d..602c9c0e2 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -90,8 +90,9 @@ synchronise-avs-users-interval: "_env:SYNCHRONISE_AVS_INTERVAL:21600" # alle 6 study-features-recache-relevance-within: 172800 study-features-recache-relevance-interval: 293 -# Enqueue at specified hour, dequeue 30min later -# qualification-check-hour: 3 +# Enqueue at specified hour, a few minutes later +# job-lms-qualifications-enqueue-hour: 15 +# job-lms-qualifications-dequeue-hour: 3 log-settings: detailed: "_env:DETAILED_LOGGING:false" diff --git a/messages/uniworx/categories/admin/de-de-formal.msg b/messages/uniworx/categories/admin/de-de-formal.msg index 2bb340724..eb6cfe753 100644 --- a/messages/uniworx/categories/admin/de-de-formal.msg +++ b/messages/uniworx/categories/admin/de-de-formal.msg @@ -111,7 +111,6 @@ ProblemsDriversHaveAvsIds: Alle Inhaber einer Fahrberechtigung konnten einer AVS ProblemsUsersAreReachable: Für alle Benutzer ist eine E-Mail oder postalische Adresse bekannt ProblemsNoStalePrintJobs n@Integer: Alle Briefversandaufträge der vergangenen #{show n} Tage wurden von der Druckerei bestätigt ProblemsNoBadAPCIds: Alle kürzlich empfangenen Druckauftragsbestätigungen waren gültig -ProblemsNoAvsSynchProblems: Synchronisation mit Ausweisverwaltungssystem (AVS) meldete keine Probleme ProblemsUnreachableHeading: Unerreichbare Benutzer ProblemsUnreachableBody: Benutzer ohne E-Mail oder Postadresse, welche z.B. bei ablaufenden Berechtigungen nicht benachrichtigt werden können: ProblemsRWithoutFHeading: Fahrer mit R ohne F @@ -119,4 +118,16 @@ ProblemsRWithoutFBody: Diese Fahrer sind wegen einer ungültigen Vorfeld-Fahrber ProblemsNoAvsIdHeading: Fahrer ohne AVS-Id ProblemsNoAvsIdBody: Fahrer mit gültiger Fahrberechtigung in FRADrive, welche trotzdem nicht fahren dürfen, da die Fahrberechtigung aufgrund einer unbekannten AVS Id nicht an die Ausweisstelle übermittelt werden konnte: ProblemsAvsSynchHeading: Synchronisation AVS Fahrberechtigungen -ProblemsAvsErrorHeading: Fehlermeldungen \ No newline at end of file +ProblemsAvsErrorHeading: Fehlermeldungen +ProblemsInterfaceSince: Berücksichtigt werden nur Erfolge und Fehler seit + +InterfacesOk: Schnittstellen sind ok. +InterfacesFail n@Int: #{pluralDEeN n "Schnittstellenproblem"}! +InterfaceStatus !ident-ok: Status +InterfaceName: Schnittstelle +InterfaceLastSynch: Zuletzt +InterfaceSubtype: Betreffend +InterfaceWrite: Schreibend +InterfaceSuccess: Rückmeldung +InterfaceInfo: Nachricht +InterfaceFreshness: Prüfungszeitraum (h) \ No newline at end of file diff --git a/messages/uniworx/categories/admin/en-eu.msg b/messages/uniworx/categories/admin/en-eu.msg index 4d973593a..13f35ed9f 100644 --- a/messages/uniworx/categories/admin/en-eu.msg +++ b/messages/uniworx/categories/admin/en-eu.msg @@ -111,7 +111,6 @@ ProblemsDriversHaveAvsIds: All driving licence holder could be matched with thei ProblemsUsersAreReachable: Either Email or postal address is known for all users ProblemsNoStalePrintJobs n: All requests for letter mailing within the last #{show n} days were acknowledged as printed by the airport printing center ProblemsNoBadAPCIds: All recently received print job ids from Airport Print Center were legit -ProblemsNoAvsSynchProblems: AVS synchronisation had not problems ProblemsUnreachableHeading: Unreachable Users ProblemsUnreachableBody: Users without Email nor postal address, who thus cannot be notified about expiring qualifications: ProblemsRWithoutFHeading: Drivers having 'R' but not 'F' @@ -119,4 +118,16 @@ ProblemsRWithoutFBody: Drivers without apron driving licence are prohibited from ProblemsNoAvsIdHeading: Drivers without AVS id ProblemsNoAvsIdBody: Drivers having a valid apron driving licence within FRADrive only, but who may not drive since a missing AVS id prevents communication of the driving licence to AVS: ProblemsAvsSynchHeading: Synchronisation AVS Driving Licences -ProblemsAvsErrorHeading: Error Log \ No newline at end of file +ProblemsAvsErrorHeading: Error Log +ProblemsInterfaceSince: Only considering successes and errors since + +InterfacesOk: Interfaces are ok. +InterfacesFail n: #{pluralENsN n "interface problem"}! +InterfaceStatus: Status +InterfaceName: Interface +InterfaceLastSynch: Last +InterfaceSubtype: Affecting +InterfaceWrite: Write +InterfaceSuccess: Returned +InterfaceInfo: Message +InterfaceFreshness: Check hours \ No newline at end of file diff --git a/messages/uniworx/categories/courses/courses/de-de-formal.msg b/messages/uniworx/categories/courses/courses/de-de-formal.msg index a0bf4391e..d8faf2d87 100644 --- a/messages/uniworx/categories/courses/courses/de-de-formal.msg +++ b/messages/uniworx/categories/courses/courses/de-de-formal.msg @@ -95,7 +95,7 @@ CourseParticipantsInvited n@Int: #{n} #{pluralDE n "Einladung" "Einladungen"} pe CourseParticipantsAlreadyRegistered n@Int: #{n} #{pluralDE n "Teinehmer:in" "Teilnehmer:innen"} #{pluralDE n "ist" "sind"} bereits zur Kursart angemeldet CourseParticipantsAlreadyTutorialMember n@Int: #{n} #{pluralDE n "Teinehmer:in" "Teilnehmer:innen"} #{pluralDE n "ist" "sind"} bereits in dieser Kurs angemeldet CourseParticipantsRegistered n@Int: #{n} #{pluralDE n "Teinehmer:in" "Teilnehmer:innen"} erfolgreich zur Kursart angemeldet -CourseParticipantsRegisteredTutorial n@Int: #{n} #{pluralDE n "Teinehmer:in" "Teilnehmer:innen"} erfolgreich zur Kurs angemeldet +CourseParticipantsRegisteredTutorial n@Int: #{n} #{pluralDE n "Teinehmer:in" "Teilnehmer:innen"} erfolgreich zum Kurs angemeldet CourseParticipantsRegisterConfirmationHeading: Teilnehmer:innen hinzufügen CourseParticipantsRegisterUnnecessary: Alle angeforderten Anmeldungen sind bereits vorhanden. Es wurden keine Änderungen vorgenommen. CourseParticipantsRegisterConfirmInvalid: Ungültiges Bestätigungsformular! diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index c50120e92..c7a92efb3 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -2,23 +2,59 @@ # # SPDX-License-Identifier: AGPL-3.0-or-later +FirmSuperDefault: Standardansprechpartner +FirmSuperForeign: Firmenfremde Ansprechpartner +FirmSuperIrregular: Irreguläre Ansprechpartner FirmAssociates: Firmenangehörige +FirmContact: Firmenkontakt +FirmNoContact: Keine allgemeinen Kontaktinformationen bekannt. FirmEmail: Allgemeine Email FirmAddress: Postanschrift FirmDefaultPreferenceInfo: Diese Voreinstellungen gelten nur für neue Firmenangehörige -FirmAllActNotify: Mitteilung versenden -FirmAllActResetSupervision: Ansprechpartner für alle Firmenangehörigen zurücksetzen +FirmAction: Firmenweite Aktion +FirmActionInfo: Betrifft alle Firmenangehörigen unter Ihrer Aufsicht. +FirmActNotify: Mitteilung versenden +FirmActResetSupervision: Ansprechpartner für alle Firmenangehörigen zurücksetzen +FirmActResetSuperKeep: Bisherige Ansprechpartner der Firmenangehörigen zusätzlich beibehalten? +FirmActResetMutualSupervision: Ansprechpartner beaufsichtigen sich gegenseitig +FirmActAddSupersvisors: Ansprechpartner hinzufügen +FirmActAddSupersEmpty: Es konnten keine Ansprechpartner hinzugefügt werden +FirmActAddSupersSet n@Int64 postal@(Maybe Bool): #{n} Standardansprechpartner geändert #{maybeBoolMessage postal "" "und auf Briefversand geschaltet" "und Benachrichtigungen per Email gesetzt"}, aber nicht nicht aktiviert. +RemoveSupervisors ndef@Int64 nact@Int64: #{ndef} Standard Ansprechpartner entfernt#{bool ", aber noch nicht deaktiviert" (", " <> tshow nact <> " aktive Ansprechpartnerbeziehungen gelöscht") (nact > 0)} +FirmActChangeContactUser: Kontaktinformationen von allen Firmenangehörigen ändern +FirmActChangeContactFirm: Kontaktinformationen der Firma ändern +FirmActChangeContactFirmInfo: Firmenkontaktinformationen werden nur für neue Firmenangehörige verwendet, für die sonst keine Kontaktinformationen vorliegen. +FirmActChangeContactFirmResult: Firmenkontaktinformationen geändert. Betrifft nur neue Firmenangehörige ohne eigene Kontaktinformationen FirmUserActNotify: Mitteilung versenden +FirmUserActResetSupervision: Ansprechpartner auf Firmenstandard zurücksetzen +FirmUserActSetSupervisor: Ansprechpartner ändern +FirmNewSupervisor: Neue individuelle Ansprechpartner hinzufügen +FirmSetSupervisor: Existierende Ansprechpartner hinzufügen +FirmSetSupersReport nusr@Int64 nspr@Int64 nrem@Int64: Für #{nusr} Firmenangehörige wurden #{nspr} individuelle Ansprechpartner eingetragen#{bool "." (" und " <> tshow nrem <> " individuelle Ansprechpartnerbeziehungen gelöscht.") (nrem >0)} FirmUserActMkSuper: Zum Firmenansprechpartner ernennen +FirmUserActChangeContact: Kontaktinformationen für ausgewählte Firmenangehörige ändern +FirmResetSupervision rem@Int64 set@Int64: #{tshow set} Ansprechpartner gesetzt#{bool mempty (", " <> tshow rem <> " zuvor gelöscht") (rem > 0)} FirmSuperActNotify: Mitteilung versenden -FirmSuperActRMSuperDef: Standard Firmenansprechpartner entfernen -FirmSuperActRMSuperAll: Als aktiven Ansprechpartner komplett entfernen -FirmsNotification: Firmen Benachrichtigung versenden -FirmNotification fsh@CompanyShorthand: Benachrichtigung an #{fsh} versenden +FirmSuperActSwitchSuper: Standard Firmenansprechpartner abändern +FirmSuperActSwitchSuperInfo: Betrifft keine firmenfremden Ansprechpartner und ändert keine aktiven individuellen Ansprechpartnerbeziehungen. Gegebenfalls im Anschluss die Funktion "Ansprechpartner auf Firmenstandard zurücksetzen" nutzen. +FirmSuperActRMSuperDef: Firmenansprechpartner entfernen +FirmSuperActRMSuperActive: Auch aktive Ansprechpartnerbeziehungen innerhalb dieser Firma beenden +FirmsNotification: Firmen E-Mail versenden +FirmNotification fsh@CompanyShorthand: E-Mail an #{fsh} senden +FirmsNotificationTitle: Firmen benachrichtigen +FirmNotificationTitle fsh@CompanyShorthand: #{fsh} benachrichtigen FilterSupervisor: Hat aktiven Ansprechpartner FilterSupervisorCompany fsh@CompanyShorthand: Hat aktiven Ansprechpartner, #{fsh} der angehört FilterSupervisorForeign fsh@CompanyShorthand: Hat aktiven Ansprechpartner, der selbst nicht #{fsh} angehört FilterForeignSupervisor: Hat firmenfremde Ansprechpartner -FilterFirmPostalAddress: Postalische Firmenadresse vorhanden +FilterFirmExtern: Externe Firma FirmSupervisorOf fsh@CompanyShorthand: Ansprechpartner #{fsh} angehörig -FirmEmployeeOf fsh@CompanyShorthand: Firmenangehörige #{fsh} \ No newline at end of file +FirmSupervisorIndependent: Ansprechpartner ohne jegliche Firmenzugehörigkeit +FirmEmployeeOf fsh@CompanyShorthand: Firmenangehörige #{fsh} +NoCompanySelected: Bitte wählen Sie mindestens eine Firma aus. +TableIsDefaultSupervisor: Standardansprechpartner +TableIsDefaultReroute: Standardumleitung +FormFieldPostal: Benachrichtigungseinstellung +FormFieldPostalTip: Gilt für alle Benachrichtigungen an diese Person, nicht nur für Umleitungen an diesen Ansprechpartner +FirmUserChanges n@Int64: Benachrichtigungseinstellung für #{n} Firmenangehörige wurden geändert +FirmSupervisionKeyData: Kennzahlen Ansprechpartner \ No newline at end of file diff --git a/messages/uniworx/categories/firm/en-eu.msg b/messages/uniworx/categories/firm/en-eu.msg index 3e24de5c5..043312a20 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -2,23 +2,59 @@ # # SPDX-License-Identifier: AGPL-3.0-or-later +FirmSuperDefault: Default supervisor +FirmSuperForeign: External supervisor +FirmSuperIrregular: Irregular supervisor FirmAssociates: Company associated users +FirmContact: Company Contact +FirmNoContact: No general contact information known. FirmEmail: General company email FirmAddress: Postal address FirmDefaultPreferenceInfo: Default setting for new company associates only -FirmAllActNotify: Send message -FirmAllActResetSupervision: Reset supervisors for all company associates +FirmAction: Companywide action +FirmActionInfo: Affects alle company associates under your supervision. +FirmActNotify: Send message +FirmActResetSupervision: Reset supervisors for all company associates +FirmActResetSuperKeep: Additionally keep existing supervisors of company associates? +FirmActResetMutualSupervision: Supervisors supervise each other +FirmActAddSupersvisors: Add supervisors +FirmActAddSupersEmpty: No supervisors added +FirmActAddSupersSet n postal: #{n} default company supervisors changed #{maybeBoolMessage postal "" "and switched to postal notifications" "and switched to email notifications"}, but not yet activated. +RemoveSupervisors ndef nact: #{ndef} default supervisors removed#{bool ", but not yet deactivated" (" and " <> tshow nact <> " active supervisions terminated") (nact > 0)} +FirmActChangeContactUser: Change contact data for all company associates +FirmActChangeContactFirm: Change company contact data +FirmActChangeContactFirmInfo: The company contact data is only used for new company associates that would habe no contact information of their own otherwise. +FirmActChangeContactFirmResult: Company contact data changed, affecting future company associates without contact information only FirmUserActNotify: Send message +FirmUserActResetSupervision: Reset supervisors to company default +FirmUserActSetSupervisor: Change supervision +FirmNewSupervisor: Appoint new individual supervisors +FirmSetSupervisor: Add existing supervisors +FirmSetSupersReport nusr@Int64 nspr@Int64 nrem@Int64: #{nspr} individal supervisors set for #{nusr} company associates#{bool "." (" and " <> tshow nrem <> " other individual supervisions terminated.") (nrem >0)} +FirmResetSupervision rem set: #{tshow set} supervisors set#{bool mempty (", " <> tshow rem <> " deleted before") (rem > 0)} +FirmUserActChangeContact: Change contact data for selected company associates FirmUserActMkSuper: Mark as company supervisor FirmSuperActNotify: Send message -FirmSuperActRMSuperDef: Remove as default supervisor -FirmSuperActRMSuperAll: Remove all active supervisions for this company -FirmsNotification: Send company notification -FirmNotification fsh: Send notification to company #{fsh} +FirmSuperActSwitchSuper: Change default company supervisor +FirmSuperActSwitchSuperInfo: Does not affect company-external supervisors and does not change any active individal supervisions. Additionally use reset action, if desired. +FirmSuperActRMSuperDef: Remove default supervisor +FirmSuperActRMSuperActive: Also remove active supervisions within this company +FirmsNotification: Send company notification e-mail +FirmNotification fsh: Send e-mail to #{fsh} +FirmsNotificationTitle: Company notification +FirmNotificationTitle fsh@CompanyShorthand: #{fsh} notification FilterSupervisor: Has active supervisor FilterSupervisorCompany fsh: Has active company supervisor belonging to #{fsh} FilterSupervisorForeign fsh: Has active supervisor not belonging to #{fsh} FilterForeignSupervisor: Has company-external supervisors -FilterFirmPostalAddress: Postal company addresse known +FilterFirmExtern: External company FirmSupervisorOf fsh@CompanyShorthand: Supervisors belonging to #{fsh} -FirmEmployeeOf fsh@CompanyShorthand: #{fsh} associated users \ No newline at end of file +FirmSupervisorIndependent: Independent supervisors +FirmEmployeeOf fsh@CompanyShorthand: #{fsh} associated users +NoCompanySelected: Select at least one company, please. +TableIsDefaultSupervisor: Default supervisor +TableIsDefaultReroute: Default reroute +FormFieldPostal: Notification type +FormFieldPostalTip: Affects all notifications to this person, not just reroutes to this supervisor +FirmUserChanges n: Notification settings changed for #{n} company associates +FirmSupervisionKeyData: Supervision key data \ No newline at end of file diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index 113121211..e0fee7cb8 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -84,14 +84,8 @@ CsvColumnLmsDate: Datum des E‑Learning Ereignisses CsvColumnLmsResetTries: Anzahl der bisher verbrauchten E‑Learning Prüfungsversuche zurücksetzen CsvColumnLmsLock: E‑Learning Login gesperrt CsvColumnLmsResult !ident-ok: LMS Status -LmsUserlistInsert: Neuer LMS User -LmsUserlistUpdate: LMS User Aktualisierung -LmsResultInsert: Neues LMS Ergebnis -LmsResultUpdate: LMS Ergebnis Aktualisierung LmsReportInsert: Neues LMS Ereignis LmsReportUpdate: LMS Ereignis Aktualisierung -LmsResultCsvExceptionDuplicatedKey: CSV-Import LmsResult fand uneindeutigen Schlüssel -LmsUserlistCsvExceptionDuplicatedKey: CSV-Import LmsUserlist fand uneindeutigen Schlüssel LmsReportCsvExceptionDuplicatedKey: CSV-Import LmsReport fand uneindeutigen Schlüssel LmsDirectUpload: Direkter Upload für automatisierte Systeme LmsErrorNoRefreshElearning: Fehler: E‑Learning wird nicht automatisch gestartet, da die Zeitspanne für den Erneurerungszeitraum nicht festgelegt wurde. @@ -138,7 +132,5 @@ LmsNotificationSend n@Int: E‑Learning Benachrichtigungen an #{n} #{pluralDE n LmsPinRenewal n@Int: E‑Learning Passwort ausgetauscht für #{n} #{pluralDE n "Prüfling" "Prüflinge"}. LmsActionFailed n@Int: Aktion nicht durchgeführt für #{n} #{pluralDE n "Person" "Personen"}, da diese derzeit nicht an einer Prüfung teilnehmen. LmsStarted: E‑Learning eröffnet -LmsAutomaticQueuing n@Natural: Die folgenden Funktionen werden normalerweise einmal pro Tag um #{show n} Uhr ausgeführt. -LmsManualQueuing: Die folgenden Funktionen sollten einmal pro Tag ausgeführt werden. BtnLmsEnqueue: Nutzer mit ablaufenden Qualifikationen zum E‑Learning anmelden und benachrichtigen -BtnLmsDequeue: Nutzer mit beendetem E‑Learning ggf. benachrichtigen und aufräumen +BtnLmsDequeue: Nutzer mit beendetem E‑Learning aufräumen und ggf. benachrichtigen diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg index 1cab2c3dd..c886cb843 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/messages/uniworx/categories/qualification/en-eu.msg @@ -7,7 +7,7 @@ QualificationName: Qualification QualificationDescription: Description QualificationValidIndicator: Validity QualificationValidDuration: Validity period -QualificationAuditDuration: Audit log keept +QualificationAuditDuration: Audit log retention period QualificationAuditDurationTooltip n@Int: Optional period for deletion of e‑learning data. Note that the e‑learning server may delete its anonymised data earlier, at most #{n} days after closing. QualificationRefreshWithin: Refresh within QualificationRefreshWithinTooltip: Optional period before expiry to start e‑learning and send a notification by post or email. @@ -19,7 +19,7 @@ QualificationExpiryNotificationTooltip: Qualification holder are notfied upon in TableQualificationCountActive: Active TableQualificationCountActiveTooltip: Number of currently valid qualification holders TableQualificationCountTotal: Total -TableQualificationIsAvsLicence: AVS Driving License +TableQualificationIsAvsLicence: AVS driving license TableQualificationIsAvsLicenceTooltip: Under which name is this qualification synchronized with AVS, if any? Only applies to qualification holders having an AVS PersonID. TableQualificationSapExport: Sent to SAP TableQualificationSapExportTooltip: Is this qualification transmitted to SAP? Only applies to qualification holder having a Fraport AG personnel number. @@ -84,14 +84,8 @@ CsvColumnLmsResetTries: Reset number of used up e‑learning exam attempts CsvColumnLmsDate: Date of e‑learning event CsvColumnLmsResult: LMS Status CsvColumnLmsLock: E‑learning login is not permitted -LmsUserlistInsert: New LMS user -LmsUserlistUpdate: Update of LMS user -LmsResultInsert: New LMS result -LmsResultUpdate: Update of LMS result LmsReportInsert: New LMS event LmsReportUpdate: Update of LMS event -LmsResultCsvExceptionDuplicatedKey: CSV import LmsResult with ambiguous key -LmsUserlistCsvExceptionDuplicatedKey: CSV import LmsUserlist with ambiguous key LmsReportCsvExceptionDuplicatedKey: CSV Import LmsReport with ambiguous key LmsDirectUpload: Direct upload for automated systems LmsErrorNoRefreshElearning: Error: E‑learning will not be started automatically due to refresh-within time period not being set. @@ -138,7 +132,5 @@ LmsNotificationSend n: E‑learning notifications will be sent to #{n} #{pluralE LmsPinRenewal n: E‑learning password replaced randomly for #{n} #{pluralENs n "examinee"}. LmsActionFailed n: No action for #{n} #{pluralENs n "person"}, since there was no ongoing examination. LmsStarted: E‑learning open since -LmsAutomaticQueuing n@Natural: The following functions are executed daily at #{show n} o'clock. -LmsManualQueuing: The following functions should be executed daily. -BtnLmsEnqueue: Enqueue users with expiring qualifications for e‑learning and notify them. -BtnLmsDequeue: Dequeue users with finished e‑learning and notify, if appropriate. +BtnLmsEnqueue: Enqueue users with expiring qualifications for e‑learning and notify them +BtnLmsDequeue: Dequeue users with finished e‑learning and notify failed users diff --git a/messages/uniworx/categories/send/send_notifications/de-de-formal.msg b/messages/uniworx/categories/send/send_notifications/de-de-formal.msg index b2a350b3e..cba2c8110 100644 --- a/messages/uniworx/categories/send/send_notifications/de-de-formal.msg +++ b/messages/uniworx/categories/send/send_notifications/de-de-formal.msg @@ -103,4 +103,4 @@ MailSupervisorNoCopy: Warnung: Diese Nachricht wurde nicht an den eigentlichen E MailSupervisedNote: Hinweis MailSupervisedBody: Eine Kopie dieser Nachricht wurde auch an folgende in FRADrive eingetragene Ansprechpartner gesendet: MailSupervisorReroute: Benachrichtigungsumleitung -MailSupervisorRerouteTooltip: Alle Benachrichtigungen werden stattdessen an alle Ansprechpartner mit Benachrichtigungsumleitung gesandt \ No newline at end of file +MailSupervisorRerouteTooltip: Alle Benachrichtigungen werden stattdessen an diese Ansprechpartner mit Benachrichtigungsumleitung gesandt \ No newline at end of file diff --git a/messages/uniworx/categories/send/send_notifications/en-eu.msg b/messages/uniworx/categories/send/send_notifications/en-eu.msg index b06a1c2eb..04fe30088 100644 --- a/messages/uniworx/categories/send/send_notifications/en-eu.msg +++ b/messages/uniworx/categories/send/send_notifications/en-eu.msg @@ -103,4 +103,4 @@ MailSupervisorNoCopy: Warning: This message was not sent to the original recipie MailSupervisedNote: Please note MailSupervisedBody: A copy of this message has been sent to all supervisors registered for you in FRADrive, namely: MailSupervisorReroute: Reroute notifications -MailSupervisorRerouteTooltip: All notification will be sent to all supervisors with notification rerouting instead \ No newline at end of file +MailSupervisorRerouteTooltip: All notification will be rerouted to these supervisors instead \ No newline at end of file diff --git a/messages/uniworx/misc/de-de-formal.msg b/messages/uniworx/misc/de-de-formal.msg index ef68eb735..3fcd6ffe6 100644 --- a/messages/uniworx/misc/de-de-formal.msg +++ b/messages/uniworx/misc/de-de-formal.msg @@ -10,6 +10,7 @@ BoolIrrelevant !ident-ok: — FieldPrimary: Hauptfach FieldSecondary: Nebenfach MultiEmailFieldTip: Es sind mehrere, Komma-separierte, E-Mail-Adressen möglich +MultiSelectTip: Mehrfachauswahl und Abwählen mit Strg-Klick WeekDay: Wochentag LdapIdentificationOrEmail: Fraport AG-Kennung / E-Mail-Adresse Months num@Int64: #{num} #{pluralDE num "Monat" "Monate"} diff --git a/messages/uniworx/misc/en-eu.msg b/messages/uniworx/misc/en-eu.msg index 97423bdda..ed8bda4db 100644 --- a/messages/uniworx/misc/en-eu.msg +++ b/messages/uniworx/misc/en-eu.msg @@ -10,6 +10,7 @@ BoolIrrelevant: — FieldPrimary: Major FieldSecondary: Minor MultiEmailFieldTip: Multiple emails addresses may be specified (comma-separated) +MultiSelectTip: Multiple selection and desection via Ctrl-Click WeekDay: Day of the week LdapIdentificationOrEmail: Fraport AG-Kennung / email address Months num: #{num} #{pluralEN num "Month" "Months"} diff --git a/messages/uniworx/utils/navigation/menu/de-de-formal.msg b/messages/uniworx/utils/navigation/menu/de-de-formal.msg index b306bfdfc..eab4f204e 100644 --- a/messages/uniworx/utils/navigation/menu/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/menu/de-de-formal.msg @@ -23,6 +23,7 @@ MenuPayments: Zahlungsbedingungen MenuInstance: Instanz-Identifikation MenuHealth: Instanz-Zustand +MenuHealthInterface: Schnittstellen Zustand MenuHelp: Hilfe MenuProfile: Anpassen MenuLogin !ident-ok: Login @@ -124,8 +125,6 @@ MenuLmsUser: Benutzerqualifikationen MenuLmsUserSchool: Bereichs Benutzerqualifikationen MenuLmsUserAll: Alle Benutzerqualifikationen MenuLmsUsers: Veralteter Export E‑Learning Benutzer -MenuLmsUserlist: Veraltetes Melden E‑Learning Benutzer -MenuLmsResult: Veralteter Melden Ergebnisse E‑Learning MenuLmsUpload: Hochladen MenuLmsDirectUpload: Direkter Upload MenuLmsDirectDownload: Direkter Download @@ -138,6 +137,7 @@ MenuFirmUsers: Angehörige MenuFirmSupervisors: Ansprechpartner MenuFirmsComm: Mitteilung +MenuInterfaces: Schnittstellen MenuSap: SAP Schnittstelle MenuAvs: AVS Schnittstelle @@ -146,6 +146,8 @@ MenuLdap: LDAP Schnittstelle MenuApc: Druckerei MenuPrintSend: Manueller Briefversand MenuPrintDownload: Brief herunterladen +MenuPrintLog: LPR Schnittstelle +MenuPrintAck: Druckbestätigung MenuApiDocs: API-Dokumentation (Englisch) MenuSwagger !ident-ok: OpenAPI 2.0 (Swagger) diff --git a/messages/uniworx/utils/navigation/menu/en-eu.msg b/messages/uniworx/utils/navigation/menu/en-eu.msg index c8c18365f..526c6d871 100644 --- a/messages/uniworx/utils/navigation/menu/en-eu.msg +++ b/messages/uniworx/utils/navigation/menu/en-eu.msg @@ -23,6 +23,7 @@ MenuPayments: Payment Terms MenuInstance: Instance identification MenuHealth: Instance health +MenuHealthInterface: Interface health MenuHelp: Support MenuProfile: Settings MenuLogin: Login @@ -70,7 +71,6 @@ MenuCourseDelete: Delete course MenuSubmissionNew: Create submission MenuSubmissionOwn: Submission MenuCorrectors: Correctors - MenuSheetEdit: Edit exercise sheet MenuSheetDelete: Delete exercise sheet MenuSheetClone: Clone exercise sheet @@ -125,8 +125,6 @@ MenuLmsUser: User Qualifications MenuLmsUserSchool: Institute User Qualifications MenuLmsUserAll: All User Qualifications MenuLmsUsers: Legacy download e‑learning users -MenuLmsUserlist: Legacy upload e‑learning users -MenuLmsResult: Legacy upload r‑learning results MenuLmsUpload: Upload MenuLmsDirectUpload: Direct Upload MenuLmsDirectDownload: Direct Download @@ -139,6 +137,7 @@ MenuFirmUsers: Associates MenuFirmSupervisors: Supervisors MenuFirmsComm: Messaging +MenuInterfaces: Interfaces MenuSap: SAP Interface MenuAvs: AVS Interface @@ -147,6 +146,8 @@ MenuLdap: LDAP Interface MenuApc: Printing MenuPrintSend: Send Letter MenuPrintDownload: Download Letter +MenuPrintLog: LPR Interface +MenuPrintAck: Acknowledge Printing MenuApiDocs: API documentation MenuSwagger: OpenAPI 2.0 (Swagger) diff --git a/messages/uniworx/utils/table_column/de-de-formal.msg b/messages/uniworx/utils/table_column/de-de-formal.msg index 295648b7e..0a67481af 100644 --- a/messages/uniworx/utils/table_column/de-de-formal.msg +++ b/messages/uniworx/utils/table_column/de-de-formal.msg @@ -104,4 +104,6 @@ TableJobActDeleteFeedback n@Int m@Int: #{n}/#{m} Jobs entfernt TableFilterComma: Es können mehrere alternative Suchkriterien mit Komma getrennt angegeben werden, wovon mindestens eines erfüllt werden muss. TableFilterCommaPlus: Mehrere alternative Suchkriterien mit Komma trennen. Mindestens ein Suchkriterium muss erfüllt werden, zusätzlich zu allen Suchkriterien mit vorangestelltem Plus-Symbol. TableFilterCommaName: Mehrere Namen mit Komma trennen. -TableFilterCommaNameNr: Mehrere Namen oder Nummern mit Komma trennen. Nummern werden nur exakt gesucht. \ No newline at end of file +TableFilterCommaNameNr: Mehrere Namen oder Nummern mit Komma trennen. Nummern werden nur exakt gesucht. +TableUserEdit: Benutzer bearbeiten +TableRows: Zeilen \ No newline at end of file diff --git a/messages/uniworx/utils/table_column/en-eu.msg b/messages/uniworx/utils/table_column/en-eu.msg index 3b7962522..e7ae23a14 100644 --- a/messages/uniworx/utils/table_column/en-eu.msg +++ b/messages/uniworx/utils/table_column/en-eu.msg @@ -104,4 +104,6 @@ TableJobActDeleteFeedback n@Int m@Int: #{n}/#{m} queued jobs deleted TableFilterComma: Separate multiple alternative filter criteria by comma, at least one of which must be fulfilled. TableFilterCommaPlus: Separate multiple alternative filter criteria by comma, at least one of which must be fulfilled in addition to all criteria preceded by a plus symbol. TableFilterCommaName: Separate names by comma. -TableFilterCommaNameNr: Separate names and numbers by comma. Numbers have to match exact. \ No newline at end of file +TableFilterCommaNameNr: Separate names and numbers by comma. Numbers have to match exact. +TableUserEdit: Edit user +TableRows: Rows \ No newline at end of file diff --git a/messages/uniworx/utils/utils/de-de-formal.msg b/messages/uniworx/utils/utils/de-de-formal.msg index c02cbe1fb..5ff122fb1 100644 --- a/messages/uniworx/utils/utils/de-de-formal.msg +++ b/messages/uniworx/utils/utils/de-de-formal.msg @@ -18,6 +18,8 @@ CommRecipients: Empfänger:innen CommRecipientsTip: Sie selbst erhalten immer eine Kopie der Nachricht CommRecipientsList: Die an Sie selbst verschickte Kopie der Nachricht wird, zu Archivierungszwecken, eine vollständige Liste aller Empfänger:innen enthalten. Die Empfängerliste wird im CSV-Format an die E-Mail angehängt. Andere Empfänger:innen erhalten die Liste nicht. Bitte entfernen Sie dementsprechend den Anhang bevor Sie die E-Mail weiterleiten oder anderweitig mit Dritten teilen. UtilEMail: E-Mail +UtilPostal: Brief +UtilUnchanged: Nicht verändern UtilMultiEmailFieldTip: Es sind mehrere, Komma-separierte, E-Mail-Adressen möglich RGTutorialParticipants tutn@TutorialName: Kursteilnehmer:innen (#{tutn}) RGExamRegistered examn@ExamName: Angemeldet zur Prüfung „#{examn}“ @@ -94,6 +96,9 @@ RoomReferenceLinkLink !ident-ok: Link RoomReferenceLinkLinkPlaceholder !ident-ok: URL RoomReferenceLinkInstructions: Anweisungen RoomReferenceLinkInstructionsPlaceholder: Anweisungen +UtilEmptyChoice: Auswahl war leer +UtilEmptyNoChangeTip: Eine leere Eingabe belässt den vorherigen Wert unverändert. +MultiNoSelection: Keine Auswahl #invitation.hs InvitationAction: Aktion diff --git a/messages/uniworx/utils/utils/en-eu.msg b/messages/uniworx/utils/utils/en-eu.msg index 1135dbade..f65004cd1 100644 --- a/messages/uniworx/utils/utils/en-eu.msg +++ b/messages/uniworx/utils/utils/en-eu.msg @@ -18,6 +18,8 @@ CommRecipients: Recipients CommRecipientsTip: You always receive a copy of the message CommRecipientsList: For archival purposes the copy of the message sent to you will contain a complete list of all recipients. The list of recipients will be attached to the email in CSV-format. Other recipients do not receive the list. Thus, please remove the attachment before you forward the email or otherwise share it with third parties. UtilEMail: Email +UtilPostal: Postal +UtilUnchanged: No change UtilMultiEmailFieldTip: Multiple emails addresses may be specified (comma-separated) RGTutorialParticipants tutn: Course participants (#{tutn}) RGExamRegistered examn: Registered for exam “#{examn}” @@ -94,6 +96,9 @@ RoomReferenceLinkLink: Link RoomReferenceLinkLinkPlaceholder: URL RoomReferenceLinkInstructions: Instructions RoomReferenceLinkInstructionsPlaceholder: Instructions +UtilEmptyChoice: Empty selection +UtilEmptyNoChangeTip: Existing values remain unchanged if this field is left empty. +MultiNoSelection: No selection #invitation.hs InvitationAction: Action diff --git a/models/audit.model b/models/audit.model index cf821f6ec..3cd567a13 100644 --- a/models/audit.model +++ b/models/audit.model @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen +-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -9,4 +9,23 @@ TransactionLog initiator UserId Maybe -- User associated with performing this action remote IP Maybe -- Remote party that triggered this action via HTTP info Value -- JSON-encoded `Transaction` - deriving Eq Read Show Generic \ No newline at end of file + deriving Eq Read Show Generic + +InterfaceLog + interface Text + subtype Text + write Bool -- requestMethod /= GET, i.e. True implies a write to FRADrive + time UTCTime + rows Int Maybe -- number of datasets transmitted + info Text -- addtional status information + success Bool default=true -- false logs a failure; but it will be overwritten by next transaction, but logged in TransactionLog + UniqueInterfaceSubtypeWrite interface subtype write + deriving Eq Read Show Generic + +InterfaceHealth + interface Text + subtype Text Maybe + write Bool Maybe + hours Int + UniqueInterfaceHealth interface subtype write !force -- Note that nullable fields must be either empty or unique + deriving Eq Read Show Generic diff --git a/models/lms.model b/models/lms.model index fc15d7fa2..713b9a57d 100644 --- a/models/lms.model +++ b/models/lms.model @@ -20,7 +20,7 @@ Qualification SchoolQualificationShort school shorthand -- must be unique per school and shorthand SchoolQualificationName school name -- must be unique per school and name -- across all schools, only one qualification may be a driving licence: - UniqueQualificationAvsLicence avsLicence !force + UniqueQualificationAvsLicence avsLicence !force -- either empty or unique -- NOTE: two NULL values are not equal for the purpose of Uniqueness constraints! deriving Eq Generic @@ -97,25 +97,20 @@ QualificationUserBlock -- - delete-flag: isJust LmsUserStatus -- Note: REST means that LmsUserResetPin and LmsUserDelete remain unchanged by this GET request! -- - -- 3. REST POST Userlist.csv: just save as is to LmsUserlist + -- 3. REST POST Report.csv: just save as is to LmsReport for later processing -- - -- 4. REST POST Ergebnisse.csv: just save as is to LmsResult - -- - -- 5. When received: Job LmsUserlist: -- Note: containment needs at-once processing + -- 4. When received: Job LmsReport: -- Note: containment needs at-once processing -- - For all LmsUser: -- + if contained: -- set LmsUserReceived to Just now() - -- if LmsUserlistFailed: set LmsUserStatus to Just LmsBlocked now + -- if Failed: set LmsUserStatus to Just LmsBlocked now + -- if Success: set LmsUserStatus to Just LmsSuccess now + -- and renew QualificationValidTo -- + not contained, by LmsUserReceived is set: set LmsUserEnded to Just now() -- - move row to LmsAudit -- - -- 6. When received: Daily Job LmsResult: - -- - set LmsUserReceived to Just now() -- always - -- - set LmsUserStatus to Just LmsSuccess now -- conditional - -- - and renew QualificationValidTo - -- - move row to LmsAudit - -- - -- 7. Daily Job: dequeue LMS Users + -- 5. Daily Job: dequeue LMS Users + -- - fail and mark expired LmsUser -- - remove from LmsUser after audit Period has passed LmsUser @@ -146,24 +141,6 @@ LmsUser -- UniqueLmsUserStatus lmsUser -- enforcing uniqueness prohibits history -- deriving Generic --- DEPRECATED V1 LmsUserlist stores LMS upload for later processing only -LmsUserlist - qualification QualificationId OnDeleteCascade OnUpdateCascade - ident LmsIdent - failed Bool - timestamp UTCTime default=now() - UniqueLmsUserlist qualification ident - deriving Generic Show - --- DEPRECATED V1 LmsResult stores LMS upload for later processing only -LmsResult - qualification QualificationId OnDeleteCascade OnUpdateCascade - ident LmsIdent - success Day -- BEWARE: timezone is local as submitted by LMS - timestamp UTCTime default=now() - UniqueLmsResult qualification ident -- required by DBTable - deriving Generic - -- V2 Stores LMS upload for processing in Background Job LmsReport qualification QualificationId OnDeleteCascade OnUpdateCascade diff --git a/models/print.model b/models/print.model index ee3f1ea7c..ee22cf922 100644 --- a/models/print.model +++ b/models/print.model @@ -9,11 +9,11 @@ PrintJob file ByteString -- stores plain pdf; otherwise use FileContentReference Maybe created UTCTime acknowledged UTCTime Maybe - recipient UserId Maybe OnDeleteCascade OnUpdateCascade -- optional as some letters may contain just an address + recipient UserId Maybe OnDeleteSetNull OnUpdateCascade -- optional as some letters may contain just an address sender UserId Maybe OnDeleteSetNull OnUpdateCascade -- senders and associations are optional course CourseId Maybe OnDeleteCascade OnUpdateCascade qualification QualificationId Maybe OnDeleteCascade OnUpdateCascade - lmsUser LmsIdent Maybe OnDeleteCascade OnUpdateCascade -- allows tracking if recipient has been notified; must be unique + lmsUser LmsIdent Maybe OnDeleteSetNull OnUpdateCascade -- allows tracking if recipient has been notified; must be unique -- UniquePrintJobLmsUser lmsUser -- Note that in fact multiple print jobs per LMS user are possible! -- UniquePrintJobApcIdent apcIdent -- TODO: not yet enforced, since LmsIdent is currently used deriving Generic diff --git a/models/schools.model b/models/schools.model index 60c45cbbd..715a43508 100644 --- a/models/schools.model +++ b/models/schools.model @@ -10,8 +10,8 @@ School json examMinimumRegisterBeforeStart NominalDiffTime Maybe examMinimumRegisterDuration NominalDiffTime Maybe examRequireModeForRegistration Bool default=false - examDiscouragedModes ExamModeDNF default='{"dnf-terms":[]}' -- This comment fixes syntax highlighting error only " - examCloseMode ExamCloseMode default='separate' + examDiscouragedModes ExamModeDNF + examCloseMode ExamCloseMode default='separate' sheetAuthorshipStatementMode SchoolAuthorshipStatementMode default='optional' sheetAuthorshipStatementDefinition AuthorshipStatementDefinitionId Maybe sheetAuthorshipStatementAllowOther Bool default=true diff --git a/models/users.model b/models/users.model index 8a686feac..b23fe85b2 100644 --- a/models/users.model +++ b/models/users.model @@ -2,7 +2,7 @@ -- -- SPDX-License-Identifier: AGPL-3.0-or-later --- The files in /models determine the database scheme. +-- The files in /models determine t he database scheme. -- The organisational split into several files has no operational effects. -- White-space and case matters: Each SQL table is named in 1st column of this file -- Indendent lower-case lines describe the SQL-columns of the table with name, type and options @@ -34,7 +34,7 @@ User json -- Each Uni2work user has a corresponding row in this table; create timeFormat DateTimeFormat "default='%R'" -- preferred Time-only display format for user; user-defined downloadFiles Bool default=false -- Should files be opened in browser or downloaded? (users often oblivious that their browser has a setting for this) languages Languages Maybe -- Preferred language; user-defined - notificationSettings NotificationSettings "default='{}'::jsonb" -- Bit-array for which events email notifications are requested by user; user-defined + notificationSettings NotificationSettings "default='{}'::jsonb" -- Bit-array for which events email notifications are requested by user; user-defined; missing fields in json object will be parsed to default trigger warningDays NominalDiffTime default=1209600 -- timedistance to pending deadlines for homepage infos csvOptions CsvOptions "default='{}'::jsonb" sex Sex Maybe -- currently ignored diff --git a/nix/docker/version.json b/nix/docker/version.json index ae41d9f2a..450e150fd 100644 --- a/nix/docker/version.json +++ b/nix/docker/version.json @@ -1,3 +1,3 @@ { - "version": "27.4.49" + "version": "27.4.59" } diff --git a/package-lock.json b/package-lock.json index a24e9106c..8baaeafcc 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.49", + "version": "27.4.59", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index b11cc7651..8c360c1e7 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.49", + "version": "27.4.59", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 04e5ca14e..2c242b3b3 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 27.4.49 +version: 27.4.59 dependencies: - base - yesod @@ -259,6 +259,7 @@ ghc-options: - -j - -freduction-depth=0 - -fprof-auto-calls + - -g when: - condition: flag(pedantic) ghc-options: diff --git a/routes b/routes index 931c52909..34ad73505 100644 --- a/routes +++ b/routes @@ -79,24 +79,26 @@ /print PrintCenterR GET POST !system-printer /print/acknowledge/#Day/#Int/#Int PrintAckR GET POST !system-printer -/print/acknowledge/direct PrintAckDirectR POST !system-printer +/print/acknowledge/direct PrintAckDirectR GET POST !system-printer /print/send PrintSendR GET POST /print/download/#CryptoUUIDPrintJob PrintDownloadR GET !system-printer +/print/log PrintLogR GET !system-printer -/health HealthR GET !free -/instance InstanceR GET !free -/info InfoR GET !free -/info/lecturer InfoLecturerR GET !free -/info/supervisor InfoSupervisorR GET !free -/info/legal LegalR GET !free -/info/glossary GlossaryR GET !free -/info/faq FaqR GET !free -/info/terms-of-use TermsOfUseR GET !free -/info/payments PaymentsR GET !free -/imprint ImprintR GET !free -/data-protection DataProtectionR GET !free -/version VersionR GET !free -/status StatusR GET !free +/health HealthR GET !free +/health/interface/+Texts HealthInterfaceR GET !free +/instance InstanceR GET !free +/info InfoR GET !free +/info/lecturer InfoLecturerR GET !free +/info/supervisor InfoSupervisorR GET !free +/info/legal LegalR GET !free +/info/glossary GlossaryR GET !free +/info/faq FaqR GET !free +/info/terms-of-use TermsOfUseR GET !free +/info/payments PaymentsR GET !free +/imprint ImprintR GET !free +/data-protection DataProtectionR GET !free +/version VersionR GET !free +/status StatusR GET !free /help HelpR GET POST !free @@ -113,12 +115,11 @@ /for/#CryptoUUIDUser/user ForProfileR GET POST !supervisor !self /for/#CryptoUUIDUser/user/profile ForProfileDataR GET !supervisor !self -/firms FirmAllR GET POST !supervisor -/firms/comm FirmsCommR GET POST -/firm/#CompanyShorthand FirmR GET POST +/firms FirmAllR GET POST -- not yet !supervisor +/firms/comm/+Companies FirmsCommR GET POST /firm/#CompanyShorthand/comm FirmCommR GET POST -/firm/#CompanyShorthand/users FirmUsersR GET POST !supervisor -/firm/#CompanyShorthand/supers FirmSupersR GET POST !supervisor +/firm/#CompanyShorthand FirmUsersR GET POST -- not yet !supervisor +/firm/#CompanyShorthand/supers FirmSupersR GET POST -- not yet !supervisor /exam-office ExamOfficeR !exam-office: / EOExamsR GET POST !system-exam-office @@ -280,20 +281,11 @@ /lms/#SchoolId LmsSchoolR GET /lms/#SchoolId/#QualificationShorthand LmsR GET POST /lms/#SchoolId/#QualificationShorthand/edit LmsEditR GET POST --- old V1 LMS Interface -/lms/#SchoolId/#QualificationShorthand/users LmsUsersR GET -/lms/#SchoolId/#QualificationShorthand/users/direct LmsUsersDirectR GET !token -- LMS -/lms/#SchoolId/#QualificationShorthand/userlist LmsUserlistR GET POST -/lms/#SchoolId/#QualificationShorthand/userlist/upload LmsUserlistUploadR GET POST !development -/lms/#SchoolId/#QualificationShorthand/userlist/direct LmsUserlistDirectR POST !token -- LMS, also remove JobLmsUserlist constructor -/lms/#SchoolId/#QualificationShorthand/result LmsResultR GET POST -/lms/#SchoolId/#QualificationShorthand/result/upload LmsResultUploadR GET POST !development -/lms/#SchoolId/#QualificationShorthand/result/direct LmsResultDirectR POST !token -- LMS, also remove JobLmsResults constructor -- new V2 LMS Interface /lms/#SchoolId/#QualificationShorthand/learners LmsLearnersR GET /lms/#SchoolId/#QualificationShorthand/learners/direct LmsLearnersDirectR GET !token -- LMS /lms/#SchoolId/#QualificationShorthand/report LmsReportR GET POST -/lms/#SchoolId/#QualificationShorthand/report/upload LmsReportUploadR GET POST !development +/lms/#SchoolId/#QualificationShorthand/report/upload LmsReportUploadR GET POST /lms/#SchoolId/#QualificationShorthand/report/direct LmsReportDirectR POST !token -- LMS -- other lms routes /lms/#SchoolId/#QualificationShorthand/ident/#LmsIdent LmsIdentR GET -- redirect to LmsR with filter-parameter diff --git a/shell.nix b/shell.nix index 0988cc475..42c65ae1f 100644 --- a/shell.nix +++ b/shell.nix @@ -223,7 +223,7 @@ let fi ''; - killallUni2work = pkgs.writeScriptBin "killall-uni2work" '' + killallUni2work = pkgs.writeScriptBin "killuni2work" '' #!${pkgs.zsh}/bin/zsh set -o pipefail diff --git a/src/Application.hs b/src/Application.hs index 45f24768e..4b60ecb39 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -145,6 +145,7 @@ import Handler.Material import Handler.CryptoIDDispatch import Handler.SystemMessage import Handler.Health +import Handler.Health.Interface import Handler.Exam import Handler.ExamOffice import Handler.Metrics diff --git a/src/Audit.hs b/src/Audit.hs index b6b8012a0..40c4a4206 100644 --- a/src/Audit.hs +++ b/src/Audit.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen +-- SPDX-FileCopyrightText: 2023 Gregor Kleen ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -8,6 +8,7 @@ module Audit , audit , AuditRemoteException(..) , getRemote + , logInterface, logInterface' ) where @@ -103,12 +104,68 @@ audit :: ( AuthId (HandlerSite m) ~ Key User -- - `transactionLogInitiator` is currently logged in user (or none) -- - `transactionLogRemote` is determined from current HTTP-Request audit transaction@(toJSON -> transactionLogInfo) = do - transactionLogTime <- liftIO getCurrentTime transactionLogInstance <- getsYesod $ view instanceID transactionLogInitiator <- liftHandler maybeAuthId transactionLogRemote <- handle (throwM . AuditRemoteException) $ Just <$> getRemote - insert_ TransactionLog{..} - $logInfoS "Audit" $ Text.filter (/= '\n') $ tshow (transaction, transactionLogInitiator, transactionLogRemote) <> " - " <> pack (prettyCallStack callStack) + +logInterface :: ( AuthId (HandlerSite m) ~ Key User + , IsSqlBackend (YesodPersistBackend (HandlerSite m)) + , SqlBackendCanWrite (YesodPersistBackend (HandlerSite m)) + , HasInstanceID (HandlerSite m) InstanceId + , YesodAuthPersist (HandlerSite m) + , MonadHandler m + , MonadCatch m + , HasAppSettings (HandlerSite m) + , HasCallStack + ) + => Text -- ^ Interface that is used + -> Text -- ^ Subtype of the interface, if any + -> Bool -- ^ Success=True, Failure=False + -> Maybe Int -- ^ Number of transmitted datasets + -> Text -- ^ Any additional information + -> ReaderT (YesodPersistBackend (HandlerSite m)) m () +-- ^ Log a transaction using information available from `HandlerT`, also calls `audit` +logInterface interfaceLogInterface interfaceLogSubtype interfaceLogSuccess interfaceLogRows interfaceLogInfo = do + interfaceLogWrite <- (methodGet /=) . Wai.requestMethod . reqWaiRequest <$> getRequest + logInterface' interfaceLogInterface interfaceLogSubtype interfaceLogWrite interfaceLogSuccess interfaceLogRows interfaceLogInfo + +logInterface' :: ( AuthId (HandlerSite m) ~ Key User + , IsSqlBackend (YesodPersistBackend (HandlerSite m)) + , SqlBackendCanWrite (YesodPersistBackend (HandlerSite m)) + , HasInstanceID (HandlerSite m) InstanceId + , YesodAuthPersist (HandlerSite m) + , MonadHandler m + , MonadCatch m + , HasAppSettings (HandlerSite m) + , HasCallStack + ) + => Text -- ^ Interface that is used + -> Text -- ^ Subtype of the interface, if any + -> Bool -- ^ True indicates Write Access to FRADrive + -> Bool -- ^ Success=True, Failure=False + -> Maybe Int -- ^ Number of transmitted datasets + -> Text -- ^ Any additional information + -> ReaderT (YesodPersistBackend (HandlerSite m)) m () +-- ^ Log a transaction using information available from `HandlerT`, also calls `audit` +logInterface' (Text.strip -> interfaceLogInterface) (Text.strip -> interfaceLogSubtype) interfaceLogWrite interfaceLogSuccess interfaceLogRows (Text.strip -> interfaceLogInfo) = do + interfaceLogTime <- liftIO getCurrentTime + -- deleteBy $ UniqueInterfaceSubtypeWrite interfaceLogInterface interfaceLogSubtype interfaceLogWrite -- always replace: deleteBy & insert seems to be safest and fastest + -- insert_ InterfaceLog{..} + void $ upsertBy (UniqueInterfaceSubtypeWrite interfaceLogInterface interfaceLogSubtype interfaceLogWrite) + ( InterfaceLog{..} ) + [ InterfaceLogTime =. interfaceLogTime + , InterfaceLogRows =. interfaceLogRows + , InterfaceLogInfo =. interfaceLogInfo + , InterfaceLogSuccess =. interfaceLogSuccess + ] + audit TransactionInterface + { transactionInterfaceName = interfaceLogInterface + , transactionInterfaceSubtype = interfaceLogSubtype + , transactionInterfaceWrite = interfaceLogWrite + , transactionInterfaceRows = interfaceLogRows + , transactionInterfaceInfo = interfaceLogInfo + , transactionInterfaceSuccess = Just interfaceLogSuccess + } diff --git a/src/Audit/Types.hs b/src/Audit/Types.hs index ed3927a03..976171ec4 100644 --- a/src/Audit/Types.hs +++ b/src/Audit/Types.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-23 Gregor Kleen ,Sarah Vaupel ,,Steffen Jost +-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen ,Sarah Vaupel ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -234,6 +234,14 @@ data Transaction , transactionQualification :: QualificationId , transactionQualificationScheduleRenewal :: Maybe Bool -- TRUE=will be notified upon expiry, FALSE=won't be notified; always JUST, for compatibility with TransactionQualificationUserEdit } + | TransactionInterface + { transactionInterfaceName :: Text + , transactionInterfaceSubtype :: Text + , transactionInterfaceWrite :: Bool -- True implies a write to FRADrive + , transactionInterfaceRows :: Maybe Int + , transactionInterfaceInfo :: Text + , transactionInterfaceSuccess :: Maybe Bool -- Just False implies a failure; Maybe used to achieve backwards compatibility + } deriving (Eq, Ord, Read, Show, Generic) deriveJSON defaultOptions @@ -243,4 +251,4 @@ deriveJSON defaultOptions , sumEncoding = TaggedObject "transaction" "data" } ''Transaction -derivePersistFieldJSON ''Transaction +derivePersistFieldJSON ''Transaction \ No newline at end of file diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 3cba53920..127e0ed88 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-23 Gregor Kleen ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -17,6 +17,7 @@ module Database.Esqueleto.Utils , (>~.), (<~.) , or, and , any, all + , not__, parens , subSelectAnd, subSelectOr , mkExactFilter, mkExactFilterWith, mkExactFilterWithComma , mkExactFilterLast, mkExactFilterLastWith @@ -227,8 +228,13 @@ explicitUnsafeCoerceSqlExprValue typ (E.ERaw _m1 f1) = E.ERaw E.noMeta $ \_nPare ) and, or :: Foldable f => f (E.SqlExpr (E.Value Bool)) -> E.SqlExpr (E.Value Bool) -and = F.foldr (E.&&.) true -or = F.foldr (E.||.) false +-- and = F.foldl' (E.&&.) true -- we can use foldl' since PostgreSQL reorders conditions anyway +-- or = F.foldl' (E.||.) false +-- Maybe this help the PostgreSQL query optimizer, though I doubt it? +and f | F.null f = true + | otherwise = F.foldl1 (E.&&.) f +or f | F.null f = false + | otherwise = F.foldl1 (E.||.) f -- | Given a test and a set of values, check whether anyone succeeds the test -- WARNING: SQL leaves it explicitely unspecified whether `||` is short curcuited (i.e. lazily evaluated) @@ -247,6 +253,9 @@ subSelectOr q = parens . E.subSelectUnsafe $ flip (E.unsafeSqlAggregateFunction parens :: E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value a) parens = E.unsafeSqlFunction "" +-- | Workaround for Esqueleto-Bug not placing parenthesis after NOT, see #155 +not__ :: E.SqlExpr (E.Value Bool) -> E.SqlExpr (E.Value Bool) +not__ = E.not_ . parens -- Allow usage of Tuples as DbtRowKey, i.e. SqlIn instances for tuples $(sqlInTuples [2..16]) @@ -700,7 +709,6 @@ interval = E.unsafeSqlCastAs "interval". E.unsafeSqlValue . wrapSqlString . Text singleQuote = Text.Builder.singleton '\'' wrapSqlString b = singleQuote <> b <> singleQuote - infixl 6 `diffDays`, `diffTimes` diffDays :: E.SqlExpr (E.Value Day) -> E.SqlExpr (E.Value Day) -> E.SqlExpr (E.Value Int) diff --git a/src/Foundation/Authorization.hs b/src/Foundation/Authorization.hs index 7ca298622..0243b0609 100644 --- a/src/Foundation/Authorization.hs +++ b/src/Foundation/Authorization.hs @@ -554,7 +554,8 @@ tagAccessPredicate AuthSupervisor = APDB $ \_ _ mAuthId route _ -> case route of return Authorized checkCompanySupervisor sup@(mAuthId, fsh) = $cachedHereBinary sup . exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId - isSupervisor <- lift . existsBy $ UniqueUserCompany authId $ CompanyKey fsh + -- isSupervisor <- lift . existsBy $ UniqueUserCompany authId $ CompanyKey fsh + isSupervisor <- lift $ exists [UserCompanyUser ==. authId, UserCompanyCompany ==. CompanyKey fsh, UserCompanySupervisor ==. True] guardMExceptT isSupervisor (unauthorizedI $ MsgUnauthorizedCompanySupervisor fsh) return Authorized checkAnySupervisor mAuthId = $cachedHereBinary mAuthId . exceptT return return $ do diff --git a/src/Foundation/I18n.hs b/src/Foundation/I18n.hs index a7fd0ac1d..fd2bb9479 100644 --- a/src/Foundation/I18n.hs +++ b/src/Foundation/I18n.hs @@ -43,6 +43,8 @@ module Foundation.I18n , UniWorXMessages(..) , uniworxMessages , unRenderMessage, unRenderMessage', unRenderMessageLenient + , SomeMessages(..) + , someMessages , module Foundation.I18n.TH ) where @@ -203,6 +205,11 @@ maybeToMessage :: ToMessage m => Text -> Maybe m -> Text -> Text maybeToMessage _ Nothing _ = mempty maybeToMessage before (Just x) after = before <> toMessage x <> after +maybeBoolMessage :: Maybe Bool -> Text -> Text -> Text -> Text +maybeBoolMessage Nothing n _ _ = n +maybeBoolMessage (Just True) _ t _ = t +maybeBoolMessage (Just False) _ _ f = f + newtype ShortTermIdentifier = ShortTermIdentifier TermIdentifier deriving stock (Eq, Ord, Read, Show) @@ -261,6 +268,18 @@ mkMessageAddition ''UniWorX "Avs" "messages/uniworx/categories/avs" "de-de-forma embedRenderMessage ''UniWorX ''LmsStatus (uncurry ((<>) . (<> "Status")) . Text.splitAt 3) + +newtype SomeMessages master = SomeMessages [SomeMessage master] + deriving newtype (Semigroup, Monoid) + +instance master ~ master' => RenderMessage master (SomeMessages master') where + renderMessage a b (SomeMessages msgs) = Text.intercalate "\n " $ renderMessage a b <$> msgs + +-- | convenienience function if all messages happen to belong to the exact same type +someMessages :: RenderMessage master msg => [msg] -> SomeMessages master +someMessages msgs = SomeMessages $ SomeMessage <$> msgs + + instance RenderMessage UniWorX (Maybe LmsStatus) where -- useful for Filter with optionsFinite renderMessage f ls (Just s) = renderMessage f ls s renderMessage f ls Nothing = renderMessage f ls MsgLmsStateOpen diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 0c8cbd1a2..008e68e08 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -121,20 +121,20 @@ breadcrumb ProblemUnreachableR = i18nCrumb MsgProblemsUnreachableHeading $ Just breadcrumb ProblemWithoutAvsId = i18nCrumb MsgProblemsNoAvsIdHeading $ Just AdminProblemsR breadcrumb ProblemFbutNoR = i18nCrumb MsgProblemsRWithoutFHeading $ Just AdminProblemsR breadcrumb ProblemAvsSynchR = i18nCrumb MsgProblemsAvsSynchHeading $ Just AdminProblemsR -breadcrumb ProblemAvsErrorR = i18nCrumb MsgProblemsAvsErrorHeading $ Just ProblemAvsSynchR +breadcrumb ProblemAvsErrorR = i18nCrumb MsgProblemsAvsErrorHeading $ Just AdminProblemsR breadcrumb FirmAllR = i18nCrumb MsgMenuFirms Nothing -breadcrumb FirmsCommR = i18nCrumb MsgMenuFirmsComm $ Just FirmAllR -breadcrumb FirmR{} = i18nCrumb MsgMenuAdminHeading $ Just FirmAllR -- TODO: change heading or remove +breadcrumb FirmsCommR{} = i18nCrumb MsgMenuFirmsComm $ Just FirmAllR breadcrumb FirmUsersR{} = i18nCrumb MsgMenuFirmUsers $ Just FirmAllR breadcrumb (FirmSupersR fsh)= i18nCrumb MsgMenuFirmSupervisors $ Just $ FirmUsersR fsh -breadcrumb (FirmCommR fsh)= i18nCrumb MsgMenuFirmsComm $ Just $ FirmUsersR fsh +breadcrumb (FirmCommR fsh)= i18nCrumb MsgMenuFirmsComm $ Just $ FirmUsersR fsh breadcrumb PrintCenterR = i18nCrumb MsgMenuApc Nothing breadcrumb PrintSendR = i18nCrumb MsgMenuPrintSend $ Just PrintCenterR breadcrumb PrintDownloadR{} = i18nCrumb MsgMenuPrintDownload $ Just PrintCenterR breadcrumb PrintAckR{} = i18nCrumb MsgMenuPrintSend $ Just PrintCenterR -- never displayed -breadcrumb PrintAckDirectR{}= i18nCrumb MsgMenuPrintSend $ Just PrintCenterR -- never displayed +breadcrumb PrintAckDirectR{}= i18nCrumb MsgMenuPrintAck $ Just PrintCenterR +breadcrumb PrintLogR = i18nCrumb MsgMenuPrintLog $ Just PrintCenterR breadcrumb SchoolListR = i18nCrumb MsgMenuSchoolList $ Just AdminR breadcrumb (SchoolR ssh sRoute) = case sRoute of @@ -165,9 +165,10 @@ breadcrumb FaqR = i18nCrumb MsgBreadcrumbFaq $ Just InfoR breadcrumb HelpR = i18nCrumb MsgMenuHelp Nothing -breadcrumb HealthR = i18nCrumb MsgMenuHealth Nothing -breadcrumb InstanceR = i18nCrumb MsgMenuInstance Nothing -breadcrumb StatusR = i18nCrumb MsgMenuHealth Nothing -- never displayed +breadcrumb HealthR = i18nCrumb MsgMenuHealth Nothing +breadcrumb (HealthInterfaceR _) = i18nCrumb MsgMenuHealthInterface (Just HealthR) +breadcrumb InstanceR = i18nCrumb MsgMenuInstance Nothing +breadcrumb StatusR = i18nCrumb MsgMenuHealth Nothing -- never displayed breadcrumb QualificationAllR = i18nCrumb MsgMenuQualifications Nothing breadcrumb (QualificationSchoolR ssh ) = useRunDB . maybeT (i18nCrumb MsgBreadcrumbSchool . Just $ SchoolListR) $ do -- redirect only, used in other breadcrumbs @@ -186,21 +187,13 @@ breadcrumb (LmsR ssh qsh) = useRunDB . maybeT (i18nCrumb MsgBrea guardM . lift . existsBy $ SchoolQualificationShort ssh qsh return (CI.original qsh, Just $ LmsSchoolR ssh) breadcrumb (LmsEditR ssh qsh) = i18nCrumb MsgMenuLmsEdit $ Just $ LmsR ssh qsh -breadcrumb (LmsUsersR ssh qsh) = i18nCrumb MsgMenuLmsUsers $ Just $ LmsR ssh qsh -breadcrumb (LmsUsersDirectR ssh qsh) = i18nCrumb MsgMenuLmsUsers $ Just $ LmsUsersR ssh qsh -- never displayed, TypedContent -breadcrumb (LmsUserlistR ssh qsh) = i18nCrumb MsgMenuLmsUserlist $ Just $ LmsR ssh qsh -breadcrumb (LmsUserlistUploadR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsUserlistR ssh qsh -breadcrumb (LmsUserlistDirectR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsUserlistR ssh qsh -- never displayed -breadcrumb (LmsResultR ssh qsh) = i18nCrumb MsgMenuLmsResult $ Just $ LmsR ssh qsh -breadcrumb (LmsResultUploadR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsResultR ssh qsh -breadcrumb (LmsResultDirectR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsResultR ssh qsh -- never displayed -- v2 breadcrumb (LmsLearnersR ssh qsh) = i18nCrumb MsgMenuLmsLearners $ Just $ LmsR ssh qsh breadcrumb (LmsLearnersDirectR ssh qsh) = i18nCrumb MsgMenuLmsLearners $ Just $ LmsLearnersR ssh qsh -- never displayed, TypedContent breadcrumb (LmsReportR ssh qsh) = i18nCrumb MsgMenuLmsReport $ Just $ LmsR ssh qsh breadcrumb (LmsReportUploadR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsReportR ssh qsh breadcrumb (LmsReportDirectR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsReportR ssh qsh -- never displayed --- +-- breadcrumb (LmsIdentR ssh qsh _ ) = breadcrumb $ LmsR ssh qsh -- just a redirect breadcrumb (LmsUserR ssh _qsh u ) = i18nCrumb MsgMenuLmsUser $ Just $ LmsUserSchoolR u ssh breadcrumb (LmsUserSchoolR u _ ) = i18nCrumb MsgMenuLmsUserSchool $ Just $ LmsUserAllR u @@ -301,7 +294,7 @@ breadcrumb (CourseR tid ssh csh (TutorialR tutn sRoute)) = case sRoute of TUsersR -> useRunDB . maybeT (i18nCrumb MsgBreadcrumbTutorial . Just $ CourseR tid ssh csh CTutorialListR) $ do guardM . lift . hasReadAccessTo $ CTutorialR tid ssh csh tutn TUsersR return (CI.original tutn, Just $ CourseR tid ssh csh CTutorialListR) - TAddUserR -> i18nCrumb MsgMenuTutorialAddMembers . Just $ CTutorialR tid ssh csh tutn TUsersR + TAddUserR -> i18nCrumb MsgMenuTutorialAddMembers . Just $ CTutorialR tid ssh csh tutn TUsersR TEditR -> i18nCrumb MsgMenuTutorialEdit . Just $ CTutorialR tid ssh csh tutn TUsersR TDeleteR -> i18nCrumb MsgMenuTutorialDelete . Just $ CTutorialR tid ssh csh tutn TUsersR TCommR -> i18nCrumb MsgMenuTutorialComm . Just $ CTutorialR tid ssh csh tutn TUsersR @@ -1342,6 +1335,17 @@ pageActions HealthR = return } , navChildren = [] } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuHealthInterface + , navRoute = HealthInterfaceR [] + , navAccess' = NavAccessTrue + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } ] pageActions InstanceR = return [ NavPageActionPrimary @@ -2377,26 +2381,6 @@ pageActions (LmsR sid qsh) = return , defNavLink MsgMenuLmsDirectUpload $ LmsReportDirectR sid qsh ] } - , NavPageActionSecondary - { navLink = defNavLink MsgMenuLmsUsers $ LmsUsersR sid qsh - -- , navChildren = - -- [ defNavLink MsgMenuLmsDirectDownload $ LmsUsersDirectR sid qsh - -- ] - } - , NavPageActionSecondary - { navLink = defNavLink MsgMenuLmsUserlist $ LmsUserlistR sid qsh - -- , navChildren = - -- [ defNavLink MsgMenuLmsUpload $ LmsUserlistUploadR sid qsh - -- , defNavLink MsgMenuLmsDirectUpload $ LmsUserlistDirectR sid qsh - -- ] - } - , NavPageActionSecondary - { navLink = defNavLink MsgMenuLmsResult $ LmsResultR sid qsh - -- , navChildren = - -- [ defNavLink MsgMenuLmsUpload $ LmsResultUploadR sid qsh - -- , defNavLink MsgMenuLmsDirectUpload $ LmsResultDirectR sid qsh - -- ] - } , NavPageActionSecondary { navLink = defNavLink MsgMenuLmsEdit $ LmsEditR sid qsh } @@ -2417,21 +2401,11 @@ pageActions ApiDocsR = return , navChildren = [] } ] -pageActions (FirmR fsh) = return - [ NavPageActionPrimary - { navLink = defNavLink MsgTableCompanyNrSupers $ FirmSupersR fsh - , navChildren = [] - } - , NavPageActionPrimary - { navLink = defNavLink MsgTableCompanyNrUsers $ FirmUsersR fsh - , navChildren = [] - } - ] pageActions (FirmUsersR fsh) = return [ NavPageActionPrimary { navLink = defNavLink MsgTableCompanyNrSupers $ FirmSupersR fsh , navChildren = [] - } + } ] pageActions (FirmSupersR fsh) = return [ NavPageActionPrimary @@ -2474,10 +2448,30 @@ pageActions PrintCenterR = do , navForceActive = False } } + printLog = NavPageActionSecondary + { navLink = NavLink + { navLabel = MsgMenuPrintLog + , navRoute = PrintLogR + , navAccess' = NavAccessTrue + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + } + printAck = NavPageActionSecondary + { navLink = NavLink + { navLabel = MsgMenuPrintAck + , navRoute = PrintAckDirectR + , navAccess' = NavAccessTrue + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + } dayLinks <- mapM toDayAck $ Map.toAscList dayMap - return $ manualSend : take 9 dayLinks + return $ manualSend : printLog : printAck : take 9 dayLinks -pageActions AdminCrontabR = return +pageActions AdminCrontabR = return [ NavPageActionPrimary { navLink = defNavLink MsgMenuAdminJobs AdminJobsR , navChildren = [] diff --git a/src/Foundation/Yesod/ErrorHandler.hs b/src/Foundation/Yesod/ErrorHandler.hs index 769f65faf..6d11826dc 100644 --- a/src/Foundation/Yesod/ErrorHandler.hs +++ b/src/Foundation/Yesod/ErrorHandler.hs @@ -9,9 +9,9 @@ module Foundation.Yesod.ErrorHandler import Import.NoFoundation hiding (errorHandler) import Foundation.Type --- import Foundation.I18n +import Foundation.I18n import Foundation.Authorization --- import Foundation.SiteLayout +import Foundation.SiteLayout import Foundation.Routes import Foundation.DB @@ -20,15 +20,15 @@ import qualified Data.Text as Text import qualified Network.Wai as W --- import System.Exit -- DEBUG: just for testing --- import System.Posix.Process -- DEBUG: just for testing +import System.Exit -- DEBUG: just for testing +import System.Posix.Process -- DEBUG: just for testing errorHandler :: ( MonadSecretBox (HandlerFor UniWorX) - -- , MonadSecretBox (WidgetFor UniWorX) + , MonadSecretBox (WidgetFor UniWorX) , MonadSecretBox (ExceptT EncodedSecretBoxException (HandlerFor UniWorX)) , MonadAuth (HandlerFor UniWorX) , BearerAuthSite UniWorX - -- , YesodPersistBackend UniWorX ~ SqlBackend + , YesodPersistBackend UniWorX ~ SqlBackend ) => ErrorResponse -> HandlerFor UniWorX TypedContent errorHandler err = do @@ -72,39 +72,39 @@ errorHandler err = do setSessionJson SessionError sessErr selectRep $ do - -- provideRep $ do - -- mr <- getMessageRender - -- let - -- encrypted :: Text -> WidgetFor UniWorX () -> WidgetFor UniWorX () - -- encrypted plaintextJson plaintext = do - -- let displayEncrypted ciphertext = - -- [whamlet| - -- $newline never - --

_{MsgErrorResponseEncrypted} - --

-    --                 #{ciphertext}
-    --             |]
-    --       if
-    --         | isEncrypted && shouldEncrypt -> displayEncrypted plaintextJson
-    --         | shouldEncrypt -> displayEncrypted =<< encodedSecretBox SecretBoxPretty plaintextJson
-    --         | otherwise -> plaintext
+    provideRep $ do
+      mr <- getMessageRender
+      let
+        encrypted :: Text -> WidgetFor UniWorX () -> WidgetFor UniWorX ()
+        encrypted plaintextJson plaintext = do
+          let displayEncrypted ciphertext = 
+                [whamlet|
+                  $newline never
+                  

_{MsgErrorResponseEncrypted} +

+                    #{ciphertext}
+                |]
+          if
+            | isEncrypted && shouldEncrypt -> displayEncrypted plaintextJson
+            | shouldEncrypt -> displayEncrypted =<< encodedSecretBox SecretBoxPretty plaintextJson
+            | otherwise -> plaintext
 
-    --     errPage = case err of
-    --       NotFound -> [whamlet|

_{MsgErrorResponseNotFound}|] - -- InternalError err' - -- | "Crash Button" `isPrefixOf` err' -> liftIO $ exitImmediately ExitSuccess -- DEBUG: just for Testing - -- | otherwise -> encrypted err' [whamlet|

#{fromMaybe err' decrypted}|] - -- InvalidArgs errs -> [whamlet| - --

    - -- $forall err' <- errs - --
  • - -- #{err'} - -- |] - -- NotAuthenticated -> [whamlet|

    _{MsgErrorResponseNotAuthenticated}|] - -- PermissionDenied err' -> [whamlet|

    #{err'}|] - -- BadMethod method -> [whamlet|

    _{MsgErrorResponseBadMethod (decodeUtf8 method)}|] - -- siteLayout (toWgt . mr $ ErrorResponseTitle err) $ do - -- errPage + errPage = case err of + NotFound -> [whamlet|

    _{MsgErrorResponseNotFound}|] + InternalError err' + | "Crash Button" `isPrefixOf` err' -> liftIO $ exitImmediately ExitSuccess -- DEBUG: just for Testing + | otherwise -> encrypted err' [whamlet|

    #{fromMaybe err' decrypted}|] + InvalidArgs errs -> [whamlet| +

      + $forall err' <- errs +
    • + #{err'} + |] + NotAuthenticated -> [whamlet|

      _{MsgErrorResponseNotAuthenticated}|] + PermissionDenied err' -> [whamlet|

      #{err'}|] + BadMethod method -> [whamlet|

      _{MsgErrorResponseBadMethod (decodeUtf8 method)}|] + siteLayout (toWgt . mr $ ErrorResponseTitle err) $ do + errPage provideRep $ case err of PermissionDenied err' -> return err' InternalError err' diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 0340bc41f..fd001c768 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -21,11 +21,10 @@ import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Experimental as E import qualified Database.Esqueleto.Utils as E -import Handler.Utils.DateTime +import Handler.Utils import Handler.Utils.Avs -import Handler.Utils.Widgets import Handler.Utils.Users -import Handler.Utils.Qualification +import Handler.Health.Interface import Handler.Admin.Test as Handler.Admin import Handler.Admin.ErrorMessage as Handler.Admin @@ -42,22 +41,35 @@ getAdminProblemsR :: Handler Html getAdminProblemsR = do now <- liftIO getCurrentTime let nowaday = utctDay now - cutOffPrintDays = 7 - cutOffPrintJob = addLocalDays (-cutOffPrintDays) now + cutOffOldDays = 1 + cutOffOldTime = toMidnight $ addDays (-cutOffOldDays) nowaday - (usersAreReachable, driversHaveAvsIds, rDriversHaveFs, noStalePrintJobs, noBadAPCids, noAvsSynchProblems) <- runDB $ (,,,,,) + -- we abuse messageTooltip for colored icons here + msgSuccessTooltip <- messageI Success MsgMessageSuccess + msgWarningTooltip <- messageI Warning MsgMessageWarning + msgErrorTooltip <- messageI Error MsgMessageError + + let flagError = messageTooltip . bool msgErrorTooltip msgSuccessTooltip + flagWarning = messageTooltip . bool msgWarningTooltip msgSuccessTooltip + flagNonZero :: Int -> Widget + flagNonZero n | n <= 0 = flagError True + | otherwise = messageTooltip =<< handlerToWidget (messageI Error (MsgProblemsDriverSynch n)) + + (usersAreReachable, driversHaveAvsIds, rDriversHaveFs, noStalePrintJobs, noBadAPCids, (interfaceOks, interfaceTable)) <- runDB $ (,,,,,) <$> areAllUsersReachable <*> allDriversHaveAvsId now <*> allRDriversHaveFs now - <*> (not <$> exists [PrintJobAcknowledged ==. Nothing, PrintJobCreated <=. cutOffPrintJob]) - <*> (not <$> exists [PrintAcknowledgeProcessed ==. False]) - <*> (not <$> exists [UserAvsLastSynchError !=. Nothing]) + <*> (not <$> exists [PrintJobAcknowledged ==. Nothing, PrintJobCreated <. cutOffOldTime]) + <*> (not <$> exists [PrintAcknowledgeProcessed ==. False]) + <*> mkInterfaceLogTable flagError mempty + let interfacesBadNr = length $ filter (not . snd) interfaceOks + -- interfacesOk = all snd interfaceOks diffLics <- try retrieveDifferingLicences >>= \case -- (Left (UnsupportedContentType "text/html" resp)) -> Left $ text2widget "Html received" (Left e) -> return $ Left $ text2widget $ tshow (e :: SomeException) (Right AvsLicenceDifferences{..}) -> do - let problemIds = avsLicenceDiffRevokeAll <> avsLicenceDiffGrantVorfeld <> avsLicenceDiffRevokeRollfeld <> avsLicenceDiffGrantRollfeld - forM_ (take 42 $ Set.toList problemIds) $ queueJob' . flip JobSynchroniseAvsId (Just nowaday) + let problemIds = avsLicenceDiffRevokeAll <> avsLicenceDiffGrantVorfeld <> avsLicenceDiffRevokeRollfeld <> avsLicenceDiffGrantRollfeld + forM_ (take 42 $ Set.toList problemIds) $ queueJob' . flip JobSynchroniseAvsId (Just nowaday) return $ Right ( Set.size avsLicenceDiffRevokeAll , Set.size avsLicenceDiffGrantVorfeld @@ -72,18 +84,7 @@ getAdminProblemsR = do -- ex -> return $ Left $ text2widget $ tshow ex) -- , Catch.Handler (\(ex::SomeException) -> return $ Left $ text2widget $ tshow ex) -- ] - - -- we abuse messageTooltip for colored icons here - msgSuccessTooltip <- messageI Success MsgMessageSuccess - msgWarningTooltip <- messageI Warning MsgMessageWarning - msgErrorTooltip <- messageI Error MsgMessageError - let flagError = messageTooltip . bool msgErrorTooltip msgSuccessTooltip - flagWarning = messageTooltip . bool msgWarningTooltip msgSuccessTooltip - flagNonZero :: Int -> Widget - flagNonZero n | n <= 0 = flagError True - | otherwise = messageTooltip =<< handlerToWidget (messageI Error (MsgProblemsDriverSynch n)) - rerouteMail <- getsYesod $ view _appMailRerouteTo siteLayoutMsg MsgProblemsHeading $ do @@ -237,4 +238,3 @@ retrieveDriversRWithoutF now = do E.where_ $ E.exists (hasValidQual AvsLicenceRollfeld) E.&&. E.notExists (hasValidQual AvsLicenceVorfeld) return usr - diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index 3773a9c85..9521912c9 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -548,7 +548,7 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do [ dbSelect (applying _2) id $ return . view (resultUserAvs . _userAvsPersonId) -- (\DBRow{dbrOutput=(_,_,apid,_)} -> return apid -- return . view resultAvsPID) -- does not type due to traversal , colUserNameLink AdminUserR - , sortable (Just "avspersonno") (i18nCell MsgAvsPersonNo) $ \(view resultUserAvs -> a) -> avsPersonNoLinkedCell a + , sortable (Just "avspersonno") (i18nCell MsgAvsPersonNo) $ \(view resultUserAvs -> a) -> avsPersonNoLinkedCellAdmin a -- , colUserCompany , 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 @@ -558,7 +558,7 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do return (comp E.^. CompanyShorthand, comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor) let icnSuper = toWidget $ text2markup " " <> icon IconSupervisor companies = - (\(E.Value cmpSh, E.Value cmpName, E.Value cmpSpr) -> simpleLink (citext2widget cmpName) (FirmR cmpSh) <> bool mempty icnSuper cmpSpr) <$> companies' + (\(E.Value cmpSh, E.Value cmpName, E.Value cmpSpr) -> simpleLink (citext2widget cmpName) (FirmUsersR cmpSh) <> bool mempty icnSuper cmpSpr) <$> companies' pure $ intercalate (text2widget "; ") companies , sortable (Just "qualification") (i18nCell MsgTableQualifications) $ \(preview resultQualification -> q) -> cellMaybe lmsShortCell q @@ -752,7 +752,7 @@ getProblemAvsErrorR = do dbtRowKey = qerryUsrAvs >>> (E.^. UserAvsId) dbtProj = dbtProjId dbtColonnade = dbColonnade $ mconcat - [ colUserNameModalHdr MsgLmsUser AdminUserR + [ colUserNameModalHdrAdmin MsgLmsUser AdminUserR , sortable (Just "avs-nr") (i18nCell MsgAvsPersonNo) $ avsPersonNoLinkedCell . view reserrUsrAvs , sortable Nothing (i18nCell MsgAvsPersonId) diff --git a/src/Handler/Course/Communication.hs b/src/Handler/Course/Communication.hs index 07bce86e7..a584267a5 100644 --- a/src/Handler/Course/Communication.hs +++ b/src/Handler/Course/Communication.hs @@ -64,8 +64,10 @@ postCCommR tid ssh csh = do return (cid, tuts, exams, sheets) + let heading = SomeMessage . prependCourseTitle tid ssh csh $ SomeMessage MsgCommCourseHeading commR CommunicationRoute - { crHeading = SomeMessage . prependCourseTitle tid ssh csh $ SomeMessage MsgCommCourseHeading + { crHeading = heading + , crTitle = heading , crUltDest = SomeRoute $ CourseR tid ssh csh CCommR , crJobs = crJobsCourseCommunication cid , crTestJobs = crTestJobsCourseCommunication cid diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs index 127056489..ae88bb64c 100644 --- a/src/Handler/Course/Edit.hs +++ b/src/Handler/Course/Edit.hs @@ -279,8 +279,8 @@ getCourseNewR = do , E.desc $ courseCreated course] -- most recent created course E.limit 1 return course - template <- case listToMaybe oldCourses of - (Just oldTemplate) -> + template <- case oldCourses of + (oldTemplate:_) -> let newTemplate = courseToForm oldTemplate mempty mempty in return $ Just $ newTemplate { cfCourseId = Nothing @@ -289,7 +289,7 @@ getCourseNewR = do , cfRegTo = Nothing , cfDeRegUntil = Nothing } - Nothing -> do + [] -> do (tidOk,sshOk,cshOk) <- runDB $ (,,) <$> ifMaybeM mbTid True existsKey <*> ifMaybeM mbSsh True existsKey diff --git a/src/Handler/Course/List.hs b/src/Handler/Course/List.hs index 513e63f87..1a8784748 100644 --- a/src/Handler/Course/List.hs +++ b/src/Handler/Course/List.hs @@ -226,7 +226,16 @@ getCourseListR = do ] validator = def & defaultSorting [SortDescBy "term",SortAscBy "course"] - coursesTable <- runDB $ makeCourseTable colonnade validator + now <- liftIO getCurrentTime + coursesTable <- runDB $ do + activeTs <- selectList [TermActiveFrom <=. now + , FilterOr [TermActiveTo >. Just now, TermActiveTo ==. Nothing] + , FilterOr [TermActiveFor ==. muid, TermActiveFor ==. Nothing] -- TermActiveFor <-. [Nothing, muid] did not work as intended + ] [Desc TermActiveTerm] + let addTermFilter = if null activeTs + then id + else defaultFilter $ singletonMap "term" [toPathPiece termActiveTerm | Entity _ TermActive{termActiveTerm} <- activeTs] + makeCourseTable colonnade (validator & addTermFilter) defaultLayout $ do setTitleI MsgCourseListTitle $(widgetFile "courses") diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index 82ebe492f..53eff795d 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/src/Handler/Course/ParticipantInvite.hs @@ -192,26 +192,37 @@ handleAddUserR tid ssh csh tdesc ttyp = do currentRoute <- fromMaybe (error "postCAddUserR called from 404-handler") <$> getCurrentRoute - confirmedActs :: Set CourseRegisterActionData <- fmap Set.fromList . throwExceptT . mapMM encodedSecretBoxOpen . lookupPostParams $ toPathPiece PostCourseUserAddConfirmAction - -- $logDebugS "CAddUserR confirmedActs" . tshow $ Set.map Aeson.encode confirmedActs - unless (Set.null confirmedActs) $ do -- TODO: check that all acts are member of availableActs - let - users = Map.fromList . fmap (\act -> (crActIdent act, Just . view _1 $ crActUser act)) $ Set.toList confirmedActs - tutActs = Set.filter (is _CourseRegisterActionAddTutorialMemberData) confirmedActs - actTutorial = crActTutorial <$> Set.lookupMin tutActs -- tutorial ident must be the same for every added member! - registeredUsers <- registerUsers cid users - whenIsJust actTutorial $ \(tutName,tutType,tutDay) -> do - whenIsJust (tutName <|> fmap (tutorialDefaultName tutType) tutDay) $ \tName -> do - tutId <- upsertNewTutorial cid tName tutType tutDay - registerTutorialMembers tutId registeredUsers - -- when (Set.size tutActs == Set.size confirmedActs) $ -- not sure how this condition might be false at this point - redirect $ CTutorialR tid ssh csh tName TUsersR - redirect $ CourseR tid ssh csh CUsersR + (_ , registerConfirmResult) <- runButtonForm FIDCourseRegisterConfirm + -- $logDebugS "***AbortProblem***" $ tshow registerConfirmResult + prefillUsers <- case registerConfirmResult of + Nothing -> return mempty + (Just BtnCourseRegisterAbort) -> do + addMessageI Warning MsgAborted + -- prefill confirmed users for convenience. Note that Browser-Back may also return to the filled form, but history.back() does not in Chrome + confirmedActs :: [CourseRegisterActionData] <- exceptT (const $ return mempty) return . mapMM encodedSecretBoxOpen . lookupPostParams $ toPathPiece PostCourseUserAddConfirmAction -- ignore any exception, since it is only used to prefill a form field for convenience + return $ Just $ Set.fromList $ fmap crActIdent confirmedActs + (Just BtnCourseRegisterConfirm) -> do + confirmedActs :: Set CourseRegisterActionData <- fmap Set.fromList . throwExceptT . mapMM encodedSecretBoxOpen . lookupPostParams $ toPathPiece PostCourseUserAddConfirmAction + -- $logDebugS "CAddUserR confirmedActs" . tshow $ Set.map Aeson.encode confirmedActs + unless (Set.null confirmedActs) $ do -- TODO: check that all acts are member of availableActs + let + users = Map.fromList . fmap (\act -> (crActIdent act, Just . view _1 $ crActUser act)) $ Set.toList confirmedActs + tutActs = Set.filter (is _CourseRegisterActionAddTutorialMemberData) confirmedActs + actTutorial = crActTutorial <$> Set.lookupMin tutActs -- tutorial ident must be the same for every added member! + registeredUsers <- registerUsers cid users + whenIsJust actTutorial $ \(tutName,tutType,tutDay) -> do + whenIsJust (tutName <|> fmap (tutorialDefaultName tutType) tutDay) $ \tName -> do + tutId <- upsertNewTutorial cid tName tutType tutDay + registerTutorialMembers tutId registeredUsers + -- when (Set.size tutActs == Set.size confirmedActs) $ -- not sure how this condition might be false at this point + redirect $ CTutorialR tid ssh csh tName TUsersR + redirect $ CourseR tid ssh csh CUsersR + return mempty - ((usersToAdd :: FormResult AddUserRequest, formWgt), formEncoding) <- runFormPost . renderWForm FormStandard $ do + ((usersToAdd :: FormResult AddUserRequest, formWgt), formEncoding) <- runFormPost . identifyForm FIDCourseRegister . renderWForm FormStandard $ do let tutTypesMsg = [(SomeMessage tt,tt) | tt <- tutTypes] tutDefType = ttyp >>= (\ty -> if ty `elem` tutTypes then Just ty else Nothing) - auReqUsers <- wreq (textField & cfAnySeparatedSet) (fslI MsgCourseParticipantsRegisterUsersField & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) mempty + auReqUsers <- wreq (textField & cfAnySeparatedSet) (fslI MsgCourseParticipantsRegisterUsersField & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) prefillUsers auReqTutorial <- optionalActionW ( (,,) <$> aopt (textField & cfStrip & cfCI & addDatalist tutNameSuggestions) diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs index c2056d6c8..4a4e11e9d 100644 --- a/src/Handler/Course/Users.hs +++ b/src/Handler/Course/Users.hs @@ -660,7 +660,7 @@ postCUsersR tid ssh csh = do , pure . cap' $ colUserNameLink (CourseR tid ssh csh . CUserR) , guardOn showSex . cap' $ colUserSex' , pure . cap' $ colUserEmail - , pure . cap' $ colUserMatriclenr + , pure . cap' $ colUserMatriclenr False , pure . cap' $ colUserQualifications nowaday , guardOn hasSubmissionGroups $ cap' colUserSubmissionGroup , guardOn hasTutorials . cap' $ colUserTutorials tid ssh csh diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs index 89d0bf40f..cd06ea982 100644 --- a/src/Handler/Exam/Users.hs +++ b/src/Handler/Exam/Users.hs @@ -484,7 +484,7 @@ postEUsersR tid ssh csh examn = do dbtColonnade = mconcat $ catMaybes [ pure $ dbSelect (_2 . applying _2) _1 $ return . view (resultExamRegistration . _entityKey) , pure $ colUserNameLink (CourseR tid ssh csh . CUserR) - , pure colUserMatriclenr + , pure $ colUserMatriclenr False , pure $ colStudyFeatures resultStudyFeatures , pure $ sortable (Just "occurrence") (i18nCell MsgTableExamOccurrence) $ maybe mempty (anchorCell' (\n -> CExamR tid ssh csh examn EShowR :#: [st|exam-occurrence__#{n}|]) id . examOccurrenceName . entityVal) . view _userTableOccurrence , guardOn showPasses $ sortable Nothing (i18nCell MsgAchievedPasses) $ \(view $ resultUser . _entityKey -> uid) -> diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 9e6cdd55e..596ea40c9 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -2,13 +2,12 @@ -- -- SPDX-License-Identifier: AGPL-3.0-or-later -{-# OPTIONS -Wno-unused-top-binds -Wno-unused-imports #-} -- TODO: remove me, for debugging only +{-# OPTIONS -Wno-unused-top-binds #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances {-# LANGUAGE TypeApplications #-} module Handler.Firm ( getFirmAllR , postFirmAllR - , getFirmR , postFirmR , getFirmUsersR , postFirmUsersR , getFirmSupersR, postFirmSupersR , getFirmCommR , postFirmCommR @@ -21,6 +20,7 @@ import Import -- import Jobs import Handler.Utils import Handler.Utils.Communication +import Handler.Utils.Avs (guessAvsUser) import qualified Data.Set as Set import qualified Data.Map as Map @@ -28,11 +28,11 @@ import qualified Data.Map as Map -- import qualified Data.Text as T import qualified Data.CaseInsensitive as CI -- import qualified Data.Conduit.List as C --- import Database.Persist.Sql (updateWhereCount) +import Database.Persist.Sql (deleteWhereCount, updateWhereCount) import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma -import qualified Database.Esqueleto.Legacy as EL (from, on) --- import qualified Database.Esqueleto.PostgreSQL as E +import qualified Database.Esqueleto.Legacy as EL (on) +import qualified Database.Esqueleto.PostgreSQL as E import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH @@ -41,99 +41,266 @@ import Database.Esqueleto.Utils.TH single :: (k,a) -> Map k a single = uncurry Map.singleton +-- decryptUser :: (MonadHandler m, HandlerSite m ~ UniWorX) => CryptoUUIDUser -> m UserId +-- decryptUser = decrypt -getFirmR, postFirmR :: CompanyShorthand -> Handler Html -getFirmR = postFirmR -postFirmR fsh = do - let fshId = CompanyKey fsh - cusers <- runDB $ do - cusers <- selectList [UserCompanyCompany ==. fshId] [] - selectList [UserId <-. fmap (userCompanyUser . entityVal) cusers] [Asc UserDisplayName] - csuper <- runDB $ do - csuper <- selectList [UserCompanyCompany ==. fshId, UserCompanySupervisor ==. True] [] - selectList [UserId <-. fmap (userCompanyUser . entityVal) csuper] [Asc UserDisplayName] - cactSuper <- runDB $ E.select $ do - (usr :& spr :& scmpy) <- E.from $ - E.table @User - `E.innerJoin` E.table @UserSupervisor - `E.on` (\(usr :& spr ) -> spr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId) - `E.leftJoin` E.table @UserCompany - `E.on` (\(_ :& spr :& scmpy) -> spr E.^. UserSupervisorSupervisor E.=?. scmpy E.?. UserCompanyUser) - E.where_ $ (spr E.^. UserSupervisorUser) `E.in_` E.valList (entityKey <$> cusers) - E.groupBy (usr E.^. UserId, usr E.^. UserDisplayName, usr E.^. UserSurname, scmpy E.?. UserCompanyCompany) - E.orderBy [E.asc $ usr E.^. UserId, E.asc $ usr E.^. UserDisplayName, E.asc $ usr E.^. UserSurname, E.asc $ scmpy E.?. UserCompanyCompany] - let countRows' :: E.SqlExpr (E.Value Int64) = E.countRows - return (usr E.^. UserId, usr E.^. UserDisplayName, usr E.^. UserSurname, scmpy E.?. UserCompanyCompany, countRows', usr E.^. UserPrefersPostal) +encryptUser :: (MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> m CryptoUUIDUser +encryptUser = encrypt - siteLayoutMsg (SomeMessage fsh) $ do - setTitle $ citext2Html fsh - [whamlet| -

      PROVISORISCHE DEBUG SEITE -

      Diese Seite wird in der finalen Version nicht mehr enthalten sein. +postalEmailField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m Bool +postalEmailField = boolFieldCustom (SomeMessage MsgUtilPostal) (SomeMessage MsgUtilEMail) $ Just $ SomeMessage MsgUtilUnchanged -

      #{length csuper} Company Default Supervisors (non-foreign only) -
        - $forall u <- csuper -
      • ^{linkUserWidget ForProfileDataR u} +--------------------------------- +-- General firm affecting actions -

        #{length cactSuper} Active Supervisors for Employees -
          - $forall (E.Value _, E.Value dn, E.Value sn, E.Value mbCsh, E.Value nr, E.Value prefPost) <- cactSuper -
        • #{nr} Employees supervised by ^{nameWidget dn sn} # - #{iconLetterOrEmail prefPost} # - $maybe csh <- mbCsh - $if csh /= fshId - from foreign company #{unCompanyKey csh} - $else - from this company - $nothing - having no associated company - -

          #{length cusers} Employees -
            - $forall u <- cusers -
          • ^{linkUserWidget ForProfileDataR u} - - In the end, this needs to be a dbTable, of course! - |] - - ------------------------ --- All Firms Table - -data FirmAllAction = FirmAllActNotify - | FirmAllActResetSupervision +data FirmAction = FirmActNotify + | FirmActResetSupervision + | FirmActAddSupersvisors + | FirmActChangeContactFirm + | FirmActChangeContactUser deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) deriving anyclass (Universe, Finite) -nullaryPathPiece ''FirmAllAction $ camelToPathPiece' 3 -embedRenderMessage ''UniWorX ''FirmAllAction id +nullaryPathPiece ''FirmAction $ camelToPathPiece' 1 +embedRenderMessage ''UniWorX ''FirmAction id -data FirmAllActionData = FirmAllActNotifyData - | FirmAllActResetSupervisionData - deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) +data FirmActionData = FirmActNotifyData + | FirmActResetSupervisionData + { firmActResetKeepOldSupers :: Maybe Bool + , firmActResetMutualSupervision :: Maybe Bool + } + | FirmActAddSupersvisorsData + { firmActAddSupervisorIds :: Set Text + , firmActAddSupervisorReroute :: Bool + , firmActAddSupervisorPostal :: Maybe Bool + } + | FirmActChangeContactFirmData + { firmActCCFPostalAddr :: Maybe StoredMarkup + , firmActCCFEmail :: Maybe UserEmail + , firmActCCFPostalPref :: Maybe Bool + } + | FirmActChangeContactUserData + { firmActCCUPostalAddr :: Maybe StoredMarkup + , firmActCCUPostalPref :: Maybe Bool + } + deriving (Eq, Ord, Read, Show, Generic) --- just in case for future extensions -type AllCompanyTableExpr = E.SqlExpr (Entity Company) -queryAllCompany :: AllCompanyTableExpr -> E.SqlExpr (Entity Company) -queryAllCompany = id +firmActionMap :: (_ -> Text) -> Bool -> [FirmAction] -> Map FirmAction (AForm Handler FirmActionData) +firmActionMap mr isAdmin acts = mconcat (mkAct isAdmin <$> acts) + where + mkAct True FirmActNotify = singletonMap FirmActNotify $ pure FirmActNotifyData + mkAct _ FirmActResetSupervision = singletonMap FirmActResetSupervision $ FirmActResetSupervisionData + <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just $ Just False) + <*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True ) + mkAct _ FirmActAddSupersvisors = singletonMap FirmActAddSupersvisors $ FirmActAddSupersvisorsData + <$> areq (textField & cfAnySeparatedSet) (fslI MsgTableIsDefaultSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing + <*> areq checkBoxField (fslI MsgTableIsDefaultReroute) (Just True) + <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing + mkAct _ FirmActChangeContactFirm = singletonMap FirmActChangeContactFirm $ FirmActChangeContactFirmData + <$> aopt htmlField (fslI MsgPostAddress & setTooltip (SomeMessages [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing + <*> aopt (emailField & cfStrip & cfCI) (fslI MsgUserDisplayEmail & setTooltip MsgUtilEmptyNoChangeTip) Nothing + <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing + <* aformMessage (Message Info (toHtml $ mr MsgFirmActChangeContactFirmInfo) (Just IconNotificationNonactive)) + mkAct _ FirmActChangeContactUser = singletonMap FirmActChangeContactUser $ FirmActChangeContactUserData + <$> aopt htmlField (fslI MsgPostAddress & setTooltip (SomeMessages [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing + <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing + mkAct _ _ = mempty -type AllCompanyTableData = DBRow (Entity Company, E.Value Word64, E.Value Bool, E.Value Bool) -resultAllCompanyEntity :: Lens' AllCompanyTableData (Entity Company) -resultAllCompanyEntity = _dbrOutput . _1 +firmActionForm :: _ -> Bool -> [FirmAction] -> AForm Handler FirmActionData +firmActionForm mr isAdmin acts = multiActionA (firmActionMap mr isAdmin acts) (fslI MsgTableAction) Nothing -resultAllCompany :: Lens' AllCompanyTableData Company -resultAllCompany = resultAllCompanyEntity . _entityVal +makeFirmActionForm :: CompanyId -> _ -> Bool -> [FirmAction] -> Form (FirmActionData, Set CompanyId) +makeFirmActionForm cid mr isAdmin acts html = flip (renderAForm FormStandard) html $ (,Set.singleton cid) <$> firmActionForm mr isAdmin acts -resultAllCompanyUsers :: Lens' AllCompanyTableData Word64 -resultAllCompanyUsers = _dbrOutput . _2 . _unValue +firmActionHandler :: Route UniWorX -> Bool -> FormResult (FirmActionData, Set CompanyId) -> Handler () +firmActionHandler route isAdmin = flip formResult faHandler + where + faHandler (_,fids) | null fids = addMessageI Error MsgNoCompanySelected -resultAllCompanySupervisors :: Lens' AllCompanyTableData Bool -resultAllCompanySupervisors = _dbrOutput . _3 . _unValue + faHandler (FirmActNotifyData, Set.toList -> fids) = do + usrs <- runDB $ E.select $ E.distinct $ do + (usr :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser) + E.where_ $ uc E.^. UserCompanyCompany `E.in_` E.valList fids + return $ usr E.^. UserId + cuids <- traverse (encrypt . E.unValue) usrs :: Handler [CryptoUUIDUser] + redirect (FirmsCommR $ fmap unCompanyKey fids, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids]) -resultAllCompanyDefaultReroutes :: Lens' AllCompanyTableData Bool -resultAllCompanyDefaultReroutes = _dbrOutput . _4 . _unValue + faHandler (FirmActResetSupervisionData{..}, fids) = do + madId <- bool maybeAuthId (return Nothing) isAdmin + let suprFltr = if + | isAdmin -> const E.true + | (Just suprId) <- madId -> \spr -> spr E.^. UserSupervisorSupervisor E.==. E.val suprId + | otherwise -> const E.false + runDB $ do + delSupers <- if firmActResetKeepOldSupers == Just False + then E.deleteCount $ do + spr <- E.from $ E.table @UserSupervisor + E.where_ $ suprFltr spr E.&&. E.exists (do + usr <- E.from $ E.table @UserCompany + E.where_ $ usr E.^. UserCompanyCompany `E.in_` E.vals fids + E.&&. usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser + ) + else return 0 + newSupers <- addDefaultSupervisorsFor madId (firmActResetMutualSupervision /= Just False) fids + addMessageI Success $ MsgFirmResetSupervision delSupers newSupers + reloadKeepGetParams route -- reload to reflect changes + faHandler (FirmActAddSupersvisorsData{..}, Set.toList -> [cid]) = do + avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser firmActAddSupervisorIds + let (usersFound', usersNotFound) = partition (is _Just . view _2) $ Map.toList avsUsers + usersFound = mapMaybe snd usersFound' + unless (null usersNotFound) $ + let msgContent = [whamlet| + $newline never +
              + $forall (usr,_) <- usersNotFound +
            • #{usr} + |] + in addMessageModal Error (i18n . MsgCourseParticipantsRegisterNotFoundInAvs $ length usersNotFound) (Right msgContent) + when (null usersFound) $ do + addMessageI Warning MsgFirmActAddSupersEmpty + reloadKeepGetParams route + runDB $ do + putMany [UserCompany uid cid True firmActAddSupervisorReroute | uid <- usersFound] + whenIsJust firmActAddSupervisorPostal $ \prefPostal -> + updateWhere [UserId <-. usersFound] [UserPrefersPostal =. prefPostal] + addMessageI Success $ MsgFirmActAddSupersSet (fromIntegral $ length usersFound) firmActAddSupervisorPostal + redirect route + + faHandler (FirmActChangeContactFirmData{..}, Set.toList -> [cid]) = + let changes = catMaybes + [ (CompanyPostAddress =.) . Just <$> canonical firmActCCFPostalAddr + , (CompanyEmail =.) . Just <$> canonical firmActCCFEmail + , (CompanyPrefersPostal =.) <$> firmActCCFPostalPref + ] + in unless (null changes) $ do + runDB $ updateBy (UniqueCompanyShorthand $ unCompanyKey cid) changes + addMessageI Success MsgFirmActChangeContactFirmResult + reloadKeepGetParams route + + faHandler (FirmActChangeContactUserData{..}, Set.toList -> [cid]) = + let changes = catMaybes + [ (UserPostAddress E.=.) . E.justVal <$> canonical firmActCCUPostalAddr -- note that Nothing means no change and not delete address! + , (UserPrefersPostal E.=.) . E.val <$> firmActCCUPostalPref + ] + in unless (null changes) $ do + nrChanged <- runDB $ E.updateCount $ \usr -> do + E.set usr changes + E.where_ $ E.exists $ do + usrCmpy <- E.from $ E.table @UserCompany + E.where_ $ usrCmpy E.^. UserCompanyCompany E.==. E.val cid + E.&&. usrCmpy E.^. UserCompanyUser E.==. usr E.^. UserId + addMessageI Success $ MsgFirmUserChanges nrChanged + reloadKeepGetParams route -- reload to reflect changes + + faHandler _ = addMessageI Error MsgErrorUnknownFormAction + + +runFirmActionFormPost :: CompanyId -> Route UniWorX -> Bool -> [FirmAction] -> Handler Widget +runFirmActionFormPost cid route isAdmin acts = do + mr <- getMessageRender + ((faRes, faWgt), faEnctype) <- runFormPost . identifyForm FIDFirmAction $ makeFirmActionForm cid mr isAdmin acts + let faAnchor = "firm-action-form" :: Text + faRoute = route :#: faAnchor + faForm = wrapForm faWgt FormSettings + { formMethod = POST + , formAction = Just . SomeRoute $ faRoute + , formEncoding = faEnctype + , formAttrs = [] + , formSubmit = FormSubmit + , formAnchor = Just faAnchor + } + firmActionHandler route isAdmin faRes + return [whamlet| +
              +

              + _{MsgFirmAction} +
              +

              + _{MsgFirmActionInfo} +

              + ^{faForm} + |] + + +--------------------------- +-- Firm specific utilities +-- for filters and counts also see before FirmAllR Handlers + + + +-- remove supervisors: +deleteSupervisors :: NonEmpty UserId -> DB Int64 +deleteSupervisors usrs = deleteWhereCount [UserSupervisorUser <-. toList usrs] + +-- reset supervisors given employees of a company to default company supervision, deleting all other supervisors +resetSupervisors :: CompanyId -> NonEmpty UserId -> DB Int64 +resetSupervisors cid employees = do + nr_del <- deleteSupervisors employees + nr_add <- addDefaultSupervisors cid employees + return $ max nr_del nr_add + +-- adds the default company supervisors as supervisor to a given set of users, which themselves may belong to any company +addDefaultSupervisors :: CompanyId -> NonEmpty UserId -> DB Int64 +addDefaultSupervisors cid employees = do + E.insertSelectWithConflictCount UniqueUserSupervisor + (do + (spr :& usr) <- E.from $ E.table @UserCompany `E.crossJoin` E.toValues employees + E.where_ $ spr E.^. UserCompanyCompany E.==. E.val cid + E.&&. spr E.^. UserCompanySupervisor + E.distinct $ return $ UserSupervisor + E.<# (spr E.^. UserCompanyUser) + E.<&> usr + E.<&> (spr E.^. UserCompanySupervisorReroute) + ) + (\_old new -> [UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications]) + +-- like `addDefaultSupervisors`, but selects all employees of given companies from database, optionally filtered by being under supervision of a given individual +addDefaultSupervisorsFor :: (CompanyId ~ Element mono, MonoFoldable mono) => Maybe UserId -> Bool -> mono -> DB Int64 +addDefaultSupervisorsFor mbSuperId mutualSupervision cids = do + E.insertSelectWithConflictCount UniqueUserSupervisor + (do + (spr :& usr) <- E.from $ E.table @UserCompany `E.innerJoin` E.table @UserCompany `E.on` (\(spr :& usr) -> spr E.^. UserCompanyCompany E.==. usr E.^. UserCompanyCompany) + E.where_ $ E.and $ guardMonoid (not mutualSupervision) + [ E.not_ $ usr E.^. UserCompanySupervisor ] + <> maybeEmpty mbSuperId (\sprId -> [E.exists $ do + superv <- E.from $ E.table @UserSupervisor + E.where_ $ superv E.^. UserSupervisorSupervisor E.==. E.val sprId + E.&&. superv E.^. UserSupervisorUser E.==. usr E.^. UserCompanyUser + ]) + <> [ spr E.^. UserCompanySupervisor + , spr E.^. UserCompanyCompany `E.in_` E.vals cids + , usr E.^. UserCompanyCompany `E.in_` E.vals cids + ] + E.distinct $ return $ UserSupervisor + E.<# (spr E.^. UserCompanyUser) + E.<&> (usr E.^. UserCompanyUser) + E.<&> (spr E.^. UserCompanySupervisorReroute) + ) + (\_old new -> [UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications] ) + +-- like `addDefaultSupervisors`, but selects all employees of given companies from database +addDefaultSupervisorsAll :: (CompanyId ~ Element mono, MonoFoldable mono) => Bool -> mono -> DB Int64 +addDefaultSupervisorsAll mutualSupervision cids = do + E.insertSelectWithConflictCount UniqueUserSupervisor + (do + (spr :& usr) <- E.from $ E.table @UserCompany `E.innerJoin` E.table @UserCompany `E.on` (\(spr :& usr) -> spr E.^. UserCompanyCompany E.==. usr E.^. UserCompanyCompany) + E.where_ $ E.and $ guardMonoid (not mutualSupervision) + [ E.not_ $ usr E.^. UserCompanySupervisor ] + <> [ spr E.^. UserCompanySupervisor + , spr E.^. UserCompanyCompany `E.in_` E.vals cids + , usr E.^. UserCompanyCompany `E.in_` E.vals cids + ] + E.distinct $ return $ UserSupervisor + E.<# (spr E.^. UserCompanyUser) + E.<&> (usr E.^. UserCompanyUser) + E.<&> (spr E.^. UserCompanySupervisorReroute) + ) + (\_old new -> [UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications] ) + + +------------------------------ +-- repeatedly useful queries fromUserCompany :: Maybe (E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (Entity Company) -> E.SqlQuery () fromUserCompany mbFltr cmpy = do @@ -173,7 +340,7 @@ firmCountEmployeeSupervised = E.subSelectCount . fromUserCompany (Just fltr) firmCountEmployeeRerouted :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) firmCountEmployeeRerouted = E.subSelectCount . fromUserCompany (Just fltr) - where + where fltr usrc = E.exists $ do usrSuper <- E.from $ E.table @UserSupervisor E.where_ $ usrSuper E.^. UserSupervisorUser E.==. usrc E.^. UserCompanyUser @@ -181,7 +348,7 @@ firmCountEmployeeRerouted = E.subSelectCount . fromUserCompany (Just fltr) firmCountEmployeeRerPost :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) firmCountEmployeeRerPost = E.subSelectCount . fromUserCompany (Just fltr) - where + where fltr usrc = E.exists $ do (usrSuper :& usr) <- E.from $ E.table @UserSupervisor @@ -213,20 +380,69 @@ firmCountForeignSupervisors cmpy = E.subSelectCountDistinct $ do -- firmCountActiveReroutes :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) -- firmCountActiveReroutes cmpy = E.subSelectCountDistinct $ do -- usrSuper <- E.from $ E.table @UserSupervisor --- E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy) +-- E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy) -- E.&&. usrSuper E.^. UserSupervisorRerouteNotifications -- pure $ usrSuper E.^. UserSupervisorSupervisor firmCountActiveReroutes :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) firmCountActiveReroutes cmpy = E.subSelectCount $ do usrSuper <- E.from $ E.table @UserSupervisor - E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy) + E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy) E.&&. usrSuper E.^. UserSupervisorRerouteNotifications +firmQuerySupervisedBy :: CompanyId -> Maybe (E.SqlExpr (Entity UserSupervisor) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (Entity User) -> E.SqlQuery () +firmQuerySupervisedBy cid mbFltr usr = do + (usrSpr :& usrCmp) <- E.from $ E.table @UserSupervisor + `E.innerJoin` E.table @UserCompany + `E.on` (\(usrSpr :& usrCmp) -> usrSpr E.^. UserSupervisorUser E.==. usrCmp E.^. UserCompanyUser) + let basecond = usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId + E.&&. usrCmp E.^. UserCompanyCompany E.==. E.val cid + E.where_ $ maybe basecond ((basecond E.&&.).($ usrSpr)) mbFltr -mkFirmAllTable :: Bool -> UserId -> DB (FormResult (FirmAllActionData, Set CompanyId), Widget) +firmCountForSupervisor :: CompanyId -> Maybe (E.SqlExpr (Entity UserSupervisor) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (Entity User) -> E.SqlExpr (E.Value Word64) +firmCountForSupervisor = ((E.subSelectCount .) .) . firmQuerySupervisedBy + +firmCountUserSupervisors :: E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Word64) +firmCountUserSupervisors usrCmp = E.subSelectCount $ do + usrSpr <- E.from $ E.table @UserSupervisor + E.where_ $ usrSpr E.^. UserSupervisorUser E.==. usrCmp E.^. UserCompanyUser + +firmCountUserSupervisorsReroute :: E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Word64) +firmCountUserSupervisorsReroute usrCmp = E.subSelectCount $ do + usrSpr <- E.from $ E.table @UserSupervisor + E.where_ $ usrSpr E.^. UserSupervisorUser E.==. usrCmp E.^. UserCompanyUser + E.&&. usrSpr E.^. UserSupervisorRerouteNotifications + + +----------------------- +-- All Firms Table + +-- just in case for future extensions +type AllCompanyTableExpr = E.SqlExpr (Entity Company) +queryAllCompany :: AllCompanyTableExpr -> E.SqlExpr (Entity Company) +queryAllCompany = id + +type AllCompanyTableData = DBRow (Entity Company, E.Value Word64, E.Value Bool, E.Value Bool) +resultAllCompanyEntity :: Lens' AllCompanyTableData (Entity Company) +resultAllCompanyEntity = _dbrOutput . _1 + +resultAllCompany :: Lens' AllCompanyTableData Company +resultAllCompany = resultAllCompanyEntity . _entityVal + +resultAllCompanyUsers :: Lens' AllCompanyTableData Word64 +resultAllCompanyUsers = _dbrOutput . _2 . _unValue + +resultAllCompanySupervisors :: Lens' AllCompanyTableData Bool +resultAllCompanySupervisors = _dbrOutput . _3 . _unValue + +resultAllCompanyDefaultReroutes :: Lens' AllCompanyTableData Bool +resultAllCompanyDefaultReroutes = _dbrOutput . _4 . _unValue + + +mkFirmAllTable :: Bool -> UserId -> DB (FormResult (FirmActionData, Set CompanyId), Widget) mkFirmAllTable isAdmin uid = do -- now <- liftIO getCurrentTime + mr <- getMessageRender let resultDBTable = DBTable{..} where @@ -234,7 +450,12 @@ mkFirmAllTable isAdmin uid = do unless isAdmin $ E.where_ $ E.exists $ do -- only show associated companies usrCmpy <- E.from $ E.table @UserCompany E.where_ $ usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId - E.&&. usrCmpy E.^. UserCompanyUser E.==. E.val uid + E.&&. ((usrCmpy E.^. UserCompanyUser E.==. E.val uid E.&&. usrCmpy E.^. UserCompanySupervisor) + E.||. E.exists (do + usrSpr <- E.from $ E.table @UserSupervisor + E.where_ $ usrSpr E.^. UserSupervisorUser E.==. usrCmpy E.^. UserCompanyUser + E.&&. usrSpr E.^. UserSupervisorSupervisor E.==. E.val uid + )) return ( cmpy -- 1 , cmpy & firmCountUsers -- 2 , cmpy & firmHasSupervisors -- 3 @@ -247,23 +468,22 @@ mkFirmAllTable isAdmin uid = do -- , cmpy & firmCountActiveReroutes' -- 10 ) dbtRowKey = (E.^. CompanyId) - dbtProj = dbtProjId + dbtProj = dbtProjFilteredPostId dbtColonnade = formColonnade $ mconcat - [ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultAllCompanyEntity . _entityKey)) + [ dbSelect (applying _2) id (return . view (resultAllCompanyEntity . _entityKey)) , sortable (Just "name") (i18nCell MsgTableCompany) $ \(view resultAllCompany -> firm) -> anchorCell (FirmUsersR $ companyShorthand firm) . toWgt $ companyName firm , sortable (Just "short") (i18nCell MsgTableCompanyShort) $ \(view resultAllCompany -> firm) -> let fsh = companyShorthand firm - in anchorCell (FirmUsersR fsh) $ toWgt fsh - , sortable (Just "avsnr") (i18nCell MsgTableCompanyNo) $ \(view resultAllCompany -> firm) -> - anchorCell (FirmR $ companyShorthand firm) $ toWgt $ companyAvsId firm + in anchorCell (FirmSupersR fsh) $ toWgt fsh + , sortable (Just "avsnr") (i18nCell MsgTableCompanyNo) $ \(view resultAllCompany -> firm) -> numCell $ companyAvsId firm , sortable (Just "users") (i18nCell MsgTableCompanyNrUsers) $ \(view resultAllCompanyUsers -> nr) -> wgtCell $ word2widget nr - , sortable (Just "supervisors") (i18nCell MsgTableCompanyNrSupersDefault) $ \row -> + , sortable (Just "supervisors") (i18nCell MsgTableCompanyNrSupersDefault) $ \row -> anchorCell (FirmSupersR $ row ^. resultAllCompany . _companyShorthand) $ toWgt $ hasTickmark $ row ^. resultAllCompanySupervisors , sortable (Just "reroute-def") (i18nCell MsgTableCompanyNrRerouteDefault) $ \(view resultAllCompanyDefaultReroutes -> ok) -> tickmarkCell ok -- , sortable (Just "emp-supervised")(i18nCell MsgTableCompanyNrEmpSupervised) $ \(view resultAllCompanyEmployeeSupervised -> nr) -> wgtCell $ word2widget nr -- , sortable (Just "emp-rerouted") (i18nCell MsgTableCompanyNrEmpRerouted) $ \(view resultAllCompanyEmployeeRerouted -> nr) -> wgtCell $ word2widget nr - -- , sortable (Just "emp-rer-post") (i18nCell MsgTableCompanyNrEmpRerPost) $ \(view resultAllCompanyEmpRerPost -> nr) -> wgtCell $ word2widget nr + -- , sortable (Just "emp-rer-post") (i18nCell MsgTableCompanyNrEmpRerPost) $ \(view resultAllCompanyEmpRerPost -> nr) -> wgtCell $ word2widget nr -- , sortable (Just "foreigners") (i18nCell MsgTableCompanyNrForeignSupers) $ \(view resultAllCompanyForeignSupers -> nr) -> wgtCell $ word2widget nr -- , sortable (Just "reroute-act") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultAllCompanyActiveReroutes -> nr) -> wgtCell $ word2widget nr -- , sortable (Just "reroute-all") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultAllCompanyActiveReroutes' -> nr) -> wgtCell $ word2widget nr @@ -287,56 +507,195 @@ mkFirmAllTable isAdmin uid = do dbtFilter = mconcat [ single $ fltrCompanyNameNr queryAllCompany , single ("company-number", FilterColumn $ E.mkExactFilterWithComma readMay (queryAllCompany >>> (E.^. CompanyAvsId))) - , single ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do + , single ("is-associate" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do (usr :& usrCmp) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany - `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser) + `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser) E.where_ $ usrCmp E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId E.&&. ( (usr E.^. UserDisplayName `E.hasInfix` E.val criterion) E.||. (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk criterion)) E.||. (usr E.^. UserSurname `E.hasInfix` E.val criterion) ) ) - , single ("foreign-supervisor", FilterColumn $ \row (getLast -> criterion) -> - let checkSuper = do - usrSpr <- E.from $ E.table @UserSupervisor - E.where_ $ E.notExists (do - spr <- E.from $ E.table @UserCompany - E.where_ $ spr E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId - E.&&. spr E.^. UserCompanyUser E.==. usrSpr E.^. UserSupervisorSupervisor - ) E.&&. E.exists (do - usr <- E.from $ E.table @UserCompany - E.where_ $ usr E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId - E.&&. usr E.^. UserCompanyUser E.==. usrSpr E.^. UserSupervisorUser - ) - in case criterion of + -- THIS WAS WAY TOO SLOW: + -- , single ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do -- too slow + -- (usr :& usrCmp) <- E.from $ E.table @User + -- `E.leftJoin` E.table @UserCompany + -- `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.=?. usrCmp E.?. UserCompanyUser) + -- E.where_ $ ((usr E.^. UserDisplayName `E.hasInfix` E.val criterion) + -- E.||. (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk criterion)) + -- E.||. (usr E.^. UserSurname `E.hasInfix` E.val criterion) + -- ) E.&&. ((E.isTrue (usrCmp E.?. UserCompanySupervisor) E.&&. usrCmp E.?. UserCompanyCompany E.?=. queryAllCompany row E.^. CompanyId) + -- E.||. E.exists (do + -- usrSpr <- E.from $ E.table @UserSupervisor + -- E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId + -- E.&&. E.exists (do + -- usrSub <- E.from $ E.table @UserCompany + -- E.where_ $ usrSub E.^. UserCompanyUser E.==. usrSpr E.^. UserSupervisorUser + -- E.&&. usrSub E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId + -- ) + -- ) + -- ) + -- ) + -- , single ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do -- too slow + -- usr <- E.from $ E.table @User + -- E.where_ $ ((usr E.^. UserDisplayName `E.hasInfix` E.val criterion) + -- E.||. (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk criterion)) + -- -- E.||. (usr E.^. UserSurname `E.hasInfix` E.val criterion) + -- ) E.&&. (E.exists (do + -- usrCmp <- E.from $ E.table @UserCompany + -- E.where_ $ usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser + -- E.&&. usrCmp E.^. UserCompanySupervisor + -- E.&&. usrCmp E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId + -- ) E.||. E.exists (do + -- usrSpr <- E.from $ E.table @UserSupervisor + -- E.where_ $ usr E.^. UserId E.==. usrSpr E.^. UserSupervisorSupervisor + -- E.&&. E.exists (do + -- usrSub <- E.from $ E.table @UserCompany + -- E.where_ $ usrSub E.^. UserCompanyUser E.==. usrSpr E.^. UserSupervisorUser + -- E.&&. usrSub E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId + -- ) + -- ) + -- ) + -- ) + -- , single ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do -- too slow + -- usr <- E.from $ E.table @User + -- E.where_ $ ((usr E.^. UserDisplayName `E.hasInfix` E.val criterion) + -- E.||. (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk criterion)) + -- -- E.||. (usr E.^. UserSurname `E.hasInfix` E.val criterion) + -- ) E.&&. E.exists (do + -- usrCmp <- E.from $ E.table @UserCompany + -- E.where_ $ usrCmp E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId + -- E.&&. (( usrCmp E.^. UserCompanySupervisor + -- E.&&. usrCmp E.^. UserCompanyUser E.==. usr E.^. UserId + -- ) E.||. E.exists (do + -- usrSpr <- E.from $ E.table @UserSupervisor + -- E.where_ $ usrSpr E.^. UserSupervisorUser E.==. usrCmp E.^. UserCompanyUser + -- E.&&. usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId + -- )) + -- ) + -- ) + -- , single ("is-supervisor", FilterColumn $ \row (getLast -> criterion) -> + -- case criterion of + -- Nothing -> E.true + -- (Just (crit::Text)) -> E.exists $ do + -- usr <- E.from $ E.table @User + -- E.where_ $ ((usr E.^. UserDisplayName `E.hasInfix` E.val crit) + -- E.||. (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk crit)) + -- E.||. (usr E.^. UserSurname `E.hasInfix` E.val crit) + -- ) E.&&. E.exists (do + -- usrCmp <- E.from $ E.table @UserCompany + -- E.where_ $ usrCmp E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId + -- E.&&. (( usrCmp E.^. UserCompanySupervisor + -- E.&&. usrCmp E.^. UserCompanyUser E.==. usr E.^. UserId + -- ) E.||. E.exists (do + -- usrSpr <- E.from $ E.table @UserSupervisor + -- E.where_ $ usrSpr E.^. UserSupervisorUser E.==. usrCmp E.^. UserCompanyUser + -- E.&&. usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId + -- )) + -- ) + -- ) + , single ("is-supervisor", mkFilterProjectedPost $ \(getLast -> criterion) dbr -> + case criterion of + Nothing -> return True :: DB Bool + (Just (crit::Text)) -> do + critFirms <- memcachedBy (Just . Right $ 5 * diffMinute) ("svr:"<>crit) $ fmap (Set.fromAscList . fmap E.unValue) $ E.select $ E.distinct $ do + (usr :& cmp) <- E.from $ E.table @User `E.innerJoin` E.table @Company + `E.on` (\(usr :& cmp) -> E.exists (do + usrCmp <- E.from $ E.table @UserCompany + E.where_ $ usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser + E.&&. usrCmp E.^. UserCompanySupervisor + E.&&. usrCmp E.^. UserCompanyCompany E.==. cmp E.^. CompanyId + ) E.||. E.exists (do + usrSpr <- E.from $ E.table @UserSupervisor + E.where_ $ usr E.^. UserId E.==. usrSpr E.^. UserSupervisorSupervisor + E.&&. E.exists (do + usrSub <- E.from $ E.table @UserCompany + E.where_ $ usrSub E.^. UserCompanyUser E.==. usrSpr E.^. UserSupervisorUser + E.&&. usrSub E.^. UserCompanyCompany E.==. cmp E.^. CompanyId + ) + )) + E.where_ $ (usr E.^. UserDisplayName `E.hasInfix` E.val crit) + E.||. (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk crit)) + E.||. (usr E.^. UserSurname `E.hasInfix` E.val crit) + E.orderBy [E.asc $ cmp E.^. CompanyId] + return $ cmp E.^. CompanyId + let cid = dbr ^. resultAllCompanyEntity . _entityKey + return $ Set.member cid critFirms + ) + -- , single ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do -- too slow + -- (usr :& usrCmp) <- E.from $ E.table @User + -- `E.leftJoin` E.table @UserCompany + -- `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.=?. usrCmp E.?. UserCompanyUser) + -- E.where_ $ ((usr E.^. UserDisplayName `E.hasInfix` E.val criterion) + -- E.||. (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk criterion)) + -- E.||. (usr E.^. UserSurname `E.hasInfix` E.val criterion) + -- ) E.&&. ((E.isTrue (usrCmp E.?. UserCompanySupervisor) E.&&. usrCmp E.?. UserCompanyCompany E.?=. queryAllCompany row E.^. CompanyId) + -- E.||. E.exists (do + -- (usrSpr :& usrSub) <- E.from $ E.table @UserSupervisor `E.innerJoin` E.table @UserCompany `E.on` (\(usrSpr :& usrSub) -> usrSpr E.^. UserSupervisorUser E.==. usrSub E.^. UserCompanyUser) + -- E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId + -- E.&&. usrSub E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId + -- ) + -- ) + -- ) + , single ("is-default-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do + (usr :& usrCmp) <- E.from $ E.table @User + `E.innerJoin` E.table @UserCompany + `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser) + E.where_ $ ((usr E.^. UserDisplayName `E.hasInfix` E.val criterion) + E.||. (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk criterion)) + E.||. (usr E.^. UserSurname `E.hasInfix` E.val criterion) + ) E.&&. usrCmp E.^. UserCompanySupervisor + E.&&. usrCmp E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId + ) + , single ("foreign-supervisor", FilterColumn $ \row (getLast -> criterion) -> + -- let checkSuper = do -- expensive + -- usrSpr <- E.from $ E.table @UserSupervisor + -- E.where_ $ E.notExists (do + -- spr <- E.from $ E.table @UserCompany + -- E.where_ $ spr E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId + -- E.&&. spr E.^. UserCompanyUser E.==. usrSpr E.^. UserSupervisorSupervisor + -- ) E.&&. E.exists (do + -- usr <- E.from $ E.table @UserCompany + -- E.where_ $ usr E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId + -- E.&&. usr E.^. UserCompanyUser E.==. usrSpr E.^. UserSupervisorUser + -- ) + let checkSuper = do + usr <- E.from $ E.table @UserCompany + E.where_ $ usr E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId + E.&&. E.exists (do + usrSpr <- E.from $ E.table @UserSupervisor + E.where_ $ usrSpr E.^. UserSupervisorUser E.==. usr E.^. UserCompanyUser + E.&&. E.notExists (do + sprCmp <- E.from $ E.table @UserCompany + E.where_ $ sprCmp E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId + E.&&. sprCmp E.^. UserCompanyUser E.==. usrSpr E.^. UserSupervisorSupervisor + ) + ) + in case criterion of Nothing -> E.true Just True -> E.exists checkSuper Just False -> E.notExists checkSuper ) , single ("company-postal", FilterColumn $ E.mkExactFilterLast $ views (to queryAllCompany) (E.isJust . (E.^. CompanyPostAddress))) ] - dbtFilterUI mPrev = mconcat + dbtFilterUI mPrev = mconcat [ fltrCompanyNameUI mPrev , prismAForm (singletonFilter "company-number") mPrev $ aopt textField (fslI MsgTableCompanyNo) + , prismAForm (singletonFilter "is-associate") mPrev $ aopt textField (fslI MsgTableCompanyUser) + -- , prismAForm (singletonFilter "is-supervisor0") mPrev $ aopt textField (fslI MsgTableSupervisor) , prismAForm (singletonFilter "is-supervisor") mPrev $ aopt textField (fslI MsgTableSupervisor) + , prismAForm (singletonFilter "is-default-supervisor") mPrev $ aopt textField (fslI MsgFirmSuperDefault) , prismAForm (singletonFilter "foreign-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterForeignSupervisor) - , prismAForm (singletonFilter "company-postal" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterFirmPostalAddress) + , prismAForm (singletonFilter "company-postal" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterFirmExtern) ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } - acts :: Map FirmAllAction (AForm Handler FirmAllActionData) - acts = mconcat - [ singletonMap FirmAllActNotify $ pure FirmAllActNotifyData - , singletonMap FirmAllActResetSupervision $ pure FirmAllActResetSupervisionData - ] dbtParams = DBParamsForm { dbParamsFormMethod = POST , dbParamsFormAction = Nothing , dbParamsFormAttrs = [] , dbParamsFormSubmit = FormSubmit - , dbParamsFormAdditional - = renderAForm FormStandard $ (, mempty) . First . Just - <$> multiActionA acts (fslI MsgTableAction) Nothing + , dbParamsFormAdditional = renderAForm FormStandard $ (, mempty) . First . Just <$> firmActionForm mr isAdmin [FirmActNotify, FirmActResetSupervision] , dbParamsFormEvaluate = liftHandler . runFormPost , dbParamsFormResult = id , dbParamsFormIdent = def @@ -347,14 +706,14 @@ mkFirmAllTable isAdmin uid = do dbtCsvDecode = Nothing dbtExtraReps = [] - postprocess :: FormResult (First FirmAllActionData, DBFormResult CompanyId Bool AllCompanyTableData) - -> FormResult ( FirmAllActionData, Set CompanyId) + postprocess :: FormResult (First FirmActionData, DBFormResult CompanyId Bool AllCompanyTableData) + -> FormResult ( FirmActionData, Set CompanyId) postprocess inp = do (First (Just act), cmpMap) <- inp let cmpSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) cmpMap return (act, cmpSet) - -- resultDBTableValidator :: PSValidator (MForm Handler) (FormResult (First FirmAllActionData, DBFormResult CompanyId Bool FirmAllActionData)) + -- resultDBTableValidator :: PSValidator (MForm Handler) (FormResult (First FirmActionData, DBFormResult CompanyId Bool FirmActionData)) resultDBTableValidator = def & defaultSorting [SortAscBy "short"] over _1 postprocess <$> dbTable resultDBTableValidator resultDBTable @@ -364,17 +723,9 @@ getFirmAllR, postFirmAllR :: Handler Html getFirmAllR = postFirmAllR postFirmAllR = do uid <- requireAuthId - isAdmin <- hasReadAccessTo AdminR + isAdmin <- checkAdmin (firmRes, firmTable) <- runDB $ mkFirmAllTable isAdmin uid -- filters to associated companies for non-admins - formResult firmRes $ \case - (FirmAllActResetSupervisionData, fids) -> addMessage Info $ text2Html $ "Reset " <> tshow (length fids) <> " companies. TODO" - (FirmAllActNotifyData , fids) -> do - usrs <- runDB $ E.select $ E.distinct $ do - (usr :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser) - E.where_ $ uc E.^. UserCompanyCompany `E.in_` E.valList (Set.toList fids) - return $ usr E.^. UserId - cuids <- traverse (encrypt . E.unValue) usrs :: Handler [CryptoUUIDUser] - redirect (FirmsCommR, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids]) + firmActionHandler FirmAllR isAdmin firmRes siteLayoutMsg MsgMenuFirms $ do setTitleI MsgMenuFirms $(i18nWidgetFile "firm-all") @@ -383,8 +734,12 @@ postFirmAllR = do ----------------------- -- Firm Users Table -data FirmUserAction = FirmUserActNotify + +data FirmUserAction = FirmUserActNotify + | FirmUserActResetSupervision + | FirmUserActSetSupervisor | FirmUserActMkSuper + | FirmUserActChangeContact deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) deriving anyclass (Universe, Finite) @@ -392,8 +747,23 @@ nullaryPathPiece ''FirmUserAction $ camelToPathPiece' 3 embedRenderMessage ''UniWorX ''FirmUserAction id data FirmUserActionData = FirmUserActNotifyData + | FirmUserActResetSupervisionData + { firmUserActResetKeepOldSupers :: Maybe Bool + -- , firmUserActResetMutualSupervision :: Maybe Bool + } + | FirmUserActSetSupervisorData + { firmUserActSetSuperNames :: Maybe (Set Text) + , firmUserActSetSuperIds :: Maybe [UserId] + , firmUserActSetSuperReroute :: Bool + , firmUserActSetSuperKeep :: Bool + } | FirmUserActMkSuperData - deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) + { firmUserActMkSuperReroute :: Maybe Bool } + | FirmUserActChangeContactData + { firmUserActPostalAddr :: Maybe StoredMarkup + , firmUserActPostalPref :: Maybe Bool + } + deriving (Eq, Ord, Show, Generic) type UserCompanyTableExpr = E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity UserCompany) @@ -406,7 +776,7 @@ queryUserUserCompany = $(sqlIJproj 2 2) type UserCompanyTableData = DBRow (Entity User, Entity UserCompany, E.Value Word64, E.Value Word64) resultUserUser :: Lens' UserCompanyTableData (Entity User) -resultUserUser = _dbrOutput . _1 +resultUserUser = _dbrOutput . _1 resultUserUserCompany :: Lens' UserCompanyTableData (Entity UserCompany) resultUserUserCompany = _dbrOutput . _2 @@ -417,27 +787,41 @@ resultUserCompanySupervisors = _dbrOutput . _3 . _unValue resultUserCompanyReroutes :: Lens' UserCompanyTableData Word64 resultUserCompanyReroutes = _dbrOutput . _4 . _unValue -instance HasEntity UserCompanyTableData User where +instance HasEntity UserCompanyTableData User where hasEntity = resultUserUser -instance HasUser UserCompanyTableData where +instance HasUser UserCompanyTableData where hasUser = resultUserUser . _entityVal -firmCountUserSupervisors :: E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Word64) -firmCountUserSupervisors usrCmp = E.subSelectCount $ do - usrSpr <- E.from $ E.table @UserSupervisor - E.where_ $ usrSpr E.^. UserSupervisorUser E.==. usrCmp E.^. UserCompanyUser - -firmCountUserSupervisorsReroute :: E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Word64) -firmCountUserSupervisorsReroute usrCmp = E.subSelectCount $ do - usrSpr <- E.from $ E.table @UserSupervisor - E.where_ $ usrSpr E.^. UserSupervisorUser E.==. usrCmp E.^. UserCompanyUser - E.&&. usrSpr E.^. UserSupervisorRerouteNotifications - mkFirmUserTable :: Bool -> CompanyId -> DB (FormResult (FirmUserActionData, Set UserId), Widget) mkFirmUserTable isAdmin cid = do + mr <- getMessageRender let + mkSprOption (E.Value uid, E.Value udn, E.Value mbSpr) = do + uuid <- toPathPiece <$> encryptUser uid + return (Option{ optionDisplay = udn, optionInternalValue = uid, optionExternalValue = uuid }, mbSpr) + + procOptions rawSupers = do + procSupers <- traverse mkSprOption rawSupers + return $ mkOptionListGrouped $ filter (notNull . snd) + [ (mr MsgFirmSuperDefault , [opt | (opt, Just True ) <- procSupers]) + , (mr MsgFirmSuperIrregular, [opt | (opt, Just False) <- procSupers]) + , (mr MsgFirmSuperForeign , [opt | (opt, Nothing ) <- procSupers]) + ] + + rawSupers <- E.select $ do + (usr :& usrCmp) <- E.from $ E.table @User `E.leftJoin` E.table @UserCompany + `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.=?. usrCmp E.?. UserCompanyUser E.&&. usrCmp E.?. UserCompanyCompany E.==. E.justVal cid) + E.where_ $ E.isTrue (usrCmp E.?. UserCompanySupervisor) + E.||. E.exists (firmQuerySupervisedBy cid Nothing usr) + return (usr E.^. UserId, usr E.^. UserDisplayName, usrCmp E.?. UserCompanySupervisor) + let + -- supervisorField :: Field Handler UserId + -- supervisorField = selectField' (Just $ SomeMessage MsgMultiNoSelection) $ procOptions rawSupers + supervisorsField = multiSelectField' (Just $ SomeMessage MsgMultiNoSelection) $ procOptions rawSupers + + fsh = unCompanyKey cid resultDBTable = DBTable{..} where @@ -448,14 +832,15 @@ mkFirmUserTable isAdmin cid = do dbtRowKey = queryUserUser >>> (E.^. UserId) dbtProj = dbtProjId dbtColonnade = formColonnade $ mconcat - [ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultUserUser . _entityKey)) + [ dbSelect (applying _2) id (return . view (resultUserUser . _entityKey)) , colUserNameModalHdr MsgTableCompanyUser ForProfileDataR - , sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \(view resultUserUser -> entUsr ) -> cellHasMatrikelnummerLinked entUsr + , guardMonoid isAdmin $ sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \(view resultUserUser -> entUsr ) -> cellHasMatrikelnummerLinkedAdmin entUsr , sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \(view $ resultUserUser . _userCompanyPersonalNumber -> t) -> foldMap textCell t , sortable (Just "supervisors") (i18nCell MsgTableCompanyNrSupers ) $ \(view resultUserCompanySupervisors -> nr) -> wgtCell $ word2widget nr , sortable (Just "reroutes") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultUserCompanyReroutes -> nr) -> wgtCell $ word2widget nr , sortable (Just "postal-pref") (i18nCell MsgPrefersPostal) $ \(view $ resultUserUser . _userPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b , colUserEmail + , sortable Nothing (i18nCell MsgTableUserEdit) $ \(view resultUserUser -> entUsr) -> cellEditUserModal entUsr ] dbtSorting = mconcat [ single $ sortUserNameLink queryUserUser @@ -468,16 +853,16 @@ mkFirmUserTable isAdmin cid = do ] dbtFilter = mconcat [ single $ fltrUserNameEmail queryUserUser - , singletonMap "has-supervisor" $ FilterColumn $ \row (getLast -> criterion) -> - let checkSuper = do + , singletonMap "has-supervisor" $ FilterColumn $ \row (getLast -> criterion) -> + let checkSuper = do usrSpr <- E.from $ E.table @UserSupervisor E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId in case criterion of Nothing -> E.true Just True -> E.exists checkSuper Just False -> E.notExists checkSuper - , singletonMap "has-company-supervisor" $ FilterColumn $ \row (getLast -> criterion) -> - let checkSuper = do + , singletonMap "has-company-supervisor" $ FilterColumn $ \row (getLast -> criterion) -> + let checkSuper = do usrSpr <- E.from $ E.table @UserSupervisor E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId E.&&. E.exists (do @@ -489,8 +874,8 @@ mkFirmUserTable isAdmin cid = do Nothing -> E.true Just True -> E.exists checkSuper Just False -> E.notExists checkSuper - , singletonMap "has-foreign-supervisor" $ FilterColumn $ \row (getLast -> criterion) -> - let checkSuper = do + , singletonMap "has-foreign-supervisor" $ FilterColumn $ \row (getLast -> criterion) -> + let checkSuper = do usrSpr <- E.from $ E.table @UserSupervisor E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId E.&&. E.notExists (do @@ -502,11 +887,30 @@ mkFirmUserTable isAdmin cid = do Nothing -> E.true Just True -> E.exists checkSuper Just False -> E.notExists checkSuper + , singletonMap "supervisor-is" $ FilterColumn $ \row (getLast -> criterion) -> + case criterion of + Just uid -> do + -- uid <- decryptUser uuid + E.exists $ do + usrSpr <- E.from $ E.table @UserSupervisor + E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId + E.&&. usrSpr E.^. UserSupervisorSupervisor E.==. E.val uid + _otherwise -> E.true + , singletonMap "supervisors-are" $ FilterColumn $ \row criteria -> + case criteria of + _ | Set.null criteria -> E.true + | otherwise -> do + -- uids <- traverse decryptUser criteria + E.exists $ do + usrSpr <- E.from $ E.table @UserSupervisor + E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId + E.&&. usrSpr E.^. UserSupervisorSupervisor `E.in_` E.vals criteria ] -- superField = selectField $ ???? dbtFilterUI mPrev = mconcat [ fltrUserNameEmailHdrUI MsgTableCompanyUser mPrev - , prismAForm (singletonFilter "supervisor-is" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift termField) (fslI MsgTableTerm) + -- , prismAForm (singletonFilter "supervisor-is" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift supervisorField) (fslI MsgFilterSupervisor) + , prismAForm (multiFilter "supervisors-are" . maybePrism monoPathPieces) mPrev $ aopt (hoistField lift supervisorsField) (fslI MsgFilterSupervisor & setTooltip MsgMultiSelectTip) , prismAForm (singletonFilter "has-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterSupervisor) , prismAForm (singletonFilter "has-company-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI $ MsgFilterSupervisorCompany fsh) , prismAForm (singletonFilter "has-foreign-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI $ MsgFilterSupervisorForeign fsh) @@ -514,8 +918,20 @@ mkFirmUserTable isAdmin cid = do dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } acts :: Map FirmUserAction (AForm Handler FirmUserActionData) acts = mconcat - [ singletonMap FirmUserActNotify $ pure FirmUserActNotifyData - , singletonMap FirmUserActMkSuper $ pure FirmUserActMkSuperData + [ guardMonoid isAdmin $ singletonMap FirmUserActNotify $ pure FirmUserActNotifyData + , singletonMap FirmUserActResetSupervision $ FirmUserActResetSupervisionData + <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just $ Just False) + -- <*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True ) + , singletonMap FirmUserActSetSupervisor $ FirmUserActSetSupervisorData + <$> aopt (textField & cfAnySeparatedSet) (fslI MsgFirmNewSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing + <*> aopt supervisorsField (fslI MsgFirmSetSupervisor & setTooltip MsgMultiSelectTip) Nothing + <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just False) + <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just False) + , singletonMap FirmUserActMkSuper $ FirmUserActMkSuperData + <$> aopt checkBoxField (fslI MsgTableIsDefaultReroute) (Just $ Just True) + , singletonMap FirmUserActChangeContact $ FirmUserActChangeContactData + <$> aopt htmlField (fslI MsgPostAddress & setTooltip (SomeMessages [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing + <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing ] dbtParams = DBParamsForm { dbParamsFormMethod = POST @@ -542,7 +958,7 @@ mkFirmUserTable isAdmin cid = do let s = Map.keysSet . Map.filter id $ getDBFormResult (const False) m return (act, s) - -- resultDBTableValidator :: PSValidator (MForm Handler) (FormResult (First FirmAllActionData, DBFormResult CompanyId Bool FirmAllActionData)) + -- resultDBTableValidator :: PSValidator (MForm Handler) (FormResult (First FirmActionData, DBFormResult CompanyId Bool FirmActionData)) resultDBTableValidator = def & defaultSorting [SortAscBy "user-name"] over _1 postprocess <$> dbTable resultDBTableValidator resultDBTable @@ -551,7 +967,7 @@ mkFirmUserTable isAdmin cid = do getFirmUsersR, postFirmUsersR :: CompanyShorthand -> Handler Html getFirmUsersR = postFirmUsersR postFirmUsersR fsh = do - isAdmin <- hasReadAccessTo AdminR + isAdmin <- checkAdmin let cid = CompanyKey fsh (( Entity{entityVal=Company{..}} , E.Value nrCompanyUsers @@ -562,7 +978,7 @@ postFirmUsersR fsh = do , E.Value nrCompanyEmployeeRerPost , E.Value nrCompanyDefaultReroutes , E.Value nrCompanyActiveReroutes - ) , (fusrRes, fusrTable)) <- runDB $ (,) + ) , (fusrRes, fusrTable)) <- runDB $ (,) <$> fromMaybeM notFound (E.selectOne $ do cmpy <- E.from $ E.table @Company E.where_ $ cmpy E.^. CompanyId E.==. E.val cid @@ -576,29 +992,75 @@ postFirmUsersR fsh = do , cmpy & firmCountDefaultReroutes , cmpy & firmCountActiveReroutes )) - -- superVs <- E.select $ do + -- superVs <- E.select $ do -- usr <- E.from $ E.table @User -- E.where_ $ E.exists $ firmQuerySupervisedBy cmpyId Nothing usr -- return usr - <*> mkFirmUserTable isAdmin cid + <*> mkFirmUserTable isAdmin cid - formResult fusrRes $ \case - (FirmUserActMkSuperData, fids) -> addMessage Info $ text2Html $ "Make " <> tshow (length fids) <> " employees to supervisors. TODO" - (FirmUserActNotifyData , fids) -> do - cuids <- traverse encrypt $ Set.toList fids :: Handler [CryptoUUIDUser] + formResult fusrRes $ \case + (_, uids) | null uids -> addMessageI Error MsgUtilEmptyChoice + (FirmUserActNotifyData , uids) -> do + cuids <- traverse encrypt $ Set.toList uids :: Handler [CryptoUUIDUser] redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids]) + (FirmUserActResetSupervisionData{..}, set2NonEmpty (error "Unexpected empty user list in getFirmUserR action handler.") -> uids) -> do -- set guaranteed to be non-empty due to first case clause + runDB $ do + delSupers <- if firmUserActResetKeepOldSupers == Just False + then deleteSupervisors uids + else return 0 + newSupers <- addDefaultSupervisors cid uids + addMessageI Info $ MsgFirmResetSupervision delSupers newSupers + reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes + (FirmUserActSetSupervisorData{..}, set2NonEmpty (error "Unexpected empty user list in getFirmUserR action handler.") -> uids) -> do + avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser $ maybeMonoid firmUserActSetSuperNames + let (usersFound', usersNotFound) = partition (is _Just . view _2) $ Map.toList avsUsers + usersFound = mapMaybe snd usersFound' + newSupers = Set.toList $ Set.fromList (maybeMonoid firmUserActSetSuperIds) <> Set.fromList usersFound + nrSupers = fromIntegral $ length newSupers + nrUsers = fromIntegral $ length uids + unless (null usersNotFound) $ + let msgContent = [whamlet| + $newline never +

                + $forall (usr,_) <- usersNotFound +
              • #{usr} + |] + in addMessageModal Error (i18n . MsgCourseParticipantsRegisterNotFoundInAvs $ length usersNotFound) (Right msgContent) + delSupers <- runDB + $ bool (deleteSupervisors uids) (return 0) firmUserActSetSuperKeep + <* putMany [UserSupervisor s u firmUserActSetSuperReroute | u <- toList uids, s <- newSupers] + addMessageI Success $ MsgFirmSetSupersReport nrUsers nrSupers delSupers + reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes + + (FirmUserActMkSuperData{..}, Set.toList -> uids) -> do + nrMkSuper <- runDB $ updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. True, UserCompanySupervisorReroute =. (firmUserActMkSuperReroute == Just True)] + addMessageI Info $ MsgFirmActAddSupersSet nrMkSuper Nothing + reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes + (FirmUserActChangeContactData{..}, Set.toList -> uids) -> + let changes = catMaybes + [ (UserPostAddress =.) . Just <$> canonical firmUserActPostalAddr -- note that Nothing means no change and not delete address! + , (UserPrefersPostal =.) <$> firmUserActPostalPref + ] + in unless (null changes) $ do + nrChanged <- runDB $ updateWhereCount [UserId <-. uids] changes + addMessageI Success $ MsgFirmUserChanges nrChanged + reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes + + formFirmAction <- runFirmActionFormPost cid (FirmUsersR fsh) isAdmin [FirmActNotify, FirmActResetSupervision, FirmActAddSupersvisors, FirmActChangeContactFirm, FirmActChangeContactUser] siteLayout (citext2widget companyName) $ do - setTitle $ toHtml $ CI.original companyShorthand <> " (" <> tshow companyAvsId <> ")" + setTitle $ toHtml $ CI.original companyShorthand <> "-" <> tshow companyAvsId + let firmContactInfo = $(widgetFile "firm-contact-info") $(widgetFile "firm-users") ----------------------------- -- Firm Supervisors Table -data FirmSuperAction = FirmSuperActNotify +data FirmSuperAction = FirmSuperActNotify + | FirmSuperActSwitchSuper | FirmSuperActRMSuperDef - | FirmSuperActRMSuperAll + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) deriving anyclass (Universe, Finite) @@ -606,19 +1068,31 @@ nullaryPathPiece ''FirmSuperAction $ camelToPathPiece' 3 embedRenderMessage ''UniWorX ''FirmSuperAction id data FirmSuperActionData = FirmSuperActNotifyData + | FirmSuperActSwitchSuperData + { firmSuperActSwitchSuper :: Maybe Bool + , firmSuperActSwitchReroute :: Maybe Bool + } | FirmSuperActRMSuperDefData - | FirmSuperActRMSuperAllData - deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) + { firmSuperActRMSuperActive :: Maybe Bool } -type SuperCompanyTableExpr = E.SqlExpr (Entity User) + deriving (Eq, Ord, Show, Generic) + + +type SuperCompanyTableExpr = E.SqlExpr (Entity User) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity UserCompany)) querySuperUser :: SuperCompanyTableExpr -> E.SqlExpr (Entity User) -querySuperUser = id +querySuperUser = $(sqlLOJproj 2 1) -type SuperCompanyTableData = DBRow (Entity User, E.Value Word64, E.Value Word64, [(E.Value CompanyName, E.Value CompanyShorthand, E.Value Bool)]) +querySuperUserCompany :: SuperCompanyTableExpr -> E.SqlExpr (Maybe (Entity UserCompany)) +querySuperUserCompany = $(sqlLOJproj 2 2) + +type SuperCompanyTableData = DBRow (Entity User, E.Value Word64, E.Value Word64 + , [(E.Value CompanyName, E.Value CompanyShorthand, E.Value Bool)] + , E.Value (Maybe Bool), E.Value (Maybe Bool) -- Maybe (Entity UserCompany) + ) resultSuperUser :: Lens' SuperCompanyTableData (Entity User) -resultSuperUser = _dbrOutput . _1 +resultSuperUser = _dbrOutput . _1 resultSuperCompanySupervised :: Lens' SuperCompanyTableData Word64 resultSuperCompanySupervised = _dbrOutput . _2 . _unValue @@ -629,60 +1103,62 @@ resultSuperCompanyReroutes = _dbrOutput . _3 . _unValue resultSuperCompanies :: Lens' SuperCompanyTableData [(E.Value CompanyName, E.Value CompanyShorthand, E.Value Bool)] resultSuperCompanies = _dbrOutput . _4 +resultSuperCompanyDefaultSuper :: Lens' SuperCompanyTableData (Maybe Bool) +resultSuperCompanyDefaultSuper = _dbrOutput . _5 . _unValue -instance HasEntity SuperCompanyTableData User where +resultSuperCompanyDefaultReroute :: Lens' SuperCompanyTableData (Maybe Bool) +resultSuperCompanyDefaultReroute = _dbrOutput . _6 . _unValue + +instance HasEntity SuperCompanyTableData User where hasEntity = resultSuperUser -instance HasUser SuperCompanyTableData where +instance HasUser SuperCompanyTableData where hasUser = resultSuperUser . _entityVal -firmQuerySupervisedBy :: CompanyId -> Maybe (E.SqlExpr (Entity UserSupervisor) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (Entity User) -> E.SqlQuery () -firmQuerySupervisedBy cid mbFltr usr = do - (usrSpr :& usrCmp) <- E.from $ E.table @UserSupervisor - `E.innerJoin` E.table @UserCompany - `E.on` (\(usrSpr :& usrCmp) -> usrSpr E.^. UserSupervisorUser E.==. usrCmp E.^. UserCompanyUser) - let basecond = usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId - E.&&. usrCmp E.^. UserCompanyCompany E.==. E.val cid - E.where_ $ maybe basecond ((basecond E.&&.).($ usrSpr)) mbFltr - -firmCountForSupervisor :: CompanyId -> Maybe (E.SqlExpr (Entity UserSupervisor) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (Entity User) -> E.SqlExpr (E.Value Word64) -firmCountForSupervisor = ((E.subSelectCount .) .) . firmQuerySupervisedBy mkFirmSuperTable :: Bool -> CompanyId -> DB (FormResult (FirmSuperActionData, Set UserId), Widget) mkFirmSuperTable isAdmin cid = do + msgSupervisorUnchanged <- messageI Info MsgFirmSuperActSwitchSuperInfo let -- fsh = unCompanyKey cid resultDBTable = DBTable{..} where - dbtSQLQuery = \usr -> do - E.where_ $ E.exists $ firmQuerySupervisedBy cid Nothing usr + dbtSQLQuery = \(usr `E.LeftOuterJoin` usrCmp) -> do + EL.on $ usr E.^. UserId E.=?. usrCmp E.?. UserCompanyUser E.&&. usrCmp E.?. UserCompanyCompany E.?=. E.val cid + E.where_ $ E.isTrue (usrCmp E.?. UserCompanySupervisor) + E.||. E.exists (firmQuerySupervisedBy cid Nothing usr) return ( usr , usr & firmCountForSupervisor cid Nothing , usr & firmCountForSupervisor cid (Just (E.^. UserSupervisorRerouteNotifications)) + , usrCmp E.?. UserCompanySupervisor + , usrCmp E.?. UserCompanySupervisorReroute ) dbtRowKey = querySuperUser >>> (E.^. UserId) - dbtProj = dbtProjSimple $ \(usr, supervised, rerouted) -> do - cmps <- E.select $ do + dbtProj = dbtProjSimple $ \(usr, supervised, rerouted, supervisor, reroute) -> do + cmps <- E.select $ do (cmp :& usrCmp) <- E.from $ E.table @Company `E.innerJoin` E.table @UserCompany `E.on` (\(cmp :& usrCmp) -> cmp E.^. CompanyId E.==. usrCmp E.^. UserCompanyCompany) E.where_ $ usrCmp E.^. UserCompanyUser E.==. E.val (entityKey usr) E.orderBy [E.asc $ cmp E.^. CompanyName] return (cmp E.^. CompanyName, cmp E.^. CompanyShorthand, usrCmp E.^. UserCompanySupervisor) - return (usr, supervised, rerouted, cmps) + return (usr, supervised, rerouted, cmps, supervisor, reroute) dbtColonnade = formColonnade $ mconcat - [ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultSuperUser . _entityKey)) + [ dbSelect (applying _2) id (return . view (resultSuperUser . _entityKey)) , colUserNameModalHdr MsgTableSupervisor ForProfileDataR - , sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \(view resultSuperUser -> entUsr) -> cellHasMatrikelnummerLinked entUsr + , guardMonoid isAdmin $ sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \(view resultSuperUser -> entUsr) -> cellHasMatrikelnummerLinkedAdmin entUsr , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultSuperCompanies -> cmps) -> intercalate semicolonCell [companyCell cmpShort cmpName isSuper | (E.Value cmpName, E.Value cmpShort, E.Value isSuper) <- cmps] , sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \(view $ resultSuperUser . _userCompanyPersonalNumber -> t) -> foldMap textCell t , sortable (Just "postal-pref") (i18nCell MsgPrefersPostal) $ \(view $ resultSuperUser . _userPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b , colUserEmail - , sortable (Just "supervised") (i18nCell MsgTableCompanyNrEmpSupervised) $ \(view resultSuperCompanySupervised -> nr) -> wgtCell $ word2widget nr - , sortable (Just "rerouted") (i18nCell MsgTableCompanyNrEmpRerouted ) $ \(view resultSuperCompanyReroutes -> nr) -> wgtCell $ word2widget nr + , sortable (Just "supervised") (i18nCell MsgTableCompanyNrEmpSupervised) $ \(view resultSuperCompanySupervised -> nr) -> wgtCell $ word2widget nr + , sortable (Just "rerouted") (i18nCell MsgTableCompanyNrEmpRerouted ) $ \(view resultSuperCompanyReroutes -> nr) -> wgtCell $ word2widget nr + , sortable (Just "def-super") (i18nCell MsgTableIsDefaultSupervisor) $ \(view resultSuperCompanyDefaultSuper -> mb) -> case mb of { Nothing -> iconCell IconSupervisorForeign; Just True -> iconCell IconSupervisor; Just False -> iconSpacerCell } + , sortable (Just "def-reroute") (i18nCell MsgTableIsDefaultReroute) $ \(view resultSuperCompanyDefaultReroute -> mb) -> tickmarkCell (mb == Just True) + , sortable Nothing (i18nCell MsgTableUserEdit) $ \(view resultSuperUser -> entUsr) -> cellEditUserModal entUsr ] dbtSorting = mconcat [ single $ sortUserNameLink querySuperUser - , single $ sortUserEmail querySuperUser + , single $ sortUserEmail querySuperUser , singletonMap "matriculation" $ SortColumn $ querySuperUser >>> (E.^. UserMatrikelnummer) , singletonMap "personal-number" $ SortColumn $ querySuperUser >>> (E.^. UserCompanyPersonalNumber) , singletonMap "postal-pref" $ SortColumn $ querySuperUser >>> (E.^. UserPrefersPostal) @@ -694,6 +1170,8 @@ mkFirmSuperTable isAdmin cid = do E.orderBy [E.asc $ cmp E.^. CompanyName] return (cmp E.^. CompanyName) ) + , singletonMap "def-super" $ SortColumn $ querySuperUserCompany >>> (E.?. UserCompanySupervisor) + , singletonMap "def-reroute" $ SortColumn $ querySuperUserCompany >>> (E.?. UserCompanySupervisorReroute) ] dbtFilter = mconcat [ single $ fltrUserNameEmail querySuperUser @@ -704,9 +1182,13 @@ mkFirmSuperTable isAdmin cid = do dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } acts :: Map FirmSuperAction (AForm Handler FirmSuperActionData) acts = mconcat - [ singletonMap FirmSuperActNotify $ pure FirmSuperActNotifyData - , singletonMap FirmSuperActRMSuperDef $ pure FirmSuperActRMSuperDefData - , singletonMap FirmSuperActRMSuperAll $ pure FirmSuperActRMSuperAllData + [ guardMonoid isAdmin $ singletonMap FirmSuperActNotify $ pure FirmSuperActNotifyData + , singletonMap FirmSuperActSwitchSuper $ FirmSuperActSwitchSuperData + <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableIsDefaultSupervisor) (Just $ Just True) + <*> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableIsDefaultReroute) Nothing + <* aformMessage msgSupervisorUnchanged + , singletonMap FirmSuperActRMSuperDef $ FirmSuperActRMSuperDefData + <$> aopt checkBoxField (fslI MsgFirmSuperActRMSuperActive) (Just $ Just True) ] dbtParams = DBParamsForm { dbParamsFormMethod = POST @@ -732,7 +1214,7 @@ mkFirmSuperTable isAdmin cid = do (First (Just act), m) <- inp let s = Map.keysSet . Map.filter id $ getDBFormResult (const False) m return (act, s) - + resultDBTableValidator = def & defaultSorting [SortAscBy "user-name"] over _1 postprocess <$> dbTable resultDBTableValidator resultDBTable @@ -741,115 +1223,118 @@ mkFirmSuperTable isAdmin cid = do getFirmSupersR, postFirmSupersR :: CompanyShorthand -> Handler Html getFirmSupersR = postFirmSupersR postFirmSupersR fsh = do - isAdmin <- hasReadAccessTo AdminR - let fshId = CompanyKey fsh + isAdmin <- checkAdmin + let cid = CompanyKey fsh (Company{..},(fsprRes,fsprTable)) <- runDB $ (,) - <$> get404 fshId - <*> mkFirmSuperTable isAdmin fshId + <$> get404 cid + <*> mkFirmSuperTable isAdmin cid formResult fsprRes $ \case - (FirmSuperActRMSuperDefData, fids) -> addMessage Info $ text2Html $ "Remove " <> tshow (length fids) <> " default supervisors. TODO" - (FirmSuperActRMSuperAllData, fids) -> addMessage Info $ text2Html $ "Make " <> tshow (length fids) <> " default and active supervisors. TODO" - (FirmSuperActNotifyData , fids) -> do - cuids <- traverse encrypt $ Set.toList fids :: Handler [CryptoUUIDUser] + (_, uids) | null uids -> addMessageI Error MsgUtilEmptyChoice + (FirmSuperActRMSuperDefData{..}, Set.toList -> uids) -> do + (nrRmSuper,nrRmActual) <- runDB $ (,) + <$> updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False] + <*> if firmSuperActRMSuperActive /= Just True + then return 0 + else E.deleteCount $ do + spr <- E.from $ E.table @UserSupervisor + E.where_ $ spr E.^. UserSupervisorSupervisor `E.in_` E.vals uids + E.&&. E.exists (do + usr <- E.from $ E.table @UserCompany + E.where_ $ usr E.^. UserCompanyCompany E.==. E.val cid + E.&&. usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser + ) + addMessageI Info $ MsgRemoveSupervisors nrRmSuper nrRmActual + reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes + (FirmSuperActSwitchSuperData{..}, Set.toList -> uids) -> do + let (fltrSpr, changes) = case (firmSuperActSwitchSuper, firmSuperActSwitchReroute) of + (Just True, Nothing) -> ([UserCompanySupervisor ==. False], [UserCompanySupervisor =. True ]) + (Just True, Just rer) -> ([UserCompanySupervisor ==. False] ||. [UserCompanySupervisorReroute !=. rer] + , [UserCompanySupervisor =. True , UserCompanySupervisorReroute =. rer ]) + (Just False, _) -> ([UserCompanySupervisor ==. True ], [UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False]) + (Nothing, Just True) -> ([UserCompanySupervisor ==. True, UserCompanySupervisorReroute ==. False], [UserCompanySupervisorReroute =. True ]) + (Nothing, Just False) -> ([ UserCompanySupervisorReroute ==. True ], [UserCompanySupervisorReroute =. False]) + (Nothing, Nothing ) -> ([],[]) + nrSuperChanges <- runDB $ updateWhereCount (fltrSpr <> [UserCompanyUser <-. uids, UserCompanyCompany ==. cid]) changes + addMessageI Info $ MsgFirmActAddSupersSet nrSuperChanges Nothing + reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes + (FirmSuperActNotifyData , uids) -> do + cuids <- traverse encrypt $ Set.toList uids :: Handler [CryptoUUIDUser] redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids]) + formFirmAction <- runFirmActionFormPost cid (FirmSupersR fsh) isAdmin [FirmActAddSupersvisors, FirmActResetSupervision, FirmActChangeContactFirm] siteLayout (citext2widget fsh) $ do - setTitle $ citext2Html fsh - -- TODO: factor out company info section hamlet here and from user table - [whamlet| -
                -

                !!!STUB!!!TO DO!!! -
                -
                - $maybe fem <- companyEmail -
                - _{MsgFirmEmail} #{iconLetterOrEmail False} -
                - #{mailtoHtml fem} - $maybe addr <- companyPostAddress -
                - _{MsgFirmAddress} #{iconLetterOrEmail True} -
                - #{addr} -
                - ^{fsprTable} - |] + setTitle $ citext2Html $ fsh <> " Supers" + let firmContactInfo = $(widgetFile "firm-contact-info") + $(i18nWidgetFile "firm-supervisors") + + +------------------------ +-- Firm Communications getFirmCommR, postFirmCommR :: CompanyShorthand -> Handler Html getFirmCommR = postFirmCommR -postFirmCommR fsh = handleFirmCommR (SomeRoute $ FirmUsersR fsh) (Just fsh) +postFirmCommR fsh = handleFirmCommR (SomeRoute $ FirmUsersR fsh) [fsh] -getFirmsCommR, postFirmsCommR :: Handler Html +getFirmsCommR, postFirmsCommR :: Companies -> Handler Html getFirmsCommR = postFirmsCommR -postFirmsCommR = handleFirmCommR (SomeRoute FirmAllR) Nothing +postFirmsCommR = handleFirmCommR (SomeRoute FirmAllR) -handleFirmCommR :: SomeRoute UniWorX -> Maybe CompanyShorthand -> Handler Html -handleFirmCommR ultDest mbFsh = do - let decryptUserId :: CryptoUUIDUser -> Handler UserId - decryptUserId = decrypt - - mbCid = CompanyKey <$> mbFsh - - {- - queryEmpys :: CompanyId -> Handler [UserId] - queryEmpys cid = E.unValue <<$>> runDB (E.select $ do - (emp :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser) - E.where_ $ uc E.^. UserCompanyCompany E.==. E.val cid - return $ emp E.^. UserId - ) - -} - - selected <- mapM decryptUserId =<< lookupGlobalGetParams GetRecipient -- retrieve selected users - empys <- ifMaybeM mbCid selected (\cid -> -- get all employees or stick with selected users, if no company was pre-selected (to limit choices) - E.unValue <<$>> runDB (E.select $ do - (emp :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser) - E.where_ $ uc E.^. UserCompanyCompany E.==. E.val cid - return $ emp E.^. UserId - )) - - cmpys <- E.unValue <<$>> runDB (E.select $ do - cmpy <- E.from $ E.table @Company - E.where_ $ E.exists $ do - usrCmpy <- E.from $ E.table @UserCompany - E.where_ $ usrCmpy E.^. UserCompanyUser `E.in_` E.valList selected - E.&&. usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId - return $ cmpy E.^.CompanyId +handleFirmCommR :: SomeRoute UniWorX -> Companies -> Handler Html +handleFirmCommR _ [] = invalidArgs ["At least one company name must be provided."] +handleFirmCommR ultDest cs = do + let + queryGiven :: [UserId] -> E.SqlQuery (E.SqlExpr (Entity User)) -- get users from a list of UserIds + queryGiven usrs = do + usr <- E.from $ E.table @User + E.where_ $ usr E.^. UserId `E.in_` E.valList usrs + return usr + mkCompanyUsrList :: [(E.Value (Maybe CompanyId), E.Value UserId)] -> Map.Map (Maybe CompanyId) [UserId] + mkCompanyUsrList l = Map.fromAscListWith (++) [(c,[u]) | (E.Value c, E.Value u) <- l] + toGrp = maybe RGFirmIndependent (RGFirmSupervisor . unCompanyKey) + csKeys = CompanyKey <$> cs + mbUser <- maybeAuthId + -- get employees of chosen companies + empys <- mkCompanyUsrList <$> runDB (E.select $ do + (emp :& cmp) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& cmp) -> emp E.^. UserId E.==. cmp E.^. UserCompanyUser) + E.where_ $ cmp E.^. UserCompanyCompany `E.in_` E.valList csKeys + E.orderBy [E.ascNullsFirst $ cmp E.^. UserCompanyCompany] + return (E.just $ cmp E.^. UserCompanyCompany, emp E.^. UserId) + ) + -- get supervisors of employees + sprs <- mkCompanyUsrList <$> runDB (E.select $ do + (spr :& cmp) <- E.from $ E.table @User `E.leftJoin` E.table @UserCompany `E.on` (\(spr :& cmp) -> spr E.^. UserId E.=?. cmp E.?. UserCompanyUser) + E.where_ $ (E.isTrue (cmp E.?. UserCompanySupervisor) E.&&. cmp E.?. UserCompanyCompany `E.in_` E.justValList csKeys) + E.||. (spr E.^. UserId E.=?. E.val mbUser) + E.||. E.exists (do + usrSpr <- E.from $ E.table @UserSupervisor + E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. spr E.^. UserId + E.&&. usrSpr E.^. UserSupervisorUser `E.in_` E.valList (concat $ Map.elems empys) + ) + E.orderBy [E.ascNullsFirst $ cmp E.?. UserCompanyCompany] + return (cmp E.?. UserCompanyCompany, spr E.^. UserId) ) - let queryCmpy :: Bool -> CompanyId -> E.SqlQuery (E.SqlExpr (Entity User)) - queryCmpy sORe acid = do - (usr :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser) - E.where_ $ uc E.^. UserCompanyCompany E.==. E.val acid - E.&&. (if sORe - then -- supervisors only - E.exists $ do - usrSpr <- E.from $ E.table @UserSupervisor - E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId - E.&&. usrSpr E.^. UserSupervisorUser `E.in_` E.valList empys - else -- selected employees for this company only - usr E.^. UserId `E.in_` E.valList empys - ) - return usr commR CommunicationRoute - { crHeading = SomeMessage $ maybe MsgFirmsNotification MsgFirmNotification mbFsh + { crHeading = SomeMessage $ case cs of { [c] -> MsgFirmNotification c ; _ -> MsgFirmsNotification } + , crTitle = SomeMessage $ case cs of { [c] -> MsgFirmNotificationTitle c ; _ -> MsgFirmsNotificationTitle } , crUltDest = ultDest - , crJobs = crJobsFirmCommunication mbFsh -- :: Communication -> ConduitT () Job (YesodDB UniWorX) () - , crTestJobs = crTestFirmCommunication mbFsh -- :: Communication -> ConduitT () Job (YesodDB UniWorX) () - , crRecipientAuth = Nothing -- :: Maybe (UserId -> DB AuthResult) -- an optional filter passed to guardAuthResult + , crJobs = crJobsFirmCommunication cs -- :: Communication -> ConduitT () Job (YesodDB UniWorX) () + , crTestJobs = crTestFirmCommunication cs -- :: Communication -> ConduitT () Job (YesodDB UniWorX) () + , crRecipientAuth = Nothing -- :: Maybe (UserId -> DB AuthResult) -- an optional filter passed to guardAuthResult , crRecipients = -- :: [(RecipientGroup, SqlQuery (SqlExpr (Entity User)))] - [(RGFirmSupervisor $ unCompanyKey acid, queryCmpy True acid) | acid <- cmpys ] <> - [(RGFirmEmployees $ unCompanyKey acid, queryCmpy False acid) | acid <- cmpys, maybe True (acid ==) mbCid] + [(toGrp acid, queryGiven usrs) | (acid, usrs) <- Map.toAscList sprs ] ++ + [(RGFirmEmployees $ unCompanyKey acid, queryGiven usrs) | (Just acid, usrs) <- Map.toAscList empys ] } {- Auswahlbox für Mitteilung: Wenn Firma gewählt, dann zeige: - Alle Supervisor von Leuten in X, gruppiert nach deren Firma - Alle Teilnehmer von X + Alle Supervisor von Leuten in X, gruppiert nach deren Firma + Alle Teilnehmer von X Wenn keine Firma gewählt, dann zeige: Alle Supervisor von gewählten Leuten, gruppiert nach deren Firma Alle gewählten Personen, gruppiert nach deren Firma diff --git a/src/Handler/Health/Interface.hs b/src/Handler/Health/Interface.hs new file mode 100644 index 000000000..7dbc96932 --- /dev/null +++ b/src/Handler/Health/Interface.hs @@ -0,0 +1,251 @@ +-- SPDX-FileCopyrightText: 2024 Steffen Jost +-- +-- SPDX-License-Identifier: AGPL-3.0-or-later + + +module Handler.Health.Interface + ( + getHealthInterfaceR + , mkInterfaceLogTable + , runInterfaceChecks + ) + where + +import Import + +-- import qualified Data.Set as Set +import qualified Data.Text as Text +import Handler.Utils +import Handler.Utils.Concurrent + +-- import Database.Esqueleto.Experimental ((:&)(..)) +import qualified Database.Esqueleto.Experimental as E +import qualified Database.Esqueleto.Utils as E +import qualified Database.Esqueleto.Legacy as EL (on) +import qualified Database.Persist.Sql as E (deleteWhereCount) + + +-- | identify a wildcard argument +wc2null :: Text -> Maybe Text +-- wc2null "." = Nothing -- does not work, since dots are eliminated in URLs +-- wc2null "-" = Nothing -- used as wildcard subtype in lpr interface +wc2null "_" = Nothing +wc2null "*" = Nothing +wc2null o = Just o + +-- | sloppily parse a boolean, also see Model.Types.Avs.SloppyBool +pbool :: Text -> Maybe Bool +pbool (Text.toLower . Text.strip -> w) + | w `elem` ["1", "t", "true" ,"wahr", "w"] = Just True + | w `elem` ["0", "f", "false","falsch"] = Just False + | otherwise = Nothing + +-- | parse UniqueInterfaceHealth with subtype and write arguments being optional for the last interface. Wildcards '_' or '.' are also allowed in all places. +identifyInterfaces :: [Text] -> [Unique InterfaceHealth] +identifyInterfaces [] = [] +identifyInterfaces [i] = [UniqueInterfaceHealth i Nothing Nothing] +identifyInterfaces [i,s] = [UniqueInterfaceHealth i (wc2null s) Nothing] +identifyInterfaces (i:s:w:r) = UniqueInterfaceHealth i (wc2null s) (pbool w) : identifyInterfaces r + +type ReqBanInterfaceHealth = ([Unique InterfaceHealth],[Unique InterfaceHealth]) + +-- | Interface names prefixed with '-' are to be excluded from the query +splitInterfaces :: [Unique InterfaceHealth] -> ReqBanInterfaceHealth +splitInterfaces = foldl' aux mempty + where + aux (reqs,bans) uih@(UniqueInterfaceHealth i s w) + | Just ('-', b) <- Text.uncons i = (reqs, UniqueInterfaceHealth b s w : bans) + | otherwise = (uih : reqs, bans) + +-- | check whether the first argument is equal or more specialzed (i.e. more Just) than the second +matchesUniqueInterfaceHealth :: Unique InterfaceHealth -> Unique InterfaceHealth -> Bool +matchesUniqueInterfaceHealth (UniqueInterfaceHealth ai as aw) (UniqueInterfaceHealth bi bs bw) = ai == bi && eqOrNothing as bs && eqOrNothing aw bw + where + eqOrNothing _ Nothing = True + eqOrNothing a b = a == b + + +getHealthInterfaceR :: [Text] -> Handler TypedContent +getHealthInterfaceR (dropWhile (=="force") -> ris) = do -- for backwards compatibility we ignore leading "force" + let interfs = splitInterfaces $ identifyInterfaces ris + (missing, allok, res, iltable) <- runInterfaceLogTable interfs + when missing notFound -- send 404 if any requested interface was not found + let ihstatus = if allok then status200 + else internalServerError500 + plainMsg = if allok then "Interfaces are healthy." + else "Unhealthy interfaces: " <> Text.intercalate ", " [iface | (iface, False) <- res] + sendResponseStatus ihstatus <=< selectRep $ do -- most browsers send accept:text/html, thus text/plain can be default here + provideRep . return . RepPlain $ toContent plainMsg -- /?_accept=text/plain + provideRep . siteLayoutMsg MsgMenuHealthInterface $ do -- /?_accept=text/html + setTitleI MsgMenuHealthInterface + [whamlet| +
                + #{plainMsg} +
                + ^{iltable} + |] + + +runInterfaceLogTable :: ReqBanInterfaceHealth -> Handler (Bool, Bool, [(Text,Bool)], Widget) +runInterfaceLogTable interfs@(reqIfs,_) = do + -- we abuse messageTooltip for colored icons here + msgSuccessTooltip <- messageI Success MsgMessageSuccess + -- msgWarningTooltip <- messageI Warning MsgMessageWarning + msgErrorTooltip <- messageI Error MsgMessageError + let flagError = messageTooltip . bool msgErrorTooltip msgSuccessTooltip + (res, twgt) <- runDB $ mkInterfaceLogTable flagError interfs + let missing = notNull [ifce | (UniqueInterfaceHealth ifce _subt _writ) <- reqIfs, ifce `notElem` (fst <$> res) ] + allok = all snd res + return (missing, allok, res, twgt) + +-- ihDebugShow :: Unique InterfaceHealth -> Text +-- ihDebugShow (UniqueInterfaceHealth i s w) = "(" <> tshow i <> "," <> tshow s <> "," <> tshow w <> ")" + +mkInterfaceLogTable :: (Bool -> Widget) -> ReqBanInterfaceHealth -> DB ([(Text,Bool)], Widget) +mkInterfaceLogTable flagError interfs@(reqIfs, banIfs) = do + -- $logWarnS "DEBUG" $ tshow ([ihDebugShow x | x<- reqIfs], [ihDebugShow x | x<- banIfs]) + void $ liftHandler $ timeoutHandler 42000001 $ runDB $ runInterfaceChecks interfs + now <- liftIO getCurrentTime + dbTableDB ilvalidator DBTable{dbtColonnade=colonnade now, ..} + where + sanitize = text2AlphaNumPlus ['+','-','_','Ä','Ö','Ü','ß','ä','ö','ü'] + dbtIdent = "interface-log" :: Text + dbtProj = dbtProjId + dbtSQLQuery (ilog `E.LeftOuterJoin` ihealth) = do + EL.on ( ilog E.^. InterfaceLogInterface E.=?. ihealth E.?. InterfaceHealthInterface + E.&&. ilog E.^. InterfaceLogSubtype E.=~. E.joinV (ihealth E.?. InterfaceHealthSubtype) + E.&&. ilog E.^. InterfaceLogWrite E.=~. E.joinV (ihealth E.?. InterfaceHealthWrite ) + ) + let matchUIH crits = E.or + [ E.and $ catMaybes + [ ilog E.^. InterfaceLogInterface E.==. E.val (sanitize ifce) & Just + , (ilog E.^. InterfaceLogSubtype E.==.) . E.val . sanitize <$> subt + , (ilog E.^. InterfaceLogWrite E.==.) . E.val <$> writ + ] + | (UniqueInterfaceHealth ifce subt writ) <- crits + ] + matchUIHnot crits = E.and + [ E.or $ catMaybes + [ ilog E.^. InterfaceLogInterface E.!=. E.val (sanitize ifce) & Just + , (ilog E.^. InterfaceLogSubtype E.!=.) . E.val . sanitize <$> subt + , (ilog E.^. InterfaceLogWrite E.!=.) . E.val <$> writ + ] + | (UniqueInterfaceHealth ifce subt writ) <- crits + ] + unless (null reqIfs) $ E.where_ $ matchUIH reqIfs + unless (null banIfs) $ E.where_ $ matchUIHnot banIfs + -- unless (null banIfs) $ E.where_ $ E.not_ $ matchUIH banIfs -- !!! DOES NOT WORK !!! Yields strange results, see #155 + -- unless (null banIfs) $ E.where_ $ E.not_ $ E.parens $ matchUIH banIfs -- WORKS OKAY + -- E.where_ $ E.not_ (ilog E.^. InterfaceLogInterface E.==. E.val "LMS" E.&&. ilog E.^. InterfaceLogSubtype E.==. E.val (sanitize "F")) -- BAD All missing, except for "Printer" "F" + -- E.where_ $ E.not_ $ E.parens (ilog E.^. InterfaceLogInterface E.==. E.val "LMS" E.&&. ilog E.^. InterfaceLogSubtype E.==. E.val (sanitize "F")) -- WORKS OKAY + -- E.where_ $ ilog E.^. InterfaceLogInterface E.!=. E.val "LMS" E.||. ilog E.^. InterfaceLogSubtype E.!=. E.val (sanitize "F") -- WORKS OKAY + let ihour = E.coalesceDefault [ihealth E.?. InterfaceHealthHours] (E.val $ 3 * 24) -- if no default time is set, use 3 days instead + return (ilog, ihour) + + queryILog :: (E.SqlExpr (Entity InterfaceLog) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity InterfaceHealth))) -> E.SqlExpr (Entity InterfaceLog) + queryILog = $(E.sqlLOJproj 2 1) + resultILog :: Lens' (DBRow (Entity InterfaceLog, E.Value Int)) InterfaceLog + resultILog = _dbrOutput . _1 . _entityVal + resultHours :: Lens' (DBRow (Entity InterfaceLog, E.Value Int)) Int + resultHours = _dbrOutput . _2 . E._unValue + + dbtRowKey = queryILog >>> (E.^.InterfaceLogId) + colonnade now = mconcat + [ sortable Nothing (i18nCell MsgInterfaceStatus) $ \row -> -- do + let hours = row ^. resultHours + -- defmsg = row ^? resultErrMsg + logtime = row ^. resultILog . _interfaceLogTime + success = row ^. resultILog . _interfaceLogSuccess + iface = row ^. resultILog . _interfaceLogInterface + status = success && now <= addHours hours logtime + in tellCell [(iface,status)] $ + wgtCell $ flagError status + , sortable (Just "interface") (i18nCell MsgInterfaceName ) $ \(view (resultILog . _interfaceLogInterface) -> n) -> textCell n + , sortable (Just "subtype") (i18nCell MsgInterfaceSubtype ) $ textCell . view (resultILog . _interfaceLogSubtype) + , sortable (Just "write") (i18nCell MsgInterfaceWrite ) $ (`ifIconCell` IconEdit) . view (resultILog . _interfaceLogWrite) + , sortable (Just "time") (i18nCell MsgInterfaceLastSynch ) $ dateTimeCell . view (resultILog . _interfaceLogTime) + , sortable Nothing (i18nCell MsgInterfaceFreshness ) $ numCell . view resultHours + , sortable (Just "rows") (i18nCell MsgTableRows ) $ cellMaybe numCell . view (resultILog . _interfaceLogRows) + , sortable (Just "success") (i18nCell MsgInterfaceSuccess ) $ \(view (resultILog . _interfaceLogSuccess) -> s) -> iconBoolCell s + , sortable Nothing (i18nCell MsgInterfaceInfo ) $ \(view resultILog -> ilt) -> case ilt of + InterfaceLog "AVS" "Synch" True _ _ i _ -> anchorCell ProblemAvsErrorR $ toWgt $ bool i "AVS-Log" $ null i + InterfaceLog "LPR" _ _ _ _ i _ -> anchorCell PrintLogR $ toWgt $ bool i "LPR-Log" $ null i + InterfaceLog _ _ _ _ _ i _ -> textCell i + ] + + dbtSorting = mconcat + [ singletonMap "interface" $ SortColumn $ queryILog >>> (E.^. InterfaceLogInterface) + , singletonMap "subtype" $ SortColumn $ queryILog >>> (E.^. InterfaceLogSubtype) + , singletonMap "write" $ SortColumn $ queryILog >>> (E.^. InterfaceLogWrite) + , singletonMap "time" $ SortColumn $ queryILog >>> (E.^. InterfaceLogTime) + , singletonMap "rows" $ SortColumn $ queryILog >>> (E.^. InterfaceLogRows) + , singletonMap "success" $ SortColumn $ queryILog >>> (E.^. InterfaceLogSuccess) + ] + ilvalidator = def & defaultSorting [SortAscBy "interface", SortAscBy "subtype", SortAscBy "write"] + dbtFilter = mempty + dbtFilterUI = mempty + dbtStyle = def + dbtParams = def + dbtCsvEncode = noCsvEncode + dbtCsvDecode = Nothing + dbtExtraReps = [] + + +-- | runs additional checks and logs results within InterfaceLogTable; assumed to executable within a handler call +runInterfaceChecks :: ReqBanInterfaceHealth -> DB () +runInterfaceChecks interfs = do + avsInterfaceCheck interfs + lprAckCheck interfs + +maybeRunCheck :: ReqBanInterfaceHealth -> Unique InterfaceHealth -> (UTCTime -> DB ()) -> DB () +maybeRunCheck (reqIfs,banIfs) uih act + | null reqIfs || any (matchesUniqueInterfaceHealth uih) reqIfs + , null banIfs || not (any (matchesUniqueInterfaceHealth uih) banIfs) = do + mih <- getBy uih + whenIsJust mih $ \eih -> do + now <- liftIO getCurrentTime + act $ addHours (negate $ interfaceHealthHours $ entityVal eih) now + | otherwise = return () + + +lprAckCheck :: ReqBanInterfaceHealth -> DB () +lprAckCheck interfs = maybeRunCheck interfs (UniqueInterfaceHealth "Printer" (Just "Acknowledge") (Just True)) $ \cutOffOldTime -> do + unproc <- selectList [PrintAcknowledgeTimestamp <. cutOffOldTime, PrintAcknowledgeProcessed ==. False] [] + if notNull unproc + then mkLog False (Just $ length unproc) "Long unprocessed APC-Idents exist" + else do + oks <- E.deleteWhereCount [PrintAcknowledgeTimestamp <. cutOffOldTime, PrintAcknowledgeProcessed ==. True] + if oks > 0 + then mkLog True (Just $ fromIntegral oks) "Long processed APC-Idents removed" + else mkLog True Nothing mempty + where + mkLog = logInterface' "Printer" "Acknowledge" True + + +avsInterfaceCheck :: ReqBanInterfaceHealth -> DB () +avsInterfaceCheck interfs = maybeRunCheck interfs (UniqueInterfaceHealth "AVS" (Just "Synch") (Just True)) $ \cutOffOldTime -> do + avsSynchStats <- E.select $ do + uavs <- E.from $ E.table @UserAvs + E.where_ $ uavs E.^. UserAvsLastSynch E.>. E.val cutOffOldTime + let isOk = E.isNothing (uavs E.^. UserAvsLastSynchError) + E.groupBy isOk + E.orderBy [E.descNullsLast isOk] + return (isOk, E.countRows, E.max_ $ uavs E.^. UserAvsLastSynch) + let + mkBadInfo badRows (fromMaybe cutOffOldTime -> badTime) | badRows > 0 = do + fmtCut <- formatTime SelFormatDate cutOffOldTime + fmtBad <- formatTime SelFormatDateTime badTime + return $ tshow badRows <> " Fehler seit " <> fmtCut <> ", zuletzt um " <> fmtBad + mkBadInfo _ _ = return mempty + writeAvsSynchStats okRows badInfo = + logInterface' "AVS" "Synch" True (null badInfo) okRows badInfo + --case $(unValueN 3) <$> avsSynchStats of + case avsSynchStats of + ((E.Value True , E.Value okRows, E.Value _okTime):(E.Value False, E.Value badRows, E.Value badTime):_) -> + writeAvsSynchStats (Just okRows) =<< mkBadInfo badRows badTime + ((E.Value True , E.Value okRows, E.Value _okTime):_) -> + writeAvsSynchStats (Just okRows) mempty + ((E.Value False, E.Value badRows, E.Value badTime):_) -> + -- lastOk <- userAvsLastSynch . entityVal <<$>> selectFirst [UserAvsLastSynchError ==. Nothing] [Desc UserAvsLastSynch] + writeAvsSynchStats Nothing =<< mkBadInfo badRows badTime + _ -> return () diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 682e0c7f4..abc8d8bd6 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -11,13 +11,7 @@ module Handler.LMS , getLmsR , postLmsR , getLmsIdentR , getLmsEditR , postLmsEditR - -- V1 - , getLmsUsersR , getLmsUsersDirectR - , getLmsUserlistR , postLmsUserlistR - , getLmsUserlistUploadR , postLmsUserlistUploadR, postLmsUserlistDirectR - , getLmsResultR , postLmsResultR - , getLmsResultUploadR , postLmsResultUploadR , postLmsResultDirectR - -- V1 + -- V2 , getLmsLearnersR , getLmsLearnersDirectR , getLmsReportR , postLmsReportR , getLmsReportUploadR , postLmsReportUploadR , postLmsReportDirectR @@ -50,10 +44,6 @@ import qualified Database.Esqueleto.PostgreSQL as E import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH import Database.Persist.Sql (deleteWhereCount, updateWhereCount) --- V1 -import Handler.LMS.Users as Handler.LMS -import Handler.LMS.Userlist as Handler.LMS -import Handler.LMS.Result as Handler.LMS -- V2 import Handler.LMS.Learners as Handler.LMS import Handler.LMS.Report as Handler.LMS @@ -75,7 +65,7 @@ embedRenderMessage ''UniWorX ''ButtonManualLms id instance Button UniWorX ButtonManualLms where btnClasses BtnLmsEnqueue = [BCIsButton, BCPrimary] - btnClasses BtnLmsDequeue = [BCIsButton, BCDefault] + btnClasses BtnLmsDequeue = [BCIsButton, BCPrimary] getLmsSchoolR :: SchoolId -> Handler Html @@ -85,7 +75,8 @@ getLmsAllR, postLmsAllR :: Handler Html getLmsAllR = postLmsAllR postLmsAllR = do isAdmin <- hasReadAccessTo AdminR - mbQcheck <- getsYesod $ view _appQualificationCheckHour + mbJLQenqueue <- getsYesod $ view _appJobLmsQualificationsEnqueueHour + mbJLQdequeue <- getsYesod $ view _appJobLmsQualificationsDequeueHour -- TODO: Move this functionality elsewhere without the need for `isAdmin` mbBtnForm <- if not isAdmin then return Nothing else do ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm ("buttons" :: Text) (buttonForm :: Form ButtonManualLms) @@ -109,7 +100,7 @@ postLmsAllR = do view _2 <$> mkLmsAllTable isAdmin lmsDeletionDays siteLayoutMsg MsgMenuLms $ do setTitleI MsgMenuLms - $(widgetFile "lms-all") + $(i18nWidgetFile "lms-all") type AllQualificationTableData = DBRow (Entity Qualification, Ex.Value Word64, Ex.Value Word64) resultAllQualification :: Lens' AllQualificationTableData Qualification @@ -632,7 +623,7 @@ postLmsR sid qsh = do ] colChoices cmpMap = mconcat [ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultUser . _entityKey)) - , colUserNameModalHdr MsgLmsUser AdminUserR + , colUserNameModalHdrAdmin MsgLmsUser AdminUserR , colUserEmail , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultCompanyUser -> cmps) -> let cs = [ companyCell (unCompanyKey cmpId) cmpName cmpSpr @@ -640,7 +631,7 @@ postLmsR sid qsh = do , let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap ] in intercalate spacerCell cs - , colUserMatriclenr + , colUserMatriclenr isAdmin -- , sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser) , sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d diff --git a/src/Handler/LMS/Learners.hs b/src/Handler/LMS/Learners.hs index ff329166e..1b149b95f 100644 --- a/src/Handler/LMS/Learners.hs +++ b/src/Handler/LMS/Learners.hs @@ -209,10 +209,10 @@ getLmsLearnersDirectR sid qsh = do csvOpts = def { csvFormat = fmtOpts } csvSheetName <- csvFilenameLmsUser qsh let nr = length lms_users - msg = "Success. LMS user learners download file " <> csvSheetName <> " containing " <> tshow nr <> " rows" + msg = "Success. LMS user learners download file " <> csvSheetName <> " containing " <> tshow nr <> " rows" $logInfoS "LMS" msg addHeader "Content-Disposition" $ "attachment; filename=\"" <> csvSheetName <> "\"" - csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered - + csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered + <* runDB (logInterface "LMS" (ciOriginal qsh) True (Just nr) "") -- direct Download see: -- https://ersocon.net/blog/2017/2/22/creating-csv-files-in-yesod \ No newline at end of file diff --git a/src/Handler/LMS/Report.hs b/src/Handler/LMS/Report.hs index c95f13a1f..2e3ffb00b 100644 --- a/src/Handler/LMS/Report.hs +++ b/src/Handler/LMS/Report.hs @@ -199,8 +199,7 @@ mkReportTable sid qsh qid = do , LmsReportResult =. lmsReportCsvResult actionData , LmsReportLock =. lmsReportCsvLock actionData , LmsReportTimestamp =. eanow - ] - -- audit $ Transaction.. (add to Audit.Types) + ] lift . queueDBJob $ JobLmsReports qid return $ LmsReportR sid qsh , dbtCsvRenderKey = const $ \case @@ -295,8 +294,7 @@ postLmsReportUploadR sid qsh = do setTitleI MsgMenuLmsUpload [whamlet|$newline never
                - ^{widget} -

                + ^{widget} |] @@ -316,11 +314,13 @@ postLmsReportDirectR sid qsh = do case enr of Left (e :: SomeException) -> do -- catch all to avoid ok220 in case of any error $logWarnS "LMS" $ "Report upload failed parsing: " <> tshow e + logInterface "LMS" (ciOriginal qsh) False Nothing "" return (badRequest400, "Exception: " <> tshow e) Right nr -> do let msg = "Success. LMS Report upload file " <> fileName file <> " containing " <> tshow nr <> " rows for " <> fhead <> ". " $logInfoS "LMS" msg when (nr > 0) $ queueDBJob $ JobLmsReports qid + logInterface "LMS" (ciOriginal qsh) True (Just nr) "" return (ok200, msg) [] -> do let msg = "Report upload file missing." diff --git a/src/Handler/LMS/Result.hs b/src/Handler/LMS/Result.hs deleted file mode 100644 index aca551ab6..000000000 --- a/src/Handler/LMS/Result.hs +++ /dev/null @@ -1,293 +0,0 @@ --- SPDX-FileCopyrightText: 2022 Steffen Jost ,Steffen Jost --- --- SPDX-License-Identifier: AGPL-3.0-or-later - -{-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances - -module Handler.LMS.Result - ( getLmsResultR, postLmsResultR - , getLmsResultUploadR, postLmsResultUploadR - , postLmsResultDirectR - ) - where - -import Import - -import Handler.Utils -import Handler.Utils.Csv -import Handler.Utils.LMS - -import qualified Data.Map as Map -import qualified Data.Csv as Csv -import qualified Data.Conduit.List as C -import qualified Database.Esqueleto.Legacy as E -import qualified Database.Esqueleto.Utils as E - -import Jobs.Queue - - -data LmsResultTableCsv = LmsResultTableCsv - { csvLRTident :: LmsIdent - , csvLRTsuccess :: LmsDay - } - deriving Generic -makeLenses_ ''LmsResultTableCsv - --- csv without headers -instance Csv.ToRecord LmsResultTableCsv -- default suffices -instance Csv.FromRecord LmsResultTableCsv -- default suffices - --- csv with headers -lmsResultTableCsvHeader :: Csv.Header -lmsResultTableCsvHeader = Csv.header [ csvLmsIdent, csvLmsSuccess ] - -instance ToNamedRecord LmsResultTableCsv where - toNamedRecord LmsResultTableCsv{..} = Csv.namedRecord - [ csvLmsIdent Csv..= csvLRTident - , csvLmsSuccess Csv..= csvLRTsuccess - ] - -instance FromNamedRecord LmsResultTableCsv where - parseNamedRecord (lsfHeaderTranslate -> csv) - = LmsResultTableCsv - <$> csv Csv..: csvLmsIdent - <*> csv Csv..: csvLmsSuccess - -instance CsvColumnsExplained LmsResultTableCsv where - csvColumnsExplanations _ = mconcat - [ single csvLmsIdent MsgCsvColumnLmsIdent - , single csvLmsSuccess MsgCsvColumnLmsSuccess - ] - where - single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget - single k v = singletonMap k [whamlet|_{v}|] - -data LmsResultCsvActionClass = LmsResultInsert | LmsResultUpdate - deriving (Eq, Ord, Read, Show, Generic, Enum, Bounded) -embedRenderMessage ''UniWorX ''LmsResultCsvActionClass id - --- By coincidence the action type is identical to LmsResultTableCsv -data LmsResultCsvAction = LmsResultInsertData { lmsResultInsertIdent :: LmsIdent, lmsResultInsertSuccess :: Day } - | LmsResultUpdateData { lmsResultInsertIdent :: LmsIdent, lmsResultInsertSuccess :: Day } - deriving (Eq, Ord, Read, Show, Generic) - -deriveJSON defaultOptions - { constructorTagModifier = camelToPathPiece'' 2 1 -- LmsResultInsertData -> insert - , fieldLabelModifier = camelToPathPiece' 2 -- lmsResultInsertIdent -> insert-ident | lmsResultInsertSuccess -> insert-success - , sumEncoding = TaggedObject "action" "data" - } ''LmsResultCsvAction - -data LmsResultCsvException - = LmsResultCsvExceptionDuplicatedKey -- TODO: this is not used anywhere?! - deriving (Show, Generic) - -instance Exception LmsResultCsvException -embedRenderMessage ''UniWorX ''LmsResultCsvException id - -mkResultTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget) -mkResultTable sid qsh qid = do - now_day <- utctDay <$> liftIO getCurrentTime - dbtCsvName <- csvFilenameLmsResult qsh - let dbtCsvSheetName = dbtCsvName - let - resultDBTable = DBTable{..} - where - dbtSQLQuery lmsresult = do - E.where_ $ lmsresult E.^. LmsResultQualification E.==. E.val qid - return lmsresult - dbtRowKey = (E.^. LmsResultId) - 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 - , sortable (Just csvLmsTimestamp) (i18nCell MsgTableLmsReceived) $ \(view $ _dbrOutput . _entityVal . _lmsResultTimestamp -> timestamp) -> dateTimeCell timestamp - ] - dbtSorting = Map.fromList - [ (csvLmsIdent , SortColumn (E.^. LmsResultIdent)) - , (csvLmsSuccess , SortColumn (E.^. LmsResultSuccess)) - , (csvLmsTimestamp, SortColumn (E.^. LmsResultTimestamp)) - ] - dbtFilter = Map.fromList - [ (csvLmsIdent , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsResultIdent)) - , (csvLmsSuccess, FilterColumn $ E.mkExactFilter (E.^. LmsResultSuccess)) - ] - dbtFilterUI = \mPrev -> mconcat - [ prismAForm (singletonFilter csvLmsIdent . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent) - , prismAForm (singletonFilter csvLmsSuccess . maybePrism _PathPiece) mPrev $ aopt (hoistField lift dayField) (fslI MsgTableLmsSuccess) - ] - dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } - dbtParams = def - dbtIdent :: Text - dbtIdent = "lms-result" - dbtCsvEncode = Just DBTCsvEncode - { dbtCsvExportForm = pure () - , dbtCsvDoEncode = \() -> C.map (doEncode' . view _2) - , dbtCsvName - , dbtCsvSheetName - , dbtCsvNoExportData = Just id - , dbtCsvHeader = const $ return lmsResultTableCsvHeader - , dbtCsvExampleData = Just - [ LmsResultTableCsv{csvLRTident = LmsIdent lid, csvLRTsuccess = LmsDay $ addDays (-dos) now_day } - | (lid,dos) <- zip ["abcdefgh", "12345678", "ident8ch"] [1..] - ] - } - where - doEncode' = LmsResultTableCsv - <$> view (_dbrOutput . _entityVal . _lmsResultIdent) - <*> view (_dbrOutput . _entityVal . _lmsResultSuccess . _lmsDay) - dbtCsvDecode = Just DBTCsvDecode -- Just save to DB; Job will process data later - { dbtCsvRowKey = \LmsResultTableCsv{..} -> - fmap E.Value . MaybeT . getKeyBy $ UniqueLmsResult qid csvLRTident - , dbtCsvComputeActions = \case -- purpose is to show a diff to the user first - DBCsvDiffNew{dbCsvNewKey = Nothing, dbCsvNew} -> do - yield $ LmsResultInsertData - { lmsResultInsertIdent = csvLRTident dbCsvNew - , lmsResultInsertSuccess = csvLRTsuccess dbCsvNew & lms2day - } - DBCsvDiffNew{dbCsvNewKey = Just _, dbCsvNew = _} -> error "UniqueLmsResult was found, but the key no longer exists." -- TODO: how can this ever happen? Check Pagination-Code - DBCsvDiffExisting{dbCsvNew = LmsResultTableCsv{..}, dbCsvOld} -> do - let successDay = lms2day csvLRTsuccess - when (successDay /= dbCsvOld ^. _dbrOutput . _entityVal . _lmsResultSuccess) $ - yield $ LmsResultUpdateData - { lmsResultInsertIdent = csvLRTident - , lmsResultInsertSuccess = successDay - } - DBCsvDiffMissing{} -> return () -- no deletion - , dbtCsvClassifyAction = \case - LmsResultInsertData{} -> LmsResultInsert - LmsResultUpdateData{} -> LmsResultUpdate - , dbtCsvCoarsenActionClass = \case - LmsResultInsert -> DBCsvActionNew - LmsResultUpdate -> DBCsvActionExisting - , dbtCsvValidateActions = return () -- no validation, since this is an automatic upload, i.e. no user to review error - , dbtCsvExecuteActions = do - C.mapM_ $ \actionData -> do - now <- liftIO getCurrentTime - void $ upsert - LmsResult - { lmsResultQualification = qid - , lmsResultIdent = lmsResultInsertIdent actionData - , lmsResultSuccess = lmsResultInsertSuccess actionData - , lmsResultTimestamp = now -- lmsResultInsertTimestamp -- does it matter which one to choose? - } - [ LmsResultSuccess =. lmsResultInsertSuccess actionData - , LmsResultTimestamp =. now - ] - -- audit $ Transaction.. (add to Audit.Types) - lift . queueDBJob $ JobLmsResults qid - return $ LmsResultR sid qsh - , dbtCsvRenderKey = const $ \case - LmsResultInsertData{..} -> do -- TODO: i18n - [whamlet| - $newline never - Insert: Ident #{getLmsIdent lmsResultInsertIdent} # - had success on ^{formatTimeW SelFormatDate lmsResultInsertSuccess} - |] - LmsResultUpdateData{..} -> do -- TODO: i18n - [whamlet| - $newline never - Update: Ident #{getLmsIdent lmsResultInsertIdent} # - had success on ^{formatTimeW SelFormatDate lmsResultInsertSuccess} - |] - , dbtCsvRenderActionClass = toWidget <=< ap getMessageRender . pure - , dbtCsvRenderException = ap getMessageRender . pure :: LmsResultCsvException -> DB Text - } - dbtExtraReps = [] - - resultDBTableValidator = def - & defaultSorting [SortAscBy csvLmsIdent] - dbTable resultDBTableValidator resultDBTable - -getLmsResultR, postLmsResultR :: SchoolId -> QualificationShorthand -> Handler Html -getLmsResultR = postLmsResultR -postLmsResultR sid qsh = do - let directUploadLink = LmsResultUploadR sid qsh - lmsTable <- runDB $ do - qid <- getKeyBy404 $ SchoolQualificationShort sid qsh - view _2 <$> mkResultTable sid qsh qid - siteLayoutMsg MsgMenuLmsResult $ do - setTitleI MsgMenuLmsResult - $(widgetFile "lms-result") - - --- Direct File Upload/Download - -saveResultCsv :: QualificationId -> Int -> LmsResultTableCsv -> DB Int -saveResultCsv qid i LmsResultTableCsv{..} = do - now <- liftIO getCurrentTime - void $ upsert - LmsResult - { lmsResultQualification = qid - , lmsResultIdent = csvLRTident - , lmsResultSuccess = csvLRTsuccess & lms2day - , lmsResultTimestamp = now - } - [ LmsResultSuccess =. (csvLRTsuccess & lms2day) - , LmsResultTimestamp =. now - ] - return $ succ i - -makeResultUploadForm :: Form FileInfo -makeResultUploadForm = renderAForm FormStandard $ fileAFormReq "Result CSV" - -getLmsResultUploadR, postLmsResultUploadR :: SchoolId -> QualificationShorthand -> Handler Html -getLmsResultUploadR = postLmsResultUploadR -postLmsResultUploadR sid qsh = do - ((result,widget), enctype) <- runFormPost makeResultUploadForm - case result of - FormSuccess file -> do - -- content <- fileSourceByteString file - -- return $ Just (fileName file, content) - nr <- runDB $ do - qid <- getKeyBy404 $ SchoolQualificationShort sid qsh - nr <- runConduit $ fileSource file - .| decodeCsv - .| foldMC (saveResultCsv qid) 0 - queueJob' $ JobLmsResults qid - return nr - addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file <> pack (" mit " <> show nr <> " Zeilen") - redirect $ LmsResultR sid qsh - FormFailure errs -> do - forM_ errs $ addMessage Error . toHtml - redirect $ LmsResultUploadR sid qsh - FormMissing -> - siteLayoutMsg MsgMenuLmsResult $ do - setTitleI MsgMenuLmsUpload - [whamlet|$newline never - - ^{widget} -

                - - |] - - -postLmsResultDirectR :: SchoolId -> QualificationShorthand -> Handler Html -postLmsResultDirectR sid qsh = do - (_params, files) <- runRequestBody - (status, msg) <- case files of - [(fhead,file)] -> do - lmsDecoder <- getLmsCsvDecoder - runDB $ do - qid <- getKeyBy404 $ SchoolQualificationShort sid qsh - enr <- try $ runConduit $ fileSource file - .| lmsDecoder - .| foldMC (saveResultCsv qid) 0 - case enr of - Left (e :: SomeException) -> do -- catch all to avoid ok220 in case of any error - $logWarnS "LMS" $ "Result upload failed parsing: " <> tshow e - return (badRequest400, "Exception: " <> tshow e) - Right nr -> do - let msg = "Success. LMS Result upload file " <> fileName file <> " containing " <> tshow nr <> " rows for " <> fhead <> ". " - $logInfoS "LMS" msg - when (nr > 0) $ queueJob' $ JobLmsResults qid - return (ok200, msg) - [] -> do - let msg = "Result upload file missing." - $logWarnS "LMS" msg - return (badRequest400, msg) - _other -> do - let msg = "Result upload received multiple files; all ignored." - $logWarnS "LMS" msg - return (badRequest400, msg) - sendResponseStatus status msg - diff --git a/src/Handler/LMS/Userlist.hs b/src/Handler/LMS/Userlist.hs deleted file mode 100644 index 6304c5be7..000000000 --- a/src/Handler/LMS/Userlist.hs +++ /dev/null @@ -1,288 +0,0 @@ --- SPDX-FileCopyrightText: 2022 Steffen Jost --- --- SPDX-License-Identifier: AGPL-3.0-or-later - -{-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances - -module Handler.LMS.Userlist - ( getLmsUserlistR, postLmsUserlistR - , getLmsUserlistUploadR, postLmsUserlistUploadR - , postLmsUserlistDirectR - ) - where - -import Import - -import Handler.Utils -import Handler.Utils.Csv -import Handler.Utils.LMS - -import qualified Data.Map as Map -import qualified Data.Csv as Csv -import qualified Data.Conduit.List as C -import qualified Database.Esqueleto.Legacy as E -import qualified Database.Esqueleto.Utils as E - -import Jobs.Queue - -data LmsUserlistTableCsv = LmsUserlistTableCsv - { csvLULident :: LmsIdent - , csvLULfailed :: LmsBool - } - deriving Generic -makeLenses_ ''LmsUserlistTableCsv - --- csv without headers -instance Csv.ToRecord LmsUserlistTableCsv -instance Csv.FromRecord LmsUserlistTableCsv - --- csv with headers -instance DefaultOrdered LmsUserlistTableCsv where - headerOrder = const $ Csv.header [ csvLmsIdent, csvLmsBlocked ] - -instance ToNamedRecord LmsUserlistTableCsv where - toNamedRecord LmsUserlistTableCsv{..} = Csv.namedRecord - [ csvLmsIdent Csv..= csvLULident - , csvLmsBlocked Csv..= csvLULfailed - ] -instance FromNamedRecord LmsUserlistTableCsv where - parseNamedRecord (lsfHeaderTranslate -> csv) - = LmsUserlistTableCsv - <$> csv Csv..: csvLmsIdent - <*> csv Csv..: csvLmsBlocked - -instance CsvColumnsExplained LmsUserlistTableCsv where - csvColumnsExplanations _ = mconcat - [ single csvLmsIdent MsgCsvColumnLmsIdent - , single csvLmsBlocked MsgCsvColumnLmsLock - ] - where - single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget - single k v = singletonMap k [whamlet|_{v}|] - - -data LmsUserlistCsvActionClass = LmsUserlistInsert | LmsUserlistUpdate - deriving (Eq, Ord, Read, Show, Generic, Enum, Bounded) -embedRenderMessage ''UniWorX ''LmsUserlistCsvActionClass id - -data LmsUserlistCsvAction = LmsUserlistInsertData { lmsUserlistInsertIdent :: LmsIdent, lmsUserlistInsertFailed :: Bool } - | LmsUserlistUpdateData { lmsUserlistInsertIdent :: LmsIdent, lmsUserlistInsertFailed :: Bool } - deriving (Eq, Ord, Read, Show, Generic) - -deriveJSON defaultOptions - { constructorTagModifier = camelToPathPiece'' 2 1 -- LmsUserlistInsertData -> insert - , fieldLabelModifier = camelToPathPiece' 2 -- lmsUserlistInsertIdent -> insert-ident | lmsUserlistInsertFailed -> insert-failed - , sumEncoding = TaggedObject "action" "data" - } ''LmsUserlistCsvAction - - -data LmsUserlistCsvException - = LmsUserlistCsvExceptionDuplicatedKey -- TODO: this is not used anywhere?! - deriving (Show, Generic) - -instance Exception LmsUserlistCsvException -embedRenderMessage ''UniWorX ''LmsUserlistCsvException id - -mkUserlistTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget) -mkUserlistTable sid qsh qid = do - dbtCsvName <- csvFilenameLmsUserlist qsh - let dbtCsvSheetName = dbtCsvName - let - userlistTable = DBTable{..} - where - dbtSQLQuery lmslist = do - E.where_ $ lmslist E.^. LmsUserlistQualification E.==. E.val qid - return lmslist - dbtRowKey = (E.^. LmsUserlistId) - dbtProj = dbtProjId - dbtColonnade = dbColonnade $ mconcat - [ sortable (Just csvLmsIdent) (i18nCell MsgTableLmsIdent) $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> textCell $ lmsUserlistIdent & getLmsIdent - , sortable (Just csvLmsBlocked) (i18nCell MsgTableLmsLock) $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> ifIconCell lmsUserlistFailed IconBlocked - , sortable (Just csvLmsTimestamp) (i18nCell MsgTableLmsReceived) $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> dateTimeCell lmsUserlistTimestamp - ] - dbtSorting = Map.fromList - [ (csvLmsIdent , SortColumn $ \lmslist -> lmslist E.^. LmsUserlistIdent) - , (csvLmsBlocked , SortColumn $ \lmslist -> lmslist E.^. LmsUserlistFailed) - , (csvLmsTimestamp, SortColumn $ \lmslist -> lmslist E.^. LmsUserlistTimestamp) - ] - dbtFilter = Map.fromList - [ (csvLmsIdent , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsUserlistIdent )) - , (csvLmsBlocked, FilterColumn $ E.mkExactFilter (E.^. LmsUserlistFailed)) - ] - dbtFilterUI = \mPrev -> mconcat - [ prismAForm (singletonFilter csvLmsIdent . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent) - , prismAForm (singletonFilter csvLmsBlocked . maybePrism _PathPiece) mPrev $ aopt (hoistField lift checkBoxField) (fslI MsgTableLmsLock) - ] - dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } - dbtParams = def - dbtIdent :: Text - dbtIdent = "lms-userlist" - dbtCsvEncode = simpleCsvEncode dbtCsvName dbtCsvSheetName doEncode' <&> addExample - where - addExample dce = dce{ dbtCsvExampleData = csvExample } - csvExample = Just - [ LmsUserlistTableCsv{csvLULident = LmsIdent lid, csvLULfailed = LmsBool ufl} - | (lid,ufl) <- zip ["abcdefgh", "12345678", "ident8ch"] [False,True,False] - ] - doEncode' = LmsUserlistTableCsv - <$> view (_dbrOutput . _entityVal . _lmsUserlistIdent) - <*> view (_dbrOutput . _entityVal . _lmsUserlistFailed . _lmsBool) - dbtCsvDecode = Just DBTCsvDecode {..} - where - dbtCsvRowKey = \LmsUserlistTableCsv{csvLULident} -> - fmap E.Value . MaybeT . getKeyBy $ UniqueLmsUserlist qid csvLULident - dbtCsvComputeActions = \case -- shows a diff first - DBCsvDiffNew{dbCsvNew} -> do - yield $ LmsUserlistInsertData - { lmsUserlistInsertIdent = csvLULident dbCsvNew - , lmsUserlistInsertFailed = lms2bool $ csvLULfailed dbCsvNew - } - DBCsvDiffExisting{dbCsvNew = LmsUserlistTableCsv{..}, dbCsvOld} -> do - let failedBool = lms2bool csvLULfailed - when (failedBool /= dbCsvOld ^. _dbrOutput . _entityVal . _lmsUserlistFailed) $ - yield $ LmsUserlistUpdateData - { lmsUserlistInsertIdent = csvLULident - , lmsUserlistInsertFailed = csvLULfailed & lms2bool - } - DBCsvDiffMissing{} -> return () -- no deletion - dbtCsvClassifyAction = \case - LmsUserlistInsertData{} -> LmsUserlistInsert - LmsUserlistUpdateData{} -> LmsUserlistUpdate - dbtCsvCoarsenActionClass = \case - LmsUserlistInsert -> DBCsvActionNew - LmsUserlistUpdate -> DBCsvActionExisting - dbtCsvValidateActions = return () -- no validation, since this is an automatic upload, i.e. no user to review error - dbtCsvExecuteActions = do - C.mapM_ $ \actionData -> do - now <- liftIO getCurrentTime - void $ upsert LmsUserlist - { - lmsUserlistQualification = qid - , lmsUserlistIdent = lmsUserlistInsertIdent actionData - , lmsUserlistFailed = lmsUserlistInsertFailed actionData - , lmsUserlistTimestamp = now - } - [ - LmsUserlistFailed =. lmsUserlistInsertFailed actionData -- TODO: should we allow a reset from failed: True to False? - , LmsUserlistTimestamp =. now - ] - -- audit - lift . queueDBJob $ JobLmsUserlist qid - return $ LmsUserlistR sid qsh - dbtCsvRenderKey = const $ \case - LmsUserlistInsertData{..} -> do -- TODO: i18n - [whamlet| - $newline never - Insert: Course for Ident #{getLmsIdent lmsUserlistInsertIdent} # - $if lmsUserlistInsertFailed - is closed due to failure. - $else - is open. - |] - LmsUserlistUpdateData{..} -> do -- TODO: i18n - [whamlet| - $newline never - Update: Course for Ident #{getLmsIdent lmsUserlistInsertIdent} # - $if lmsUserlistInsertFailed - is now closed due to failure. - $else - is still open. - |] - dbtCsvRenderActionClass = toWidget <=< ap getMessageRender . pure - dbtCsvRenderException = ap getMessageRender . pure :: LmsUserlistCsvException -> DB Text - dbtExtraReps = [] - - userlistDBTableValidator = def - & defaultSorting [SortAscBy csvLmsIdent] - - dbTable userlistDBTableValidator userlistTable - - -getLmsUserlistR, postLmsUserlistR :: SchoolId -> QualificationShorthand -> Handler Html -getLmsUserlistR = postLmsUserlistR -postLmsUserlistR sid qsh = do - lmsTable <- runDB $ do - qid <- getKeyBy404 $ SchoolQualificationShort sid qsh - view _2 <$> mkUserlistTable sid qsh qid - siteLayoutMsg MsgMenuLmsUserlist $ do - setTitleI MsgMenuLmsUserlist - lmsTable - - --- Direct File Upload/Download --- saveUserlistCsv :: (PersistUniqueWrite backend, MonadIO m, BaseBackend backend ~ SqlBackend, Enum b) => --- Key Qualification -> b -> LmsUserlistTableCsv -> ReaderT backend m b -saveUserlistCsv :: QualificationId -> Int -> LmsUserlistTableCsv -> DB Int -saveUserlistCsv qid i LmsUserlistTableCsv{..} = do - now <- liftIO getCurrentTime - void $ upsert - LmsUserlist - { lmsUserlistQualification = qid - , lmsUserlistIdent = csvLULident - , lmsUserlistFailed = csvLULfailed & lms2bool - , lmsUserlistTimestamp = now - } - [ LmsUserlistFailed =. (csvLULfailed & lms2bool) - , LmsUserlistTimestamp =. now - ] - return $ succ i - -makeUserlistUploadForm :: Form FileInfo -makeUserlistUploadForm = renderAForm FormStandard $ fileAFormReq "Userlist CSV" - -getLmsUserlistUploadR, postLmsUserlistUploadR :: SchoolId -> QualificationShorthand -> Handler Html -getLmsUserlistUploadR = postLmsUserlistUploadR -postLmsUserlistUploadR sid qsh = do - ((result,widget), enctype) <- runFormPost makeUserlistUploadForm - case result of - FormSuccess file -> do - nr <- runDB $ do - qid <- getKeyBy404 $ SchoolQualificationShort sid qsh - nr <- runConduit $ fileSource file .| decodeCsv .| foldMC (saveUserlistCsv qid) 0 - queueJob' $ JobLmsUserlist qid - return nr - addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file <> pack (" mit " <> show nr <> " Zeilen") - redirect $ LmsUserlistR sid qsh - FormFailure errs -> do - forM_ errs $ addMessage Error . toHtml - redirect $ LmsUserlistUploadR sid qsh - FormMissing -> - siteLayoutMsg MsgMenuLmsUserlist $ do - setTitleI MsgMenuLmsUpload - [whamlet|$newline never - - ^{widget} -

                - - |] - - -postLmsUserlistDirectR :: SchoolId -> QualificationShorthand -> Handler Html -postLmsUserlistDirectR sid qsh = do - (_params, files) <- runRequestBody - (status, msg) <- case files of - [(fhead,file)] -> do - lmsDecoder <- getLmsCsvDecoder - runDB $ do - qid <- getKeyBy404 $ SchoolQualificationShort sid qsh - enr <- try $ runConduit $ fileSource file - .| lmsDecoder - .| foldMC (saveUserlistCsv qid) 0 - case enr of - Left (e :: SomeException) -> do - $logWarnS "LMS" $ "Userlist upload failed parsing: " <> tshow e - return (badRequest400, "Exception: " <> tshow e) - Right nr -> do - let msg = "Success. LMS Userlist upload file " <> fileName file <> " containing " <> tshow nr <> " rows for " <> fhead <> ". " - $logInfoS "LMS" msg - when (nr > 0) $ queueJob' $ JobLmsUserlist qid - return (ok200, msg) - [] -> do - let msg = "Userlist upload file missing." - $logWarnS "LMS" msg - return (badRequest400, msg) - _other -> do - let msg = "Userlist upload received multiple files; all ignored." - $logWarnS "LMS" msg - return (badRequest400, msg) - sendResponseStatus status msg diff --git a/src/Handler/PrintCenter.hs b/src/Handler/PrintCenter.hs index 6be31bf20..084cc74d6 100644 --- a/src/Handler/PrintCenter.hs +++ b/src/Handler/PrintCenter.hs @@ -7,10 +7,11 @@ module Handler.PrintCenter ( getPrintDownloadR - , getPrintCenterR, postPrintCenterR + , getPrintCenterR, postPrintCenterR , getPrintSendR , postPrintSendR , getPrintAckR , postPrintAckR - , postPrintAckDirectR + , getPrintAckDirectR, postPrintAckDirectR + , getPrintLogR ) where import Import @@ -26,7 +27,7 @@ import Database.Esqueleto.Utils.TH import Utils.Print --- import Data.Aeson (encode) +import qualified Data.Aeson as Aeson -- import qualified Data.Text as Text -- import qualified Data.Set as Set @@ -43,11 +44,11 @@ single :: (k,a) -> Map k a single = uncurry Map.singleton -data LRQF = LRQF - { lrqfLetter :: Text +data LRQF = LRQF + { lrqfLetter :: Text , lrqfUser :: Either UserEmail UserId , lrqfSuper :: Maybe (Either UserEmail UserId) - , lrqfQuali :: Entity Qualification + , lrqfQuali :: Entity Qualification , lrqfIdent :: LmsIdent , lrqfPin :: Text , lrqfExpiry :: Maybe Day @@ -62,12 +63,12 @@ makeRenewalForm tmpl = identifyForm FIDLmsLetter . validateForm validateLetterRe <*> 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) + <*> areq lmsField (fslI MsgTableLmsIdent) (lrqfIdent <$> tmpl) <*> areq textField (fslI MsgTableLmsPin) (lrqfPin <$> tmpl) <*> aopt dayField (fslI MsgLmsQualificationValidUntil) (lrqfExpiry <$> tmpl) - <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) + <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgLmsRenewalReminder) (lrqfReminder <$> tmpl) - where + where lmsField = convertField LmsIdent getLmsIdent textField validateLetterRenewQualificationF :: FormValidator LRQF Handler () @@ -76,12 +77,12 @@ validateLetterRenewQualificationF = -- do return () lrqf2letter :: LRQF -> DB (Entity User, SomeLetter) -lrqf2letter LRQF{..} - | lrqfLetter == "r" = do +lrqf2letter LRQF{..} + | lrqfLetter == "r" = do usr <- getUser lrqfUser rcvr <- mapM getUser lrqfSuper now <- liftIO getCurrentTime - let letter = LetterRenewQualificationF + let letter = LetterRenewQualificationF { lmsLogin = lrqfIdent , lmsPin = lrqfPin , qualHolderID = usr ^. _entityKey @@ -96,13 +97,13 @@ lrqf2letter LRQF{..} , isReminder = lrqfReminder } return (fromMaybe usr rcvr, SomeLetter letter) - | lrqfLetter == "e" || lrqfLetter == "E" = do + | lrqfLetter == "e" || lrqfLetter == "E" = do rcvr <- mapM getUser lrqfSuper usr <- getUser lrqfUser usrShrt <- encrypt $ entityKey usr usrUuid <- encrypt $ entityKey usr urender <- liftHandler getUrlRender - let letter = LetterExpireQualification + let letter = LetterExpireQualification { leqHolderCFN = usrShrt , leqHolderID = usr ^. _entityKey , leqHolderDN = usr ^. _userDisplayName @@ -111,15 +112,15 @@ lrqf2letter LRQF{..} , leqId = lrqfQuali ^. _entityKey , leqName = lrqfQuali ^. _qualificationName . _CI , leqShort = lrqfQuali ^. _qualificationShorthand . _CI - , leqSchool = lrqfQuali ^. _qualificationSchool + , leqSchool = lrqfQuali ^. _qualificationSchool , leqUrl = pure . urender $ ForProfileDataR usrUuid } return (fromMaybe usr rcvr, SomeLetter letter) | otherwise = error "Unknown Letter Type encountered. Use 'e' or 'r' only." - where + where getUser :: Either UserEmail UserId -> DB (Entity User) getUser (Right uid) = getEntity404 uid - getUser (Left mail) = getBy404 $ UniqueEmail mail + getUser (Left mail) = getBy404 $ UniqueEmail mail data PJTableAction = PJActAcknowledge | PJActReprint @@ -190,7 +191,7 @@ pjTableQuery (printJob `E.LeftOuterJoin` recipient return (printJob, recipient, sender, course, quali) mkPJTable :: DB (FormResult (PJTableActionData, Set PrintJobId), Widget) -mkPJTable = do +mkPJTable = do let dbtSQLQuery = pjTableQuery dbtRowKey = queryPrintJob >>> (E.^. PrintJobId) @@ -225,7 +226,7 @@ mkPJTable = do dbtFilter = mconcat [ single ("name" , FilterColumn . E.mkContainsFilterWithCommaPlus id $ views (to queryPrintJob) (E.^. PrintJobName)) , single ("apcid" , FilterColumn . E.mkContainsFilterWithComma id $ views (to queryPrintJob) (E.^. PrintJobApcIdent)) - , single ("filename" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobFilename)) + , single ("filename" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobFilename)) , single ("created" , FilterColumn . E.mkDayFilter $ views (to queryPrintJob) (E.^. PrintJobCreated)) --, single ("created" , FilterColumn . E.mkDayBetweenFilter $ views (to queryPrintJob) (E.^. PrintJobCreated)) , single ("recipient" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to queryRecipient) (E.?. UserDisplayName)) @@ -233,7 +234,7 @@ mkPJTable = do , single ("course" , FilterColumn . E.mkContainsFilterWith (Just . CI.mk) $ views (to queryCourse) (E.?. CourseName)) , single ("qualification", FilterColumn . E.mkContainsFilterWith (Just . CI.mk) $ views (to queryQualification) (E.?. QualificationName)) , single ("lmsid" , FilterColumn . E.mkContainsFilterWithCommaPlus (Just . LmsIdent) $ views (to queryPrintJob) (E.^. PrintJobLmsUser)) - + , single ("acknowledged" , FilterColumn . E.mkExactFilterLast $ views (to queryPrintJob) (E.isJust . (E.^. PrintJobAcknowledged))) ] dbtFilterUI mPrev = mconcat @@ -288,7 +289,7 @@ mkPJTable = do getPrintCenterR, postPrintCenterR :: Handler Html getPrintCenterR = postPrintCenterR -postPrintCenterR = do +postPrintCenterR = do (pjRes, pjTable) <- runDB mkPJTable formResult pjRes $ \case @@ -298,21 +299,21 @@ postPrintCenterR = do addMessageI Success $ MsgPrintJobAcknowledge num reloadKeepGetParams PrintCenterR (PJActReprintData{ignoreReroute}, Set.toList -> pjIds) -> do - let countOk = either (const $ Sum 0) (const $ Sum 1) + let countOk = either (const $ Sum 0) (const $ Sum 1) oks <- runDB $ forM pjIds $ fmap countOk . reprintPDF (fromMaybe False ignoreReroute) let nr_oks = getSum $ mconcat oks nr_tot = length pjIds mstat = bool Warning Success $ nr_oks == nr_tot addMessageI mstat $ MsgPrintJobReprint nr_oks nr_tot reloadKeepGetParams PrintCenterR - siteConf <- getYesod + siteConf <- getYesod let lprConf = siteConf ^. _appLprConf reroute = siteConf ^. _appMailRerouteTo lprWgt = [whamlet| LPR Konfiguration ist #{lprQueue lprConf}@#{lprHost lprConf}:#{lprPort lprConf}

                $maybe _ <- reroute - Mail-reroute-to ist gesetzt, somit werden alle lpr Kommandos unterdrückt! + Mail-reroute-to ist gesetzt, somit werden alle lpr Kommandos unterdrückt! |] siteLayoutMsg MsgMenuApc $ do setTitleI MsgMenuApc @@ -322,7 +323,7 @@ postPrintCenterR = do getPrintSendR, postPrintSendR :: Handler Html getPrintSendR = postPrintSendR postPrintSendR = do - usr <- requireAuth -- to determine language and recipient for test + usr <- requireAuth -- to determine language and recipient for test mbQual <- runDB $ selectFirst [] [Asc QualificationAvsLicence, Asc QualificationShorthand] now <- liftIO getCurrentTime let nowaday = utctDay now @@ -340,7 +341,7 @@ postPrintSendR = do def_lrqf = mkLetter <$> mbQual ((sendResult, sendWidget), sendEnctype) <- runFormPost $ makeRenewalForm def_lrqf - let procFormSend lrqf = case lrqfLetter lrqf of + let procFormSend lrqf = case lrqfLetter lrqf of "E" -> (runDB (lrqf2letter lrqf) >>= printHtml (Just uid)) >>= \case Right html -> sendResponse $ toTypedContent html Left err -> do @@ -348,7 +349,7 @@ postPrintSendR = do $logErrorS "LPR" msg addMessage Error $ toHtml msg pure () - _ -> do + _ -> do ok <- (runDB (lrqf2letter lrqf) >>= printLetter (Just uid)) >>= \case Left err -> do let msg = "PDF printing failed with error: " <> err @@ -399,26 +400,26 @@ postPrintAckR ackDay numAck chksm = do , formSubmit = FormNoSubmit } formResult ackRes $ \BtnConfirm -> do - numNew <- runDB $ do - pjs <- Ex.select $ do + numNew <- runDB $ do + pjs <- Ex.select $ do pj <- Ex.from $ Ex.table @PrintJob - let pjDay = E.day $ pj Ex.^. PrintJobCreated + let pjDay = E.day $ pj Ex.^. PrintJobCreated Ex.where_ $ Ex.isNothing (pj Ex.^. PrintJobAcknowledged) - Ex.&&. (pjDay Ex.==. Ex.val ackDay) + Ex.&&. (pjDay Ex.==. Ex.val ackDay) return $ pj Ex.^. PrintJobId let changed = numAck /= length pjs || chksm /= hash (Set.fromList (Ex.unValue <$> pjs)) if changed then return (-1) - else do + else do now <- liftIO getCurrentTime E.updateCount $ \pj -> do - let pjDay = E.day $ pj E.^. PrintJobCreated + let pjDay = E.day $ pj E.^. PrintJobCreated E.set pj [ PrintJobAcknowledged E.=. E.justVal now ] E.where_ $ E.isNothing (pj E.^. PrintJobAcknowledged) E.&&. (pjDay E.==. E.val ackDay) -- Ex.updateCount $ do -- pj <- Ex.from $ Ex.table @PrintJob - -- let pjDay = E.day $ pj Ex.^. PrintJobCreated + -- let pjDay = E.day $ pj Ex.^. PrintJobCreated -- Ex.set pj [ PrintJobAcknowledged Ex.=. Ex.just (Ex.val now) ] -- Ex.where_ $ Ex.isNothing (pj Ex.^. PrintJobAcknowledged) -- Ex.&&. (pjDay Ex.==. Ex.val ackDay) @@ -427,29 +428,44 @@ postPrintAckR ackDay numAck chksm = do else addMessageI Error MsgPrintJobAcknowledgeFailed redirect PrintCenterR ackDayText <- formatTime SelFormatDate ackDay - siteLayoutMsg - (MsgPrintJobAcknowledgeQuestion numAck ackDayText) + siteLayoutMsg + (MsgPrintJobAcknowledgeQuestion numAck ackDayText) ackForm -- no header csv, containing a single column of lms identifiers (logins) -- instance Csv.FromRecord LmsIdent -- default suffices --- instance Csv.FromRecord Text where --- parseRecord v +-- instance Csv.FromRecord Text where +-- parseRecord v -- | length v >= 1 = v Csv..! 0 -- | otherwise = pure "ERROR" saveApcident :: UTCTime -> Natural -> Text -> JobDB Natural saveApcident t i apci = insert_ (PrintAcknowledge apci t False) >> return (succ i) + +makeAckUploadForm :: Form FileInfo +makeAckUploadForm = renderAForm FormStandard $ fileAFormReq "Acknowledge APC-Ident CSV" + +getPrintAckDirectR :: Handler Html +getPrintAckDirectR = do + (widget, enctype) <- generateFormPost makeAckUploadForm + siteLayoutMsg MsgMenuPrintAck $ do + setTitleI MsgMenuPrintAck + [whamlet|$newline never + + ^{widget} + + |] + postPrintAckDirectR :: Handler Html postPrintAckDirectR = do now <- liftIO getCurrentTime (_params, files) <- runRequestBody (status, msg) <- case files of - [(_fhead,file)] -> do - runDBJobs $ do + [(_fhead,file)] -> do + runDBJobs $ do enr <- try $ runConduit $ fileSource file - -- .| decodeCsvPositional Csv.NoHeader -- decode by separator position + -- .| decodeCsvPositional Csv.NoHeader -- decode by separator position .| decodeUtf8C -- no CSV, just convert each line to a single text .| linesUnboundedC .| foldMC (saveApcident now) 0 @@ -461,7 +477,7 @@ postPrintAckDirectR = do let msg = "Success: received " <> tshow nr <> " APC identifiers to be processed later." $logInfoS "LMS" msg when (nr > 0) $ queueDBJob JobPrintAck - return (ok200, msg) + return (ok200, msg) [] -> do let msg = "Error: No file received. A file of lms identifiers must be supplied for print job acknowledging." $logWarnS "APC" msg @@ -471,3 +487,55 @@ postPrintAckDirectR = do $logErrorS "APC" msg return (badRequest400, msg) sendResponseStatus status msg -- must be outside of runDB; otherwise transaction is rolled back + + +getPrintLogR :: Handler Html +getPrintLogR = do + let + logDBTable = DBTable{..} + where + resultLog :: Lens' (DBRow (TransactionLog, Aeson.Result Transaction)) TransactionLog + resultLog = _dbrOutput . _1 + + resultTrans :: Lens' (DBRow (TransactionLog, Aeson.Result Transaction)) (Aeson.Result Transaction) + resultTrans = _dbrOutput . _2 + + tCell' err c dbr = case view resultTrans dbr of + (Aeson.Error msg) -> err msg -- should not happen, due to query filter + (Aeson.Success t) -> c t + tCellErr = tCell' stringCell + tCell = tCell' $ const mempty + + dbtIdent = "lpr-log" :: Text + dbtSQLQuery l = do + E.where_ $ E.val "LPR" E.==. l E.^. TransactionLogInfo E.->>. "interface-name" + -- E.&&. E.val "interface" E.==. l E.^. TransactionLogInfo E.->>. "transaction" -- not necessary + return l + dbtRowKey = (E.^. TransactionLogId) + dbtProj = dbtProjSimple $ \(Entity _ l) -> do + return (l, Aeson.fromJSON $ transactionLogInfo l) + dbtColonnade = dbColonnade $ mconcat + [ sortable (Just "time") (i18nCell MsgSystemMessageTimestamp) $ \(view $ resultLog . to transactionLogTime -> t) -> dateTimeCell t + , sortable (Just "status") (textCell "Status") $ tCell (cellMaybe iconBoolCell . transactionInterfaceSuccess) + , sortable (Just "subtype") (i18nCell MsgInterfaceSubtype) $ tCell ( textCell . transactionInterfaceSubtype) + , sortable (Just "info") (i18nCell MsgSystemMessageContent) $ tCellErr ( textCell . transactionInterfaceInfo) + ] + dbtSorting = mconcat + [ singletonMap "time" $ SortColumn (E.^. TransactionLogTime) + , singletonMap "status" $ SortColumn (\r -> r E.^. TransactionLogTime E.->>. "interface-success") + , singletonMap "subtype" $ SortColumn (\r -> r E.^. TransactionLogTime E.->>. "interface-subtype") + , singletonMap "info" $ SortColumn (\r -> r E.^. TransactionLogTime E.->>. "interface-info" ) + ] + dbtFilter = mempty + dbtFilterUI = mempty + + dbtStyle = def + dbtParams = def + dbtCsvEncode = noCsvEncode + dbtCsvDecode = Nothing + dbtExtraReps = [] + validator = def & defaultSorting [ SortDescBy "time" ] + tbl <- runDB $ dbTableDB' validator logDBTable + siteLayoutMsg MsgMenuPrintLog $ do + setTitleI MsgMenuPrintLog + [whamlet|^{tbl}|] diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index e0a12e0b1..3a0103c58 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -70,6 +70,9 @@ data SettingsForm = SettingsForm , stgPrefersPostal :: Bool , stgPostAddress :: Maybe StoredMarkup + , stgTelephone :: Maybe Text + , stgMobile :: Maybe Text + , stgExamOfficeSettings :: ExamOfficeSettings , stgSchools :: Set SchoolId , stgNotificationSettings :: NotificationSettings @@ -129,9 +132,12 @@ makeSettingForm template html = do <*> apopt checkBoxField (fslI MsgShowSex & setTooltip MsgShowSexTip) (stgShowSex <$> template) <* aformSection MsgFormNotifications - <*> aopt (textField & cfStrip) (fslI MsgPDFPassword & setTooltip MsgPDFPasswordTip) (stgPinPassword <$> template) + <*> aopt (textField & cfStrip) (fslI MsgPDFPassword & setTooltip MsgPDFPasswordTip) (stgPinPassword <$> template) <*> apopt checkBoxField (fslI MsgPrefersPostalExp & setTooltip MsgPostalTip) (stgPrefersPostal <$> template) - <*> aopt htmlField (fslI MsgPostAddress & setTooltip MsgPostAddressTip) (stgPostAddress <$> template) + <*> aopt htmlField (fslI MsgPostAddress & setTooltip MsgPostAddressTip) (stgPostAddress <$> template) + + <*> aopt (textField & cfStrip) (fslI MsgUserTelephone) (stgTelephone <$> template) + <*> aopt (textField & cfStrip) (fslI MsgUserMobile ) (stgMobile <$> template) <*> examOfficeForm (stgExamOfficeSettings <$> template) <*> schoolsForm (stgSchools <$> template) @@ -362,14 +368,14 @@ validateSettings User{..} = do validEmail' userDisplayEmail' userPostAddress' <- use _stgPostAddress - let postalNotSet = isNothing userPostAddress' + let postalNotSet = isNothing userPostAddress' -- TODO $ canonical userPostAddress' postalIsValid = validPostAddress userPostAddress' guardValidation MsgUserPostalInvalid $ postalNotSet || postalIsValid userPrefersPostal' <- use _stgPrefersPostal guardValidation MsgUserPrefersPostalInvalid $ - not $ userPrefersPostal' && (postalNotSet || isJust userCompanyDepartment) + not $ userPrefersPostal' && postalNotSet && isNothing userCompanyDepartment userPinPassword' <- use _stgPinPassword let pinBad = validCmdArgument =<< userPinPassword' @@ -439,6 +445,8 @@ serveProfileR (uid, user@User{..}) = do , stgPinPassword = userPinPassword , stgPostAddress = userPostAddress , stgPrefersPostal = userPrefersPostal + , stgTelephone = userTelephone + , stgMobile = userMobile , stgExamOfficeSettings = ExamOfficeSettings { eosettingsGetSynced = userExamOfficeGetSynced , eosettingsGetLabels = userExamOfficeGetLabels @@ -467,9 +475,11 @@ serveProfileR (uid, user@User{..}) = do , UserWarningDays =. stgWarningDays , UserNotificationSettings =. stgNotificationSettings , UserShowSex =. stgShowSex - , UserPinPassword =. stgPinPassword - , UserPostAddress =. stgPostAddress + , UserPinPassword =. (stgPinPassword & canonical) + , UserPostAddress =. (stgPostAddress & canonical) , UserPrefersPostal =. stgPrefersPostal + , UserTelephone =. (stgTelephone & canonical) + , UserMobile =. (stgMobile & canonical) , UserExamOfficeGetSynced =. (stgExamOfficeSettings & eosettingsGetSynced) , UserExamOfficeGetLabels =. (stgExamOfficeSettings & eosettingsGetLabels) ] diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 65710b884..5b2c315af 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -591,7 +591,7 @@ postQualificationR sid qsh = do , let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap ] in intercalate spacerCell cs - , guardMonoid isAdmin colUserMatriclenr + , guardMonoid isAdmin $ colUserMatriclenr isAdmin -- , sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser) , sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d diff --git a/src/Handler/SAP.hs b/src/Handler/SAP.hs index be4ad973a..3414b618b 100644 --- a/src/Handler/SAP.hs +++ b/src/Handler/SAP.hs @@ -16,6 +16,7 @@ import Handler.Utils import Handler.Utils.Csv import Handler.Utils.Profile +import qualified Data.Text as Text (intercalate) -- import qualified Data.CaseInsensitive as CI import qualified Data.Csv as Csv import Database.Esqueleto.Experimental ((:&)(..)) @@ -137,10 +138,13 @@ getQualificationSAPDirectR = do csvOpts = def { csvFormat = fmtOpts } csvSheetName = "fradrive_sap_" <> fdate <> ".csv" nr = length qualUsers - msg = "Qualification download file " <> csvSheetName <> " containing " <> tshow nr <> " rows" + msg = "Qualification download file " <> csvSheetName <> " containing " <> tshow nr <> " rows" + quals = Text.intercalate ", " $ nubOrd $ mapMaybe (view (_2 . E._unValue)) qualUsers $logInfoS "SAP" msg + let logInt = runDB $ logInterface "SAP" quals True (Just nr) "" addHeader "Content-Disposition" $ "attachment; filename=\"" <> csvSheetName <> "\"" - csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered + csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered <* logInt + -- direct Download see: -- https://ersocon.net/blog/2017/2/22/creating-csv-files-in-yesod diff --git a/src/Handler/Submission/Helper/ArchiveTable.hs b/src/Handler/Submission/Helper/ArchiveTable.hs index 737440df2..05062d1a1 100644 --- a/src/Handler/Submission/Helper/ArchiveTable.hs +++ b/src/Handler/Submission/Helper/ArchiveTable.hs @@ -74,7 +74,7 @@ mkSubmissionArchiveTable tid ssh csh shn showCorrection smid = do isFile' = origIsFile <|> corrIsFile in maybeCell ((,) <$> fileTitle'' <*> isFile') $ \(fileTitle', isFile) -> if | Just True <- origIsFile -> anchorCell (subDownloadLink SubmissionOriginal fileTitle') [whamlet|#{fileTitle'}|] - | otherwise -> textCell $ bool (<> "/") id isFile fileTitle' + | otherwise -> stringCell $ bool (<> "/") id isFile fileTitle' , guardOn showCorrection . sortable (toNothing "state") (i18nCell MsgTableCorState) $ \t -> case t ^? resultCorrected of Nothing -> cell mempty Just (Entity _ SubmissionFile{..}) -> tellCell (Any True) $ if diff --git a/src/Handler/Submission/List.hs b/src/Handler/Submission/List.hs index 72c17f0e5..4590b9f48 100644 --- a/src/Handler/Submission/List.hs +++ b/src/Handler/Submission/List.hs @@ -397,7 +397,7 @@ colSubmissionLink = sortable (Just "submission") (i18nCell MsgTableSubmission) $ csh = x ^. resultCourseShorthand shn = x ^. resultSheet . _entityVal . _sheetName subCID = x ^. resultCryptoID - in anchorCellC $cacheIdentHere (CSubmissionR tid ssh csh shn subCID SubShowR) (toPathPiece subCID) + in anchorCell (CSubmissionR tid ssh csh shn subCID SubShowR) (toPathPiece subCID) colSelect :: forall act h epId. (Semigroup act, Monoid act, Headedness h, Ord epId) => Colonnade h CorrectionTableData (DBCell _ (FormResult (act, DBFormResult CryptoFileNameSubmission Bool CorrectionTableData), SheetTypeSummary epId)) colSelect = dbSelect (_1 . applying _2) id $ views resultCryptoID return diff --git a/src/Handler/Tutorial/Communication.hs b/src/Handler/Tutorial/Communication.hs index ede48066a..ed5349e03 100644 --- a/src/Handler/Tutorial/Communication.hs +++ b/src/Handler/Tutorial/Communication.hs @@ -32,9 +32,10 @@ postTCommR tid ssh csh tutn = do ) return (tutData, usertuts) - + let heading = SomeMessage . prependCourseTitle tid ssh csh $ SomeMessage MsgCommTutorialHeading commR CommunicationRoute - { crHeading = SomeMessage . prependCourseTitle tid ssh csh $ SomeMessage MsgCommTutorialHeading + { crHeading = heading + , crTitle = heading , crUltDest = SomeRoute $ CTutorialR tid ssh csh tutn TCommR , crJobs = crJobsCourseCommunication cid , crTestJobs = crTestJobsCourseCommunication cid diff --git a/src/Handler/Tutorial/Users.hs b/src/Handler/Tutorial/Users.hs index 46d15e16b..973366f0a 100644 --- a/src/Handler/Tutorial/Users.hs +++ b/src/Handler/Tutorial/Users.hs @@ -71,8 +71,8 @@ postTUsersR tid ssh csh tutn = do colChoices = mconcat $ catMaybes [ pure $ dbSelect (applying _2) id (return . view (hasEntity . _entityKey)) , pure $ colUserNameModalHdr MsgTableCourseMembers ForProfileDataR - , pure colUserEmail - , pure colUserMatriclenr + , pure colUserEmail + , pure $ colUserMatriclenr isAdmin , pure $ colUserQualifications nowaday , pure $ colUserQualificationBlocked isAdmin nowaday ] diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 1133c56d8..2af62ef7d 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -100,7 +100,7 @@ postUsersR = do , sortable (Just "name") (i18nCell MsgName) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM (AdminUserR <$> encrypt uid) (nameWidget userDisplayName userSurname) - , sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \DBRow{ dbrOutput = entUsr } -> cellHasMatrikelnummerLinked entUsr + , sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \DBRow{ dbrOutput = entUsr } -> cellHasMatrikelnummerLinkedAdmin entUsr , 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 @@ -109,7 +109,7 @@ postUsersR = do return (comp E.^. CompanyShorthand, comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor) let icnSuper = toWidget $ text2markup " " <> icon IconSupervisor companies = - (\(E.Value cmpSh, E.Value cmpName, E.Value cmpSpr) -> simpleLink (citext2widget cmpName) (FirmR cmpSh) <> bool mempty icnSuper cmpSpr) <$> companies' + (\(E.Value cmpSh, E.Value cmpName, E.Value cmpSpr) -> simpleLink (citext2widget cmpName) (FirmUsersR cmpSh) <> bool mempty icnSuper cmpSpr) <$> companies' pure $ intercalate (text2widget "; ") companies -- , sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM -- (AdminUserR <$> encrypt uid) @@ -129,8 +129,9 @@ postUsersR = do (\(usr, E.Value reroutCom) -> linkUserWidget ForProfileDataR usr <> bool mempty icnReroute reroutCom) <$> supervisors' icnReroute = text2widget " " <> toWgt (icon IconLetter) pure $ mconcat supervisors - , sortable (Just "auth-ldap") (i18nCell MsgAuthMode) $ \DBRow{ dbrOutput = Entity _ User{..} } -> i18nCell userAuthentication - , sortable (Just "ldap-sync") (i18nCell MsgLdapSynced) $ \DBRow{ dbrOutput = Entity _ User{..} } -> maybe mempty dateTimeCell userLastLdapSynchronisation + , sortable (Just "last-login") (i18nCell MsgLastLogin) $ \DBRow{ dbrOutput = Entity _ User{..} } -> maybe mempty dateTimeCell userLastAuthentication + , sortable (Just "auth-ldap") (i18nCell MsgAuthMode) $ \DBRow{ dbrOutput = Entity _ User{..} } -> i18nCell userAuthentication + , sortable (Just "ldap-sync") (i18nCell MsgLdapSynced) $ \DBRow{ dbrOutput = Entity _ User{..} } -> maybe mempty dateTimeCell userLastLdapSynchronisation , flip foldMap universeF $ \function -> sortable (Just $ SortingKey $ CI.mk $ toPathPiece function) (i18nCell function) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do schools <- liftHandler . runDB . E.select . E.from $ \(school `E.InnerJoin` userFunction) -> do @@ -228,6 +229,9 @@ postUsersR = do , ( "auth-ldap" , SortColumn $ \user -> user E.^. UserAuthentication E.!=. E.val AuthLDAP ) + , ( "last-login" + , SortColumn $ \user -> user E.^. UserLastAuthentication + ) , ( "ldap-sync" , SortColumn $ \user -> user E.^. UserLastLdapSynchronisation ) diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index 2460eb65d..4648cf647 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -35,6 +35,8 @@ import Handler.Utils.Qualification as Handler.Utils import Handler.Utils.Term as Handler.Utils +-- import Handler.Utils.Concurrent as Handler.Utils -- only imported when needed + import Control.Monad.Logger @@ -146,7 +148,7 @@ redirectAlternatives = go reload :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route (HandlerSite m) -> m a reload r = getCurrentRoute >>= redirect . fromMaybe r --- | like `reload`, preserving all GET parameters +-- | like `reload` to current route, but also preserving all GET parameters, using the current route, if known reloadKeepGetParams :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route (HandlerSite m) -> m a reloadKeepGetParams r = liftHandler $ do getps <- reqGetParams <$> getRequest @@ -155,7 +157,7 @@ reloadKeepGetParams r = liftHandler $ do -- RECALL: redirect GET parameters are used like so: -- redirect (UsersR, [("users-user-company","fraport")]) redirect (route, getps) --- | redirect preserving all GET parameters +-- | like `reloadKeepGetParams`, but always leading to the specific route instead of the current route redirectKeepGetParams :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route (HandlerSite m) -> m a redirectKeepGetParams route = liftHandler $ do getps <- reqGetParams <$> getRequest diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index ce86e627d..42275f139 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -494,7 +494,7 @@ upsertAvsUserById api = do whenIsJust pinCard $ \pCard -> -- update pin, but only if it was unset or set to the value of an old card unlessM (exists [UserAvsCardCardNo ==. getFullCardNo pCard]) $ do let oldPins = Just . personCard2pin . userAvsCardCard . entityVal <$> oldCards - updateWhere [UserId ==. uid, UserPinPassword !=. userPin, UserPinPassword <-. Nothing:oldPins] + updateWhere [UserId ==. uid, UserPinPassword !=. userPin, UserPinPassword <-. oldPins] -- check for old pin ensures that unset/manually set passwords remain unchanged [UserPinPassword =. userPin] insert_ $ UserAvsCard api (getFullCardNo pCard) pCard now upsertUserCompany uid mbCompany userFirmAddr diff --git a/src/Handler/Utils/Communication.hs b/src/Handler/Utils/Communication.hs index 893b22d14..3783ba0aa 100644 --- a/src/Handler/Utils/Communication.hs +++ b/src/Handler/Utils/Communication.hs @@ -15,6 +15,7 @@ module Handler.Utils.Communication import Import import Handler.Utils +import Handler.Utils.Users import Jobs.Queue @@ -32,7 +33,7 @@ data RecipientGroup = RGCourseParticipants | RGCourseLecturers | RGCourseCorrect | RGTutorialParticipants CryptoUUIDTutorial | RGExamRegistered CryptoUUIDExam | RGSheetSubmittor CryptoUUIDSheet - | RGFirmSupervisor CompanyShorthand | RGFirmEmployees CompanyShorthand + | RGFirmSupervisor CompanyShorthand | RGFirmEmployees CompanyShorthand | RGFirmIndependent deriving (Eq, Ord, Read, Show, Generic) instance LowerBounded RecipientGroup where @@ -80,6 +81,7 @@ data CommunicationRoute = CommunicationRoute , crRecipientAuth :: Maybe (UserId -> DB AuthResult) -- ^ Only resolve userids given as GET-Parameter if they fulfil this criterion , crJobs, crTestJobs :: Communication -> ConduitT () Job (YesodDB UniWorX) () , crHeading :: SomeMessage UniWorX + , crTitle :: SomeMessage UniWorX , crUltDest :: SomeRoute UniWorX } @@ -94,148 +96,154 @@ makeLenses_ ''Communication crJobsCourseCommunication, crTestJobsCourseCommunication :: CourseId -> Communication -> ConduitT () Job (YesodDB UniWorX) () crJobsCourseCommunication jCourse Communication{..} = do jSender <- requireAuthId - let jMailContent = cContent - allRecipients = Set.toList $ Set.insert (Right jSender) cRecipients jMailObjectUUID <- liftIO getRandom - jAllRecipientAddresses <- lift . fmap Set.fromList . forM allRecipients $ \case - Left email -> return . Address Nothing $ CI.original email - Right rid -> userAddress <$> getJust rid - forM_ allRecipients $ \jRecipientEmail -> - yield JobSendCourseCommunication{..} + let jMailContent = cContent + (rawReceiverMails, rawReceiverIds) = setPartitionEithers cRecipients + adrReceiverMails = Set.map (Address Nothing . CI.original) rawReceiverMails + netReceiverAddresses <- lift $ do + netReceiverIds <- getReceiversFor $ jSender : Set.toList rawReceiverIds -- ensure supervisors get only one email + (userAddress . entityVal) <<$>> selectList [UserId <-. netReceiverIds] [] + -- let jAllRecipientAddresses = Set.fromList netReceiverAddresses <> adrReceiverMails + let jAllRecipientAddresses = Set.map getAddress (Set.fromList (AddressEqIgnoreName <$> netReceiverAddresses) <> Set.map AddressEqIgnoreName adrReceiverMails) + forM_ jAllRecipientAddresses $ \raddr -> + yield JobSendCourseCommunication{jRecipientEmail = Left $ CI.mk $ addressEmail raddr, ..} -- using Left UserMail ensures that no further reroutes are used, thus supervised supervisors also receive an email + crTestJobsCourseCommunication jCourse comm = do jSender <- requireAuthId - MsgRenderer mr <- getMsgRenderer let comm' = comm & _cContent . _ccSubject %~ Just . mr . MsgCommCourseTestSubject . fromMaybe (mr MsgUtilCommCourseSubject) crJobsCourseCommunication jCourse comm' .| C.filter ((== Right jSender) . jRecipientEmail) -crJobsFirmCommunication :: Maybe CompanyShorthand -> Communication -> ConduitT () Job (YesodDB UniWorX) () -crJobsFirmCommunication jCompany Communication{..} = do +crJobsFirmCommunication, crTestFirmCommunication :: Companies -> Communication -> ConduitT () Job (YesodDB UniWorX) () +crJobsFirmCommunication jCompanies Communication{..} = do jSender <- requireAuthId - let jMailContent = cContent - allRecipients = Set.toList $ Set.insert (Right jSender) cRecipients jMailObjectUUID <- liftIO getRandom - jAllRecipientAddresses <- lift . fmap Set.fromList . forM allRecipients $ \case - Left email -> return . Address Nothing $ CI.original email - Right rid -> userAddress <$> getJust rid - forM_ allRecipients $ \jRecipientEmail -> - yield JobSendFirmCommunication{..} + let jMailContent = cContent + (rawReceiverMails, rawReceiverIds) = setPartitionEithers cRecipients + adrReceiverMails = Set.map (Address Nothing . CI.original) rawReceiverMails + netReceiverAddresses <- lift $ do + netReceiverIds <- getReceiversFor $ jSender : Set.toList rawReceiverIds -- ensure supervisors get only one email + (userAddress . entityVal) <<$>> selectList [UserId <-. netReceiverIds] [] + -- let jAllRecipientAddresses = Set.fromList netReceiverAddresses <> adrReceiverMails + let jAllRecipientAddresses = Set.map getAddress (Set.fromList (AddressEqIgnoreName <$> netReceiverAddresses) <> Set.map AddressEqIgnoreName adrReceiverMails) + forM_ jAllRecipientAddresses $ \raddr -> + yield JobSendFirmCommunication{jRecipientEmail = Left $ CI.mk $ addressEmail raddr, ..} -- using Left UserMail ensures that no further reroutes are used, thus supervised supervisors also receive an email -crTestFirmCommunication :: Maybe CompanyShorthand -> Communication -> ConduitT () Job (YesodDB UniWorX) () -crTestFirmCommunication jCompany comm = do +crTestFirmCommunication jCompanies comm = do jSender <- requireAuthId MsgRenderer mr <- getMsgRenderer let comm' = comm & _cContent . _ccSubject %~ Just . mr . MsgCommCourseTestSubject . fromMaybe (mr MsgUtilCommFirmSubject) - crJobsFirmCommunication jCompany comm' .| C.filter ((== Right jSender) . jRecipientEmail) + crJobsFirmCommunication jCompanies comm' .| C.filter ((== Right jSender) . jRecipientEmail) commR :: CommunicationRoute -> Handler Html commR CommunicationRoute{..} = do - cUser <- maybeAuth - - MsgRenderer mr <- getMsgRenderer - mbCurrentRoute <- getCurrentRoute - - (suggestedRecipients, chosenRecipients) <- runDB $ do - suggestedUsers <- for crRecipients $ \(_,user) -> E.select user - let suggested = zip (view _1 <$> crRecipients) suggestedUsers - - let - decrypt' :: CryptoUUIDUser -> DB (Maybe (Entity User)) + let decrypt' :: CryptoUUIDUser -> DB (Maybe (Entity User)) decrypt' cID = do uid <- decrypt cID whenIsJust crRecipientAuth $ guardAuthResult <=< ($ uid) - getEntity uid - - chosen' <- fmap (maybe id cons cUser . catMaybes) $ mapM decrypt' =<< lookupGlobalGetParams GetRecipient - - return (suggested, chosen') + getEntity uid + cUser <- maybeAuth + (chosenRecipients, suggestedRecipients) <- runDB $ (,) + <$> (maybe id cons cUser . catMaybes <$> (mapM decrypt' =<< lookupGlobalGetParams GetRecipient)) + <*> (filter (notNull . snd) <$> for crRecipients (\(grp,usrQry) -> (grp,) <$> E.select usrQry)) + $logWarnS "COMM" ("Communication handlerwith (sugg:" <> tshow (length suggestedRecipients) <> ", chosen:" <> tshow (length chosenRecipients) <> ")") + MsgRenderer mr <- getMsgRenderer + mbCurrentRoute <- getCurrentRoute + globalCC <- getsYesod $ view _appCommunicationGlobalCC + let - lookupUser :: UserId -> User - lookupUser lId - = entityVal . unsafeHead . filter ((== lId) . entityKey) $ concatMap (view _2) suggestedRecipients ++ chosenRecipients - - let chosenRecipients' = Map.fromList $ - [ ( (BoundedPosition $ RecipientGroup g, pos) - , (Right recp, recp `elem` map entityKey chosenRecipients) + lookupUser :: UserId -> (UserDisplayName,UserSurname) + lookupUser = + let usrMap = Map.fromList $ fmap (\u -> (entityKey u, entityVal u)) $ chosenRecipients ++ concatMap (view _2) suggestedRecipients + usrNames Nothing = ("???","???") -- this case only happens during runFormPost when POST Data is present and no form is display + usrNames (Just User{userDisplayName, userSurname}) = (userDisplayName, userSurname) + in usrNames . flip Map.lookup usrMap + + chosenRecipients' = Map.fromList $ + [ ( (BoundedPosition $ RecipientGroup g, pos) + , (Right recp, recp `elem` map entityKey chosenRecipients) + ) + | (g, recps) <- suggestedRecipients + , (pos, recp) <- zip [0..] $ map entityKey recps + ] ++ + [ ( (BoundedPosition RecipientCustom, pos) + , (recp, True) + ) + | (pos, recp) <- zip [0..] + ( mcons (Left <$> globalCC) + (Right <$> Set.toList (Set.fromList (map entityKey chosenRecipients) \\ Set.fromList (concatMap (map entityKey) $ view _2 <$> suggestedRecipients))) ) - | (g, recps) <- suggestedRecipients - , (pos, recp) <- zip [0..] $ map entityKey recps - ] ++ - [ ( (BoundedPosition RecipientCustom, pos) - , (Right recp, True) - ) - | (pos, recp) <- zip [0..] . Set.toList $ Set.fromList (map entityKey chosenRecipients) \\ Set.fromList (concatMap (map entityKey) $ view _2 <$> suggestedRecipients) - ] - activeCategories = map RecipientGroup (view _1 <$> suggestedRecipients) `snoc` RecipientCustom + ] + activeCategories = map RecipientGroup (view _1 <$> suggestedRecipients) `snoc` RecipientCustom - let recipientAForm :: AForm Handler (Set (Either UserEmail UserId)) - recipientAForm = postProcess <$> massInputA MassInput{..} (fslI MsgCommRecipients & setTooltip MsgCommRecipientsTip) True (Just chosenRecipients') - where - miAdd pos@(BoundedPosition RecipientCustom, 0) dim@1 liveliness nudge submitView = guardOn (miAllowAdd pos dim liveliness) $ \csrf -> do - (addRes, addView) <- mpreq (multiUserField True Nothing) (fslpI MsgUtilEMail (mr MsgUtilEMail) & setTooltip MsgUtilMultiEmailFieldTip & addName (nudge "email")) Nothing - let - addRes' = addRes <&> \nEmails ((Map.elems &&& maybe 0 (succ . snd . fst) . Map.lookupMax) . Map.filterWithKey (\(BoundedPosition c, _) _ -> c == RecipientCustom) -> (oEmails, kStart)) -> FormSuccess . Map.fromList . zip (map (BoundedPosition RecipientCustom, ) [kStart..]) . Set.toList $ nEmails `Set.difference` Set.fromList oEmails - return (addRes', $(widgetFile "widgets/communication/recipientAdd")) - miAdd _ _ _ _ _ = Nothing - miCell _ (Left (CI.original -> email)) initRes nudge csrf = do - (tickRes, tickView) <- mpreq checkBoxField ("" & addName (nudge "tick")) $ initRes <|> Just True - return (tickRes, $(widgetFile "widgets/communication/recipientEmail")) - miCell _ (Right uid@(lookupUser -> User{..})) initRes nudge csrf = do - (tickRes, tickView) <- if - | fmap entityKey cUser == Just uid - -> mforced checkBoxField ("" & addName (nudge "tick")) True - | otherwise - -> mpreq checkBoxField ("" & addName (nudge "tick")) $ initRes <|> Just True - return (tickRes, $(widgetFile "widgets/communication/recipientName")) - miAllowAdd (BoundedPosition RecipientCustom, 0) 1 _ = True - miAllowAdd _ _ _ = False - miAddEmpty _ 0 _ = Set.singleton (BoundedPosition RecipientCustom, 0) - miAddEmpty _ _ _ = Set.empty - miButtonAction :: forall p . PathPiece p => p -> Maybe (SomeRoute UniWorX) - miButtonAction anchor = SomeRoute . (:#: anchor) <$> mbCurrentRoute - miLayout :: MapLiveliness (BoundedLiveliness RecipientCategory) ListLength - -> Map (BoundedPosition RecipientCategory, ListPosition) (_, FormResult Bool) - -> Map (BoundedPosition RecipientCategory, ListPosition) Widget - -> Map (BoundedPosition RecipientCategory, ListPosition) (FieldView UniWorX) - -> Map (Natural, (BoundedPosition RecipientCategory, ListPosition)) Widget - -> Widget - miLayout liveliness cState cellWdgts _delButtons addWdgts = do - checkedIdentBase <- newIdent - let checkedCategories = Set.mapMonotonic (unBoundedPosition . fst) . Set.filter (\k' -> Map.foldrWithKey (\k (_, checkState) -> (||) $ k == k' && checkState /= FormSuccess False && (checkState /= FormMissing || maybe True snd (chosenRecipients' !? k))) False cState) $ Map.keysSet cState - checkedIdent c = checkedIdentBase <> "-" <> toPathPiece c - hasContent c = not (null $ categoryIndices c) || Map.member (1, (BoundedPosition c, 0)) addWdgts - categoryIndices c = Set.filter ((== c) . unBoundedPosition . fst) $ review liveCoords liveliness - rgTutorialParticipantsCaption :: CryptoUUIDTutorial -> Widget - rgTutorialParticipantsCaption cID = do - tutId <- decrypt cID - Tutorial{..} <- liftHandler . runDBRead $ get404 tutId - i18n $ MsgRGTutorialParticipants tutorialName - rgExamRegisteredCaption :: CryptoUUIDExam -> Widget - rgExamRegisteredCaption cID = do - eId <- decrypt cID - Exam{..} <- liftHandler . runDBRead $ get404 eId - i18n $ MsgRGExamRegistered examName - rgSheetSubmittorCaption :: CryptoUUIDSheet -> Widget - rgSheetSubmittorCaption cID = do - sId <- decrypt cID - Sheet{..} <- liftHandler . runDBRead $ get404 sId - i18n $ MsgRGSheetSubmittor sheetName - $(widgetFile "widgets/communication/recipientLayout") - miDelete :: Map (BoundedPosition RecipientCategory, ListPosition) (Either UserEmail UserId) -> (BoundedPosition RecipientCategory, ListPosition) -> MaybeT (MForm Handler) (Map (BoundedPosition RecipientCategory, ListPosition) (BoundedPosition RecipientCategory, ListPosition)) - -- miDelete liveliness@(MapLiveliness lMap) (BoundedPosition RecipientCustom, delPos) = mappend (Map.fromSet id . Set.filter (\(BoundedPosition c, _) -> c /= RecipientCustom) $ review liveCoords liveliness) . fmap (BoundedPosition RecipientCustom, ) . Map.mapKeysMonotonic (BoundedPosition RecipientCustom, ) <$> miDeleteList (lMap ! BoundedPosition RecipientCustom) delPos - miDelete _ _ = mzero - miIdent :: Text - miIdent = "recipients" - postProcess :: Map (BoundedPosition RecipientCategory, ListPosition) (Either UserEmail UserId, Bool) -> Set (Either UserEmail UserId) - postProcess = Set.fromList . map fst . filter snd . Map.elems + recipientAForm :: AForm Handler (Set (Either UserEmail UserId)) + recipientAForm = postProcess <$> massInputA MassInput{..} (fslI MsgCommRecipients & setTooltip MsgCommRecipientsTip) True (Just chosenRecipients') + where + miAdd pos@(BoundedPosition RecipientCustom, 0) dim@1 liveliness nudge submitView = guardOn (miAllowAdd pos dim liveliness) $ \csrf -> do + (addRes, addView) <- mpreq (multiUserField True Nothing) (fslpI MsgUtilEMail (mr MsgUtilEMail) & setTooltip MsgUtilMultiEmailFieldTip & addName (nudge "email")) Nothing + let + addRes' = addRes <&> \nEmails ((Map.elems &&& maybe 0 (succ . snd . fst) . Map.lookupMax) . Map.filterWithKey (\(BoundedPosition c, _) _ -> c == RecipientCustom) -> (oEmails, kStart)) -> FormSuccess . Map.fromList . zip (map (BoundedPosition RecipientCustom, ) [kStart..]) . Set.toList $ nEmails `Set.difference` Set.fromList oEmails + return (addRes', $(widgetFile "widgets/communication/recipientAdd")) + miAdd _ _ _ _ _ = Nothing + miCell _ (Left (CI.original -> email)) initRes nudge csrf = do + (tickRes, tickView) <- mpreq checkBoxField ("" & addName (nudge "tick")) $ initRes <|> Just True + return (tickRes, $(widgetFile "widgets/communication/recipientEmail")) + miCell _ (Right uid@(lookupUser -> (userDisplayName, userSurname))) initRes nudge csrf = do + (tickRes, tickView) <- if + | fmap entityKey cUser == Just uid + -> mforced checkBoxField ("" & addName (nudge "tick")) True + | otherwise + -> mpreq checkBoxField ("" & addName (nudge "tick")) $ initRes <|> Just True + return (tickRes, $(widgetFile "widgets/communication/recipientName")) + miAllowAdd (BoundedPosition RecipientCustom, 0) 1 _ = True + miAllowAdd _ _ _ = False + miAddEmpty _ 0 _ = Set.singleton (BoundedPosition RecipientCustom, 0) + miAddEmpty _ _ _ = Set.empty + miButtonAction :: forall p . PathPiece p => p -> Maybe (SomeRoute UniWorX) + miButtonAction anchor = SomeRoute . (:#: anchor) <$> mbCurrentRoute + miLayout :: MapLiveliness (BoundedLiveliness RecipientCategory) ListLength + -> Map (BoundedPosition RecipientCategory, ListPosition) (_, FormResult Bool) + -> Map (BoundedPosition RecipientCategory, ListPosition) Widget + -> Map (BoundedPosition RecipientCategory, ListPosition) (FieldView UniWorX) + -> Map (Natural, (BoundedPosition RecipientCategory, ListPosition)) Widget + -> Widget + miLayout liveliness cState cellWdgts _delButtons addWdgts = do + checkedIdentBase <- newIdent + let checkedCategories = Set.mapMonotonic (unBoundedPosition . fst) . Set.filter (\k' -> Map.foldrWithKey (\k (_, checkState) -> (||) $ k == k' && checkState /= FormSuccess False && (checkState /= FormMissing || maybe True snd (chosenRecipients' !? k))) False cState) $ Map.keysSet cState + checkedIdent c = checkedIdentBase <> "-" <> toPathPiece c + hasContent c = not (null $ categoryIndices c) || Map.member (1, (BoundedPosition c, 0)) addWdgts + categoryIndices c = Set.filter ((== c) . unBoundedPosition . fst) $ review liveCoords liveliness + rgTutorialParticipantsCaption :: CryptoUUIDTutorial -> Widget + rgTutorialParticipantsCaption cID = do + tutId <- decrypt cID + Tutorial{..} <- liftHandler . runDBRead $ get404 tutId + i18n $ MsgRGTutorialParticipants tutorialName + rgExamRegisteredCaption :: CryptoUUIDExam -> Widget + rgExamRegisteredCaption cID = do + eId <- decrypt cID + Exam{..} <- liftHandler . runDBRead $ get404 eId + i18n $ MsgRGExamRegistered examName + rgSheetSubmittorCaption :: CryptoUUIDSheet -> Widget + rgSheetSubmittorCaption cID = do + sId <- decrypt cID + Sheet{..} <- liftHandler . runDBRead $ get404 sId + i18n $ MsgRGSheetSubmittor sheetName + $(widgetFile "widgets/communication/recipientLayout") + miDelete :: Map (BoundedPosition RecipientCategory, ListPosition) (Either UserEmail UserId) -> (BoundedPosition RecipientCategory, ListPosition) -> MaybeT (MForm Handler) (Map (BoundedPosition RecipientCategory, ListPosition) (BoundedPosition RecipientCategory, ListPosition)) + -- miDelete liveliness@(MapLiveliness lMap) (BoundedPosition RecipientCustom, delPos) = mappend (Map.fromSet id . Set.filter (\(BoundedPosition c, _) -> c /= RecipientCustom) $ review liveCoords liveliness) . fmap (BoundedPosition RecipientCustom, ) . Map.mapKeysMonotonic (BoundedPosition RecipientCustom, ) <$> miDeleteList (lMap ! BoundedPosition RecipientCustom) delPos + miDelete _ _ = mzero + miIdent :: Text + miIdent = "recipients" + postProcess :: Map (BoundedPosition RecipientCategory, ListPosition) (Either UserEmail UserId, Bool) -> Set (Either UserEmail UserId) + postProcess = Set.fromList . map fst . filter snd . Map.elems recipientsListMsg <- messageI Info MsgCommRecipientsList - + attachmentsMaxSize <- getsYesod $ view _appCommunicationAttachmentsMaxSize let attachmentField = genericFileField $ return FileField { fieldIdent = Nothing @@ -246,14 +254,16 @@ commR CommunicationRoute{..} = do , fieldMaxFileSize = Nothing, fieldMaxCumulativeSize = attachmentsMaxSize , fieldAllEmptyOk = True } + ((commRes,commWdgt),commEncoding) <- runFormPost . identifyForm FIDCommunication . withButtonForm' universeF . renderAForm FormStandard $ Communication <$> recipientAForm <* aformMessage recipientsListMsg <*> ( CommunicationContent <$> aopt textField (fslI MsgCommSubject & addAttr "uw-enter-as-tab" "") Nothing <*> (markupOutput <$> areq htmlField (fslI MsgCommBody) Nothing) - <*> fmap fold (aopt (convertFieldM (runConduit . (.| C.foldMap Set.singleton)) yieldMany attachmentField) (fslI MsgCommAttachments & setTooltip MsgCommAttachmentsTip) Nothing) - ) + <*> fmap fold (aopt (convertFieldM (runConduit . (.| C.foldMap Set.singleton)) yieldMany attachmentField) + (fslI MsgCommAttachments & setTooltip MsgCommAttachmentsTip) Nothing) + ) formResult commRes $ \case (comm, BtnCommunicationSend) -> do runDBJobs . runConduit $ transPipe (mapReaderT lift) (crJobs comm) .| sinkDBJobs @@ -262,15 +272,15 @@ commR CommunicationRoute{..} = do (comm, BtnCommunicationTest) -> do runDBJobs . runConduit $ transPipe (mapReaderT lift) (crTestJobs comm) .| sinkDBJobs addMessageI Info MsgCommTestSuccess - + let formWdgt = wrapForm commWdgt def { formMethod = POST , formAction = SomeRoute <$> mbCurrentRoute , formEncoding = commEncoding , formSubmit = FormNoSubmit - } + } siteLayoutMsg crHeading $ do - setTitleI crHeading + setTitleI crTitle let commTestTip = $(i18nWidgetFile "comm-test-tip") [whamlet| $newline never diff --git a/src/Handler/Utils/Concurrent.hs b/src/Handler/Utils/Concurrent.hs new file mode 100644 index 000000000..1faaff498 --- /dev/null +++ b/src/Handler/Utils/Concurrent.hs @@ -0,0 +1,38 @@ +-- SPDX-FileCopyrightText: 2024 Steffen Jost +-- +-- SPDX-License-Identifier: AGPL-3.0-or-later + +module Handler.Utils.Concurrent + ( module Handler.Utils.Concurrent + ) where + +-- NOTE: use `retrySTM` and `checkSTM` instead of `retry` or `check` + +import Import +import UnliftIO.Concurrent as Handler.Utils.Concurrent hiding (yield) + + + +-- | Run a handler action until it finishes or if it exceeds a given number of microseconds via `registerDelay` +timeoutHandler :: Int -> HandlerFor site a -> HandlerFor site (Maybe a) +timeoutHandler maxWait act = do + innerAct <- handlerToIO + (hresult, tid) <- liftIO $ do + hresult <- newTVarIO Nothing + tid <- forkIO $ do + res <- innerAct act + atomically $ writeTVar hresult $ Just res + return (hresult, tid) + res <- liftIO $ do + flag <- registerDelay maxWait + atomically $ do + out <- readTVar flag + res <- readTVar hresult + checkSTM $ out || isJust res + return res + case res of + Nothing -> liftIO $ do + killThread tid + readTVarIO hresult -- read once more after kill to ensure that any result is noticed + _ -> return res + diff --git a/src/Handler/Utils/DateTime.hs b/src/Handler/Utils/DateTime.hs index 49cc6a7ba..2b05f208f 100644 --- a/src/Handler/Utils/DateTime.hs +++ b/src/Handler/Utils/DateTime.hs @@ -93,8 +93,8 @@ toMorning = toTimeOfDay 6 0 0 toTimeOfDay :: Int -> Int -> Pico -> Day -> UTCTime toTimeOfDay todHour todMin todSec d = localTimeToUTCTZ appTZ $ LocalTime d TimeOfDay{..} -addHours :: Integer -> UTCTime -> UTCTime -addHours = addUTCTime . secondsToNominalDiffTime . fromInteger . (* 3600) +addHours :: Integral n => n -> UTCTime -> UTCTime +addHours = addUTCTime . secondsToNominalDiffTime . fromIntegral . (* 3600) instance HasLocalTime UTCTime where toLocalTime = utcToLocalTime diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 28b1b9d32..f992e76d8 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -1498,7 +1498,20 @@ boolField mkNone = radioGroupField mkNone $ do _other -> Nothing } - +-- | like `boolField` but with custom labels +boolFieldCustom :: (MonadHandler m, HandlerSite m ~ UniWorX) + => SomeMessage UniWorX -> SomeMessage UniWorX -> Maybe (SomeMessage UniWorX) -> Field m Bool +boolFieldCustom mkTrue mkFalse mkNone = radioGroupField mkNone $ do + mr <- getMessageRender + return OptionList + { olOptions = [ Option (mr mkFalse) False "false" + , Option (mr mkTrue) True "true" + ] + , olReadExternal = \case + "false" -> Just False + "true" -> Just True + _other -> Nothing + } sectionedFuncForm :: forall f k v m sec. ( TraversableWithIndex k f diff --git a/src/Handler/Utils/LMS.hs b/src/Handler/Utils/LMS.hs index 3c0aa14e7..78d6dfab8 100644 --- a/src/Handler/Utils/LMS.hs +++ b/src/Handler/Utils/LMS.hs @@ -19,8 +19,6 @@ module Handler.Utils.LMS , csvLmsLock , csvLmsResult , csvFilenameLmsUser - , csvFilenameLmsUserlist - , csvFilenameLmsResult , csvFilenameLmsReport , lmsDeletionDate , lmsUserToDelete , _lmsUserToDelete , lmsUserToDeleteExpr @@ -109,14 +107,6 @@ csvLmsResult = fromString "result" -- LmsStatus: 0=Versuche aufgebraucht, 1=Offe csvFilenameLmsUser :: MonadHandler m => QualificationShorthand -> m Text csvFilenameLmsUser = makeLmsFilename "user" --- | Filename for Userlist transmission, contains current datestamp as agreed in LMS interface V2 -csvFilenameLmsUserlist :: MonadHandler m => QualificationShorthand -> m Text -csvFilenameLmsUserlist = makeLmsFilename "userliste" - --- | Filename for Result transmission, contains current datestamp as agreed in LMS interface V1 -csvFilenameLmsResult :: MonadHandler m => QualificationShorthand -> m Text -csvFilenameLmsResult = makeLmsFilename "ergebnisse" - -- | Filename for Report transmission, combining former Userlist and Result as agreed in new LMS interface V2 csvFilenameLmsReport :: MonadHandler m => QualificationShorthand -> m Text csvFilenameLmsReport = makeLmsFilename "report" diff --git a/src/Handler/Utils/Mail.hs b/src/Handler/Utils/Mail.hs index 6a5e7be61..851928033 100644 --- a/src/Handler/Utils/Mail.hs +++ b/src/Handler/Utils/Mail.hs @@ -4,7 +4,8 @@ module Handler.Utils.Mail ( addRecipientsDB - , userAddress, userAddressFrom + , userAddress, userAddress' + , userAddressFrom , userMailT, userMailTdirect , addFileDB , addHtmlMarkdownAlternatives @@ -52,6 +53,11 @@ userAddress :: User -> Address userAddress User{userEmail, userDisplayEmail, userDisplayName} = Address (Just userDisplayName) $ CI.original $ pickValidEmail userDisplayEmail userEmail +userAddress' :: UserEmail -> UserEmail -> UserDisplayName -> Address +-- Like userAddress', but does not require a complete entity +userAddress' userEmail userDisplayEmail userDisplayName + = Address (Just userDisplayName) $ CI.original $ pickValidEmail userDisplayEmail userEmail + userAddressError :: (MonadHandler m, HandlerSite m ~ UniWorX) => User -> m (Bool, Address) userAddressError User{userEmail, userDisplayEmail, userDisplayName} | Just okEmail <- pickValidEmail' userDisplayEmail userEmail = pure (True, Address (Just userDisplayName) $ CI.original okEmail) diff --git a/src/Handler/Utils/StudyFeatures.hs b/src/Handler/Utils/StudyFeatures.hs index 1bc5baba8..8aa191153 100644 --- a/src/Handler/Utils/StudyFeatures.hs +++ b/src/Handler/Utils/StudyFeatures.hs @@ -137,7 +137,7 @@ cacheStudyFeatureRelevance fFilter = do E.on E.true E.where_ $ fFilter studyFeatures E.where_ $ isRelevantStudyFeature (E.val now) TermId term studyFeatures - return $ RelevantStudyFeatures E.<# (term E.^. TermId) E.<&> (studyFeatures E.^. StudyFeaturesId) + E.distinct $ return $ RelevantStudyFeatures E.<# (term E.^. TermId) E.<&> (studyFeatures E.^. StudyFeaturesId) ) ( \_current _excluded -> [] ) diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index cf5051ef5..3994b81f0 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -158,8 +158,8 @@ modalCell content = cell $ modal (toWidget $ hasComment True) (Right $ toWidget -- | Show Text if it is small, create modal otherwise modalCellLarge :: (IsDBTable m a, ToWidget UniWorX t, MonoFoldable t, Element t ~ Char) => t -> DBCell m a modalCellLarge content - | length content > 32 = modalCell content - | otherwise = textCell content + | length content > 32 = modalCell content + | otherwise = stringCell content markupCellLargeModal :: IsDBTable m a => StoredMarkup -> DBCell m a markupCellLargeModal mup @@ -218,7 +218,7 @@ cellHasUserLink toLink user = nWdgt = nameWidget (userEntity ^. _entityVal . _userDisplayName) (userEntity ^. _entityVal . _userSurname) in anchorCellM (toLink <$> encrypt uid) nWdgt --- | like `cellHasUserLink` but opens the user in a modal instead +-- | like `cellHasUserLink` but opens the user in a modal instead; link is only displayed if the user has sufficient rights cellHasUserModal :: (IsDBTable m c, HasEntity u User) => (CryptoUUIDUser -> Route UniWorX) -> u -> DBCell m c cellHasUserModal toLink user = let userEntity = user ^. hasEntityUser @@ -226,17 +226,61 @@ cellHasUserModal toLink user = nWdgt = nameWidget (userEntity ^. _entityVal . _userDisplayName) (userEntity ^. _entityVal . _userSurname) lWdgt = do uuid <- liftHandler $ encrypt uid - modal nWdgt (Left $ SomeRoute $ toLink uuid) + modalAccess nWdgt nWdgt False $ toLink uuid + in cell lWdgt + +-- | like `cellHasUserModal` but but always display link without prior access rights checks +cellHasUserModalAdmin :: (IsDBTable m c, HasEntity u User) => (CryptoUUIDUser -> Route UniWorX) -> u -> DBCell m c +cellHasUserModalAdmin toLink user = + let userEntity = user ^. hasEntityUser + uid = userEntity ^. _entityKey + nWdgt = nameWidget (userEntity ^. _entityVal . _userDisplayName) (userEntity ^. _entityVal . _userSurname) + lWdgt = do + uuid <- liftHandler $ encrypt uid + modal nWdgt $ Left $ SomeRoute $ toLink uuid + in cell lWdgt + +-- | like `cellHasUserModal` but with fixed route and showing an edit icon instead; link is only displayed if the user has sufficient rights +cellEditUserModal :: (IsDBTable m c, HasEntity u User) => u -> DBCell m c +cellEditUserModal user = + let userEntity = user ^. hasEntityUser + uid = userEntity ^. _entityKey + nWdgt = toWidget $ icon IconUserEdit + lWdgt = do + uuid <- liftHandler $ encrypt uid + modalAccess mempty nWdgt True $ ForProfileR uuid + in cell lWdgt + +-- | like `cellEditUserModal` but always displays the link without prior access rights checks +cellEditUserModalAdmin :: (IsDBTable m c, HasEntity u User) => u -> DBCell m c +cellEditUserModalAdmin user = + let userEntity = user ^. hasEntityUser + uid = userEntity ^. _entityKey + nWdgt = toWidget $ icon IconUserEdit + lWdgt = do + uuid <- liftHandler $ encrypt uid + modal nWdgt (Left $ SomeRoute $ ForProfileR uuid) in cell lWdgt cellHasMatrikelnummer :: (IsDBTable m a, HasUser u) => u -> DBCell m a cellHasMatrikelnummer = maybe mempty textCell . view _userMatrikelnummer -cellHasMatrikelnummerLinked :: (IsDBTable m a, HasEntity u User) => u -> DBCell m a -cellHasMatrikelnummerLinked usr +cellHasMatrikelnummerLinked :: (IsDBTable m a, HasEntity u User) => Bool -> u -> DBCell m a +cellHasMatrikelnummerLinked isAdmin usr | Just matNr <- usrEntity ^. _userMatrikelnummer = cell $ do uuid <- liftHandler $ encrypt $ usrEntity ^. _entityKey - modal (text2widget matNr) (Left $ SomeRoute $ AdminAvsUserR uuid) + if isAdmin + then modal (text2widget matNr) (Left $ SomeRoute $ AdminAvsUserR uuid) + else modalAccess mempty (text2widget matNr) False (AdminAvsUserR uuid) + | otherwise = mempty + where + usrEntity = usr ^. hasEntityUser + +cellHasMatrikelnummerLinkedAdmin :: (IsDBTable m a, HasEntity u User) => u -> DBCell m a +cellHasMatrikelnummerLinkedAdmin usr + | Just matNr <- usrEntity ^. _userMatrikelnummer = cell $ do + uuid <- liftHandler $ encrypt $ usrEntity ^. _entityKey + modal (text2widget matNr) (Left $ SomeRoute $ AdminAvsUserR uuid) | otherwise = mempty where usrEntity = usr ^. hasEntityUser @@ -314,7 +358,7 @@ courseCell Course{..} = anchorCell link name `mappend` desc companyCell :: IsDBTable m a => CompanyShorthand -> CompanyName -> Bool -> DBCell m a companyCell cid cname isSupervisor = anchorCell link name where - link = FirmR cid + link = FirmUsersR cid corg = ciOriginal cname name | isSupervisor = text2markup (corg <> " ") <> icon IconSupervisor @@ -354,7 +398,7 @@ qualificationValidUntilCell' mbToLink d qb qu = cell $ case mbToLink of Nothing -> headWgt <> dateWgt Just toLink -> do uuid <- liftHandler $ encrypt $ qu ^. hasQualificationUser . _qualificationUserUser - let modalWgt = modal dateWgt (Left $ SomeRoute $ toLink uuid) + let modalWgt = modalAccess dateWgt dateWgt False $ toLink uuid headWgt <> modalWgt where dateWgt = formatTimeW SelFormatDate (qu ^. hasQualificationUser . _qualificationUserValidUntil) @@ -375,7 +419,8 @@ qualificationValidReasonCell' mbToLink showReason d qb qu = ic <> foldMap blc qb dc tstamp | Just toLink <- mbToLink = cell $ do uuid <- liftHandler $ encrypt uid - modal (formatTimeW SelFormatDate tstamp) (Left $ SomeRoute $ toLink uuid) + let dWgt = formatTimeW SelFormatDate tstamp + modalAccess dWgt dWgt False $ toLink uuid -- anchorCellM (toLink <$> encrypt uid) | otherwise = dateCell tstamp uid = qu ^. hasQualificationUser . _qualificationUserUser @@ -393,7 +438,8 @@ qualificationValidReasonCell'' mbToLink showReason d qb qu extValid = ic <> icEr dc tstamp | Just toLink <- mbToLink = cell $ do uuid <- liftHandler $ encrypt uid - modal (formatTimeW SelFormatDate tstamp) (Left $ SomeRoute $ toLink uuid) + let dWgt = formatTimeW SelFormatDate tstamp + modalAccess dWgt dWgt False $ toLink uuid -- anchorCellM (toLink <$> encrypt uid) | otherwise = dateCell tstamp uid = qu ^. hasQualificationUser . _qualificationUserUser @@ -453,7 +499,14 @@ avsPersonNoCell = numCell . view _userAvsNoPerson avsPersonNoLinkedCell :: (IsDBTable m c, HasUserAvs a) => a -> DBCell m c avsPersonNoLinkedCell a = cell $ do uuid <- liftHandler $ encrypt $ a ^. _userAvsUser - modal (toWgt $ toMessage $ a ^. _userAvsNoPerson) (Left $ SomeRoute $ AdminAvsUserR uuid) + let nWgt = toWgt $ toMessage $ a ^. _userAvsNoPerson + modalAccess nWgt nWgt False $ AdminAvsUserR uuid + +avsPersonNoLinkedCellAdmin :: (IsDBTable m c, HasUserAvs a) => a -> DBCell m c +avsPersonNoLinkedCellAdmin a = cell $ do + uuid <- liftHandler $ encrypt $ a ^. _userAvsUser + let nWgt = toWgt $ toMessage $ a ^. _userAvsNoPerson + modal nWgt (Left $ SomeRoute $ AdminAvsUserR uuid) avsPersonCardCell :: (IsDBTable m c) => Set AvsDataPersonCard -> DBCell m c avsPersonCardCell cards = wgtCell diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs index 6184d1314..c0f768e99 100644 --- a/src/Handler/Utils/Table/Columns.hs +++ b/src/Handler/Utils/Table/Columns.hs @@ -336,6 +336,10 @@ colUserNameLinkHdr colHeader userLink = sortable (Just "user-name") (i18nCell co colUserNameModalHdr :: (IsDBTable m c, HasEntity a User, RenderMessage UniWorX msg) => msg -> (CryptoUUIDUser -> Route UniWorX) -> Colonnade Sortable a (DBCell m c) colUserNameModalHdr colHeader userLink = sortable (Just "user-name") (i18nCell colHeader) (cellHasUserModal userLink) +-- | like `colUserNameModalHdr` but without checking access rights before displaying the link (no risk, but non-admins may see links that are unusable for them) +colUserNameModalHdrAdmin :: (IsDBTable m c, HasEntity a User, RenderMessage UniWorX msg) => msg -> (CryptoUUIDUser -> Route UniWorX) -> Colonnade Sortable a (DBCell m c) +colUserNameModalHdrAdmin colHeader userLink = sortable (Just "user-name") (i18nCell colHeader) (cellHasUserModalAdmin userLink) + -- | Intended to work with @nameWidget@, showing highlighter Surname within Displayname sortUserName :: IsString a => (t -> E.SqlExpr (Entity User)) -> (a, SortColumn t r') sortUserName = ("user-name",) . sortUserNameBare @@ -442,8 +446,8 @@ fltrUserMatriculationUI :: DBFilterUI fltrUserMatriculationUI mPrev = prismAForm (singletonFilter "user-matriculation") mPrev $ aopt textField (fslI MsgTableUserMatriculation) -colUserMatriclenr :: (IsDBTable m c, HasEntity a User) => Colonnade Sortable a (DBCell m c) -colUserMatriclenr = sortable (Just "user-matriclenumber") (i18nCell MsgTableMatrikelNr) cellHasMatrikelnummerLinked +colUserMatriclenr :: (IsDBTable m c, HasEntity a User) => Bool -> Colonnade Sortable a (DBCell m c) +colUserMatriclenr isAdmin = sortable (Just "user-matriclenumber") (i18nCell MsgTableMatrikelNr) $ cellHasMatrikelnummerLinked isAdmin sortUserMatriclenr :: IsString d => (t -> E.SqlExpr (Entity User)) -> (d, SortColumn t r') sortUserMatriclenr queryUser = ("user-matriclenumber", SortColumn $ queryUser >>> (E.^. UserMatrikelnummer)) diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 2e44c6323..0bca321ac 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -37,7 +37,7 @@ module Handler.Utils.Table.Pagination , dbtProjFilteredPostId, dbtProjFilteredPostSimple , noCsvEncode, simpleCsvEncode, simpleCsvEncodeM , withCsvExtraRep - , singletonFilter + , singletonFilter, multiFilter , DBParams(..) , cellAttrs, cellContents , addCellClass @@ -647,6 +647,13 @@ singletonFilter key = prism' fromInner (fmap Just . fromOuter) fromInner = maybe Map.empty $ Map.singleton key . pure fromOuter = Map.lookup key >=> listToMaybe +multiFilter :: Ord k => k -> Prism' (Map k [v]) (Maybe [v]) +-- ^ for use with @prismAForm@ +multiFilter key = prism' fromInner fromOuter + where + -- prism' :: (Maybe [v] -> (Map k [v])) -> ((Map k [v]) -> Maybe (Maybe [v])) -> Prism' (Map k [v]) (Maybe [v]) + fromInner = maybe Map.empty (Map.singleton key) + fromOuter = Just . Map.lookup key data DBTCsvEncode r' k' csv = forall exportData filename sheetName. ( ToNamedRecord csv, CsvColumnsExplained csv @@ -762,7 +769,7 @@ dbtProjFilteredPostId :: forall fs 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 +-- | Kombination aus `dbtProjFilteredPostId` und `dbtProjSimple`, d.h. Ergebniszeilen in Haskell transformieren und filtern dbtProjFilteredPostSimple :: forall fs r r' r''. ( fs ~ DBTProjFilterPost r', DBRow r'' ~ r' ) => (r -> DB r'') @@ -1704,9 +1711,11 @@ cell wgt = dbCell # ([], return wgt) wgtCell :: (IsDBTable m a, ToWidget UniWorX wgt) => wgt -> DBCell m a wgtCell = cell . toWidget -textCell, stringCell :: (MonoFoldable msg, Element msg ~ Char, IsDBTable m a) => msg -> DBCell m a -textCell = cell . toWidget . (pack :: String -> Text) . otoList -stringCell = textCell +textCell :: (IsDBTable m a) => Text -> DBCell m a +textCell = wgtCell + +stringCell :: (MonoFoldable msg, Element msg ~ Char, IsDBTable m a) => msg -> DBCell m a +stringCell = wgtCell . (pack :: String -> Text) . otoList i18nCell :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a i18nCell msg = cell $ do @@ -1716,6 +1725,7 @@ i18nCell msg = cell $ do cellTooltip :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a -> DBCell m a cellTooltip = cellTooltipIcon Nothing +-- note that you can also use `cellTooltip` with `SomeMessages`, which uses ' ' for separation only cellTooltips :: (RenderMessage UniWorX msg, IsDBTable m a) => [msg] -> DBCell m a -> DBCell m a cellTooltips msgs = cellTooltipWgt Nothing [whamlet| $forall msg <- msgs diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index fb19f07a7..e281c7fcf 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -1,7 +1,9 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later +{-# LANGUAGE TypeApplications #-} + -- NOTE: Also see Handler.Utils.Profile for similar utilities module Handler.Utils.Users ( computeUserAuthenticationDigest @@ -17,7 +19,7 @@ module Handler.Utils.Users , getEmailAddress , getPostalAddress, getPostalPreferenceAndAddress , abbrvName - , getReceivers + , getReceivers, getReceiversFor , getSupervisees ) where @@ -38,7 +40,9 @@ import qualified Data.Set as Set -- import qualified Data.List as List import qualified Data.CaseInsensitive as CI -import qualified Database.Esqueleto.Legacy as E +import Database.Esqueleto.Experimental ((:&)(..)) +import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma +import qualified Database.Esqueleto.Legacy as EL (on,from) import qualified Database.Esqueleto.PostgreSQL as E import qualified Database.Esqueleto.Utils as E @@ -111,6 +115,14 @@ getReceivers uid = do then directResult else return (underling, receivers, uid `elem` (entityKey <$> receivers)) +-- | For user with mailTdirect, since this query will also return supervisors that have reroute supervisors themselves, who would then receive multiple duplicates +getReceiversFor :: (MonoFoldable mono, UserId ~ Element mono) => mono -> DB [UserId] +getReceiversFor uids = (E.unValue <<$>>) $ E.select $ E.distinct $ do + usr :& spr <- E.from $ E.table @User `E.leftJoin` E.table @UserSupervisor + `E.on` (\(usr :& spr) -> usr E.^. UserId E.=?. spr E.?. UserSupervisorUser E.&&. E.isTrue (spr E.?. UserSupervisorRerouteNotifications)) + E.where_ $ usr E.^. UserId `E.in_` E.vals uids + return $ E.coalesceDefault [spr E.?. UserSupervisorSupervisor] $ usr E.^. UserId + -- | return underlings for currently logged in user getSupervisees :: DB (Set UserId) getSupervisees = do @@ -177,7 +189,7 @@ guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria) containsAsSet x y = E.and . map (\y' -> x `E.hasInfix` E.val y') $ asWords y - toSql user pl = bool id E.not_ (is _PLNegated pl) $ case pl ^. _plVar of + toSql user pl = bool id E.not__ (is _PLNegated pl) $ case pl ^. _plVar of GuessUserMatrikelnummer userMatriculation' -> user E.^. UserMatrikelnummer E.==. E.val (Just userMatriculation') GuessUserEduPersonPrincipalName userEPPN' -> user E.^. UserLdapPrimaryKey E.==. E.val (Just userEPPN') GuessUserDisplayName userDisplayName' -> user E.^. UserDisplayName `containsAsSet` userDisplayName' @@ -185,7 +197,7 @@ guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria) GuessUserFirstName userFirstName' -> user E.^. UserFirstName `containsAsSet` userFirstName' go didLdap = do - let retrieveUsers = E.select . E.from $ \user -> do + let retrieveUsers = E.select . EL.from $ \user -> do E.where_ . E.or $ map (E.and . map (toSql user)) criteria when (is _Just mQueryLimit) $ (E.limit . fromJust) mQueryLimit return user @@ -307,7 +319,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.insertSelectWithConflict UniqueCourseFavourite - (E.from $ \courseFavourite -> do + (EL.from $ \courseFavourite -> do E.where_ $ courseFavourite E.^. CourseFavouriteUser E.==. E.val oldUserId return $ CourseFavourite E.<# E.val newUserId @@ -320,7 +332,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.insertSelectWithConflict UniqueCourseNoFavourite - (E.from $ \courseNoFavourite -> do + (EL.from $ \courseNoFavourite -> do E.where_ $ courseNoFavourite E.^. CourseNoFavouriteUser E.==. E.val oldUserId return $ CourseNoFavourite E.<# E.val newUserId @@ -331,7 +343,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.insertSelectWithConflict UniqueExamOfficeField - (E.from $ \examOfficeField -> do + (EL.from $ \examOfficeField -> do E.where_ $ examOfficeField E.^. ExamOfficeFieldOffice E.==. E.val oldUserId return $ ExamOfficeField E.<# E.val newUserId @@ -343,7 +355,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.insertSelectWithConflict UniqueExamOfficeUser - (E.from $ \examOfficeUser -> do + (EL.from $ \examOfficeUser -> do E.where_ $ examOfficeUser E.^. ExamOfficeUserOffice E.==. E.val oldUserId return $ ExamOfficeUser E.<# E.val newUserId @@ -353,7 +365,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do deleteWhere [ ExamOfficeUserOffice ==. oldUserId ] E.insertSelectWithConflict UniqueExamOfficeUser - (E.from $ \examOfficeUser -> do + (EL.from $ \examOfficeUser -> do E.where_ $ examOfficeUser E.^. ExamOfficeUserUser E.==. E.val oldUserId return $ ExamOfficeUser E.<# (examOfficeUser E.^. ExamOfficeUserOffice) @@ -362,7 +374,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do (\_current _excluded -> []) deleteWhere [ ExamOfficeUserUser ==. oldUserId ] - E.insertSelect . E.from $ \examOfficeResultSynced -> do + E.insertSelect . EL.from $ \examOfficeResultSynced -> do E.where_ $ examOfficeResultSynced E.^. ExamOfficeResultSyncedOffice E.==. E.val oldUserId return $ ExamOfficeResultSynced E.<# (examOfficeResultSynced E.^. ExamOfficeResultSyncedSchool) @@ -371,7 +383,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.<&> (examOfficeResultSynced E.^. ExamOfficeResultSyncedTime) deleteWhere [ ExamOfficeResultSyncedOffice ==. oldUserId ] - E.insertSelect . E.from $ \examOfficeExternalResultSynced -> do + E.insertSelect . EL.from $ \examOfficeExternalResultSynced -> do E.where_ $ examOfficeExternalResultSynced E.^. ExamOfficeExternalResultSyncedOffice E.==. E.val oldUserId return $ ExamOfficeExternalResultSynced E.<# (examOfficeExternalResultSynced E.^. ExamOfficeExternalResultSyncedSchool) @@ -400,7 +412,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.insertSelectWithConflict UniqueExternalExamStaff - (E.from $ \externalExamStaff -> do + (EL.from $ \externalExamStaff -> do E.where_ $ externalExamStaff E.^. ExternalExamStaffUser E.==. E.val oldUserId return $ ExternalExamStaff E.<# E.val newUserId @@ -415,7 +427,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.insertSelectWithConflict UniqueSubmissionUser - (E.from $ \submissionUser -> do + (EL.from $ \submissionUser -> do E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val oldUserId return $ SubmissionUser E.<# E.val newUserId @@ -425,19 +437,19 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do deleteWhere [ SubmissionUserUser ==. oldUserId ] do - collisions <- E.select . E.from $ \((submissionGroupUserA `E.InnerJoin` submissionGroupA) `E.InnerJoin` (submissionGroupUserB `E.InnerJoin` submissionGroupB)) -> do - E.on $ submissionGroupB E.^. SubmissionGroupId E.==. submissionGroupUserB E.^. SubmissionGroupUserSubmissionGroup - E.on $ submissionGroupUserA E.^. SubmissionGroupUserSubmissionGroup E.!=. submissionGroupUserB E.^. SubmissionGroupUserSubmissionGroup + collisions <- E.select . EL.from $ \((submissionGroupUserA `E.InnerJoin` submissionGroupA) `E.InnerJoin` (submissionGroupUserB `E.InnerJoin` submissionGroupB)) -> do + EL.on $ submissionGroupB E.^. SubmissionGroupId E.==. submissionGroupUserB E.^. SubmissionGroupUserSubmissionGroup + EL.on $ submissionGroupUserA E.^. SubmissionGroupUserSubmissionGroup E.!=. submissionGroupUserB E.^. SubmissionGroupUserSubmissionGroup E.&&. submissionGroupUserA E.^. SubmissionGroupUserUser E.==. E.val oldUserId E.&&. submissionGroupUserB E.^. SubmissionGroupUserUser E.==. E.val newUserId - E.on $ submissionGroupA E.^. SubmissionGroupId E.==. submissionGroupUserA E.^. SubmissionGroupUserSubmissionGroup + EL.on $ submissionGroupA E.^. SubmissionGroupId E.==. submissionGroupUserA E.^. SubmissionGroupUserSubmissionGroup E.where_ $ submissionGroupA E.^. SubmissionGroupCourse E.==. submissionGroupB E.^. SubmissionGroupCourse return (submissionGroupUserA, submissionGroupUserB) forM_ collisions $ \(submissionGroupUserA, submissionGroupUserB) -> tellWarning $ UserAssimilateSubmissionGroupUserMultiple submissionGroupUserA submissionGroupUserB E.insertSelectWithConflict UniqueSubmissionGroupUser - (E.from $ \submissionGroupUser -> do + (EL.from $ \submissionGroupUser -> do E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val oldUserId return $ SubmissionGroupUser E.<# (submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup) @@ -454,7 +466,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.insertSelectWithConflict UniqueLecturer - (E.from $ \lecturer -> do + (EL.from $ \lecturer -> do E.where_ $ lecturer E.^. LecturerUser E.==. E.val oldUserId return $ Lecturer E.<# E.val newUserId @@ -466,7 +478,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.insertSelectWithConflict UniqueParticipant - (E.from $ \courseParticipant -> do + (EL.from $ \courseParticipant -> do E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val oldUserId return $ CourseParticipant E.<# (courseParticipant E.^. CourseParticipantCourse) @@ -496,7 +508,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.insertSelectWithConflict UniqueCourseUserExamOfficeOptOut - (E.from $ \examOfficeOptOut -> do + (EL.from $ \examOfficeOptOut -> do E.where_ $ examOfficeOptOut E.^. CourseUserExamOfficeOptOutUser E.==. E.val oldUserId return $ CourseUserExamOfficeOptOut E.<# (examOfficeOptOut E.^. CourseUserExamOfficeOptOutCourse) @@ -508,7 +520,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.insertSelectWithConflict UniqueUserFunction - (E.from $ \userFunction -> do + (EL.from $ \userFunction -> do E.where_ $ userFunction E.^. UserFunctionUser E.==. E.val oldUserId return $ UserFunction E.<# E.val newUserId @@ -520,7 +532,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.insertSelectWithConflict UniqueUserSystemFunction - (E.from $ \userSystemFunction -> do + (EL.from $ \userSystemFunction -> do E.where_ $ userSystemFunction E.^. UserSystemFunctionUser E.==. E.val oldUserId return $ UserSystemFunction E.<# E.val newUserId @@ -533,7 +545,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.insertSelectWithConflict UniqueUserExamOffice - (E.from $ \userExamOffice -> do + (EL.from $ \userExamOffice -> do E.where_ $ userExamOffice E.^. UserExamOfficeUser E.==. E.val oldUserId return $ UserExamOffice E.<# E.val newUserId @@ -544,7 +556,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.insertSelectWithConflict UniqueUserSchool - (E.from $ \userSchool -> do + (EL.from $ \userSchool -> do E.where_ $ userSchool E.^. UserSchoolUser E.==. E.val oldUserId return $ UserSchool E.<# E.val newUserId @@ -557,7 +569,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do updateWhere [ UserGroupMemberUser ==. oldUserId, UserGroupMemberPrimary ==. Active ] [ UserGroupMemberUser =. newUserId ] E.insertSelectWithConflict UniqueUserGroupMember - (E.from $ \userGroupMember -> do + (EL.from $ \userGroupMember -> do E.where_ $ userGroupMember E.^. UserGroupMemberUser E.==. E.val oldUserId return $ UserGroupMember E.<# (userGroupMember E.^. UserGroupMemberGroup) @@ -568,8 +580,8 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do deleteWhere [ UserGroupMemberUser ==. oldUserId ] do - collisions <- E.select . E.from $ \(examRegistrationA `E.InnerJoin` examRegistrationB) -> do - E.on $ examRegistrationA E.^. ExamRegistrationExam E.==. examRegistrationB E.^. ExamRegistrationExam + collisions <- E.select . EL.from $ \(examRegistrationA `E.InnerJoin` examRegistrationB) -> do + EL.on $ examRegistrationA E.^. ExamRegistrationExam E.==. examRegistrationB E.^. ExamRegistrationExam E.&&. examRegistrationA E.^. ExamRegistrationUser E.==. E.val oldUserId E.&&. examRegistrationB E.^. ExamRegistrationUser E.==. E.val newUserId E.where_ $ examRegistrationA E.^. ExamRegistrationOccurrence E.!=. examRegistrationB E.^. ExamRegistrationOccurrence @@ -580,7 +592,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do -> tellWarning $ UserAssimilateExamRegistrationDifferentOccurrence oldExamRegistration newExamRegistration E.insertSelectWithConflict UniqueExamRegistration - (E.from $ \examRegistration -> do + (EL.from $ \examRegistration -> do E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val oldUserId return $ ExamRegistration E.<# (examRegistration E.^. ExamRegistrationExam) @@ -592,8 +604,8 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do deleteWhere [ ExamRegistrationUser ==. oldUserId ] do - collision <- E.selectMaybe . E.from $ \(examPartResultA `E.InnerJoin` examPartResultB) -> do - E.on $ examPartResultA E.^. ExamPartResultExamPart E.==. examPartResultB E.^. ExamPartResultExamPart + collision <- E.selectMaybe . EL.from $ \(examPartResultA `E.InnerJoin` examPartResultB) -> do + EL.on $ examPartResultA E.^. ExamPartResultExamPart E.==. examPartResultB E.^. ExamPartResultExamPart E.&&. examPartResultA E.^. ExamPartResultUser E.==. E.val oldUserId E.&&. examPartResultB E.^. ExamPartResultUser E.==. E.val newUserId E.where_ $ examPartResultA E.^. ExamPartResultResult E.!=. examPartResultB E.^. ExamPartResultResult @@ -602,7 +614,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do -> tellError $ UserAssimilateExamPartResultDifferentResult oldExamPartResult newExamPartResult E.insertSelectWithConflict UniqueExamPartResult - (E.from $ \examPartResult -> do + (EL.from $ \examPartResult -> do E.where_ $ examPartResult E.^. ExamPartResultUser E.==. E.val oldUserId return $ ExamPartResult E.<# (examPartResult E.^. ExamPartResultExamPart) @@ -614,8 +626,8 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do deleteWhere [ ExamPartResultUser ==. oldUserId ] do - collision <- E.selectMaybe . E.from $ \(examBonusA `E.InnerJoin` examBonusB) -> do - E.on $ examBonusA E.^. ExamBonusExam E.==. examBonusB E.^. ExamBonusExam + collision <- E.selectMaybe . EL.from $ \(examBonusA `E.InnerJoin` examBonusB) -> do + EL.on $ examBonusA E.^. ExamBonusExam E.==. examBonusB E.^. ExamBonusExam E.&&. examBonusA E.^. ExamBonusUser E.==. E.val oldUserId E.&&. examBonusB E.^. ExamBonusUser E.==. E.val newUserId E.where_ $ examBonusA E.^. ExamBonusBonus E.!=. examBonusB E.^. ExamBonusBonus @@ -624,7 +636,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do -> tellError $ UserAssimilateExamBonusDifferentBonus oldExamBonus newExamBonus E.insertSelectWithConflict UniqueExamBonus - (E.from $ \examBonus -> do + (EL.from $ \examBonus -> do E.where_ $ examBonus E.^. ExamBonusUser E.==. E.val oldUserId return $ ExamBonus E.<# (examBonus E.^. ExamBonusExam) @@ -657,8 +669,8 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do Entity newECId _ <- upsert examCorrector{ examCorrectorUser = newUserId } [] E.insertSelectWithConflict UniqueExamPartCorrector - (E.from $ \(examPartCorrector `E.InnerJoin` examCorrector') -> do - E.on $ examCorrector' E.^. ExamCorrectorId E.==. examPartCorrector E.^. ExamPartCorrectorCorrector + (EL.from $ \(examPartCorrector `E.InnerJoin` examCorrector') -> do + EL.on $ examCorrector' E.^. ExamCorrectorId E.==. examPartCorrector E.^. ExamPartCorrectorCorrector E.where_ $ examCorrector' E.^. ExamCorrectorUser E.==. E.val oldUserId E.&&. examCorrector' E.^. ExamCorrectorExam E.==. E.val (examCorrectorExam examCorrector) return $ ExamPartCorrector @@ -704,8 +716,8 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do in runConduit $ getSheetCorrectors .| C.mapM_ upsertSheetCorrector do - collision <- E.selectMaybe . E.from $ \(personalisedSheetFileA `E.InnerJoin` personalisedSheetFileB) -> do - E.on $ personalisedSheetFileA E.^. PersonalisedSheetFileSheet E.==. personalisedSheetFileB E.^. PersonalisedSheetFileSheet + collision <- E.selectMaybe . EL.from $ \(personalisedSheetFileA `E.InnerJoin` personalisedSheetFileB) -> do + EL.on $ personalisedSheetFileA E.^. PersonalisedSheetFileSheet E.==. personalisedSheetFileB E.^. PersonalisedSheetFileSheet E.&&. personalisedSheetFileA E.^. PersonalisedSheetFileType E.==. personalisedSheetFileB E.^. PersonalisedSheetFileType E.&&. personalisedSheetFileA E.^. PersonalisedSheetFileTitle E.==. personalisedSheetFileB E.^. PersonalisedSheetFileTitle E.&&. personalisedSheetFileA E.^. PersonalisedSheetFileUser E.==. E.val oldUserId @@ -716,7 +728,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do -> tellError $ UserAssimilatePersonalisedSheetFileDifferentContent oldPersonalisedSheetFile newPersonalisedSheetFile E.insertSelectWithConflict UniquePersonalisedSheetFile - (E.from $ \personalisedSheetFile -> do + (EL.from $ \personalisedSheetFile -> do E.where_ $ personalisedSheetFile E.^. PersonalisedSheetFileUser E.==. E.val oldUserId return $ PersonalisedSheetFile E.<# (personalisedSheetFile E.^. PersonalisedSheetFileSheet) @@ -731,7 +743,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.insertSelectWithConflict UniqueTutor - (E.from $ \tutor -> do + (EL.from $ \tutor -> do E.where_ $ tutor E.^. TutorUser E.==. E.val oldUserId return $ Tutor E.<# (tutor E.^. TutorTutorial) @@ -740,12 +752,12 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do (\_current _excluded -> []) do - collision <- E.selectMaybe . E.from $ \((tutorialA `E.InnerJoin` tutorialParticipantA) `E.InnerJoin` (tutorialB `E.InnerJoin` tutorialParticipantB)) -> do - E.on $ tutorialParticipantB E.^. TutorialParticipantTutorial E.==. tutorialB E.^. TutorialId - E.on $ tutorialA E.^. TutorialCourse E.==. tutorialB E.^. TutorialCourse + collision <- E.selectMaybe . EL.from $ \((tutorialA `E.InnerJoin` tutorialParticipantA) `E.InnerJoin` (tutorialB `E.InnerJoin` tutorialParticipantB)) -> do + EL.on $ tutorialParticipantB E.^. TutorialParticipantTutorial E.==. tutorialB E.^. TutorialId + EL.on $ tutorialA E.^. TutorialCourse E.==. tutorialB E.^. TutorialCourse E.&&. tutorialParticipantB E.^. TutorialParticipantUser E.==. E.val newUserId E.&&. tutorialParticipantA E.^. TutorialParticipantUser E.==. E.val oldUserId - E.on $ tutorialParticipantA E.^. TutorialParticipantTutorial E.==. tutorialA E.^. TutorialId + EL.on $ tutorialParticipantA E.^. TutorialParticipantTutorial E.==. tutorialA E.^. TutorialId E.where_ $ tutorialA E.^. TutorialId E.!=. tutorialB E.^. TutorialId E.&&. tutorialA E.^. TutorialRegGroup E.==. tutorialB E.^. TutorialRegGroup return (tutorialParticipantA, tutorialParticipantB) @@ -753,7 +765,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do -> tellError $ UserAssimilateTutorialParticipantCollidingRegGroups tutorialUserA tutorialUserB E.insertSelectWithConflict UniqueTutorialParticipant - (E.from $ \tutorialParticipant -> do + (EL.from $ \tutorialParticipant -> do E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. E.val oldUserId return $ TutorialParticipant E.<# (tutorialParticipant E.^. TutorialParticipantTutorial) @@ -764,7 +776,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.insertSelectWithConflict UniqueSystemMessageHidden - (E.from $ \systemMessageHidden -> do + (EL.from $ \systemMessageHidden -> do E.where_ $ systemMessageHidden E.^. SystemMessageHiddenUser E.==. E.val oldUserId return $ SystemMessageHidden E.<# (systemMessageHidden E.^. SystemMessageHiddenMessage) @@ -789,7 +801,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do ] E.insertSelectWithConflict UniqueRelevantStudyFeatures - (E.from $ \relevantStudyFeatures -> do + (EL.from $ \relevantStudyFeatures -> do E.where_ $ relevantStudyFeatures E.^. RelevantStudyFeaturesStudyFeatures E.==. E.val oldSFId return $ RelevantStudyFeatures E.<# (relevantStudyFeatures E.^. RelevantStudyFeaturesTerm) @@ -815,8 +827,8 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do unless (Set.null qResolvable) $ deleteWhere [ LmsUserUser ==. oldUserId, LmsUserQualification <-. Set.toList qResolvable ] -- delete conflicting and finished LMS, which are still within auditDuration updateWhere [ LmsUserUser ==. oldUserId ] [ LmsUserUser =. newUserId ] updateWhere [ QualificationEditUser ==. oldUserId ] [ QualificationEditUser =. newUserId ] - usrQualis <- E.select $ E.from $ \(oldQual `E.LeftOuterJoin` newQual) -> do - E.on ( newQual E.?. QualificationUserQualification E.?=. oldQual E.^. QualificationUserQualification + usrQualis <- E.select $ EL.from $ \(oldQual `E.LeftOuterJoin` newQual) -> do + EL.on ( newQual E.?. QualificationUserQualification E.?=. oldQual E.^. QualificationUserQualification E.&&. newQual E.?. QualificationUserUser E.?=. E.val newUserId ) E.where_ $ oldQual E.^. QualificationUserUser E.==. E.val oldUserId @@ -835,10 +847,14 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do delete oldQKey -- deleteWhere [ QualificationUserUser ==. oldUserId ] -- no longer needed + -- PrintJobs + updateWhere [ PrintJobRecipient ==. Just oldUserId ] [ PrintJobRecipient =. Just newUserId ] + updateWhere [ PrintJobSender ==. Just oldUserId ] [ PrintJobSender =. Just newUserId ] + -- Supervision is fully merged E.insertSelectWithConflict UniqueUserSupervisor - (E.from $ \userSupervisor -> do + (EL.from $ \userSupervisor -> do E.where_ $ userSupervisor E.^. UserSupervisorSupervisor E.==. E.val oldUserId return $ UserSupervisor E.<# E.val newUserId @@ -850,7 +866,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.insertSelectWithConflict UniqueUserSupervisor - (E.from $ \userSupervisor -> do + (EL.from $ \userSupervisor -> do E.where_ $ userSupervisor E.^. UserSupervisorUser E.==. E.val oldUserId return $ UserSupervisor E.<# (userSupervisor E.^. UserSupervisorSupervisor) @@ -863,7 +879,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do -- Companies, in conflict, keep the newUser-Company as is E.insertSelectWithConflict UniqueUserCompany - (E.from $ \userCompany -> do + (EL.from $ \userCompany -> do E.where_ $ userCompany E.^. UserCompanyUser E.==. E.val oldUserId return $ UserCompany E.<# E.val newUserId diff --git a/src/Handler/Utils/Widgets.hs b/src/Handler/Utils/Widgets.hs index 23a4b3a37..1e5f6bdc2 100644 --- a/src/Handler/Utils/Widgets.hs +++ b/src/Handler/Utils/Widgets.hs @@ -123,6 +123,14 @@ editedByW fmt tm usr = do [whamlet|_{MsgUtilEditedBy usr ft}|] +-- | like `modal`, but only conditionally displays the modal link only after checking access rights. WARNING: this might be too slow for large dbTable. Use `modalAccessCheckOnClick` instead +modalAccess :: Widget -> Widget -> Bool -> Route UniWorX -> Widget +modalAccess wdgtNo wdgtYes writeAccess route = do + authOk <- liftHandler $ bool hasReadAccessTo hasWriteAccessTo writeAccess route + if authOk + then modal wdgtYes (Left $ SomeRoute route) + else wdgtNo + ---------- -- HEAT -- ---------- diff --git a/src/Jobs.hs b/src/Jobs.hs index f48922abb..b45b24b82 100644 --- a/src/Jobs.hs +++ b/src/Jobs.hs @@ -47,7 +47,7 @@ import qualified Control.Monad.Catch as Exc import Data.Time.Zones -import Control.Concurrent.STM (stateTVar, retry) +import Control.Concurrent.STM (stateTVar) import Control.Concurrent.STM.Delay import UnliftIO.Concurrent (forkIO, myThreadId, threadDelay) @@ -260,7 +260,7 @@ manageJobPool foundation@UniWorX{..} unmask = shutdownOnException $ \routeExc -> (nextVal, newQueue) <- MaybeT . lift . fmap jqDequeue $ readTVar chan lift . lift $ writeTVar chan newQueue jobWorkers' <- lift . lift $ jobWorkers <$> readTMVar appJobState - receiver <- maybe (lift $ lift retry) return =<< uniformMay jobWorkers' + receiver <- maybe (lift $ lift retrySTM) return =<< uniformMay jobWorkers' return (nextVal, receiver) whenIsJust next $ \(nextVal, receiver) -> do atomically $ readTVar receiver >>= jqInsert nextVal >>= (writeTVar receiver $!) @@ -373,8 +373,8 @@ execCrontab = do State.modify . HashMap.filterWithKey $ \k _ -> HashMap.member k crontab prevExec <- State.get case earliestJob settings prevExec crontab refT of - Nothing -> liftBase retry - Just (_, MatchNone) -> liftBase retry + Nothing -> liftBase retrySTM + Just (_, MatchNone) -> liftBase retrySTM Just x -> return (crontab, x, prevExec) do diff --git a/src/Jobs/Crontab.hs b/src/Jobs/Crontab.hs index e352758ef..72ae6a7c4 100644 --- a/src/Jobs/Crontab.hs +++ b/src/Jobs/Crontab.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-2023 Sarah Vaupel , David Mosbach , Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -392,28 +392,31 @@ determineCrontab = execWriterT $ do -- , cronNotAfter = Right . CronTimestamp . utcToLocalTimeTZ appTZ $ addUTCTime appStudyFeaturesRecacheRelevanceInterval nextIntervalTime -- } - whenIsJust appQualificationCheckHour $ \hour -> tell $ HashMap.singleton + + whenIsJust appJobLmsQualificationsEnqueueHour $ \hour -> tell $ HashMap.singleton (JobCtlQueue JobLmsQualificationsEnqueue) Cron { cronInitial = CronAsap -- time after scheduling - , cronRepeat = CronRepeatScheduled $ cronCalendarAny { cronHour = cronMatchOne hour -- cronHour = CronMatchSome (impureNonNull $ Set.fromList [3,15] ) - , cronMinute = cronMatchOne 3 + , cronRepeat = CronRepeatScheduled $ cronCalendarAny { cronDayOfWeek = CronMatchSome . impureNonNull . Set.fromList $ [1..5] + , cronHour = cronMatchOne hour -- cronHour = CronMatchSome (impureNonNull $ Set.fromList [3,15] ) + , cronMinute = cronMatchOne 2 , cronSecond = cronMatchOne 27 } - , cronRateLimit = nominalDay / 2 -- minimal time between two executions, before the second job is skipped - , cronNotAfter = Left nominalDay -- maximal delay of an execution, before it is skipped entirely + , cronRateLimit = 600 -- minimal time between two executions, before the second job is skipped + , cronNotAfter = Right CronNotScheduled -- maximal delay of an execution, before it is skipped entirely } - whenIsJust appQualificationCheckHour $ \hour -> tell $ HashMap.singleton + whenIsJust appJobLmsQualificationsDequeueHour $ \hour -> tell $ HashMap.singleton (JobCtlQueue JobLmsQualificationsDequeue) Cron { cronInitial = CronAsap -- time after scheduling - , cronRepeat = CronRepeatScheduled $ cronCalendarAny { cronHour = cronMatchOne hour -- cronHour = CronMatchSome (impureNonNull $ Set.fromList [3,15] ) - , cronMinute = cronMatchOne 33 + , cronRepeat = CronRepeatScheduled $ cronCalendarAny { cronDayOfWeek = CronMatchSome . impureNonNull . Set.fromList $ [1..5] + , cronHour = cronMatchOne hour -- cronHour = CronMatchSome (impureNonNull $ Set.fromList [3,15] ) + , cronMinute = cronMatchOne 7 , cronSecond = cronMatchOne 27 } - , cronRateLimit = nominalDay / 2 -- minimal time between two executions, before the second job is skipped - , cronNotAfter = Left nominalDay -- maximal delay of an execution, before it is skipped entirely + , cronRateLimit = 600 -- minimal time between two executions, before the second job is skipped + , cronNotAfter = Right CronNotScheduled -- maximal delay of an execution, before it is skipped entirely } let @@ -442,28 +445,26 @@ determineCrontab = execWriterT $ do ) .| C.fold collateSubmissionsByCorrector Map.empty - submissionRatedNotificationsSince <- lift $ getMigrationTime Migration20210318CrontabSubmissionRatedNotification - whenIsJust submissionRatedNotificationsSince $ \notifySince - -> let submissionsSelect = E.selectSource . E.from $ \(submission `E.InnerJoin` sheet) -> do - E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId - E.where_ $ sqlSubmissionRatingDone submission - E.&&. submission E.^. SubmissionRatingTime E.>=. E.justVal notifySince - return (submission, sheet E.^. SheetType) - submissionJobs (Entity subId Submission{..}, E.Value sType) = maybeT_ $ do - examFinishedTime <- hoist lift . for (sType ^? _examPart . from _SqlKey) $ \epId -> do - ExamPart{examPartExam} <- MaybeT . $cachedHereBinary epId $ get epId - Exam{..} <- MaybeT . $cachedHereBinary examPartExam $ get examPartExam - return examFinished - notifyTime <- hoistMaybe . nBot $ maybe NTop (max `on` NTop) examFinishedTime submissionRatingTime - tell $ HashMap.singleton - (JobCtlQueue . JobQueueNotification $ NotificationSubmissionRated subId) - Cron - { cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ notifyTime - , cronRepeat = CronRepeatNever - , cronRateLimit = appNotificationRateLimit - , cronNotAfter = Left appNotificationExpiration - } - in runConduit $ transPipe lift submissionsSelect .| C.mapM_ submissionJobs + let submissionsSelect = E.selectSource . E.from $ \(submission `E.InnerJoin` sheet) -> do + E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId + E.where_ $ sqlSubmissionRatingDone submission + E.&&. submission E.^. SubmissionRatingTime E.>=. E.justVal (toMidnight $ fromGregorian 2024 1 1) -- no submissions used in FRADrive as of this date, previously cut off by an old legacy migration + return (submission, sheet E.^. SheetType) + submissionJobs (Entity subId Submission{..}, E.Value sType) = maybeT_ $ do + examFinishedTime <- hoist lift . for (sType ^? _examPart . from _SqlKey) $ \epId -> do + ExamPart{examPartExam} <- MaybeT . $cachedHereBinary epId $ get epId + Exam{..} <- MaybeT . $cachedHereBinary examPartExam $ get examPartExam + return examFinished + notifyTime <- hoistMaybe . nBot $ maybe NTop (max `on` NTop) examFinishedTime submissionRatingTime + tell $ HashMap.singleton + (JobCtlQueue . JobQueueNotification $ NotificationSubmissionRated subId) + Cron + { cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ notifyTime + , cronRepeat = CronRepeatNever + , cronRateLimit = appNotificationRateLimit + , cronNotAfter = Left appNotificationExpiration + } + runConduit $ transPipe lift submissionsSelect .| C.mapM_ submissionJobs let examSelect = E.selectSource . E.from $ \(exam `E.InnerJoin` course `E.InnerJoin` school) -> do diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index bdf4c7ca8..136ea518e 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-23 Steffen Jost ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -10,8 +10,6 @@ module Jobs.Handler.LMS , dispatchJobLmsEnqueue, dispatchJobLmsEnqueueUser , dispatchJobLmsDequeue , dispatchJobLmsReports - , dispatchJobLmsResults - , dispatchJobLmsUserlist ) where import Import @@ -28,7 +26,7 @@ import qualified Database.Esqueleto.Utils as E import qualified Data.Set as Set -- import qualified Data.Map as Map -import qualified Data.Time.Zones as TZ +-- import qualified Data.Time.Zones as TZ import Handler.Utils.DateTime import Handler.Utils.LMS (randomLMSIdentBut, randomLMSpw, maxLmsUserIdentRetries) import Handler.Utils.Qualification @@ -119,6 +117,7 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act NotificationQualificationExpiry { nQualification = qid, nExpiry = uex } } forM_ renewalUsers (queueDBJob . usr_job) + logInterface "LMS" (qshort <> "-enq") True (Just $ length renewalUsers) "" dispatchJobLmsEnqueueUser :: QualificationId -> UserId -> JobHandler UniWorX dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act @@ -134,14 +133,11 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act ( (E.^. LmsUserIdent) <$> E.from (E.table @LmsUser ) ) -- no filter by Qid, since LmsIdents must be unique across all `E.union_` ( (E.^. LmsReportIdent) <$> E.from (E.table @LmsReport ) ) -- V2 - `E.union_` - ( (E.^. LmsResultIdent) <$> E.from (E.table @LmsResult ) ) -- V1 DEPRECATED - `E.union_` - ( (E.^. LmsUserlistIdent) <$> E.from (E.table @LmsUserlist) ) -- V1 DEPRECATED E.orderBy [E.asc lui] pure lui now <- liftIO getCurrentTime let identsInUse = Set.fromList (E.unValue <$> identsInUseVs) + uniqLmsUse = UniqueLmsQualificationUser qid uid mkLmsUser lpin lid = LmsUser { lmsUserQualification = qid , lmsUserUser = uid @@ -157,26 +153,32 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act , lmsUserEnded = Nothing , lmsUserResetTries = False , lmsUserLocked = True -- initially display locked, since it is not yet available until the first feedback - } + } -- startLmsUser :: YesodJobDB UniWorX (Maybe (Entity LmsUser)) startLmsUser = do - lpw <- randomLMSpw + lpw <- randomLMSpw maybeM (pure Nothing) (E.insertUniqueEntity . mkLmsUser lpw) (randomLMSIdentBut qprefix identsInUse) -- runMaybeT $ do -- lid <- MaybeT $ randomLMSIdentBu qprefix identsInUse -- MaybeT $ E.insertUniqueEntity $ mkLmsUser lpw lid - inserted <- untilJustMaxM maxLmsUserIdentRetries startLmsUser - case inserted of - Nothing -> do - uuid :: CryptoUUIDUser <- encrypt uid - $logErrorS "LMS" $ "Generating and inserting fresh LmsIdent failed for uuid " <> tshow uuid <> " and qid " <> tshow qid <> "!" - (Just Entity{entityKey=lkey, entityVal=LmsUser{lmsUserIdent=lid, lmsUserUser=luid, lmsUserQualification=lqid}}) -> -- lmsUser started, but not yet notified - audit $ TransactionLmsStart - { transactionQualification = lqid - , transactionLmsIdent = lid - , transactionLmsUser = luid - , transactionLmsUserKey = lkey - } + getBy uniqLmsUse >>= \case + Just Entity{entityVal=LmsUser{..}} + | isNothing lmsUserEnded, isNothing lmsUserStatus || lmsUserStatus == Just LmsSuccess -> do + uuid :: CryptoUUIDUser <- encrypt uid + $logErrorS "LMS" $ "Generating fresh LmsIdent failed for uuid " <> tshow uuid <> " and qid " <> tshow qid <> " due to LMS still existing!" + other -> do + when (isJust other) $ deleteBy uniqLmsUse + untilJustMaxM maxLmsUserIdentRetries startLmsUser >>= \case + Nothing -> do + uuid :: CryptoUUIDUser <- encrypt uid + $logErrorS "LMS" $ "Generating and inserting fresh LmsIdent failed for uuid " <> tshow uuid <> " and qid " <> tshow qid <> " for unknown reason!" + (Just Entity{entityKey=lkey, entityVal=LmsUser{lmsUserIdent=lid, lmsUserUser=luid, lmsUserQualification=lqid}}) -> -- lmsUser started, but not yet notified + audit $ TransactionLmsStart + { transactionQualification = lqid + , transactionLmsIdent = lid + , transactionLmsUser = luid + , transactionLmsUserKey = lkey + } -- purge LmsIdent after QualificationAuditDuration expired @@ -200,7 +202,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act -- E.&&. luser E.?. LmsUserQualification E.?=. E.val qid -- E.&&. E.isNothing (luser E.^. LmsUserStatus) -- E.&&. E.isNothing (luser E.^. LmsUserEnded) - E.&&. E.not_ (validQualification now quser) + E.&&. E.not__ (validQualification now quser) pure (luser E.?. LmsUserId, quser E.^. QualificationUserUser) nrBlocked <- qualificationUserBlocking qid (E.unValue . snd <$> expiredUsers) False (Just now) (Right QualificationBlockExpired) True -- essential that blocks occur only once let expiredLearners = [ luid | (E.Value (Just luid), _) <- expiredUsers ] @@ -210,7 +212,8 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act E.where_ $ E.isNothing (luser E.^. LmsUserStatus) E.&&. luser E.^. LmsUserQualification E.==. E.val qid E.&&. (luser E.^. LmsUserId) `E.in_` E.valList expiredLearners - $logInfoS "LMS" $ "Expired qualification holders " <> tshow nrBlocked <> " and expired lms users " <> tshow nrExpired <> " for qualification " <> qshort + let dequeueInfo = "Blocked qualification holders " <> tshow nrBlocked <> " out of expired lms users " <> tshow nrExpired <> " for qualification " <> qshort + $logInfoS "LMS" dequeueInfo when (quali ^. _qualificationExpiryNotification) $ do -- notifies expired and previously lms-failed drivers notifyInvalidDrivers <- E.select $ do @@ -220,7 +223,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act `E.on` (\(quser :& qblock) -> qblock E.?. QualificationUserBlockQualificationUser E.?=. quser E.^. QualificationUserId E.&&. qblock `isLatestBlockBefore` E.val now ) - E.where_ $ -- E.not_ (validQualification now quser) -- currently invalid + E.where_ $ -- E.not__ (validQualification now quser) -- currently invalid quser E.^. QualificationUserQualification E.==. E.val qid -- correct qualification E.&&. quserToNotify now quser qblock -- recently became invalid or blocked pure (quser E.^. QualificationUserUser) @@ -254,10 +257,9 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act when (numdel > 0) $ do $logInfoS "LMS" $ "Deleting " <> tshow numdel <> " LmsIdents due to audit duration expiry for qualification " <> qshort deleteWhere [LmsUserQualification ==. qid, LmsUserIdent <-. delusers] - deleteWhere [LmsUserlistQualification ==. qid, LmsUserlistIdent <-. delusers] - deleteWhere [LmsResultQualification ==. qid, LmsResultIdent <-. delusers] -- deleteWhere [LmsAuditQualification ==. qid, LmsAuditIdent <-. delusers] deleteWhere [LmsReportLogQualification ==. qid, LmsReportLogTimestamp <. auditCutoff ] + logInterface "LMS" (qshort <> "-deq") True (Just nrBlocked) (tshow nrExpired <> " expired") dispatchJobLmsReports :: QualificationId -> JobHandler UniWorX @@ -311,7 +313,8 @@ dispatchJobLmsReports qid = JobHandlerAtomic act E.&&. lreport E.^. LmsReportLock E.==. E.true ) -- B) notify all newly reported users that lms is available - let luserFltrNew luser = E.isNothing $ luser E.^. LmsUserReceived -- not seen before, just starting + let luserFltrNew luser = E.isNothing (luser E.^. LmsUserReceived) -- not seen before, just starting + E.||. E.isNothing (luser E.^. LmsUserNotified) -- a previous notification has failed notifyNewLearner (E.Value uid) = queueDBJob JobUserNotification { jRecipient = uid, jNotification = NotificationQualificationRenewal { nQualification = qid, nReminder = False } } in luserQry luserFltrNew (const $ const E.true) >>= mapM_ notifyNewLearner -- C) block qualifications for failed learners by calling qualificationUserBlocking [uids] (includes audit), notified during expiry @@ -426,120 +429,3 @@ dispatchJobLmsReports qid = JobHandlerAtomic act E.<&> E.true) repProc <- deleteWhereCount [LmsReportQualification ==. qid] $logInfoS "LMS" [st|Processed #{tshow repProc} e-learning status reports for qualification #{tshow qid}.|] - - --- DEPRECATED processes received results and lengthen qualifications, if applicable -dispatchJobLmsResults :: QualificationId -> JobHandler UniWorX -dispatchJobLmsResults qid = JobHandlerAtomic act - where - -- act :: YesodJobDB UniWorX () - act = hoist lift $ do - results <- E.select $ do - (quser :& luser :& lresult) <- E.from $ - E.table @QualificationUser -- table not needed if renewal from lms completion day is used TODO: decide! - `E.innerJoin` E.table @LmsUser - `E.on` (\(quser :& luser) -> - luser E.^. LmsUserUser E.==. quser E.^. QualificationUserUser - E.&&. luser E.^. LmsUserQualification E.==. quser E.^. QualificationUserQualification) - `E.innerJoin` E.table @LmsResult - `E.on` (\(_ :& luser :& lresult) -> - luser E.^. LmsUserIdent E.==. lresult E.^. LmsResultIdent - E.&&. luser E.^. LmsUserQualification E.==. lresult E.^. LmsResultQualification) - E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid - E.&&. luser E.^. LmsUserQualification E.==. E.val qid - -- E.&&. E.isNothing (luser E.^. LmsUserStatus) -- do not process learners already having a result WORKAROUND LMS-Bug: LMS may send blocked & success simultanesouly or within a few hours; in this case, success is the correct meaning - E.&&. E.isNothing (luser E.^. LmsUserEnded) -- do not process closed learners - 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 - -- 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) - -- && qualificationUserLastRefresh <= utctDay lmsUserStarted NOTE: not always true due to manual intervention; also renewValidQualificationUsers prevents double renewals anyway - -- newValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) qualificationUserValidUntil -- renew from old validUntil onwards - note <- if saneDate && (lmsUserStatus /= Just LmsSuccess) - then do - -- 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 - let reason_undo = Left $ "LMS Workaround undoing: " <> tshow (QualificationBlockFailedELearningBy lmsUserIdent) - ok_unblock <- qualificationUserUnblockByReason qid [qualificationUserUser] Nothing (Right $ QualificationBlockFailedELearningBy lmsUserIdent) reason_undo False -- affects audit log - when (ok_unblock > 0) ($logWarnS "LMS" [st|LMS Result: workaround triggered, unblocking #{tshow ok_unblock} e-learners for #{tshow qid}|]) - - _ok_renew <- renewValidQualificationUsers qid (Just $ Right $ QualificationRenewELearningBy lmsUserIdent) Nothing [qualificationUserUser] -- only unblocked are renewed - -- when (ok==1) $ update luid -- we end lms regardless of whether or not a regular renewal was successful, since BPol users may simultaneoysly have on-premise renewal courses and E-Learnings - - update luid - [ LmsUserStatus =. Just LmsSuccess - , LmsUserStatusDay =. Just (utctDayMidnight lmsResultSuccess) - , LmsUserReceived =. Just lmsResultTimestamp - ] - return Nothing - else do - let errmsg = [st|LMS Result: success with insane date #{tshow lmsResultSuccess} received for #{tshow lmsUserIdent} for #{tshow qid}|] - $logErrorS "LMS" errmsg - return $ Just errmsg - - audit TransactionLmsSuccess -- always log success, since this is only transmitted once - { transactionQualification = qid - , transactionLmsIdent = lmsUserIdent - , transactionLmsDay = utctDayMidnight lmsResultSuccess - , transactionLmsUser = lmsUserUser - , transactionNote = note - , transactionReceived = lmsResultTimestamp - } - delete lrid - $logInfoS "LMS" [st|Processed #{tshow (length results)} LMS results|] - - --- DEPRECATED processes received input and block qualifications, if applicable -dispatchJobLmsUserlist :: QualificationId -> JobHandler UniWorX -dispatchJobLmsUserlist qid = JobHandlerAtomic act - where - act :: YesodJobDB UniWorX () - act = whenM (exists [LmsUserlistQualification ==. qid]) $ do -- safeguard against multiple calls, which would close all learners due to first case below - now <- liftIO getCurrentTime - -- result :: [(Entity LmsUser, Entity LmsUserlist)] - results <- E.select $ do - (luser :& lulist) <- E.from $ - E.table @LmsUser `E.leftJoin` E.table @LmsUserlist - `E.on` (\(luser :& lulist) -> luser E.^. LmsUserIdent E.=?. lulist E.?. LmsUserlistIdent - E.&&. luser E.^. LmsUserQualification E.=?. lulist E.?. LmsUserlistQualification) - E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid - E.&&. E.isNothing (luser E.^. LmsUserEnded) -- do not process closed learners - return (luser, lulist) - forM_ results $ \case - (Entity luid luser, Nothing) - | isJust $ lmsUserReceived luser -- mark all previuosly reported, but now unreported users as ended (LMS deleted them as expected) - , isNothing $ lmsUserEnded luser -> - update luid [LmsUserEnded =. Just now] - | otherwise -> return () -- users likely not yet started - - (Entity luid luser, Just (Entity _lulid lulist)) -> do - let lReceived = lmsUserlistTimestamp lulist - update luid [LmsUserReceived =. Just lReceived] -- LmsUserNotified is only updated upon sending notifications - - when (isNothing $ lmsUserNotified luser) $ do -- notify users that lms is available - queueDBJob JobUserNotification - { jRecipient = lmsUserUser luser - , jNotification = NotificationQualificationRenewal { nQualification = qid, nReminder = False } - } - - let isBlocked = lmsUserlistFailed lulist - oldStatus = lmsUserStatus luser - updateStatus = isBlocked && oldStatus /= Just LmsSuccess - when updateStatus $ do - update luid [LmsUserStatus =. Just LmsBlocked, LmsUserStatusDay =. Just lReceived] - ok <- qualificationUserBlocking qid [lmsUserUser luser] False Nothing (Right QualificationBlockFailedELearning) True - when (ok /= 1) $ do - uuid :: CryptoUUIDUser <- encrypt $ lmsUserUser luser - $logWarnS "LmsUserlist" [st|Blocking by failed E-learning failed for learner #{tshow uuid} and qualification #{tshow qid}] - audit TransactionLmsBlocked - { transactionQualification = qid - , transactionLmsIdent = lmsUserIdent luser - , transactionLmsDay = lReceived - , transactionLmsUser = lmsUserUser luser - , transactionNote = Just $ "Old status was " <> tshow oldStatus - , transactionReceived = lReceived - } - delete lulid - $logInfoS "LMS" [st|Processed LMS Userlist with #{tshow (length results)} entries|] diff --git a/src/Jobs/Handler/SendCourseCommunication.hs b/src/Jobs/Handler/SendCourseCommunication.hs index fa4fbcb69..1a065726c 100644 --- a/src/Jobs/Handler/SendCourseCommunication.hs +++ b/src/Jobs/Handler/SendCourseCommunication.hs @@ -31,7 +31,7 @@ dispatchJobSendCourseCommunication jRecipientEmail jAllRecipientAddresses jCours (sender, Course{..}) <- runDB $ (,) <$> getJust jSender <*> getJust jCourse - either (\email -> mailT def . (assign _mailTo (pure . Address Nothing $ CI.original email) *>)) userMailT jRecipientEmail $ do + either (\email -> mailT def . (assign _mailTo (pure . Address Nothing $ CI.original email) *>)) userMailT jRecipientEmail $ do -- userMailT obeys reroutes, userMailT direct does not MsgRenderer mr <- getMailMsgRenderer void $ setMailObjectUUID jMailObjectUUID @@ -49,17 +49,17 @@ dispatchJobSendCourseCommunication jRecipientEmail jAllRecipientAddresses jCours dispatchJobSendFirmCommunication :: Either UserEmail UserId -> Set Address - -> Maybe CompanyShorthand + -> Companies -> UserId -> UUID -> CommunicationContent -> JobHandler UniWorX -dispatchJobSendFirmCommunication jRecipientEmail jAllRecipientAddresses _jCompany jSender jMailObjectUUID CommunicationContent{..} = JobHandlerException $ do +dispatchJobSendFirmCommunication jRecipientEmail jAllRecipientAddresses _jCompanies jSender jMailObjectUUID CommunicationContent{..} = JobHandlerException $ do -- (sender,mbComp) <- runDB $ (,) -- <$> getJust jSender -- <*> ifMaybeM jCompany Nothing get sender <- runDB $ getJust jSender - either (\email -> mailT def . (assign _mailTo (pure . Address Nothing $ CI.original email) *>)) userMailT jRecipientEmail $ do + either (\email -> mailT def . (assign _mailTo (pure . Address Nothing $ CI.original email) *>)) userMailT jRecipientEmail $ do -- userMailT obeys reroutes, userMailT direct does not MsgRenderer mr <- getMailMsgRenderer void $ setMailObjectUUID jMailObjectUUID diff --git a/src/Jobs/Handler/SendNotification/Qualification.hs b/src/Jobs/Handler/SendNotification/Qualification.hs index d5d8d595e..e169f1552 100644 --- a/src/Jobs/Handler/SendNotification/Qualification.hs +++ b/src/Jobs/Handler/SendNotification/Qualification.hs @@ -81,7 +81,7 @@ dispatchNotificationQualificationExpired nQualification jRecipient = do $logInfoS "LMS" $ "Notified " <> tshow encRecipient <> " about expired qualification " <> qname else $logErrorS "LMS" $ "Failed to notify " <> tshow encRecipient <> " about expired qualification " <> qname - else $logErrorS "LMS" $ "Suppressed repeated notification " <> tshow encRecipient <> " about expired qualification " <> qname + else $logInfoS "LMS" $ "Suppressed repeated notification " <> tshow encRecipient <> " about expired qualification " <> qname _ -> $logErrorS "LMS" $ "Failed to notify " <> tshow encRecipient <> " about expired qualification " <> tshow nQualification diff --git a/src/Jobs/Handler/SynchroniseAvs.hs b/src/Jobs/Handler/SynchroniseAvs.hs index 408758885..0b393f0e2 100644 --- a/src/Jobs/Handler/SynchroniseAvs.hs +++ b/src/Jobs/Handler/SynchroniseAvs.hs @@ -27,6 +27,7 @@ dispatchJobSynchroniseAvs numIterations epoch iteration pause now <- liftIO getCurrentTime todos <- runConduit $ readUsers .| filterIteration now .| sinkList putMany todos + void $ queueJob JobSynchroniseAvsQueue where readUsers :: ConduitT () UserId _ () readUsers = selectKeys [] [] diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index 6c665adb4..69ad6b4d6 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-23 Gregor Kleen ,Sarah Vaupel ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Sarah Vaupel ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -76,7 +76,7 @@ data Job } | JobSendFirmCommunication { jRecipientEmail :: Either UserEmail UserId , jAllRecipientAddresses :: Set Address - , jCompany :: Maybe CompanyShorthand + , jCompanies :: Companies , jSender :: UserId , jMailObjectUUID :: UUID , jMailContent :: CommunicationContent @@ -135,8 +135,6 @@ data Job | JobLmsEnqueueUser { jQualification :: QualificationId, jUser :: UserId } | JobLmsQualificationsDequeue | JobLmsDequeue { jQualification :: QualificationId } - | JobLmsUserlist { jQualification :: QualificationId } -- Deprecated, remove together with routes - | JobLmsResults { jQualification :: QualificationId } -- Deprecated, remove together with routes | JobLmsReports { jQualification :: QualificationId } | JobPrintAck | JobPrintAckAgain @@ -368,9 +366,7 @@ jobNoQueueSame = \case JobLmsEnqueue {} -> Just JobNoQueueSame JobLmsEnqueueUser {} -> Just JobNoQueueSame JobLmsQualificationsDequeue -> Just JobNoQueueSame - JobLmsDequeue {} -> Just JobNoQueueSame - JobLmsUserlist {} -> Just JobNoQueueSame - JobLmsResults {} -> Just JobNoQueueSame + JobLmsDequeue {} -> Just JobNoQueueSame JobLmsReports {} -> Just JobNoQueueSame JobPrintAck {} -> Just JobNoQueueSame JobPrintAckAgain {} -> Just JobNoQueueSame @@ -379,6 +375,8 @@ jobNoQueueSame = \case notifyNoQueueSame :: Notification -> Maybe JobNoQueueSame notifyNoQueueSame = \case NotificationQualificationRenewal{} -> Just JobNoQueueSame -- send one at once; safe, since the job is rescheduled if sending was not acknowledged + NotificationQualificationExpiry{} -> Just JobNoQueueSame -- do not send multiple expiry messages to the same person at once + NotificationQualificationExpired{} -> Just JobNoQueueSame _ -> Nothing jobMovable :: JobCtl -> Bool diff --git a/src/Mail.hs b/src/Mail.hs index 6f8879b71..4f9ab00d6 100644 --- a/src/Mail.hs +++ b/src/Mail.hs @@ -10,6 +10,7 @@ module Mail ( -- * Structured MIME emails module Network.Mail.Mime + , AddressEqIgnoreName(..) -- * MailT , MailT, defMailT , MailSmtpData(..), _smtpEnvelopeFrom, _smtpRecipients @@ -137,6 +138,14 @@ import Network.HTTP.Types.Header (hETag) import Web.HttpApiData (ToHttpApiData(toHeader)) +newtype AddressEqIgnoreName = AddressEqIgnoreName { getAddress :: Address } + deriving (Show, Generic) +instance Eq AddressEqIgnoreName where + (==) = (==) `on` (addressEmail . getAddress) +instance Ord AddressEqIgnoreName where + compare = compare `on` (addressEmail . getAddress) + + makeLenses_ ''Address makeLenses_ ''Mail makeLenses_ ''Part @@ -339,8 +348,8 @@ defMailT ls (MailT mailC) = do return $ mail0 & _mailFrom .~ fromAddress & _mailReplyTo .~ sender - mailRerouteTo' <- mailRerouteTo - let (mail2, smtpData1) = maybe (mail1,smtpData0) switchRecipient mailRerouteTo' -- switch receiver on enveloper, if rerouting is active + mailRerouteTo' <- mailRerouteTo -- this is the general reroute, e.g. for test instances, not for supervisors + let (mail2, smtpData1) = maybe (mail1,smtpData0) switchRecipient mailRerouteTo' -- switch receiver on envelope, if rerouting is active switchRecipient rerouteTo = (Mime.addPart switchInfo mail1, smtpData0 { smtpRecipients = Set.singleton rerouteTo } ) switchInfo = [plainPart $ LT.fromStrict $ "Due to setting 'mail-reroute-to', this mail was diverted; it was intended to be sent to: " <> tshow (smtpRecipients smtpData0)] mail3 <- liftIO $ LBS.toStrict <$> renderMail' mail2 diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index dc0f83210..42bd22236 100644 --- a/src/Model/Migration.hs +++ b/src/Model/Migration.hs @@ -31,59 +31,20 @@ import Control.Monad.Except (MonadError(..)) import Web.ServerSession.Backend.Persistent.Memcached (migrateMemcachedSqlStorage) -import qualified Control.Monad.State.Class as State +-- import qualified Control.Monad.State.Class as State -_manualMigration :: Fold (Legacy.MigrationVersion, Legacy.Version) ManualMigration -_manualMigration = folding $ \case - ([Legacy.migrationVersion|initial|], [Legacy.version|0.0.0|]) -> Just Migration20180813SimplifyUserTheme - ([Legacy.migrationVersion|0.0.0|], [Legacy.version|1.0.0|]) -> Just Migration20180813SheetJSONB - ([Legacy.migrationVersion|1.0.0|], [Legacy.version|2.0.0|]) -> Just Migration20180823SchoolShorthandPrimaryKey - ([Legacy.migrationVersion|2.0.0|], [Legacy.version|3.0.0|]) -> Just Migration20180918SheetCorrectorLoadJSON - ([Legacy.migrationVersion|3.0.0|], [Legacy.version|3.1.0|]) -> Just Migration20180918UserSurnames - ([Legacy.migrationVersion|3.1.0|], [Legacy.version|3.2.0|]) -> Just Migration20180918SheetUploadMode - ([Legacy.migrationVersion|3.2.0|], [Legacy.version|4.0.0|]) -> Just Migration20180928UserAuthentication - ([Legacy.migrationVersion|4.0.0|], [Legacy.version|5.0.0|]) -> Just Migration20181011UserNotificationSettings - ([Legacy.migrationVersion|5.0.0|], [Legacy.version|6.0.0|]) -> Just Migration20181031SheetTypeRefactor - ([Legacy.migrationVersion|6.0.0|], [Legacy.version|7.0.0|]) -> Just Migration20181129EncodedSecretBoxes - ([Legacy.migrationVersion|7.0.0|], [Legacy.version|8.0.0|]) -> Just Migration20181130SheetTypeRefactor - ([Legacy.migrationVersion|8.0.0|], [Legacy.version|9.0.0|]) -> Just Migration20190319CourseParticipantField - ([Legacy.migrationVersion|9.0.0|], [Legacy.version|10.0.0|]) -> Just Migration20190320BetterStudyShorthands - ([Legacy.migrationVersion|10.0.0|], [Legacy.version|11.0.0|]) -> Just Migration20190421MixedSheetSubmissions - ([Legacy.migrationVersion|11.0.0|], [Legacy.version|12.0.0|]) -> Just Migration20190429Tutorials - ([Legacy.migrationVersion|12.0.0|], [Legacy.version|13.0.0|]) -> Just Migration20190515Exams - ([Legacy.migrationVersion|13.0.0|], [Legacy.version|14.0.0|]) -> Just Migration20190715ExamOccurrenceName - ([Legacy.migrationVersion|14.0.0|], [Legacy.version|15.0.0|]) -> Just Migration20190726UserFirstNamesTitles - ([Legacy.migrationVersion|15.0.0|], [Legacy.version|16.0.0|]) -> Just Migration20190806TransactionLogIds - ([Legacy.migrationVersion|18.0.0|], [Legacy.version|19.0.0|]) -> Just Migration20190828UserFunction - ([Legacy.migrationVersion|19.0.0|], [Legacy.version|20.0.0|]) -> Just Migration20190912UserDisplayEmail - ([Legacy.migrationVersion|20.0.0|], [Legacy.version|21.0.0|]) -> Just Migration20190916ExamPartNumber - ([Legacy.migrationVersion|21.0.0|], [Legacy.version|22.0.0|]) -> Just Migration20190918ExamRulesRefactor - ([Legacy.migrationVersion|22.0.0|], [Legacy.version|23.0.0|]) -> Just Migration20190919ExamBonusRounding - ([Legacy.migrationVersion|23.0.0|], [Legacy.version|24.0.0|]) -> Just Migration20191002FavouriteReason - ([Legacy.migrationVersion|26.0.0|], [Legacy.version|27.0.0|]) -> Just Migration20191125UserLanguages - ([Legacy.migrationVersion|27.0.0|], [Legacy.version|28.0.0|]) -> Just Migration20191126ExamPartCorrector - ([Legacy.migrationVersion|28.0.0|], [Legacy.version|29.0.0|]) -> Just Migration20191128StudyFeaturesSuperField - ([Legacy.migrationVersion|29.0.0|], [Legacy.version|30.0.0|]) -> Just Migration20200111ExamOccurrenceRuleRefactor - ([Legacy.migrationVersion|30.0.0|], [Legacy.version|31.0.0|]) -> Just Migration20200218ExamResultPassedGrade - ([Legacy.migrationVersion|31.0.0|], [Legacy.version|32.0.0|]) -> Just Migration20200218ExamGradingModeMixed - ([Legacy.migrationVersion|32.0.0|], [Legacy.version|33.0.0|]) -> Just Migration20200218ExternalExamGradingModeMixed - ([Legacy.migrationVersion|34.0.0|], [Legacy.version|35.0.0|]) -> Just Migration20200424SubmissionGroups - ([Legacy.migrationVersion|35.0.0|], [Legacy.version|36.0.0|]) -> Just Migration20200504CourseParticipantState - ([Legacy.migrationVersion|36.0.0|], [Legacy.version|37.0.0|]) -> Just Migration20200506SessionFile - ([Legacy.migrationVersion|37.0.0|], [Legacy.version|38.0.0|]) -> Just Migration20200627FileRefactor - ([Legacy.migrationVersion|39.0.0|], [Legacy.version|40.0.0|]) -> Just Migration20200825StudyFeaturesFirstObserved - ([Legacy.migrationVersion|40.0.0|], [Legacy.version|41.0.0|]) -> Just Migration20200902FileChunking - ([Legacy.migrationVersion|41.0.0|], [Legacy.version|42.0.0|]) -> Just Migration20200916ExamMode - ([Legacy.migrationVersion|43.0.0|], [Legacy.version|44.0.0|]) -> Just Migration20201106StoredMarkup - ([Legacy.migrationVersion|44.0.0|], [Legacy.version|45.0.0|]) -> Just Migration20201119RoomTypes - _other -> Nothing - +-- _manualMigration :: Fold (Legacy.Migration Version, Legacy.Version) ManualMigration +-- _manualMigration = folding $ \case +-- ([Legacy.migrationVersion|initial|], [Legacy.version|0.0.0|]) -> Just Migration20180813SimplifyUserTheme +-- ([Legacy.migrationVersion|44.0.0|], [Legacy.version|45.0.0|]) -> Just Migration20201119RoomTypes +-- _other -> Nothing +-- AppliedMigrationMigration changed vom ManualMigration to Text (via PathPiece) so that removed extra migrations within DB are harmless (before achieved through where-clause) share [mkPersist sqlSettings, mkMigrate "migrateDBVersioning"] [persistLowerCase| AppliedMigration json - migration ManualMigration + migration Text time UTCTime Primary migration deriving Show Eq Ord @@ -99,7 +60,7 @@ migrateAll' = sequence_ migrateAll :: ( MonadLogger m , MonadResource m , MonadUnliftIO m - , MonadReader UniWorX m + -- , MonadReader UniWorX m ) => ReaderT SqlBackend m () migrateAll = do @@ -108,8 +69,9 @@ migrateAll = do missingMigrations <- getMissingMigrations let - doCustomMigration acc appliedMigrationMigration migration = acc <* do - $logInfoS "Migration" $ toPathPiece appliedMigrationMigration + doCustomMigration acc manualMigration migration = acc <* do + let appliedMigrationMigration = toPathPiece manualMigration + $logInfoS "Migration" appliedMigrationMigration appliedMigrationTime <- liftIO getCurrentTime _ <- migration insert AppliedMigration{..} @@ -154,9 +116,9 @@ initialMigration = do mapM_ migrateEnableExtension ["citext", "pgcrypto"] lift . lift . hoist runResourceT . whenM (columnExists "applied_migration" "from") $ do let getAppliedMigrations = [queryQQ|SELECT "from", "to", "time" FROM "applied_migration"|] - migrateAppliedMigration [ fromPersistValue -> Right (fromV :: Legacy.MigrationVersion), fromPersistValue -> Right (toV :: Legacy.Version), fromPersistValue -> Right (time :: UTCTime) ] = do + migrateAppliedMigration [ fromPersistValue -> Right (fromV :: Legacy.MigrationVersion), fromPersistValue -> Right (toV :: Legacy.Version), fromPersistValue -> Right (_time :: UTCTime) ] = do lift [executeQQ|DELETE FROM "applied_migration" WHERE "from" = #{fromV} AND "to" = #{toV}|] - State.modify . Map.unionWith min . Map.fromSet (const time) $ setOf _manualMigration (fromV, toV) + -- State.modify . Map.unionWith min . Map.fromSet (const time) $ setOf _manualMigration (fromV, toV) migrateAppliedMigration _ = return () insertMigrations ms = do [executeQQ| @@ -174,15 +136,16 @@ getMissingMigrations :: forall m m'. ( MonadLogger m , MonadIO m , MonadResource m' - , MonadReader UniWorX m' + -- , MonadReader UniWorX m' ) => ReaderT SqlBackend m (Map ManualMigration (ReaderT SqlBackend m' ())) getMissingMigrations = do $logDebugS "Migration" "Retrieve applied migrations" - appliedMigrations <- fmap (map E.unValue) . E.select . E.from $ \appliedMigration -> do - E.where_ $ appliedMigration E.^. AppliedMigrationMigration `E.in_` E.valList universeF + appliedMigrations <- fmap (map E.unValue) . E.select . E.from $ \appliedMigration -> do return $ appliedMigration E.^. AppliedMigrationMigration - return $ customMigrations `Map.withoutKeys` Set.fromList appliedMigrations + let migNotDone m _ = toPathPiece m `Set.notMember` Set.fromList appliedMigrations + return $ Map.filterWithKey migNotDone customMigrations + getMigrationTime :: ( MonadIO m , BaseBackend backend ~ SqlBackend @@ -190,4 +153,4 @@ getMigrationTime :: ( MonadIO m ) => ManualMigration -> ReaderT backend m (Maybe UTCTime) -getMigrationTime = fmap (fmap appliedMigrationTime) . get . AppliedMigrationKey +getMigrationTime = fmap (fmap appliedMigrationTime) . get . AppliedMigrationKey . toPathPiece diff --git a/src/Model/Migration/Definitions.hs b/src/Model/Migration/Definitions.hs index 5f9940449..ab0147ff4 100644 --- a/src/Model/Migration/Definitions.hs +++ b/src/Model/Migration/Definitions.hs @@ -1,7 +1,9 @@ --- SPDX-FileCopyrightText: 2022-23 Gregor Kleen ,Steffen Jost ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later +{-# OPTIONS_GHC -fno-warn-unused-top-binds #-} + module Model.Migration.Definitions ( ManualMigration(..) , migrateManual @@ -14,8 +16,8 @@ import Import.NoModel hiding (Max(..), Last(..)) import Model import Model.Types.TH.PathPiece import Settings -import Foundation.Type -import Audit.Types +-- import Foundation.Type +-- import Audit.Types import qualified Model.Migration.Types as Legacy import qualified Data.Map as Map @@ -28,16 +30,14 @@ import qualified Data.Conduit.List as C import Database.Persist.Sql import Database.Persist.Sql.Raw.QQ -import Text.Read (readMaybe) +-- import Text.Read (readMaybe) -import Network.IP.Addr +-- import Network.IP.Addr -import qualified Data.Char as Char -import qualified Data.CaseInsensitive as CI +-- import qualified Data.Char as Char +-- import qualified Data.CaseInsensitive as CI -import qualified Data.Aeson as Aeson - -import Data.Conduit.Algorithms.FastCDC (FastCDCParameters(fastCDCMinBlockSize)) +-- import qualified Data.Aeson as Aeson import Data.Time.Format.ISO8601 (iso8601Show) import Data.Time.Format @@ -47,53 +47,9 @@ import qualified Data.Time.Zones as TZ data ManualMigration - = Migration20180813SimplifyUserTheme - | Migration20180813SheetJSONB - | Migration20180823SchoolShorthandPrimaryKey - | Migration20180918SheetCorrectorLoadJSON - | Migration20180918UserSurnames - | Migration20180918SheetUploadMode - | Migration20180928UserAuthentication - | Migration20181011UserNotificationSettings - | Migration20181031SheetTypeRefactor - | Migration20181129EncodedSecretBoxes - | Migration20181130SheetTypeRefactor - | Migration20190319CourseParticipantField - | Migration20190320BetterStudyShorthands - | Migration20190421MixedSheetSubmissions - | Migration20190429Tutorials - | Migration20190515Exams - | Migration20190715ExamOccurrenceName - | Migration20190726UserFirstNamesTitles - | Migration20190806TransactionLogIds - | Migration20190828UserFunction - | Migration20190912UserDisplayEmail - | Migration20190916ExamPartNumber - | Migration20190918ExamRulesRefactor - | Migration20190919ExamBonusRounding - | Migration20191002FavouriteReason - | Migration20191125UserLanguages - | Migration20191126ExamPartCorrector - | Migration20191128StudyFeaturesSuperField - | Migration20200111ExamOccurrenceRuleRefactor - | Migration20200218ExamResultPassedGrade - | Migration20200218ExamGradingModeMixed - | Migration20200218ExternalExamGradingModeMixed - | Migration20200424SubmissionGroups - | Migration20200504CourseParticipantState - | Migration20200506SessionFile - | Migration20200627FileRefactor - | Migration20200825StudyFeaturesFirstObserved - | Migration20200902FileChunking - | Migration20200916ExamMode - | Migration20201106StoredMarkup - | Migration20201119RoomTypes - | Migration20210115ExamPartsFrom - | Migration20210208StudyFeaturesRelevanceCachedUUIDs - | Migration20210318CrontabSubmissionRatedNotification - | Migration20210608SeparateTermActive - | Migration20230524QualificationUserBlock + = Migration20230524QualificationUserBlock | Migration20230703LmsUserStatus + | Migration20240212InitInterfaceHealth -- create table interface_health and fill with default values deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic) deriving anyclass (Universe, Finite) @@ -141,6 +97,8 @@ migrateManual = do , ("idx_print_job_apc_ident" ,"CREATE INDEX idx_print_job_apc_ident ON \"print_job\" (\"apc_ident\")") , ("idx_user_avs_card_person_id" ,"CREATE INDEX idx_user_avs_card_person_id ON \"user_avs_card\" (\"person_id\")") , ("idx_lms_report_log_q_ident_time" ,"CREATE INDEX idx_lms_report_log_q_ident_time ON \"lms_report_log\" (\"qualification\",\"ident\",\"timestamp\")") + , ("idx_user_company_company" ,"CREATE INDEX idx_user_company_company ON \"user_company\" (\"company\")") -- composed index from unique cannot be used for frequently used filters on company + , ("idx_user_supervisor_user" ,"CREATE INDEX idx_user_supervisor_user ON \"user_supervisor\" (\"user\")") -- composed index from unique cannot be used for frequently used filters on user ] where addIndex :: Text -> Sql -> Migration @@ -177,692 +135,10 @@ migrateAlwaysSafe = do customMigrations :: forall m. ( MonadResource m - , MonadReader UniWorX m + -- , MonadReader UniWorX m ) => Map ManualMigration (ReaderT SqlBackend m ()) customMigrations = mapF $ \case - Migration20180813SimplifyUserTheme -> whenM (columnExists "user" "theme") $ do -- New theme format - userThemes <- [sqlQQ| SELECT "id", "theme" FROM "user"; |] - forM_ userThemes $ \(uid, Single str) -> case stripPrefix "theme--" str of - Just v - | Just theme <- fromPathPiece v -> update uid [UserTheme =. theme] - other -> error $ "Could not parse theme: " <> show other - - Migration20180813SheetJSONB -> whenM (tableExists "sheet") -- Better JSON encoding - [executeQQ| - ALTER TABLE "sheet" ALTER COLUMN "type" TYPE jsonb USING "type"::jsonb; - ALTER TABLE "sheet" ALTER COLUMN "grouping" TYPE jsonb USING "grouping"::jsonb; - |] - - Migration20180823SchoolShorthandPrimaryKey -> whenM (columnExists "school" "id") $ do -- SchoolId is the Shorthand CI Text now - -- Read old table into memory - schoolTable <- [sqlQQ| SELECT "id", "shorthand" FROM "school"; |] - let _sT = schoolTable :: [(Single Int64, Single (CI Text))] -- Types needed - -- Convert columns containing SchoolId - whenM (tableExists "user_admin") $ do - [executeQQ| - ALTER TABLE "user_admin" DROP CONSTRAINT "user_admin_school_fkey"; - ALTER TABLE "user_admin" ALTER COLUMN "school" TYPE citext USING "school"::citext; - |] - forM_ schoolTable $ \(Single idnr, Single ssh) -> - [executeQQ| - UPDATE "user_admin" SET "school" = #{ssh} WHERE "school" = #{tshow idnr}; - |] - [executeQQ| - ALTER TABLE "user_admin" ADD CONSTRAINT "user_admin_school_fkey" - FOREIGN KEY (school) REFERENCES school(shorthand); - |] - whenM (tableExists "user_lecturer") $ do - [executeQQ| - ALTER TABLE "user_lecturer" DROP CONSTRAINT "user_lecturer_school_fkey"; - ALTER TABLE "user_lecturer" ALTER COLUMN "school" TYPE citext USING "school"::citext; - |] - forM_ schoolTable $ \(Single idnr, Single ssh) -> - [executeQQ| - UPDATE "user_lecturer" SET "school" = #{ssh} WHERE "school" = #{tshow idnr}; - |] - [executeQQ| - ALTER TABLE "user_lecturer" ADD CONSTRAINT "user_lecturer_school_fkey" - FOREIGN KEY (school) REFERENCES school(shorthand); - |] - whenM (tableExists "course") $ do - [executeQQ| - ALTER TABLE "course" DROP CONSTRAINT "course_school_fkey"; - ALTER TABLE "course" ALTER COLUMN "school" TYPE citext USING "school"::citext; - |] - forM_ schoolTable $ \(Single idnr, Single ssh) -> - [executeQQ| - UPDATE "course" SET "school" = #{ssh} WHERE "school" = #{tshow idnr}; - |] - [executeQQ| - ALTER TABLE "course" ADD CONSTRAINT "course_school_fkey" - FOREIGN KEY (school) REFERENCES school(shorthand); - |] - [executeQQ| - ALTER TABLE "school" DROP COLUMN "id"; - ALTER TABLE "school" ADD PRIMARY KEY (shorthand); - |] - - Migration20180918SheetCorrectorLoadJSON -> whenM (tableExists "sheet_corrector") $ do -- Load is encoded as JSON now. - correctorLoads <- [sqlQQ| SELECT "id", "load" FROM "sheet_corrector"; |] - forM_ correctorLoads $ \(uid, Single str) -> case readMaybe str of - Just load -> update uid [SheetCorrectorLoad =. load] - _other -> error $ "Could not parse Load: " <> show str - [executeQQ| - ALTER TABLE "sheet_corrector" ALTER COLUMN "load" TYPE jsonb USING "load"::jsonb; - |] - - Migration20180918UserSurnames -> whenM (tableExists "user") $ do - userDisplayNames <- [sqlQQ| SELECT "id", "display_name" FROM "user"; |] - [executeQQ| - ALTER TABLE "user" ADD COLUMN IF NOT EXISTS "surname" text DEFAULT ''; - |] - forM_ userDisplayNames $ \(uid, Single str) -> case lastMaybe $ words str of - Just name -> update uid [UserSurname =. name] - _other -> error "Empty userDisplayName found" - - Migration20180918SheetUploadMode -> whenM (tableExists "sheet") - [executeQQ| - ALTER TABLE "sheet" ADD COLUMN IF NOT EXISTS "upload_mode" jsonb DEFAULT '{ "tag": "Upload", "unpackZips": true }'; - |] - - Migration20180928UserAuthentication -> whenM (columnExists "user" "plugin") - -- <> is standard sql for /= - [executeQQ| - DELETE FROM "user" WHERE "plugin" <> 'LDAP'; - ALTER TABLE "user" DROP COLUMN "plugin"; - ALTER TABLE "user" ADD COLUMN IF NOT EXISTS "authentication" jsonb DEFAULT '"ldap"'; - |] - - Migration20181011UserNotificationSettings -> whenM (tableExists "user") - [executeQQ| - ALTER TABLE "user" ADD COLUMN IF NOT EXISTS "notification_settings" jsonb NOT NULL DEFAULT '[]'; - |] - - Migration20181031SheetTypeRefactor -> whenM (tableExists "sheet") $ do - sheets <- [sqlQQ| SELECT "id", "type" FROM "sheet"; |] - forM_ sheets $ \(sid, Single lsty) -> update sid [SheetType =. Legacy.sheetType lsty] - - Migration20181129EncodedSecretBoxes -> whenM (tableExists "cluster_config") - [executeQQ| - UPDATE "cluster_config" SET "setting" = 'secret-box-key' WHERE "setting" = 'error-message-key'; - |] - - Migration20181130SheetTypeRefactor -> whenM (tableExists "sheet") - [executeQQ| - UPDATE "sheet" SET "type" = json_build_object('type', "type"->'type', 'grading', "type"->'') WHERE jsonb_exists("type", ''); - UPDATE "sheet" SET "type" = json_build_object('type', "type"->'type', 'grading', json_build_object('type', "type"->'grading'->'type', 'max', "type"->'grading'->'points')) WHERE ("type"->'grading'->'type') = '"points"' AND jsonb_exists("type"->'grading', 'points'); - UPDATE "sheet" SET "type" = json_build_object('type', "type"->'type', 'grading', json_build_object('type', "type"->'grading'->'type', 'max', "type"->'grading'->'points', 'passing', 0)) WHERE ("type"->'grading'->'type') = '"pass-points"' AND jsonb_exists("type"->'grading', 'points'); - |] - - Migration20190319CourseParticipantField -> whenM ((\a b c -> a && b && not c) <$> tableExists "study_features" <*> tableExists "course_participant" <*> columnExists "course_participant" "field") $ do - [executeQQ| - ALTER TABLE "course_participant" ADD COLUMN "field" bigint DEFAULT null REFERENCES study_features(id); - ALTER TABLE "study_features" ADD COLUMN IF NOT EXISTS "valid" boolean NOT NULL DEFAULT true; - |] - users <- [sqlQQ| SELECT DISTINCT ON ("user"."id") "user"."id", "study_features"."id" FROM "user", "study_features" WHERE "study_features"."user" = "user"."id" AND "study_features"."valid" AND "study_features"."type" = 'FieldPrimary' ORDER BY "user"."id", random(); |] - forM_ users $ \(uid :: UserId, sfid :: StudyFeaturesId) -> [executeQQ| UPDATE "course_participant" SET "field" = #{sfid} WHERE "user" = #{uid} AND "field" IS NULL; |] - - Migration20190320BetterStudyShorthands -> do - whenM (columnExists "study_degree" "shorthand") [executeQQ| UPDATE "study_degree" SET "shorthand" = NULL WHERE "shorthand" = '' |] - whenM (columnExists "study_degree" "name") [executeQQ| UPDATE "study_degree" SET "name" = NULL WHERE "shorthand" = '' |] - whenM (columnExists "study_terms" "shorthand") [executeQQ| UPDATE "study_terms" SET "shorthand" = NULL WHERE "shorthand" = '' |] - whenM (columnExists "study_terms" "name") [executeQQ| UPDATE "study_terms" SET "name" = NULL WHERE "shorthand" = '' |] - - Migration20190421MixedSheetSubmissions -> whenM ((&&) <$> columnExists "sheet" "upload_mode" <*> columnExists "sheet" "submission_mode") $ do - sheetModes <- [sqlQQ| SELECT "id", "upload_mode", "submission_mode" FROM "sheet"; |] - [executeQQ| - ALTER TABLE "sheet" DROP COLUMN "upload_mode"; - ALTER TABLE "sheet" ALTER COLUMN "submission_mode" DROP DEFAULT; - ALTER TABLE "sheet" ALTER COLUMN "submission_mode" TYPE jsonb USING 'null'::jsonb; - |] - forM_ sheetModes $ \(shid :: SheetId, unSingle -> uploadMode :: Legacy.UploadMode, unSingle -> submissionMode :: Legacy.SheetSubmissionMode ) -> do - let submissionMode' = case (submissionMode, uploadMode) of - ( Legacy.NoSubmissions , _ ) -> SubmissionMode False Nothing - ( Legacy.CorrectorSubmissions, _ ) -> SubmissionMode True Nothing - ( Legacy.UserSubmissions , Legacy.NoUpload ) -> SubmissionMode False (Just NoUpload) - ( Legacy.UserSubmissions , Legacy.Upload True ) -> SubmissionMode False (Just $ UploadAny True defaultExtensionRestriction True) - ( Legacy.UserSubmissions , Legacy.Upload False ) -> SubmissionMode False (Just $ UploadAny False defaultExtensionRestriction True) - [executeQQ| UPDATE "sheet" SET "submission_mode" = #{submissionMode'} WHERE "id" = #{shid}; |] - - Migration20190429Tutorials -> whenM ((&&) <$> tableExists "tutorial" <*> tableExists "tutorial_user") $ do -- Tutorials were an unused stub before - tableDropEmpty "tutorial" - tableDropEmpty "tutorial_user" - - Migration20190515Exams -> whenM (tableExists "exam") $ -- Exams were an unused stub before - tableDropEmpty "exam" - - Migration20190715ExamOccurrenceName -> whenM ((&&) <$> tableExists "exam_occurrence" <*> (not <$> columnExists "exam_occurrence" "name")) $ do - examOccurrences <- [sqlQQ| SELECT "id" FROM "exam_occurrence" ORDER BY "exam"; |] - [executeQQ| - ALTER TABLE "exam_occurrence" ADD COLUMN "name" citext DEFAULT null; - |] - forM_ (zip [0..] examOccurrences) $ \(n :: Natural, Single eoId :: Single ExamOccurrenceId) -> do - let name = [st|occ-#{tshow n}|] - [executeQQ| UPDATE "exam_occurrence" SET "name" = #{name} WHERE "id" = #{eoId} |] - [executeQQ| - ALTER TABLE "exam_occurrence" ALTER COLUMN "name" DROP DEFAULT; - ALTER TABLE "exam_occurrence" ALTER COLUMN "name" SET NOT NULL; - |] - - Migration20190726UserFirstNamesTitles -> whenM (tableExists "user") $ do - [executeQQ| - ALTER TABLE "user" ADD COLUMN "first_name" text NOT NULL DEFAULT ''; - ALTER TABLE "user" ADD COLUMN "title" text DEFAULT null; - |] - let getUsers = rawQuery [st|SELECT "id", "display_name", "surname" FROM "user"|] [] - updateUser (uid, firstName) = [executeQQ|UPDATE "user" SET "first_name" = #{firstName} WHERE "id" = #{uid}|] - splitFirstName :: [PersistValue] -> Maybe (UserId, Text) - splitFirstName [fromPersistValue -> Right uid, fromPersistValue -> Right displayName, fromPersistValue -> Right surname] = Just . (uid, ) $ if - | Just givenName <- Text.stripSuffix surname displayName - <|> Text.stripPrefix surname displayName - -> Text.strip givenName - | otherwise - -> Text.replace surname "…" displayName - splitFirstName _ = Nothing - runConduit $ getUsers .| C.mapMaybe splitFirstName .| C.mapM_ updateUser - - Migration20190806TransactionLogIds -> whenM (tableExists "transaction_log") $ do - [executeQQ| - UPDATE transaction_log SET remote = null WHERE remote = #{IPv4 loopbackIP4 :: IP} OR remote = #{IPv6 loopbackIP6 :: IP} - |] - - [executeQQ| - ALTER TABLE transaction_log ADD COLUMN "initiator_id" bigint DEFAULT null; - |] - - whenM (tableExists "user") - [executeQQ| - UPDATE transaction_log SET initiator_id = "user".id FROM "user" WHERE transaction_log.initiator = "user".ident; - |] - - [executeQQ| - ALTER TABLE transaction_log DROP COLUMN initiator; - ALTER TABLE transaction_log RENAME COLUMN initiator_id TO initiator; - ALTER TABLE transaction_log ALTER COLUMN initiator DROP DEFAULT; - |] - - let getLogEntries = rawQuery [st|SELECT id, info FROM transaction_log|] [] - updateTransactionInfo [fromPersistValue -> Right lid, fromPersistValue -> Right (oldT :: Legacy.Transaction)] = do - newT <- case oldT of - Legacy.TransactionTermEdit tid - -> return . Just . TransactionTermEdit $ TermKey tid - Legacy.TransactionExamRegister (TermKey -> tid) (SchoolKey -> ssh) csh examn uident - -> runMaybeT $ do - guardM . lift $ tablesExist ["user", "exam", "course"] - - cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh - eid <- MaybeT . getKeyBy $ UniqueExam cid examn - uid <- MaybeT . getKeyBy $ UniqueAuthentication uident - return $ TransactionExamRegister eid uid - Legacy.TransactionExamDeregister (TermKey -> tid) (SchoolKey -> ssh) csh examn uident - -> runMaybeT $ do - guardM . lift $ tablesExist ["user", "exam", "course"] - - cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh - eid <- MaybeT . getKeyBy $ UniqueExam cid examn - uid <- MaybeT . getKeyBy $ UniqueAuthentication uident - return $ TransactionExamRegister eid uid - whenIsJust newT $ \newT' -> - update lid [ TransactionLogInfo =. toJSON newT' ] - updateTransactionInfo _ = return () - runConduit $ getLogEntries .| C.mapM_ updateTransactionInfo - - Migration20190828UserFunction -> do - [executeQQ| - CREATE TABLE IF NOT EXISTS "user_function" ( "id" serial8 primary key, "user" bigint, "school" citext, "function" text ); - |] - - whenM (tableExists "user_admin") $ do - let getAdminEntries = rawQuery [st|SELECT user_admin.id, user_admin.user, user_admin.school FROM user_admin;|] [] - moveAdminEntry [fromPersistValue -> Right (eId :: Int64), fromPersistValue -> Right (uid :: UserId), fromPersistValue -> Right (sid :: SchoolId)] = - [executeQQ| - INSERT INTO "user_function" ("user", "school", "function") VALUES (#{uid}, #{sid}, #{SchoolAdmin}); - DELETE FROM "user_admin" WHERE "id" = #{eId}; - |] - moveAdminEntry _ = return () - runConduit $ getAdminEntries .| C.mapM_ moveAdminEntry - tableDropEmpty "user_admin" - whenM (tableExists "user_lecturer") $ do - let getLecturerEntries = rawQuery [st|SELECT user_lecturer.id, user_lecturer.user, user_lecturer.school FROM user_lecturer;|] [] - moveLecturerEntry [fromPersistValue -> Right (eId :: Int64), fromPersistValue -> Right (uid :: UserId), fromPersistValue -> Right (sid :: SchoolId)] = - [executeQQ| - INSERT INTO "user_function" ("user", "school", "function") VALUES (#{uid}, #{sid}, #{SchoolLecturer}); - DELETE FROM "user_lecturer" WHERE "id" = #{eId}; - |] - moveLecturerEntry _ = return () - runConduit $ getLecturerEntries .| C.mapM_ moveLecturerEntry - tableDropEmpty "user_lecturer" - whenM (tableExists "invitation") $ do - [executeQQ| - DELETE FROM "invitation" WHERE "for"->'junction' = '"UserLecturer"'; - |] - - Migration20190912UserDisplayEmail -> whenM (tableExists "user") $ do - [executeQQ| - ALTER TABLE "user" ADD COLUMN IF NOT EXISTS "display_email" citext; - UPDATE "user" SET "display_email" = "email" WHERE "display_email" IS NULL; - ALTER TABLE "user" ALTER COLUMN "display_email" SET NOT NULL; - |] - - Migration20190916ExamPartNumber -> whenM (tableExists "exam_part") $ do - [executeQQ| - ALTER TABLE "exam_part" ADD COLUMN IF NOT EXISTS "number" citext; - |] - - let getExamEntries = rawQuery [st|SELECT DISTINCT exam FROM exam_part ORDER BY exam;|] [] - renameExamParts [fromPersistValue -> Right (eId :: ExamId)] = do - partNames' <- [sqlQQ|SELECT id, name FROM "exam_part" WHERE exam = #{eId};|] - let - partNames :: [(ExamPartId, ExamPartName)] - partNames = foldMap (\(Single epId, Single pName) -> singletonMap epId pName) partNames' - - partsSorted = partNames - & sortOn ( map (\x -> maybe (Left x) Right (readMay x :: Maybe Integer)) - . groupBy ((==) `on` Char.isDigit) - . CI.foldedCase - . snd - ) - & map fst - forM_ (zip [_ExamPartNumber' # 1..] partsSorted) $ \(num :: ExamPartNumber, pId) -> - [executeQQ| - UPDATE "exam_part" SET "number" = #{num} WHERE "id" = #{pId}; - |] - renameExamParts _ = return () - runConduit $ getExamEntries .| C.mapM_ renameExamParts - - Migration20190918ExamRulesRefactor -> whenM (tableExists "exam") $ do - oldVersion <- columnExists "exam" "grading_key" - if - | oldVersion -> do - -- Major changes happend to the structure of exams without appropriate - -- migration, try to remedy that here - tableDropEmpty "exam_part_corrector" - tableDropEmpty "exam_corrector" - tableDropEmpty "exam_result" - tableDropEmpty "exam_registration" - tableDropEmpty "exam_occurrence" - tableDropEmpty "exam_part" - tableDropEmpty "exam" - | otherwise -> - [executeQQ| - ALTER TABLE "exam" ALTER COLUMN "grading_rule" DROP NOT NULL; - ALTER TABLE "exam" ALTER COLUMN "bonus_rule" DROP NOT NULL; - ALTER TABLE "exam" ALTER COLUMN "occurrence_rule" DROP NOT NULL; - - UPDATE "exam" SET "grading_rule" = NULL WHERE "grading_rule"->>'rule' = 'manual'; - UPDATE "exam" SET "bonus_rule" = NULL WHERE "bonus_rule"->>'rule' = 'no-bonus'; - UPDATE "exam" SET "occurrence_rule" = NULL WHERE "occurrence_rule" = '"manual"'; - - UPDATE "exam" SET "occurrence_rule" = json_build_object('rule', "occurrence_rule"); - |] - - Migration20190919ExamBonusRounding -> whenM (tableExists "exam") - [executeQQ| - UPDATE "exam" SET "bonus_rule" = jsonb_insert("bonus_rule", '{round}' :: text[], '0.01' :: jsonb) WHERE "bonus_rule"->>'rule' = 'bonus-points'; - |] - - Migration20191002FavouriteReason -> whenM (tableExists "course_favourite") - [executeQQ| - ALTER TABLE "course_favourite" RENAME COLUMN "time" TO "last_visit"; - ALTER TABLE "course_favourite" ADD COLUMN "reason" jsonb DEFAULT '"visited"'::jsonb; - |] - - Migration20191125UserLanguages -> whenM (tableExists "user") - [executeQQ| - ALTER TABLE "user" ADD COLUMN "languages" jsonb; - UPDATE "user" SET "languages" = "mail_languages" where "mail_languages" <> '[]'; - ALTER TABLE "user" DROP COLUMN "mail_languages"; - |] - - Migration20191126ExamPartCorrector -> whenM (tableExists "exam_part_corrector") $ - tableDropEmpty "exam_part_corrector" - - Migration20191128StudyFeaturesSuperField -> whenM (tableExists "study_features") - [executeQQ| - ALTER TABLE "study_features" ADD COLUMN "super_field" bigint; - UPDATE "study_features" SET "super_field" = "field", "field" = "sub_field" WHERE NOT ("sub_field" IS NULL); - ALTER TABLE "study_features" DROP COLUMN "sub_field"; - |] - - Migration20200111ExamOccurrenceRuleRefactor -> whenM (tableExists "exam") - [executeQQ| - UPDATE "exam" SET "occurrence_rule" = #{ExamRoomManual} WHERE "occurrence_rule" IS NULL; - ALTER TABLE "exam" ALTER COLUMN "occurrence_rule" SET NOT NULL; - |] - - Migration20200218ExamResultPassedGrade -> whenM ((&&) <$> tableExists "exam" <*> tableExists "exam_result") $ do - queryRes <- [sqlQQ|SELECT exam_result.id, exam_result.result FROM exam_result INNER JOIN exam ON exam_result.exam = exam.id WHERE NOT exam.show_grades;|] - forM_ queryRes $ \(resId :: ExamResultId, Single (res :: ExamResultGrade)) -> - let res' :: ExamResultPassedGrade - res' = Left . view passingGrade <$> res - in [executeQQ|UPDATE exam_result SET result = #{res'} WHERE id = #{resId};|] - - Migration20200218ExamGradingModeMixed -> whenM (tableExists "exam") - [executeQQ| - ALTER TABLE "exam" ADD COLUMN "grading_mode" character varying; - UPDATE "exam" SET "grading_mode" = 'grades' WHERE "show_grades"; - UPDATE "exam" SET "grading_mode" = 'pass' WHERE NOT "show_grades"; - ALTER TABLE "exam" DROP COLUMN "show_grades"; - ALTER TABLE "exam" ALTER COLUMN "grading_mode" SET NOT NULL; - |] - - Migration20200218ExternalExamGradingModeMixed -> whenM (tableExists "external_exam") - [executeQQ| - ALTER TABLE "external_exam" ADD COLUMN "grading_mode" character varying; - UPDATE "external_exam" SET "grading_mode" = 'grades' WHERE "show_grades"; - UPDATE "external_exam" SET "grading_mode" = 'pass' WHERE NOT "show_grades"; - ALTER TABLE "external_exam" DROP COLUMN "show_grades"; - ALTER TABLE "external_exam" ALTER COLUMN "grading_mode" SET NOT NULL; - |] - - Migration20200424SubmissionGroups -> do - whenM (tableExists "submission_group") $ - tableDropEmpty "submission_group" - whenM (tableExists "submission_group_edit") $ - tableDropEmpty "submission_group_edit" - - Migration20200504CourseParticipantState -> whenM (tableExists "course_participant") $ do - [executeQQ| - ALTER TABLE "course_participant" ADD COLUMN "state" text NOT NULL DEFAULT 'active'; - ALTER TABLE "course_participant" ALTER COLUMN "state" DROP DEFAULT; - |] - let getAuditLog = rawQuery [st|SELECT DISTINCT ON ("info") "info", max("time") FROM "transaction_log" GROUP BY "info" ORDER BY "info";|] [] - ensureParticipant :: [PersistValue] -> ReaderT SqlBackend m () - ensureParticipant [fmap Aeson.fromJSON . fromPersistValue -> Right (Aeson.Success TransactionCourseParticipantEdit{..}), fromPersistValue -> Right (time :: UTCTime)] = do - whenM (existsKey transactionCourse `and2M` existsKey transactionUser) - [executeQQ|INSERT INTO "course_participant" ("course", "user", "registration", "state") VALUES (#{transactionCourse}, #{transactionUser}, #{time}, #{CourseParticipantInactive False}) ON CONFLICT DO NOTHING;|] - ensureParticipant _ = return () - runConduit $ getAuditLog .| C.mapM_ ensureParticipant - - Migration20200506SessionFile -> whenM (tableExists "session_file") $ - tableDropEmpty "session_file" - - Migration20200627FileRefactor -> whenM (tableExists "file") $ do - [executeQQ| - ALTER TABLE "file" ADD COLUMN "hash" BYTEA; - UPDATE "file" SET "hash" = digest("content", 'sha3-512'); - |] - - let - migrateFromFile :: forall fRef. - ( HasFileReference fRef - , PersistRecordBackend fRef SqlBackend - ) - => ([PersistValue] -> (Key fRef, FileReferenceResidual fRef)) - -> (Entity fRef -> ReaderT SqlBackend m ()) - -> [PersistValue] - -> ReaderT SqlBackend m () - migrateFromFile toResidual doUpdate ((fromPersistValue -> Right (fId :: Int64)):rest) = do - let (fRefKey, residual) = toResidual rest - fileDat <- [sqlQQ| - SELECT "file".title, "file".modified, "file".hash FROM "file" WHERE "id" = #{fId}; - |] - forM_ fileDat $ \case - (fromPersistValue . unSingle -> Right (fileReferenceTitle' :: FilePath), fromPersistValue . unSingle -> Right fileReferenceModified, fromPersistValue . unSingle -> Right fileReferenceContent) -> do - let fileRef fileReferenceTitle = _FileReference # (FileReference{..}, residual) - candidateTitles = fileReferenceTitle' : [ fName <.> ("old-" <> show n) <.> ext | n <- [1..1000] ] - where (fName, ext) = splitExtension fileReferenceTitle' - validTitles <- dropWhileM (fmap (is _Just) . checkUnique . fileRef) candidateTitles - case validTitles of - fTitle : _ -> doUpdate . Entity fRefKey $ fileRef fTitle - _other -> error "Could not make validTitle" - _other -> return () - migrateFromFile _ _ _ = return () - - whenM (tableExists "submission_file") $ do - [executeQQ| - ALTER TABLE "submission_file" ADD COLUMN "title" VARCHAR; - ALTER TABLE "submission_file" ADD COLUMN "content" BYTEA NULL; - ALTER TABLE "submission_file" ADD COLUMN "modified" TIMESTAMP WITH TIME ZONE; - ALTER TABLE "submission_file" DROP CONSTRAINT "unique_submission_file"; - ALTER TABLE "submission_file" ADD CONSTRAINT "unique_submission_file" UNIQUE("submission", "title", "is_update"); - |] - let getSubmissionFiles = [queryQQ|SELECT "file", "submission_file"."id", "submission", "is_update", "is_deletion" FROM "submission_file" LEFT OUTER JOIN "file" ON "submission_file"."file" = "file".id ORDER BY "file"."modified" DESC;|] - toResidual [ fromPersistValue -> Right sfId - , fromPersistValue -> Right submissionFileResidualSubmission - , fromPersistValue -> Right submissionFileResidualIsUpdate - , fromPersistValue -> Right submissionFileResidualIsDeletion - ] - = (sfId, SubmissionFileResidual{..}) - toResidual _ = error "Could not convert SubmissionFile to residual" - runConduit $ getSubmissionFiles .| C.mapM_ (migrateFromFile @SubmissionFile toResidual replaceEntity) - [executeQQ| - ALTER TABLE "submission_file" DROP COLUMN "file"; - |] - - whenM (tableExists "sheet_file") $ do - [executeQQ| - ALTER TABLE "sheet_file" ADD COLUMN "title" VARCHAR; - ALTER TABLE "sheet_file" ADD COLUMN "content" BYTEA NULL; - ALTER TABLE "sheet_file" ADD COLUMN "modified" TIMESTAMP WITH TIME ZONE; - ALTER TABLE "sheet_file" DROP CONSTRAINT "unique_sheet_file"; - ALTER TABLE "sheet_file" ADD CONSTRAINT "unique_sheet_file" UNIQUE("sheet", "type", "title"); - |] - let getSheetFiles = [queryQQ|SELECT "file", "sheet_file"."id", "sheet", "type" FROM "sheet_file" LEFT OUTER JOIN "file" ON "sheet_file"."file" = "file".id ORDER BY "file"."modified" DESC;|] - toResidual [ fromPersistValue -> Right shfId - , fromPersistValue -> Right sheetFileResidualSheet - , fromPersistValue -> Right sheetFileResidualType - ] - = (shfId, SheetFileResidual{..}) - toResidual _ = error "Could not convert SheetFile to residual" - runConduit $ getSheetFiles .| C.mapM_ (migrateFromFile @SheetFile toResidual replaceEntity) - [executeQQ| - ALTER TABLE "sheet_file" DROP COLUMN "file"; - |] - - whenM (tableExists "course_news_file") $ do - [executeQQ| - ALTER TABLE "course_news_file" ADD COLUMN "title" VARCHAR; - ALTER TABLE "course_news_file" ADD COLUMN "content" BYTEA NULL; - ALTER TABLE "course_news_file" ADD COLUMN "modified" TIMESTAMP WITH TIME ZONE; - ALTER TABLE "course_news_file" DROP CONSTRAINT "unique_course_news_file"; - ALTER TABLE "course_news_file" ADD CONSTRAINT "unique_course_news_file" UNIQUE("news", "title"); - |] - let getCourseNewsFiles = [queryQQ|SELECT "file", "course_news_file"."id", "news" FROM "course_news_file" LEFT OUTER JOIN "file" ON "course_news_file"."file" = "file".id ORDER BY "file"."modified" DESC;|] - toResidual [ fromPersistValue -> Right cnfId - , fromPersistValue -> Right courseNewsFileResidualNews - ] - = (cnfId, CourseNewsFileResidual{..}) - toResidual _ = error "Could not convert CourseNewsFile to residual" - runConduit $ getCourseNewsFiles .| C.mapM_ (migrateFromFile @CourseNewsFile toResidual replaceEntity) - [executeQQ| - ALTER TABLE "course_news_file" DROP COLUMN "file"; - |] - - whenM (tableExists "material_file") $ do - [executeQQ| - ALTER TABLE "material_file" ADD COLUMN "title" VARCHAR; - ALTER TABLE "material_file" ADD COLUMN "content" BYTEA NULL; - ALTER TABLE "material_file" ADD COLUMN "modified" TIMESTAMP WITH TIME ZONE; - ALTER TABLE "material_file" DROP CONSTRAINT "unique_material_file"; - ALTER TABLE "material_file" ADD CONSTRAINT "unique_material_file" UNIQUE("material", "title"); - |] - let getMaterialFiles = [queryQQ|SELECT "file", "material_file"."id", "material" FROM "material_file" LEFT OUTER JOIN "file" ON "material_file"."file" = "file".id ORDER BY "file"."modified" DESC;|] - toResidual [ fromPersistValue -> Right shfId - , fromPersistValue -> Right materialFileResidualMaterial - ] - = (shfId, MaterialFileResidual{..}) - toResidual _ = error "Could not convert MaterialFile to residual" - runConduit $ getMaterialFiles .| C.mapM_ (migrateFromFile @MaterialFile toResidual replaceEntity) - [executeQQ| - ALTER TABLE "material_file" DROP COLUMN "file"; - |] - - whenM (tableExists "session_file") - [executeQQ| - ALTER TABLE "session_file" ADD COLUMN "content" BYTEA; - UPDATE "session_file" SET "content" = (SELECT "hash" FROM "file" WHERE "file".id = "session_file"."file"); - ALTER TABLE "session_file" DROP COLUMN "file"; - |] - - [executeQQ| - ALTER TABLE "file" RENAME TO "file_content"; - DELETE FROM "file_content" WHERE "content" IS NULL OR "hash" IS NULL; - |] - [executeQQ| - DELETE FROM "file_content" - WHERE "id" IN ( - SELECT - "id" - FROM ( - SELECT - "id", - ROW_NUMBER() OVER w AS rnum - FROM "file_content" - WINDOW w AS ( - PARTITION BY "hash" - ORDER BY "id" - ) - ) as t - WHERE t.rnum > 1); - |] - [executeQQ| - ALTER TABLE "file_content" DROP COLUMN "title"; - ALTER TABLE "file_content" DROP COLUMN "modified"; - ALTER TABLE "file_content" DROP COLUMN "id"; - |] - - Migration20200825StudyFeaturesFirstObserved -> whenM (tableExists "study_features") - [executeQQ| - ALTER TABLE study_features RENAME updated TO last_observed; - ALTER TABLE study_features ADD COLUMN first_observed timestamp with time zone; - UPDATE study_features SET first_observed = (SELECT MAX(last_observed) FROM study_features as other WHERE other."user" = study_features."user" AND other.degree = study_features.degree AND other.field = study_features.field AND other.type = study_features.type AND other.semester = study_features.semester - 1); - |] - - Migration20200902FileChunking -> whenM (tableExists "file_content") $ do - chunkingParams <- lift $ view _appFileChunkingParams - - [executeQQ| - ALTER TABLE file_content RENAME TO file_content_chunk; - ALTER INDEX file_content_pkey RENAME TO file_content_chunk_pkey; - - CREATE TABLE file_content_chunk_unreferenced (id bigserial, hash bytea NOT NULL, since timestamp with time zone NOT NULL); - INSERT INTO file_content_chunk_unreferenced (since, hash) (SELECT unreferenced_since as since, hash FROM file_content_chunk WHERE NOT (unreferenced_since IS NULL)); - ALTER TABLE file_content_chunk DROP COLUMN unreferenced_since; - - ALTER TABLE file_content_chunk ADD COLUMN content_based boolean NOT NULL DEFAULT false; - UPDATE file_content_chunk SET content_based = true WHERE length(content) <= #{fastCDCMinBlockSize chunkingParams}; - - CREATE TABLE file_content_entry (id bigserial NOT NULL PRIMARY KEY, hash bytea NOT NULL, ix bigint NOT NULL, chunk_hash bytea NOT NULL); - INSERT INTO file_content_entry (hash, chunk_hash, ix) (SELECT hash, hash as chunk_hash, 0 as ix FROM file_content_chunk); - |] - - Migration20200916ExamMode -> do - whenM (tableExists "exam") - [executeQQ| - ALTER TABLE exam ADD COLUMN "exam_mode" jsonb NOT NULL DEFAULT #{ExamMode Nothing Nothing Nothing Nothing}; - |] - whenM (tableExists "school") - [executeQQ| - ALTER TABLE school ADD COLUMN "exam_discouraged_modes" jsonb NOT NULL DEFAULT #{ExamModeDNF predDNFFalse}; - |] - - Migration20201106StoredMarkup -> - [executeQQ| - SET client_min_messages TO WARNING; - ALTER TABLE IF EXISTS ^{Course} ALTER COLUMN @{CourseDescription} TYPE jsonb USING (CASE WHEN @{CourseDescription} IS NOT NULL THEN to_json(@{CourseDescription}) ELSE NULL END); - ALTER TABLE IF EXISTS ^{CourseEvent} ALTER COLUMN @{CourseEventNote} TYPE jsonb USING (CASE WHEN @{CourseEventNote} IS NOT NULL THEN to_json(@{CourseEventNote}) ELSE NULL END); - ALTER TABLE IF EXISTS ^{CourseUserNote} ALTER COLUMN @{CourseUserNoteNote} TYPE jsonb USING (CASE WHEN @{CourseUserNoteNote} IS NOT NULL THEN to_json(@{CourseUserNoteNote}) ELSE NULL END); - ALTER TABLE IF EXISTS ^{Material} ALTER COLUMN @{MaterialDescription} TYPE jsonb USING (CASE WHEN @{MaterialDescription} IS NOT NULL THEN to_json(@{MaterialDescription}) ELSE NULL END); - ALTER TABLE IF EXISTS ^{CourseNews} ALTER COLUMN @{CourseNewsContent} TYPE jsonb USING (CASE WHEN @{CourseNewsContent} IS NOT NULL THEN to_json(@{CourseNewsContent}) ELSE NULL END); - ALTER TABLE IF EXISTS ^{CourseNews} ALTER COLUMN @{CourseNewsSummary} TYPE jsonb USING (CASE WHEN @{CourseNewsSummary} IS NOT NULL THEN to_json(@{CourseNewsSummary}) ELSE NULL END); - ALTER TABLE IF EXISTS ^{Exam} ALTER COLUMN @{ExamDescription} TYPE jsonb USING (CASE WHEN @{ExamDescription} IS NOT NULL THEN to_json(@{ExamDescription}) ELSE NULL END); - ALTER TABLE IF EXISTS ^{ExamOccurrence} ALTER COLUMN @{ExamOccurrenceDescription} TYPE jsonb USING (CASE WHEN @{ExamOccurrenceDescription} IS NOT NULL THEN to_json(@{ExamOccurrenceDescription}) ELSE NULL END); - ALTER TABLE IF EXISTS ^{Sheet} ALTER COLUMN @{SheetDescription} TYPE jsonb USING (CASE WHEN @{SheetDescription} IS NOT NULL THEN to_json(@{SheetDescription}) ELSE NULL END); - ALTER TABLE IF EXISTS ^{Sheet} ALTER COLUMN @{SheetMarkingText} TYPE jsonb USING (CASE WHEN @{SheetMarkingText} IS NOT NULL THEN to_json(@{SheetMarkingText}) ELSE NULL END); - ALTER TABLE IF EXISTS ^{SystemMessage} ALTER COLUMN @{SystemMessageContent} TYPE jsonb USING (CASE WHEN @{SystemMessageContent} IS NOT NULL THEN to_json(@{SystemMessageContent}) ELSE NULL END); - ALTER TABLE IF EXISTS ^{SystemMessage} ALTER COLUMN @{SystemMessageSummary} TYPE jsonb USING (CASE WHEN @{SystemMessageSummary} IS NOT NULL THEN to_json(@{SystemMessageSummary}) ELSE NULL END); - ALTER TABLE IF EXISTS ^{SystemMessageTranslation} ALTER COLUMN @{SystemMessageTranslationContent} TYPE jsonb USING (CASE WHEN @{SystemMessageTranslationContent} IS NOT NULL THEN to_json(@{SystemMessageTranslationContent}) ELSE NULL END); - ALTER TABLE IF EXISTS ^{SystemMessageTranslation} ALTER COLUMN @{SystemMessageTranslationSummary} TYPE jsonb USING (CASE WHEN @{SystemMessageTranslationSummary} IS NOT NULL THEN to_json(@{SystemMessageTranslationSummary}) ELSE NULL END); - SET client_min_messages TO NOTICE; - |] - - Migration20201119RoomTypes -> do - whenM (tableExists "exam_occurrence") $ do - [executeQQ|ALTER TABLE "exam_occurrence" ADD COLUMN "room_json" jsonb|] - let getExamOccurrences = [queryQQ|SELECT "id", "room" FROM "exam_occurrence"|] - migrateExamOccurrence [ fromPersistValue -> Right (eoId :: ExamOccurrenceId), fromPersistValue -> Right roomText ] = [executeQQ|UPDATE "exam_occurrence" SET "room_json" = #{RoomReferenceSimple roomText} WHERE "id" = #{eoId}|] - migrateExamOccurrence _ = return () - in runConduit $ getExamOccurrences .| C.mapM_ migrateExamOccurrence - [executeQQ| - ALTER TABLE "exam_occurrence" DROP COLUMN "room"; - ALTER TABLE "exam_occurrence" RENAME COLUMN "room_json" TO "room"; - |] - whenM (tableExists "tutorial") $ do - [executeQQ|ALTER TABLE "tutorial" ADD COLUMN "room_json" jsonb|] - let getTutorials = [queryQQ|SELECT "id", "room" FROM "tutorial"|] - migrateTutorial [ fromPersistValue -> Right (tutId :: TutorialId), fromPersistValue -> Right roomText ] = [executeQQ|UPDATE "tutorial" SET "room_json" = #{RoomReferenceSimple roomText} WHERE "id" = #{tutId}|] - migrateTutorial _ = return () - in runConduit $ getTutorials .| C.mapM_ migrateTutorial - [executeQQ| - ALTER TABLE "tutorial" DROP COLUMN "room"; - ALTER TABLE "tutorial" RENAME COLUMN "room_json" TO "room"; - |] - whenM (tableExists "course_event") $ do - [executeQQ|ALTER TABLE "course_event" ADD COLUMN "room_json" jsonb|] - let getCourseEvents = [queryQQ|SELECT "id", "room" FROM "course_event"|] - migrateCourseEvent [ fromPersistValue -> Right (ceId :: CourseEventId), fromPersistValue -> Right roomText ] = [executeQQ|UPDATE "course_event" SET "room_json" = #{RoomReferenceSimple roomText} WHERE "id" = #{ceId}|] - migrateCourseEvent _ = return () - in runConduit $ getCourseEvents .| C.mapM_ migrateCourseEvent - [executeQQ| - ALTER TABLE "course_event" DROP COLUMN "room"; - ALTER TABLE "course_event" RENAME COLUMN "room_json" TO "room"; - |] - whenM (tableExists "course") $ do - let getCourses = [queryQQ|SELECT "id", "link_external" FROM "course"|] - migrateCourse [ fromPersistValue -> Right (cId :: CourseId), fromPersistValue -> Right (uriText :: Maybe Text) ] - | Just uri <- parseURI . unpack =<< uriText = [executeQQ|UPDATE "course" SET "link_external" = #{uri} WHERE "id" = #{cId}|] - | otherwise = [executeQQ|UPDATE "course" SET "link_external" = NULL WHERE "id" = #{cId}|] - migrateCourse _ = return () - in runConduit $ getCourses .| C.mapM_ migrateCourse - - Migration20210115ExamPartsFrom -> do - whenM (tableExists "exam") $ do - [executeQQ|ALTER TABLE "exam" ADD COLUMN "parts_from" timestamp with time zone|] - let getExam = [queryQQ|SELECT "id", "finished" FROM "exam"|] - migrateExam [ fromPersistValue -> Right (eId :: ExamId), fromPersistValue -> Right (finished :: Maybe UTCTime) ] = [executeQQ|UPDATE "exam" SET "parts_from" = #{finished} WHERE "id" = #{eId}|] - migrateExam _ = return () - in runConduit $ getExam .| C.mapM_ migrateExam - - Migration20210208StudyFeaturesRelevanceCachedUUIDs -> - whenM (tableExists "study_features") $ do - [executeQQ| - ALTER TABLE "study_features" ADD COLUMN "relevance_cached_uuid" uuid - |] - - let getStudyFeatures = [queryQQ|SELECT "id" FROM "study_features" WHERE relevance_cached|] - migrateStudyFeatures genUUID lift' [ fromPersistValue -> Right (sfId :: StudyFeaturesId) ] = do - uuid <- genUUID - lift' [executeQQ|UPDATE "study_features" SET "relevance_cached_uuid" = #{uuid} WHERE "id" = #{sfId}|] - migrateStudyFeatures _ _ _ = return () - in runConduit $ getStudyFeatures .| randUUIDC (\genUUID lift' -> C.mapM_ $ migrateStudyFeatures genUUID lift') - - [executeQQ| - ALTER TABLE "study_features" DROP COLUMN "relevance_cached"; - ALTER TABLE "study_features" RENAME COLUMN "relevance_cached_uuid" TO "relevance_cached"; - |] - - -- Placeholder to inform crontab generation when switchover happened so old submissions don't get notified as corrected - Migration20210318CrontabSubmissionRatedNotification -> return () - - Migration20210608SeparateTermActive -> do - now <- liftIO getCurrentTime - - whenM (and2M (tableExists "term") (not <$> tableExists "term_active")) $ do - [executeQQ| - CREATE TABLE "term_active" ("id" SERIAL8 PRIMARY KEY UNIQUE, "term" numeric(5,1) NOT NULL, "from" timestamp with time zone NOT NULL) - |] - - let getTerms = [queryQQ|SELECT "name", "active" FROM "term"|] - migrateTerms [ fromPersistValue -> Right (tid :: TermId), fromPersistValue -> Right (isActive :: Bool) ] = when isActive - [executeQQ|INSERT INTO term_active (term, "from") VALUES (#{tid}, #{now})|] - migrateTerms _ = return () - in runConduit $ getTerms .| C.mapM_ migrateTerms - - [executeQQ| - ALTER TABLE "term" DROP COLUMN "active"; - |] Migration20230524QualificationUserBlock -> whenM (andM [ not <$> tableExists "qualification_user_block" @@ -902,6 +178,25 @@ customMigrations = mapF $ \case ; |] + Migration20240212InitInterfaceHealth -> + unlessM (tableExists "interface_health") $ do -- fill health table with some defaults + [executeQQ| + CREATE TABLE "interface_health" + ( id BIGSERIAL NOT NULL + , interface CHARACTER VARYING NOT NULL + , subtype CHARACTER VARYING + , write BOOLEAN + , hours BIGINT NOT NULL + , PRIMARY KEY(id) + , CONSTRAINT unique_interface_health UNIQUE(interface, subtype, write) + ); + INSERT INTO "interface_health" ("interface", "subtype", "write", "hours") + VALUES + ('Printer', 'Acknowledge', True, 168) + , ('AVS' , 'Synch' , True , 96) + ON CONFLICT DO NOTHING; + |] + tableExists :: MonadIO m => Text -> ReaderT SqlBackend m Bool tableExists table = do diff --git a/src/Model/Types/Common.hs b/src/Model/Types/Common.hs index 836d2741e..df9bc1a79 100644 --- a/src/Model/Types/Common.hs +++ b/src/Model/Types/Common.hs @@ -42,7 +42,8 @@ type SchoolName = CI Text type SchoolShorthand = CI Text type CompanyName = CI Text -type CompanyShorthand = CI Text +type CompanyShorthand = CI Text +type Companies = [CI Text] type CourseName = CI Text type CourseShorthand = CI Text diff --git a/src/Model/Types/Markup.hs b/src/Model/Types/Markup.hs index c5555ceba..0715b65b5 100644 --- a/src/Model/Types/Markup.hs +++ b/src/Model/Types/Markup.hs @@ -50,6 +50,13 @@ data StoredMarkup = StoredMarkup deriving (Read, Show, Generic) deriving anyclass (Binary, Hashable, NFData) +instance Canonical (Maybe StoredMarkup) where + canonical Nothing = Nothing + canonical r@(Just s@StoredMarkup{..}) = let mi' = LT.strip markupInput in if + | LT.null mi' -> Nothing + | markupInput == mi' -> r + | otherwise -> Just s{markupInput = mi'} + htmlToStoredMarkup :: Html -> StoredMarkup htmlToStoredMarkup html = StoredMarkup { markupInputFormat = MarkupHtml diff --git a/src/Settings.hs b/src/Settings.hs index 5b6c139cb..e3fcc6105 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -233,7 +233,8 @@ data AppSettings = AppSettings , appStudyFeaturesRecacheRelevanceWithin :: Maybe NominalDiffTime , appStudyFeaturesRecacheRelevanceInterval :: NominalDiffTime - , appQualificationCheckHour :: Maybe Natural + , appJobLmsQualificationsEnqueueHour :: Maybe Natural + , appJobLmsQualificationsDequeueHour :: Maybe Natural , appFileSourceARCConf :: Maybe (ARCConf Int) , appFileSourcePrewarmConf :: Maybe PrewarmCacheConf @@ -245,6 +246,7 @@ data AppSettings = AppSettings , appJobMaxFlush :: Maybe Natural , appCommunicationAttachmentsMaxSize :: Maybe Natural + , appCommunicationGlobalCC :: Maybe UserEmail , appFileChunkingParams :: FastCDCParameters @@ -784,7 +786,8 @@ instance FromJSON AppSettings where appStudyFeaturesRecacheRelevanceWithin <- o .:? "study-features-recache-relevance-within" appStudyFeaturesRecacheRelevanceInterval <- o .: "study-features-recache-relevance-interval" - appQualificationCheckHour <- o .:? "qualification-check-hour" + appJobLmsQualificationsEnqueueHour <- o .:? "job-lms-qualifications-enqueue-hour" + appJobLmsQualificationsDequeueHour <- o .:? "job-lms-qualifications-dequeue-hour" appFileSourceARCConf <- assertM isValidARCConf <$> o .:? "file-source-arc" @@ -804,6 +807,7 @@ instance FromJSON AppSettings where appJobMaxFlush <- o .:? "job-max-flush" appCommunicationAttachmentsMaxSize <- o .:? "communication-attachments-max-size" + appCommunicationGlobalCC <- o .:? "communication-global-cc" appLegalExternal <- o .: "legal-external" diff --git a/src/Utils.hs b/src/Utils.hs index 44b863ae9..c47f29992 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -23,7 +23,7 @@ import qualified Data.CaseInsensitive as CI import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as CBS -import qualified Data.Char as Char +-- import qualified Data.Char as Char import qualified Data.Text as Text import qualified Data.Text.Encoding as Text @@ -319,9 +319,16 @@ citext2string = Text.unpack . CI.original string2citext :: String -> CI Text string2citext = CI.mk . Text.pack +text2AlphaNumPlus :: [Char] -> Text -> Text +text2AlphaNumPlus = + let alphaNum = Set.fromAscList $ ['0'..'9'] <> ['A'..'Z'] <> ['a'..'z'] + in \oks -> + let aNumPlus = Set.fromList oks <> alphaNum + in Text.filter (`Set.member` aNumPlus) + -- | Convert or remove all non-ascii characters, e.g. for filenames text2asciiAlphaNum :: Text -> Text -text2asciiAlphaNum = Text.filter (\c -> Char.isAlphaNum c && Char.isAscii c) +text2asciiAlphaNum = text2AlphaNumPlus ['-','_'] . Text.replace "ä" "ae" . Text.replace "Ä" "Ae" . Text.replace "Æ" "ae" @@ -626,6 +633,7 @@ guardMonoid True x = x assertMonoid :: Monoid m => (m -> Bool) -> m -> m assertMonoid f x = guardMonoid (f x) x +-- fold would also do, but is more risky if the Folable isn't Maybe maybeMonoid :: Monoid m => Maybe m -> m -- ^ Identify `Nothing` with `mempty` maybeMonoid = fromMaybe mempty @@ -771,6 +779,9 @@ pattern NonEmpty :: forall a. a -> [a] -> NonEmpty a pattern NonEmpty x xs = x :| xs {-# COMPLETE NonEmpty #-} +checkAsc :: Ord a => [a] -> Bool +checkAsc (x:r@(y:_)) = x<=y && checkAsc r +checkAsc _ = True ---------- -- Sets -- @@ -1983,3 +1994,17 @@ instance {-# OVERLAPPABLE #-} (Canonical mono, MonoFoldable mono, Eq mono) => Ca -- this instance is more of a convenient abuse of the class (expand to Foldable) instance (Ord a, Canonical a) => Canonical (Set a) where canonical = Set.map canonical + +instance Canonical (Maybe Text) where -- a split into Canonical Text and Canonical a => Maybe seems nicer, but the latter instance would be troublesome + canonical Nothing = Nothing + canonical r@(Just t) = let t' = Text.strip t in if + | Text.null t' -> Nothing + | t == t' -> r + | otherwise -> Just t' + +instance Canonical (Maybe (CI Text)) where -- a split into Canonical Text and Canonical a => Maybe seems nicer, but the latter instance would be troublesome + canonical Nothing = Nothing + canonical r@(Just t) = let t' = CI.map Text.strip t in if + | mempty == t'-> Nothing + | t == t' -> r + | otherwise -> Just t' diff --git a/src/Utils/DB.hs b/src/Utils/DB.hs index f53c22d23..de9608a4d 100644 --- a/src/Utils/DB.hs +++ b/src/Utils/DB.hs @@ -97,6 +97,15 @@ updateBy uniq updates = do updateGetEntity :: (PersistStoreWrite backend, MonadIO m, PersistRecordBackend record backend) => Key record -> [Update record] -> ReaderT backend m (Entity record) updateGetEntity k = fmap (Entity k) . updateGet k +-- | insert or replace a record based on a single uniqueness constraint +-- this function was meant to be supplied with the uniqueness constraint, but it would be unsafe if the uniqueness constraint would not match the supplied record +replaceBy :: (PersistUniqueWrite backend, MonadIO m, OnlyOneUniqueKey record, PersistEntityBackend record ~ BaseBackend backend) + => record -> ReaderT backend m () +replaceBy r = do + u <- onlyUnique r + deleteBy u + insert_ r + -- | Like 'myReplaceUnique' or 'replaceUnique' but with reversed result: returns 'Nothing' if the replacement was not possible, -- and 'Just key' for the successfully replaced record uniqueReplace :: ( MonadIO m diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 2d00d373e..18c96c289 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -316,6 +316,9 @@ data FormIdentifier | FIDBtnAvsImportUnknown | FIDBtnAvsRevokeUnknown | FIDHijackUser + | FIDAddSupervisor + | FIDFirmUserChangeRequest + | FIDFirmAction deriving (Eq, Ord, Read, Show) instance PathPiece FormIdentifier where @@ -364,6 +367,8 @@ identifyForm = identifyForm' id -- Buttons (new version ) -- ---------------------------- +-- Bemerke: Back Button Widget implementierbar durch