Merge branch 'master' into test

This commit is contained in:
Sarah Vaupel 2024-03-15 10:44:43 +01:00
commit 864175284d
107 changed files with 2657 additions and 2533 deletions

View File

@ -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))

View File

@ -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"

View File

@ -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
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)

View File

@ -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
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

View File

@ -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!

View File

@ -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}
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

View File

@ -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
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

View File

@ -84,14 +84,8 @@ CsvColumnLmsDate: Datum des ELearning Ereignisses
CsvColumnLmsResetTries: Anzahl der bisher verbrauchten ELearning Prüfungsversuche zurücksetzen
CsvColumnLmsLock: ELearning 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: ELearning wird nicht automatisch gestartet, da die Zeitspanne für den Erneurerungszeitraum nicht festgelegt wurde.
@ -138,7 +132,5 @@ LmsNotificationSend n@Int: ELearning Benachrichtigungen an #{n} #{pluralDE n
LmsPinRenewal n@Int: ELearning 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: ELearning 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 ELearning anmelden und benachrichtigen
BtnLmsDequeue: Nutzer mit beendetem ELearning ggf. benachrichtigen und aufräumen
BtnLmsDequeue: Nutzer mit beendetem ELearning aufräumen und ggf. benachrichtigen

View File

@ -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 elearning data. Note that the elearning server may delete its anonymised data earlier, at most #{n} days after closing.
QualificationRefreshWithin: Refresh within
QualificationRefreshWithinTooltip: Optional period before expiry to start elearning 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 elearning exam attempts
CsvColumnLmsDate: Date of elearning event
CsvColumnLmsResult: LMS Status
CsvColumnLmsLock: Elearning 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: Elearning will not be started automatically due to refresh-within time period not being set.
@ -138,7 +132,5 @@ LmsNotificationSend n: Elearning notifications will be sent to #{n} #{pluralE
LmsPinRenewal n: Elearning password replaced randomly for #{n} #{pluralENs n "examinee"}.
LmsActionFailed n: No action for #{n} #{pluralENs n "person"}, since there was no ongoing examination.
LmsStarted: Elearning 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 elearning and notify them.
BtnLmsDequeue: Dequeue users with finished elearning and notify, if appropriate.
BtnLmsEnqueue: Enqueue users with expiring qualifications for elearning and notify them
BtnLmsDequeue: Dequeue users with finished elearning and notify failed users

View File

@ -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
MailSupervisorRerouteTooltip: Alle Benachrichtigungen werden stattdessen an diese Ansprechpartner mit Benachrichtigungsumleitung gesandt

View File

@ -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
MailSupervisorRerouteTooltip: All notification will be rerouted to these supervisors instead

View File

@ -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"}

View File

@ -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"}

View File

@ -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 ELearning Benutzer
MenuLmsUserlist: Veraltetes Melden ELearning Benutzer
MenuLmsResult: Veralteter Melden Ergebnisse ELearning
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)

View File

@ -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 elearning users
MenuLmsUserlist: Legacy upload elearning users
MenuLmsResult: Legacy upload rlearning 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)

View File

@ -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.
TableFilterCommaNameNr: Mehrere Namen oder Nummern mit Komma trennen. Nummern werden nur exakt gesucht.
TableUserEdit: Benutzer bearbeiten
TableRows: Zeilen

View File

@ -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.
TableFilterCommaNameNr: Separate names and numbers by comma. Numbers have to match exact.
TableUserEdit: Edit user
TableRows: Rows

View File

@ -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

View File

@ -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

View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
--
-- 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
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

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -1,3 +1,3 @@
{
"version": "27.4.49"
"version": "27.4.59"
}

2
package-lock.json generated
View File

@ -1,6 +1,6 @@
{
"name": "uni2work",
"version": "27.4.49",
"version": "27.4.59",
"lockfileVersion": 1,
"requires": true,
"dependencies": {

View File

@ -1,6 +1,6 @@
{
"name": "uni2work",
"version": "27.4.49",
"version": "27.4.59",
"description": "",
"keywords": [],
"author": "",

View File

@ -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:

52
routes
View File

@ -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

View File

@ -223,7 +223,7 @@ let
fi
'';
killallUni2work = pkgs.writeScriptBin "killall-uni2work" ''
killallUni2work = pkgs.writeScriptBin "killuni2work" ''
#!${pkgs.zsh}/bin/zsh
set -o pipefail

View File

@ -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

View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
-- SPDX-FileCopyrightText: 2023 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
--
-- 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
}

View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,,Steffen Jost <s.jost@fraport.de>
-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>
--
-- 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

View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
--
-- 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)

View File

@ -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

View File

@ -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

View File

@ -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 = []

View File

@ -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
-- <p>_{MsgErrorResponseEncrypted}
-- <pre .literal-error>
-- #{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
<p>_{MsgErrorResponseEncrypted}
<pre .literal-error>
#{ciphertext}
|]
if
| isEncrypted && shouldEncrypt -> displayEncrypted plaintextJson
| shouldEncrypt -> displayEncrypted =<< encodedSecretBox SecretBoxPretty plaintextJson
| otherwise -> plaintext
-- errPage = case err of
-- NotFound -> [whamlet|<p>_{MsgErrorResponseNotFound}|]
-- InternalError err'
-- | "Crash Button" `isPrefixOf` err' -> liftIO $ exitImmediately ExitSuccess -- DEBUG: just for Testing
-- | otherwise -> encrypted err' [whamlet|<p .literal-error>#{fromMaybe err' decrypted}|]
-- InvalidArgs errs -> [whamlet|
-- <ul>
-- $forall err' <- errs
-- <li .literal-error>
-- #{err'}
-- |]
-- NotAuthenticated -> [whamlet|<p>_{MsgErrorResponseNotAuthenticated}|]
-- PermissionDenied err' -> [whamlet|<p .errMsg>#{err'}|]
-- BadMethod method -> [whamlet|<p>_{MsgErrorResponseBadMethod (decodeUtf8 method)}|]
-- siteLayout (toWgt . mr $ ErrorResponseTitle err) $ do
-- errPage
errPage = case err of
NotFound -> [whamlet|<p>_{MsgErrorResponseNotFound}|]
InternalError err'
| "Crash Button" `isPrefixOf` err' -> liftIO $ exitImmediately ExitSuccess -- DEBUG: just for Testing
| otherwise -> encrypted err' [whamlet|<p .literal-error>#{fromMaybe err' decrypted}|]
InvalidArgs errs -> [whamlet|
<ul>
$forall err' <- errs
<li .literal-error>
#{err'}
|]
NotAuthenticated -> [whamlet|<p>_{MsgErrorResponseNotAuthenticated}|]
PermissionDenied err' -> [whamlet|<p .errMsg>#{err'}|]
BadMethod method -> [whamlet|<p>_{MsgErrorResponseBadMethod (decodeUtf8 method)}|]
siteLayout (toWgt . mr $ ErrorResponseTitle err) $ do
errPage
provideRep $ case err of
PermissionDenied err' -> return err'
InternalError err'

View File

@ -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

View File

@ -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)

View File

@ -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

View File

@ -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

View File

@ -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")

View File

@ -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)

View File

@ -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

View File

@ -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) ->

File diff suppressed because it is too large Load Diff

View File

@ -0,0 +1,251 @@
-- SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
--
-- 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|
<div>
#{plainMsg}
<div>
^{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 ()

View File

@ -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

View File

@ -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

View File

@ -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
<form method=post enctype=#{enctype}>
^{widget}
<p>
^{widget}
<input type=submit>
|]
@ -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."

View File

@ -1,293 +0,0 @@
-- SPDX-FileCopyrightText: 2022 Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
{-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances
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
<form method=post enctype=#{enctype}>
^{widget}
<p>
<input type=submit>
|]
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

View File

@ -1,288 +0,0 @@
-- SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- 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
<form method=post enctype=#{enctype}>
^{widget}
<p>
<input type=submit>
|]
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

View File

@ -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}
<div>
$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
<form method=post enctype=#{enctype}>
^{widget}
<input type=submit>
|]
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}|]

View File

@ -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)
]

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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
]

View File

@ -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
)

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -0,0 +1,38 @@
-- SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
--
-- 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

View File

@ -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

View File

@ -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

View File

@ -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"

View File

@ -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)

View File

@ -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 -> [] )

View File

@ -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

View File

@ -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))

View File

@ -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

View File

@ -1,7 +1,9 @@
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
--
-- 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

View File

@ -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 --
----------

View File

@ -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

View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
-- SPDX-FileCopyrightText: 2022-2023 Sarah Vaupel <sarah.vaupel@uniworx.de>, David Mosbach <david.mosbach@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- 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

View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022-23 Steffen Jost <s.jost@fraport.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
-- SPDX-FileCopyrightText: 2022-24 Steffen Jost <s.jost@fraport.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- 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|]

View File

@ -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

View File

@ -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

View File

@ -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 [] []

View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
--
-- 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

View File

@ -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

View File

@ -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

View File

@ -1,7 +1,9 @@
-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
--
-- 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

View File

@ -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

View File

@ -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

View File

@ -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"

View File

@ -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'

View File

@ -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

View File

@ -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 <button onclick="history.back()">_{MsgGenericBack}
data family ButtonClass site :: Type
class (PathPiece a, PathPiece (ButtonClass site), RenderMessage site ButtonMessage) => Button site a where
@ -373,7 +378,7 @@ class (PathPiece a, PathPiece (ButtonClass site), RenderMessage site ButtonMessa
btnLabel = toWidget <=< ap getMessageRender . return
btnValidate :: forall p. p site -> a -> Bool
btnValidate _ _ = True
btnValidate _ _ = True -- False will attach html attribute "formnovalidate", so that browsers do not validate the form data
btnClasses :: a -> [ButtonClass site]
btnClasses _ = []
@ -947,6 +952,53 @@ selectField' optMsg mkOpts = Field{..}
#{optionDisplay opt}
|]
multiSelectField' :: ( Eq a
, RenderMessage (HandlerSite m) FormMessage
, MonadHandler m
)
=> Maybe (SomeMessage (HandlerSite m)) -- ^ Caption used for @Nothing@-Option, if Field is optional and whether to show such an option
-> HandlerT (HandlerSite m) IO (OptionList a)
-> Field m [a]
-- ^ Like @multiSelectField@, but it can handle OptionListGrouped and also offers more control over the @Nothing@-Option, if Field is optional
multiSelectField' optMsg mkOpts = Field{..}
where
fieldEnctype = UrlEncoded
fieldParse [] _ = return $ Right Nothing
fieldParse optlist _ = do
let optlist' = filter notNull optlist
readExternal <- view _olReadExternal <$> liftHandler mkOpts
return $ case mapM readExternal optlist' of
Nothing -> Left $ SomeMessage $ MsgInvalidEntry $ T.intercalate ", " optlist'
res -> Right res
fieldView theId name attrs val isReq = do
opts <- liftHandler mkOpts
let
rendered = case val of
Left _ -> []
Right xs -> [optionExternalValue o | o <- opts ^.. _olOptions, x <- xs, x == optionInternalValue o]
isSel Nothing = ClassyPrelude.Yesod.null rendered
isSel (Just opt) = optionExternalValue opt `elem` rendered
[whamlet|
$newline never
<select ##{theId} name=#{name} multiple *{attrs} :isReq:required>
$maybe optMsg' <- assertM (const $ not isReq) optMsg
<option value="" :isSel Nothing:selected>
_{optMsg'}
$case opts
$of OptionList{olOptions}
$forall opt <- olOptions
<option value=#{optionExternalValue opt} :isSel (Just opt):selected>
#{optionDisplay opt}
$of OptionListGrouped{olOptionsGrouped}
$forall (groupLbl, iOpts) <- olOptionsGrouped
<optgroup label=#{groupLbl}>
$forall opt <- iOpts
<option value=#{optionExternalValue opt} :isSel (Just opt):selected>
#{optionDisplay opt}
|]
radioField' :: ( Eq a
, RenderMessage (HandlerSite m) FormMessage
, MonadHandler m

View File

@ -38,9 +38,9 @@ customModal Modal{..} = do
route <- traverse toTextUrl $ modalContent ^? _Left
modalTrigger route triggerId'
-- | Create a link to a modal
-- | Create a link to a modal, does not check link, see `Handler.Utils.Widget.modalAccess` for a checking variant
modal :: WidgetFor site () -- ^ Widget that represents the link
-> Either (SomeRoute site) (WidgetFor site ()) -- ^ Modal contant: either dynamic link or static widget
-> Either (SomeRoute site) (WidgetFor site ()) -- ^ Modal content: either dynamic link or static widget
-> WidgetFor site () -- ^ result widget
modal modalTrigger' modalContent = customModal Modal{..}
where

View File

@ -109,12 +109,16 @@ data Icon
| IconLetter
| IconAt
| IconSupervisor
| IconSupervisorForeign
-- | IconWaitingForUser
| IconExpired
| IconLocked
| IconUnlocked
| IconResetTries -- also see IconReset
| IconCompany
| IconEdit
| IconUserEdit
deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic)
deriving anyclass (Universe, Finite, NFData)
@ -201,12 +205,15 @@ iconText = \case
IconLetter -> "mail-bulk" -- Problem "envelope" already used for email as well
IconAt -> "at" -- alternative for IconEmail to distinguish from IconLetter
IconSupervisor -> "head-side" -- must be notably different to user
IconSupervisorForeign -> "alien"
-- IconWaitingForUser -> "user-cog" -- Waiting on a user to do something
IconExpired -> "hourglass-end"
IconLocked -> "lock"
IconUnlocked -> "lock-open-alt"
IconResetTries -> "trash-undo"
IconCompany -> "building"
IconEdit -> "edit"
IconUserEdit -> "user-edit"
nullaryPathPiece ''Icon $ camelToPathPiece' 1
deriveLift ''Icon

View File

@ -125,8 +125,6 @@ makeClassyFor_ ''QualificationUser
makeClassyFor_ ''QualificationUserBlock
makeClassyFor_ ''LmsUser
-- makeClassyFor_ ''LmsUserStatus
makeClassyFor_ ''LmsUserlist
makeClassyFor_ ''LmsResult
makeClassyFor_ ''LmsReport
makeClassyFor_ ''UserAvs
makeClassyFor_ ''UserAvsCard
@ -311,6 +309,9 @@ makeLenses_ ''AuthorshipStatementDefinition
makeLenses_ ''PrintJob
makeLenses_ ''InterfaceLog
-- makeLenses_ ''InterfaceLog -- not needed
--------------------------
-- Fields for `UniWorX` --
--------------------------

View File

@ -269,13 +269,17 @@ printLetter' pji pdf = do
-- printJobFile <- sinkFileDB True $ yield $ LBS.toStrict pdf -- for PrintJobFile :: FileContentReference use this code
printJobFile = LBS.toStrict pdf
printJobAcknowledged = Nothing
qshort <- ifMaybeM printJobQualification "-" $ fmap (maybe "_" $ CI.original . qualificationShorthand ) . get
let logInter = flip (logInterface "Printer" qshort) (Just 1)
lprPDF printJobFilename pdf >>= \case
Left err -> do
logInter False err
return $ Left err
Right ok -> do
printJobCreated <- liftIO getCurrentTime
-- updateWhere [PrintJobLmsUser ==. printJobLmsUser] [PrintJobLmsUser =. Nothing] -- only one printJob per LmsUser is allowed, since otherwise the qualification table contains double rows
insert_ PrintJob {..}
insert_ PrintJob{..}
logInter True ok
return $ Right (ok, printJobFilename)
reprintPDF :: Bool -> PrintJobId -> DB (Either Text Text)
@ -283,13 +287,19 @@ reprintPDF ignoreReroute pjid = maybeM (return $ Left "Print job id is unknown."
where
reprint :: PrintJob -> DB (Either Text Text)
reprint pj@PrintJob{..} = do
qshort <- ifMaybeM printJobQualification "-" $ fmap (maybe "_" $ CI.original . qualificationShorthand ) . get
let logInter = flip (logInterface "Printer" qshort) (Just 1)
result <- lprPDF' ignoreReroute printJobFilename $ LBS.fromStrict printJobFile
whenIsRight result $ const $ do
now <- liftIO getCurrentTime
insert_ pj{ printJobAcknowledged = Nothing
, printJobCreated = now
-- , printJobApcIdent = ??? cannot be modified here, since it is included inside the PDF
}
case result of
Left err ->
logInter False err
Right m -> do
logInter True m
now <- liftIO getCurrentTime
insert_ pj{ printJobAcknowledged = Nothing
, printJobCreated = now
-- , printJobApcIdent = ??? cannot be modified here, since it is included inside the PDF
}
return result
{-

View File

@ -5,7 +5,7 @@
module Utils.Set
( setIntersectNotOne
, setIntersections
, setMapMaybe
, setMapMaybe, setMapMaybeMonotonic
, concatMapSet
, setSymmDiff
, setProduct
@ -56,6 +56,10 @@ setIntersections (h:t) = foldl' Set.intersection h t
setMapMaybe :: Ord b => (a -> Maybe b) -> Set a -> Set b
setMapMaybe f = Set.fromList . mapMaybe f . Set.toList
-- | like `setMapMaybe`, but only when f is strictly increasing
setMapMaybeMonotonic :: (a -> Maybe b) -> Set a -> Set b
setMapMaybeMonotonic f = Set.fromDistinctAscList . mapMaybe f . Set.toAscList
concatMapSet :: Ord b => (a -> Set b) -> Set a -> Set b
concatMapSet f = Set.foldl ((. f) . (<>)) mempty
-- concatMapSet f = foldMap f --- requires Ord a as well, which we ought to have anyway
@ -68,8 +72,11 @@ setProduct :: Set a -> Set b -> Set (a, b)
-- ^ Depends on the valid internal structure of the given sets
setProduct (Set.toAscList -> as) (Set.toAscList -> bs) = Set.fromDistinctAscList $ (,) <$> as <*> bs
setPartitionEithers :: (Ord a, Ord b) => Set (Either a b) -> (Set a, Set b)
setPartitionEithers = (,) <$> setMapMaybe (preview _Left) <*> setMapMaybe (preview _Right)
-- setPartitionEithers :: (Ord a, Ord b) => Set (Either a b) -> (Set a, Set b)
-- setPartitionEithers = (,) <$> setMapMaybe (preview _Left) <*> setMapMaybe (preview _Right)
--
setPartitionEithers :: Set (Either a b) -> (Set a, Set b)
setPartitionEithers = (,) <$> setMapMaybeMonotonic (preview _Left) <*> setMapMaybeMonotonic (preview _Right)
setFromFunc :: (Finite k, Ord k) => (k -> Bool) -> Set k
setFromFunc = Set.fromList . flip filter universeF

View File

@ -43,7 +43,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
<dd .deflist__dd>^{simpleLinkI MsgProblemsUsersAreReachable ProblemUnreachableR}
<dt .deflist__dt>^{flagError noStalePrintJobs}
<dd .deflist__dd>^{simpleLinkI (MsgProblemsNoStalePrintJobs cutOffPrintDays) PrintCenterR}
<dd .deflist__dd>^{simpleLinkI (MsgProblemsNoStalePrintJobs cutOffOldDays) PrintCenterR}
<dt .deflist__dt>^{flagError noBadAPCids}
<dd .deflist__dd>_{MsgProblemsNoBadAPCIds}
@ -54,7 +54,14 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
<section>
<h2>
_{MsgProblemsHeadingMisc}
<dl .deflist>
<dt .deflist__dt>^{flagError noAvsSynchProblems}
<dd .deflist__dd>^{simpleLinkI MsgProblemsNoAvsSynchProblems ProblemAvsErrorR}
_{MsgMenuInterfaces}
<div>
<p>
$if interfacesBadNr > 0
_{MsgInterfacesFail interfacesBadNr}
$else
_{MsgInterfacesOk}
^{interfaceTable}
<!-- section h2 {MsgProblemsHeadingMisc} -->

View File

@ -0,0 +1,27 @@
$newline never
$# SPDX-FileCopyrightText: 2023 Steffen Jost <jost@tcs.ifi.lmu.de>
$#
$# SPDX-License-Identifier: AGPL-3.0-or-later
<section .profile>
<h2>_{MsgFirmContact}
<dl .deflist.profile-dl>
$maybe fem <- companyEmail
<dt .deflist__dt>
_{MsgFirmEmail}
$if not companyPrefersPostal
&nbsp; #{iconLetterOrEmail False}
<dd .deflist__dd .email>
#{mailtoHtml fem}
$maybe addr <- companyPostAddress
<dt .deflist__dt>
_{MsgFirmAddress}
$if companyPrefersPostal
&nbsp; #{iconLetterOrEmail True}
<dd .deflist__dd>
#{addr}
$nothing
$maybe _ <- companyEmail
$nothing
_{MsgFirmNoContact}

View File

@ -4,20 +4,13 @@ $# SPDX-FileCopyrightText: 2023 Steffen Jost <jost@tcs.ifi.lmu.de>
$#
$# SPDX-License-Identifier: AGPL-3.0-or-later
<section .profile>
<dl .deflist.profile-dl>
$maybe fem <- companyEmail
<dt .deflist__dt>
_{MsgFirmEmail} #{iconLetterOrEmail False}
<dd .deflist__dd .email>
#{mailtoHtml fem}
$maybe addr <- companyPostAddress
<dt .deflist__dt>
_{MsgFirmAddress} #{iconLetterOrEmail True}
<dd .deflist__dd>
#{addr}
^{firmContactInfo}
<section>
^{formFirmAction}
<section>
<h2 .show-hide__toggle uw-show-hide data-show-hide-collapsed>
_{MsgFirmSupervisionKeyData}
<div .scrolltable .scrolltable--bordered>
<table .table>
<tr .table__row .table__row--head>
@ -65,4 +58,4 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
<h2>
_{MsgFirmAssociates}
<p>
^{fusrTable}
^{fusrTable}

Some files were not shown because too many files have changed in this diff Show More